path: root/vim/bundle/slimv/slime/swank/mkcl.lisp

;;;; -*- 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)
  )