summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime/swank/mkcl.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'vim/bundle/slimv/slime/swank/mkcl.lisp')
-rw-r--r--vim/bundle/slimv/slime/swank/mkcl.lisp933
1 files changed, 933 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank/mkcl.lisp b/vim/bundle/slimv/slime/swank/mkcl.lisp
new file mode 100644
index 0000000..53696fb
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/mkcl.lisp
@@ -0,0 +1,933 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-mkcl.lisp --- SLIME backend for MKCL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/mkcl
+ (:use cl swank/backend))
+
+(in-package swank/mkcl)
+
+;;(declaim (optimize (debug 3)))
+
+(defvar *tmp*)
+
+(defimplementation gray-package-name ()
+ '#:gray)
+
+(eval-when (:compile-toplevel :load-toplevel)
+
+ (swank/backend::import-swank-mop-symbols :clos
+ ;; '(:eql-specializer
+ ;; :eql-specializer-object
+ ;; :generic-function-declarations
+ ;; :specializer-direct-methods
+ ;; :compute-applicable-methods-using-classes)
+ nil
+ ))
+
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (mkcl:octets (si:utf-8 string)))
+
+(defimplementation utf8-to-string (octets)
+ (string (si:utf-8 octets)))
+
+
+;;;; TCP Server
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the sb-bsd-sockets package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'sockets))
+
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket (or backlog 5))
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-bsd-sockets:socket-close socket))
+
+(defun accept (socket)
+ "Like socket-accept, but retry on EINTR."
+ (loop (handler-case
+ (return (sb-bsd-sockets:socket-accept socket))
+ (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t ;; bogus
+ :input t ;; bogus
+ :buffering buffering ;; bogus
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format
+ ))
+
+(defimplementation preferred-communication-style ()
+ :spawn
+ )
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (si:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, MKCL uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+
+;;;; Unix signals
+
+(defimplementation install-sigint-handler (handler)
+ (let ((old-handler (symbol-function 'si:terminal-interrupt)))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (if (consp handler)
+ (car handler)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (funcall handler)
+ (continue))))
+ (list old-handler)))
+
+
+(defimplementation getpid ()
+ (mkcl:getpid))
+
+(defimplementation set-default-directory (directory)
+ (mk-ext::chdir (namestring directory))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (mk-ext:getcwd)))
+
+(defmacro progf (plist &rest forms)
+ `(let (_vars _vals)
+ (do ((p ,plist (cddr p)))
+ ((endp p))
+ (push (car p) _vars)
+ (push (cadr p) _vals))
+ (progv _vars _vals ,@forms)
+ )
+ )
+
+(defvar *inferior-lisp-sleeping-post* nil)
+
+(defimplementation quit-lisp ()
+ (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams.
+ (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*))
+ ;;(mk-ext:quit :verbose t)
+ ))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defun signal-compiler-condition (&rest args)
+ (signal (apply #'make-condition 'compiler-condition args)))
+
+#|
+(defun handle-compiler-warning (condition)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (format nil "~A" condition)
+ :severity :warning
+ :location
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0))
+ ;; ;; compiler::*current-form*
+ ;; (if compiler::*current-function*
+ ;; (make-location (list :file *compile-filename*)
+ ;; (list :function-name
+ ;; (symbol-name
+ ;; (slot-value compiler::*current-function*
+ ;; 'compiler::name))))
+ (list :error "No location found.")
+ ;; )
+ )))
+|#
+
+#|
+(defun condition-location (condition)
+ (let ((file (compiler:compiler-message-file condition))
+ (position (compiler:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+|#
+
+(defun condition-location (condition)
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0))
+ ;; ;; compiler::*current-form* ;
+ ;; (if compiler::*current-function* ;
+ ;; (make-location (list :file *compile-filename*) ;
+ ;; (list :function-name ;
+ ;; (symbol-name ;
+ ;; (slot-value compiler::*current-function* ;
+ ;; 'compiler::name)))) ;
+ (if (typep condition 'compiler::compiler-message)
+ (make-location (list :file (namestring (compiler:compiler-message-file condition)))
+ (list :end-position (compiler:compiler-message-file-end-position condition)))
+ (list :error "No location found."))
+ )
+ )
+
+(defun handle-compiler-message (condition)
+ (unless (typep condition 'compiler::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (compiler:compiler-fatal-error :error)
+ (compiler:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((compiler:compiler-message #'handle-compiler-message))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (handler-bind (#|
+ (compiler::compiler-note
+ #'(lambda (n)
+ (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil))
+ (compiler::compiler-warning
+ #'(lambda (w)
+ (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil))
+ (compiler::compiler-error
+ #'(lambda (e)
+ (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil))
+ |#
+ )
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (compile-file input-file :output-file output-file :external-format external-format)
+ (values output-truename warnings-p
+ (or failure-p
+ (and load-p (not (load output-truename))))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (with-input-from-string (s string)
+ (when position (file-position position))
+ (compile-from-stream s)))))
+
+(defun compile-from-stream (stream)
+ (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX"))
+ output-truename
+ warnings-p
+ failure-p
+ )
+ (with-open-file (s file :direction :output :if-exists :overwrite)
+ (do ((line (read-line stream nil) (read-line stream nil)))
+ ((not line))
+ (write-line line s)))
+ (unwind-protect
+ (progn
+ (multiple-value-setq (output-truename warnings-p failure-p)
+ (compile-file file))
+ (and (not failure-p) (load output-truename)))
+ (when (probe-file file) (delete-file file))
+ (when (probe-file output-truename) (delete-file output-truename)))))
+
+
+;;;; Documentation
+
+(defun grovel-docstring-for-arglist (name type)
+ (flet ((compute-arglist-offset (docstring)
+ (when docstring
+ (let ((pos1 (search "Args: " docstring)))
+ (if pos1
+ (+ pos1 6)
+ (let ((pos2 (search "Syntax: " docstring)))
+ (when pos2
+ (+ pos2 8))))))))
+ (let* ((docstring (si::get-documentation name type))
+ (pos (compute-arglist-offset docstring)))
+ (if pos
+ (multiple-value-bind (arglist errorp)
+ (ignore-errors
+ (values (read-from-string docstring t nil :start pos)))
+ (if (or errorp (not (listp arglist)))
+ :not-available
+ arglist
+ ))
+ :not-available ))))
+
+(defimplementation arglist (name)
+ (cond ((and (symbolp name) (special-operator-p name))
+ (let ((arglist (grovel-docstring-for-arglist name 'function)))
+ (if (consp arglist) (cdr arglist) arglist)))
+ ((and (symbolp name) (macro-function name))
+ (let ((arglist (grovel-docstring-for-arglist name 'function)))
+ (if (consp arglist) (cdr arglist) arglist)))
+ ((or (functionp name) (fboundp name))
+ (multiple-value-bind (name fndef)
+ (if (functionp name)
+ (values (function-name name) name)
+ (values name (fdefinition name)))
+ (let ((fle (function-lambda-expression fndef)))
+ (case (car fle)
+ (si:lambda-block (caddr fle))
+ (t (typecase fndef
+ (generic-function (clos::generic-function-lambda-list fndef))
+ (compiled-function (grovel-docstring-for-arglist name 'function))
+ (function :not-available)))))))
+ (t :not-available)))
+
+(defimplementation function-name (f)
+ (si:compiled-function-name f)
+ )
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the walker package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'walker))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (walker:macroexpand-all form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (dolist (type '(:VARIABLE :FUNCTION :CLASS))
+ (let ((doc (describe-definition symbol type)))
+ (when doc
+ (setf result (list* type doc result)))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+ si::*frs-base*
+ si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+ si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+ si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defvar *backtrace* '())
+
+(defun in-swank-package-p (x)
+ (and
+ (symbolp x)
+ (member (symbol-package x)
+ (list #.(find-package :swank)
+ #.(find-package :swank/backend)
+ #.(ignore-errors (find-package :swank-mop))
+ #.(ignore-errors (find-package :swank-loader))))
+ t))
+
+(defun is-swank-source-p (name)
+ (setf name (pathname name))
+ #+(or)
+ (pathname-match-p
+ name
+ (make-pathname :defaults swank-loader::*source-directory*
+ :name (pathname-name name)
+ :type (pathname-type name)
+ :version (pathname-version name)))
+ nil)
+
+(defun is-ignorable-fun-p (x)
+ (or
+ (in-swank-package-p (frame-name x))
+ (multiple-value-bind (file position)
+ (ignore-errors (si::compiled-function-file (car x)))
+ (declare (ignore position))
+ (if file (is-swank-source-p file)))))
+
+(defmacro find-ihs-top (x)
+ (declare (ignore x))
+ '(si::ihs-top))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* (;;(*tpl-commands* si::tpl-commands)
+ (*ihs-base* 0)
+ (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
+ (*ihs-current* *ihs-top*)
+ (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top))))
+ (*frs-top* (frs-top))
+ (*read-suppress* nil)
+ ;;(*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ nil))))
+ (declare (special *ihs-current*))
+ (loop for f from *frs-base* to *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (mkcl:fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
+ (setf *tmp* *backtrace*)
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
+ (funcall fun)))
+
+(defimplementation compute-backtrace (start end)
+ (when (numberp end)
+ (setf end (min end (length *backtrace*))))
+ (loop for f in (subseq *backtrace* start end)
+ collect f))
+
+(defimplementation format-sldb-condition (condition)
+ "Format a condition for display in SLDB."
+ ;;(princ-to-string condition)
+ (format nil "~A~%In thread: ~S" condition mt:*thread*)
+ )
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun function-position (fun)
+ (multiple-value-bind (file position)
+ (si::compiled-function-file fun)
+ (and file (make-location
+ `(:file ,(if (stringp file) file (namestring file)))
+ ;;`(:position ,position)
+ `(:end-position , position)))))
+
+(defun frame-function (frame)
+ (let* ((x (first frame))
+ fun position)
+ (etypecase x
+ (symbol (and (fboundp x)
+ (setf fun (fdefinition x)
+ position (function-position fun))))
+ (function (setf fun x position (function-position x))))
+ (values fun position)))
+
+(defun frame-decode-env (frame)
+ (let ((functions '())
+ (blocks '())
+ (variables '()))
+ (setf frame (si::decode-ihs-env (second frame)))
+ (dolist (record frame)
+ (let* ((record0 (car record))
+ (record1 (cdr record)))
+ (cond ((or (symbolp record0) (stringp record0))
+ (setq variables (acons record0 record1 variables)))
+ ((not (mkcl:fixnump record0))
+ (push record1 functions))
+ ((symbolp record1)
+ (push record1 blocks))
+ (t
+ ))))
+ (values functions blocks variables)))
+
+(defimplementation print-frame (frame stream)
+ (let ((function (first frame)))
+ (let ((fname
+;;; (cond ((symbolp function) function)
+;;; ((si:instancep function) (slot-value function 'name))
+;;; ((compiled-function-p function)
+;;; (or (si::compiled-function-name function) 'lambda))
+;;; (t :zombi))
+ (si::get-fname function)
+ ))
+ (if (eq fname 'si::bytecode)
+ (format stream "~A [Evaluation of: ~S]"
+ fname (function-lambda-expression function))
+ (format stream "~A" fname)
+ )
+ (when (si::closurep function)
+ (format stream
+ ", closure generated from ~A"
+ (si::get-fname (si:closure-producer function)))
+ )
+ )
+ )
+ )
+
+(defimplementation frame-source-location (frame-number)
+ (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+ (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ with i = 0
+ collect (list :name name :id (prog1 i (incf i)) :value value)))
+
+(defimplementation frame-var-value (frame-number var-id)
+ (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id)))
+
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-fun (elt *backtrace* frame-number))))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (si:eval-in-env form env)))
+
+#|
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+|#
+
+;;;; Inspector
+
+(defmethod emacs-inspect ((o t))
+ ; ecl clos support leaves some to be desired
+ (cond
+ ((streamp o)
+ (list*
+ (format nil "~S is an ordinary stream~%" o)
+ (append
+ (list
+ "Open for "
+ (cond
+ ((ignore-errors (interactive-stream-p o)) "Interactive")
+ ((and (input-stream-p o) (output-stream-p o)) "Input and output")
+ ((input-stream-p o) "Input")
+ ((output-stream-p o) "Output"))
+ `(:newline) `(:newline))
+ (label-value-line*
+ ("Element type" (stream-element-type o))
+ ("External format" (stream-external-format o)))
+ (ignore-errors (label-value-line*
+ ("Broadcast streams" (broadcast-stream-streams o))))
+ (ignore-errors (label-value-line*
+ ("Concatenated streams" (concatenated-stream-streams o))))
+ (ignore-errors (label-value-line*
+ ("Echo input stream" (echo-stream-input-stream o))))
+ (ignore-errors (label-value-line*
+ ("Echo output stream" (echo-stream-output-stream o))))
+ (ignore-errors (label-value-line*
+ ("Output String" (get-output-stream-string o))))
+ (ignore-errors (label-value-line*
+ ("Synonym symbol" (synonym-stream-symbol o))))
+ (ignore-errors (label-value-line*
+ ("Input stream" (two-way-stream-input-stream o))))
+ (ignore-errors (label-value-line*
+ ("Output stream" (two-way-stream-output-stream o)))))))
+ ((si:instancep o) ;;t
+ (let* ((cl (si:instance-class o))
+ (slots (clos::class-slots cl)))
+ (list* (format nil "~S is an instance of class ~A~%"
+ o (clos::class-name cl))
+ (loop for x in slots append
+ (let* ((name (clos::slot-definition-name x))
+ (value (if (slot-boundp o name)
+ (clos::slot-value o name)
+ "Unbound"
+ )))
+ (list
+ (format nil "~S: " name)
+ `(:value ,value)
+ `(:newline)))))))
+ (t (list (format nil "~A" o)))))
+
+;;;; Definitions
+
+(defimplementation find-definitions (name)
+ (if (fboundp name)
+ (let ((tmp (find-source-location (symbol-function name))))
+ `(((defun ,name) ,tmp)))))
+
+(defimplementation find-source-location (obj)
+ (setf *tmp* obj)
+ (or
+ (typecase obj
+ (function
+ (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj))
+ (if (and file pos)
+ (make-location
+ `(:file ,(if (stringp file) file (namestring file)))
+ `(:end-position ,pos) ;; `(:position ,pos)
+ `(:snippet
+ ,(with-open-file (s file)
+ (file-position s pos)
+ (skip-comments-and-whitespace s)
+ (read-snippet s))))))))
+ `(:error (format nil "Source definition of ~S not found" obj))))
+
+;;;; Profiling
+
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the profile package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'profile))
+
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+
+
+;;;; Threads
+
+(defvar *thread-id-counter* 0)
+
+(defvar *thread-id-counter-lock*
+ (mt:make-lock :name "thread id counter lock"))
+
+(defun next-thread-id ()
+ (mt:with-lock (*thread-id-counter-lock*)
+ (incf *thread-id-counter*))
+ )
+
+(defparameter *thread-id-map* (make-hash-table))
+(defparameter *id-thread-map* (make-hash-table))
+
+(defvar *thread-id-map-lock*
+ (mt:make-lock :name "thread id map lock"))
+
+(defparameter +default-thread-local-variables+
+ '(*macroexpand-hook*
+ *default-pathname-defaults*
+ *readtable*
+ *random-state*
+ *compile-print*
+ *compile-verbose*
+ *load-print*
+ *load-verbose*
+ *print-array*
+ *print-base*
+ *print-case*
+ *print-circle*
+ *print-escape*
+ *print-gensym*
+ *print-length*
+ *print-level*
+ *print-lines*
+ *print-miser-width*
+ *print-pprint-dispatch*
+ *print-pretty*
+ *print-radix*
+ *print-readably*
+ *print-right-margin*
+ *read-base*
+ *read-default-float-format*
+ *read-eval*
+ *read-suppress*
+ ))
+
+(defun thread-local-default-bindings ()
+ (let (local)
+ (dolist (var +default-thread-local-variables+ local)
+ (setq local (acons var (symbol-value var) local))
+ )))
+
+;; mkcl doesn't have weak pointers
+(defimplementation spawn (fn &key name initial-bindings)
+ (let* ((local-defaults (thread-local-default-bindings))
+ (thread
+ ;;(mt:make-thread :name name)
+ (mt:make-thread :name name
+ :initial-bindings (nconc initial-bindings
+ local-defaults))
+ )
+ (id (next-thread-id)))
+ (mt:with-lock (*thread-id-map-lock*)
+ (setf (gethash id *thread-id-map*) thread)
+ (setf (gethash thread *id-thread-map*) id))
+ (mt:thread-preset
+ thread
+ #'(lambda ()
+ (unwind-protect
+ (progn
+ ;;(format t "~&Starting thread: ~S.~%" name) (finish-output)
+ (mt:thread-detach nil)
+ (funcall fn))
+ (progn
+ ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output)
+ (mt:with-lock (*thread-id-map-lock*)
+ (remhash thread *id-thread-map*)
+ (remhash id *thread-id-map*))
+ ;;(format t "~&Finished thread: ~S~%" name) (finish-output)
+ ))))
+ (mt:thread-enable thread)
+ (mt:thread-yield)
+ thread
+ ))
+
+(defimplementation thread-id (thread)
+ (block thread-id
+ (mt:with-lock (*thread-id-map-lock*)
+ (or (gethash thread *id-thread-map*)
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) thread)
+ (setf (gethash thread *id-thread-map*) id)
+ id)))))
+
+(defimplementation find-thread (id)
+ (mt:with-lock (*thread-id-map-lock*)
+ (gethash id *thread-id-map*)))
+
+(defimplementation thread-name (thread)
+ (mt:thread-name thread))
+
+(defimplementation thread-status (thread)
+ (if (mt:thread-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+(defimplementation make-lock (&key name)
+ (mt:make-lock :name name :recursive t))
+
+(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mt:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mt:*thread*)
+
+(defimplementation all-threads ()
+ (mt:all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+ (mt:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (mt:interrupt-thread thread #'mt:terminate-thread)
+ )
+
+(defimplementation thread-alive-p (thread)
+ (mt:thread-active-p thread))
+
+(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock"))
+(defvar *mailboxes* (list))
+(declaim (type list *mailboxes*))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ thread
+ locked-by
+ (mutex (mt:make-lock :name "thread mailbox"))
+ (semaphore (mt:make-semaphore))
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mt:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+(defimplementation send (thread message)
+ (handler-case
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+;; (mt:interrupt-thread
+;; thread
+;; (lambda ()
+;; (mt:with-lock (mutex)
+;; (setf (mailbox.queue mbox)
+;; (nconc (mailbox.queue mbox) (list message))))))
+
+;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%"
+;; mt:*thread* thread message) (finish-output)
+ (mt:with-lock (mutex)
+ (setf (mailbox.locked-by mbox) mt:*thread*)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ ;;(format t "*") (finish-output)
+ (handler-case
+ (mt:semaphore-signal (mailbox.semaphore mbox))
+ (condition (condition)
+ (format t "Something went bad with semaphore-signal ~A" condition) (finish-output)
+ ;;(break)
+ ))
+ (setf (mailbox.locked-by mbox) nil)
+ )
+ ;;(format t "+") (finish-output)
+ )
+ (condition (condition)
+ (format t "~&Error in send: ~S~%" condition) (finish-output))
+ )
+ )
+
+;; (defimplementation receive ()
+;; (block got-mail
+;; (let* ((mbox (mailbox mt:*thread*))
+;; (mutex (mailbox.mutex mbox)))
+;; (loop
+;; (mt:with-lock (mutex)
+;; (if (mailbox.queue mbox)
+;; (return-from got-mail (pop (mailbox.queue mbox)))))
+;; ;;interrupt-thread will halt this if it takes longer than 1sec
+;; (sleep 1)))))
+
+
+(defimplementation receive-if (test &optional timeout)
+ (handler-case
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox))
+ got-one)
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ ;;(format t "~&: ~S~%" mt:*thread*) (finish-output)
+ (handler-case
+ (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2))
+ (condition (condition)
+ (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition)
+ (finish-output)
+ nil
+ )
+ )
+ (mt:with-lock (mutex)
+ (setf (mailbox.locked-by mbox) mt:*thread*)
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (when tail
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (setf (mailbox.locked-by mbox) nil)
+ ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail))
+ (return (car tail))))
+ (setf (mailbox.locked-by mbox) nil)
+ )
+
+ ;;(format t "/ ~S~%" mt:*thread*) (finish-output)
+ (when (eq timeout t) (return (values nil t)))
+;; (unless got-one
+;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%"))
+ )
+ )
+ (condition (condition)
+ (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output)
+ nil
+ )
+ )
+ )
+
+
+(defmethod stream-finish-output ((stream stream))
+ (finish-output stream))
+
+
+;;
+
+;;#+windows
+(defimplementation doze-in-repl ()
+ (setq *inferior-lisp-sleeping-post* (mt:make-semaphore))
+ ;;(loop (sleep 1))
+ (mt:semaphore-wait *inferior-lisp-sleeping-post*)
+ (mk-ext:quit :verbose t)
+ )
+
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-05 13:21:03 +0000