dotemacs

mkcl.lisp (31123B)

---

 ;;;; -*- indent-tabs-mode: nil -*-
 ;;;
 ;;; slynk-mkcl.lisp --- SLIME backend for MKCL.
 ;;;
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
 
 ;;; Administrivia
 
 (defpackage slynk-mkcl
   (:use cl slynk-backend))
 
 (in-package slynk-mkcl)
 
 ;;(declaim (optimize (debug 3)))
 
 (defvar *tmp*)
 
 (defimplementation gray-package-name ()
   '#:gray)
 
 (eval-when (:compile-toplevel :load-toplevel)
 
   (slynk-backend::import-slynk-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
   ;; SLYNK: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 ()
   ;; restore original IO streams.
   (progf (ignore-errors (eval
                          (slynk-backend:find-symbol2 "slynk::*saved-global-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 slynk-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 "~%slynk saw a compiler note: ~A~%" n) (finish-output) nil))
                      (compiler::compiler-warning
                       #'(lambda (w)
                           (format t "~%slynk saw a compiler warning: ~A~%" w) (finish-output) nil))
                      (compiler::compiler-error
                       #'(lambda (e)
                           (format t "~%slynk 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 slynk-compile-string (string &key buffer position filename line column policy)
   (declare (ignore filename line column 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-SLYNK-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-slynk-package-p (x)
   (and
    (symbolp x)
    (member (symbol-package x)
            (list #.(find-package :slynk)
                  #.(find-package :slynk-backend)
                  #.(ignore-errors (find-package :slynk-mop))
                  #.(ignore-errors (find-package :slynk-loader))))
    t))
 
 (defun is-slynk-source-p (name)
   (setf name (pathname name))
   #+(or)
   (pathname-match-p
    name
    (make-pathname :defaults slynk-loader::*source-directory*
                   :name (pathname-name name)
                   :type (pathname-type name)
                   :version (pathname-version name)))
   nil)
 
 (defun is-ignorable-fun-p (x)
   (or
    (in-slynk-package-p (frame-name x))
    (multiple-value-bind (file position)
        (ignore-errors (si::compiled-function-file (car x)))
      (declare (ignore position))
      (if file (is-slynk-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 (slynk-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 (slynk-mkcl) receive-if: semaphore-wait timed out!~%"))
        )
     )
     (condition (condition)
       (format t "~&Error in (slynk-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)
   )