Find file
Fetching contributors…
Cannot retrieve contributors at this time
899 lines (753 sloc) 31.6 KB
;;; -*- indent-tabs-mode: nil -*-
;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
;;; Created 2003, Helmut Eller
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
(in-package :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "comm")
(import-from :stream *gray-stream-symbols* :swank-backend))
(import-swank-mop-symbols :clos '(:slot-definition-documentation
(defun swank-mop:slot-definition-documentation (slot)
(documentation slot t))
(defun swank-mop:slot-boundp-using-class (class object slotd)
(clos:slot-boundp-using-class class object
(clos:slot-definition-name slotd)))
(defun swank-mop:slot-value-using-class (class object slotd)
(clos:slot-value-using-class class object
(clos:slot-definition-name slotd)))
(defun (setf swank-mop:slot-value-using-class) (value class object slotd)
(setf (clos:slot-value-using-class class object
(clos:slot-definition-name slotd))
(defun swank-mop:slot-makunbound-using-class (class object slotd)
(clos:slot-makunbound-using-class class object
(clos:slot-definition-name slotd)))
(defun swank-mop:compute-applicable-methods-using-classes (gf classes)
(clos::compute-applicable-methods-from-classes gf classes))
;; lispworks doesn't have the eql-specializer class, it represents
;; them as a list of `(EQL ,OBJECT)
(deftype swank-mop:eql-specializer () 'cons)
(defun swank-mop:eql-specializer-object (eql-spec)
(second eql-spec))
(eval-when (:compile-toplevel :execute :load-toplevel)
(defvar *original-defimplementation* (macro-function 'defimplementation))
(defmacro defimplementation (&whole whole name args &body body
&environment env)
(declare (ignore args body))
(dspec:record-definition '(defun ,name) (dspec:location)
:check-redefinition-p nil)
,(funcall *original-defimplementation* whole env))))
;;; TCP server
(defimplementation preferred-communication-style ()
(defun socket-fd (socket)
(etypecase socket
(fixnum socket)
(comm:socket-stream (comm:socket-stream-socket socket))))
(defimplementation create-socket (host port)
(multiple-value-bind (socket where errno)
#-(or lispworks4.1 (and macosx lispworks4.3))
(comm::create-tcp-socket-for-service port :address host)
#+(or lispworks4.1 (and macosx lispworks4.3))
(comm::create-tcp-socket-for-service port)
(cond (socket socket)
(t (error 'network-error
:format-control "~A failed: ~A (~D)"
:format-arguments (list where
(list #+unix (lw:get-unix-error errno))
(defimplementation local-port (socket)
(nth-value 1 (comm:get-socket-address (socket-fd socket))))
(defimplementation close-socket (socket)
(comm::close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering))
(let* ((fd (comm::get-fd-from-socket socket)))
(assert (/= fd -1))
(assert (valid-external-format-p external-format))
(cond ((member (first external-format) '(:latin-1 :ascii))
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type 'base-char))
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type '(unsigned-byte 8))
(defun make-flexi-stream (stream external-format)
(unless (member :flexi-streams *features*)
(error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
(funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
(apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
;;; Coding Systems
(defun valid-external-format-p (external-format)
(member external-format *external-format-to-coding-system*
:test #'equal :key #'car))
(defvar *external-format-to-coding-system*
'(((:latin-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
"latin-1" "iso-latin-1" "iso-8859-1")
((:utf-8) "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix")
((:euc-jp) "euc-jp")
((:euc-jp :eol-style :lf) "euc-jp-unix")
((:ascii) "us-ascii")
((:ascii :eol-style :lf) "us-ascii-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
;;; Unix signals
(defun sigint-handler ()
(with-simple-restart (continue "Continue from SIGINT handler.")
(invoke-debugger "SIGINT")))
(defun make-sigint-handler (process)
(lambda (&rest args)
(declare (ignore args))
(mp:process-interrupt process #'sigint-handler)))
(defun set-sigint-handler ()
;; Set SIGINT handler on Swank request handler thread.
(sys::set-signal-handler +sigint+
(make-sigint-handler mp:*current-process*)))
(defimplementation install-sigint-handler (handler)
(sys::set-signal-handler +sigint+
(let ((self mp:*current-process*))
(lambda (&rest args)
(declare (ignore args))
(mp:process-interrupt self handler)))))
(defimplementation call-without-interrupts (fn)
(lw:without-interrupts (funcall fn)))
(defimplementation getpid ()
#+win32 (win32:get-current-process-id)
#-win32 (system::getpid))
(defimplementation lisp-implementation-type-name ()
(defimplementation set-default-directory (directory)
(namestring (hcl:change-directory directory)))
;;;; Documentation
(defun map-list (function list)
"Map over proper and not proper lists."
(loop for (car . cdr) on list
collect (funcall function car) into result
when (null cdr) return result
when (atom cdr) return (nconc result (funcall function cdr))))
(defun replace-strings-with-symbols (tree)
(lambda (x)
(typecase x
(replace-strings-with-symbols x))
(intern x))
(intern (write-to-string x)))))
(defimplementation arglist (symbol-or-function)
(let ((arglist (lw:function-lambda-list symbol-or-function)))
(etypecase arglist
((member :dont-know)
(replace-strings-with-symbols arglist)))))
(defimplementation function-name (function)
(nth-value 2 (function-lambda-expression function)))
(defimplementation macroexpand-all (form)
(walker:walk-form form))
(defun generic-function-p (object)
(typep object 'generic-function))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result '()))
(labels ((first-line (string)
(let ((pos (position #\newline string)))
(if (null pos) string (subseq string 0 pos))))
(doc (kind &optional (sym symbol))
(let ((string (or (documentation sym kind))))
(if string
(first-line string)
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
:variable (when (boundp symbol)
(doc 'variable)))
:generic-function (if (and (fboundp symbol)
(generic-function-p (fdefinition symbol)))
(doc 'function)))
:function (if (and (fboundp symbol)
(not (generic-function-p (fdefinition symbol))))
(doc 'function)))
:setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
(if (fboundp setf-name)
(doc 'setf))))
:class (if (find-class symbol nil)
(doc 'class)))
(defimplementation describe-definition (symbol type)
(ecase type
(:variable (describe-symbol symbol))
(:class (describe (find-class symbol)))
((:function :generic-function) (describe-function symbol))
(:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
(defun describe-function (symbol)
(cond ((fboundp symbol)
(format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
(lispworks:function-lambda-list symbol)
(documentation symbol 'function))
(describe (fdefinition symbol)))
(t (format t "~S is not fbound" symbol))))
(defun describe-symbol (sym)
(format t "~A is a symbol in package ~A." sym (symbol-package sym))
(when (boundp sym)
(format t "~%~%Value: ~A" (symbol-value sym)))
(let ((doc (documentation sym 'variable)))
(when doc
(format t "~%~%Variable documentation:~%~A" doc)))
(when (fboundp sym)
(describe-function sym)))
;;; Debugging
(defclass slime-env (env:environment)
((debugger-hook :initarg :debugger-hoook)))
(defun slime-env (hook io-bindings)
(make-instance 'slime-env :name "SLIME Environment"
:io-bindings io-bindings
:debugger-hoook hook))
(defmethod env-internals:environment-display-notifier
((env slime-env) &key restarts condition)
(declare (ignore restarts condition))
(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
;; nil
(defmethod env-internals:environment-display-debugger ((env slime-env))
(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
(apply (swank-sym :y-or-n-p-in-emacs) msg args))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook))
(env:with-environment ((slime-env hook '()))
(funcall fun))))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setf (env:environment) (slime-env function '())))
(defvar *sldb-top-frame*)
(defun interesting-frame-p (frame)
(cond ((or (dbg::call-frame-p frame)
(dbg::derived-call-frame-p frame)
(dbg::foreign-frame-p frame)
(dbg::interpreted-call-frame-p frame))
((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
((dbg::open-frame-p frame) dbg:*print-open-frames*)
(t nil)))
(defun nth-next-frame (frame n)
"Unwind FRAME N times."
(do ((frame frame (dbg::frame-next frame))
(i n (if (interesting-frame-p frame) (1- i) i)))
((or (not frame)
(and (interesting-frame-p frame) (zerop i)))
(defun nth-frame (index)
(nth-next-frame *sldb-top-frame* index))
(defun find-top-frame ()
"Return the most suitable top-frame for the debugger."
(or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
(nth-next-frame frame 1)))
((or (null frame) ; no frame found!
(and (dbg::call-frame-p frame)
(eq (dbg::call-frame-function-name frame)
(nth-next-frame frame 1)))
;; if we can't find a invoke-debugger frame, take any old frame at the top
(dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
(defimplementation call-with-debugging-environment (fn)
(dbg::with-debugger-stack ()
(let ((*sldb-top-frame* (find-top-frame)))
(funcall fn))))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum))
(backtrace '()))
(do ((frame (nth-frame start) (dbg::frame-next frame))
(i start))
((or (not frame) (= i end)) (nreverse backtrace))
(when (interesting-frame-p frame)
(incf i)
(push frame backtrace)))))
(defun frame-actual-args (frame)
(let ((*break-on-signals* nil))
(mapcar (lambda (arg)
(case arg
((&rest &optional &key) arg)
(handler-case (dbg::dbg-eval arg frame)
(error (e) (format nil "<~A>" arg))))))
(dbg::call-frame-arglist frame))))
(defimplementation print-frame (frame stream)
(cond ((dbg::call-frame-p frame)
(format stream "~S ~S"
(dbg::call-frame-function-name frame)
(frame-actual-args frame)))
(t (princ frame stream))))
(defun frame-vars (frame)
(first (dbg::frame-locals-format-list frame #'list 75 0)))
(defimplementation frame-locals (n)
(let ((frame (nth-frame n)))
(if (dbg::call-frame-p frame)
(mapcar (lambda (var)
(destructuring-bind (name value symbol location) var
(declare (ignore name location))
(list :name symbol :id 0
:value value)))
(frame-vars frame)))))
(defimplementation frame-var-value (frame var)
(let ((frame (nth-frame frame)))
(destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
(declare (ignore _n _s _l))
(defimplementation frame-source-location (frame)
(let ((frame (nth-frame frame))
(callee (if (plusp frame) (nth-frame (1- frame)))))
(if (dbg::call-frame-p frame)
(let ((dspec (dbg::call-frame-function-name frame))
(cname (and (dbg::call-frame-p callee)
(dbg::call-frame-function-name callee))))
(if dspec
(frame-location dspec cname))))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (nth-frame frame-number)))
(dbg::dbg-eval form frame)))
(defimplementation return-from-frame (frame-number form)
(let* ((frame (nth-frame frame-number))
(return-frame (dbg::find-frame-for-return frame)))
(dbg::dbg-return-from-call-frame frame form return-frame
(defimplementation restart-frame (frame-number)
(let ((frame (nth-frame frame-number)))
(dbg::restart-frame frame :same-args t)))
(defimplementation disassemble-frame (frame-number)
(let* ((frame (nth-frame frame-number)))
(when (dbg::call-frame-p frame)
(let ((function (dbg::get-call-frame-function frame)))
(disassemble function)))))
;;; Definition finding
(defun frame-location (dspec callee-name)
(let ((infos (dspec:find-dspec-locations dspec)))
(cond (infos
(destructuring-bind ((rdspec location) &rest _) infos
(declare (ignore _))
(let ((name (and callee-name (symbolp callee-name)
(string callee-name))))
(make-dspec-location rdspec location
`(:call-site ,name)))))
(list :error (format nil "Source location not available for: ~S"
(defimplementation find-definitions (name)
(let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
(loop for (dspec location) in locations
collect (list dspec (make-dspec-location dspec location)))))
;;; Compilation
(defmacro with-swank-compilation-unit ((location &rest options) &body body)
(lw:rebinding (location)
`(let ((compiler::*error-database* '()))
(with-compilation-unit ,options
(multiple-value-prog1 (progn ,@body)
(signal-error-data-base compiler::*error-database*
(signal-undefined-functions compiler::*unknown-functions*
(defimplementation swank-compile-file (input-file output-file
load-p external-format)
(with-swank-compilation-unit (input-file)
(compile-file input-file
:output-file output-file
:load load-p
:external-format external-format)))
(defvar *within-call-with-compilation-hooks* nil
"Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
(defvar *undefined-functions-hash* nil
"Hash table to map info about undefined functions to pathnames.")
(lw:defadvice (compile-file compile-file-and-collect-notes :around)
(pathname &rest rest)
(multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
(when *within-call-with-compilation-hooks*
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
(let ((unfun-info (list unfun dspec)))
(unless (gethash unfun-info *undefined-functions-hash*)
(setf (gethash unfun-info *undefined-functions-hash*)
(defimplementation call-with-compilation-hooks (function)
(let ((compiler::*error-database* '())
(*undefined-functions-hash* (make-hash-table :test 'equal))
(*within-call-with-compilation-hooks* t))
(with-compilation-unit ()
(prog1 (funcall function)
(signal-error-data-base compiler::*error-database*)
(signal-undefined-functions compiler::*unknown-functions*)))))
(defun map-error-database (database fn)
(loop for (filename . defs) in database do
(loop for (dspec . conditions) in defs do
(dolist (c conditions)
(funcall fn filename dspec (if (consp c) (car c) c))))))
(defun lispworks-severity (condition)
(cond ((not condition) :warning)
(t (etypecase condition
(error :error)
(style-warning :warning)
(warning :warning)))))
(defun signal-compiler-condition (message location condition)
(check-type message string)
(make-instance 'compiler-condition :message message
:severity (lispworks-severity condition)
:location location
:original-condition condition)))
(defvar *temp-file-format* '(:utf-8 :eol-style :lf))
(defun compile-from-temp-file (string filename)
(with-open-file (s filename :direction :output
:if-exists :supersede
:external-format *temp-file-format*)
(write-string string s)
(finish-output s))
(multiple-value-bind (binary-filename warnings? failure?)
(compile-file filename :load t
:external-format *temp-file-format*)
(declare (ignore warnings?))
(when binary-filename
(delete-file binary-filename))
(not failure?)))
(delete-file filename)))
(defun dspec-function-name-position (dspec fallback)
(etypecase dspec
(cons (let ((name (dspec:dspec-primary-name dspec)))
(typecase name
((or symbol string)
(list :function-name (string name)))
(t fallback))))
(null fallback)
(symbol (list :function-name (string dspec)))))
(defmacro with-fairly-standard-io-syntax (&body body)
(let ((package (gensym))
(readtable (gensym)))
`(let ((,package *package*)
(,readtable *readtable*))
(let ((*package* ,package)
(*readtable* ,readtable))
(defun skip-comments (stream)
(let ((pos0 (file-position stream)))
(cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
(file-position stream (1- (file-position stream))))
(t (file-position stream pos0)))))
#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
(defun dspec-stream-position (stream dspec)
(loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
(form (read stream nil '#1=#:eof)))
(when (eq form '#1#)
(return nil))
(labels ((check-dspec (form)
(when (consp form)
(let ((operator (car form)))
(case operator
(mapcar #'check-dspec
(cdr form)))
((eval-when locally macrolet symbol-macrolet)
(mapcar #'check-dspec
(cddr form)))
(let ((package (find-package (second form))))
(when package
(setq *package* package))))
(let ((form-dspec (dspec:parse-form-dspec form)))
(when (dspec:dspec-equal dspec form-dspec)
(return pos)))))))))
(check-dspec form))))))
(defun dspec-file-position (file dspec)
(let* ((*compile-file-pathname* (pathname file))
(*compile-file-truename* (truename *compile-file-pathname*))
(*load-pathname* *compile-file-pathname*)
(*load-truename* *compile-file-truename*))
(with-open-file (stream file)
(let ((pos
#-(or lispworks4.1 lispworks4.2)
(dspec-stream-position stream dspec)))
(if pos
(list :position (1+ pos))
(dspec-function-name-position dspec `(:position 1)))))))
(defun emacs-buffer-location-p (location)
(and (consp location)
(eq (car location) :emacs-buffer)))
(defun make-dspec-location (dspec location &optional hints)
(etypecase location
((or pathname string)
(multiple-value-bind (file err)
(ignore-errors (namestring (truename location)))
(if err
(list :error (princ-to-string err))
(make-location `(:file ,file)
(dspec-file-position file dspec)
`(:error ,(format nil "Cannot resolve location: ~S" location)))
((satisfies emacs-buffer-location-p)
(destructuring-bind (_ buffer offset string) location
(declare (ignore _ string))
(make-location `(:buffer ,buffer)
(dspec-function-name-position dspec `(:offset ,offset 0))
(defun make-dspec-progenitor-location (dspec location)
(let ((canon-dspec (dspec:canonicalize-dspec dspec)))
(if canon-dspec
(if (dspec:local-dspec-p canon-dspec)
(dspec:dspec-progenitor canon-dspec)
(defun signal-error-data-base (database &optional location)
(lambda (filename dspec condition)
(format nil "~A" condition)
(make-dspec-progenitor-location dspec (or location filename))
(defun unmangle-unfun (symbol)
"Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
function names like \(SETF GET)."
(cond ((sys::setf-symbol-p symbol)
(sys::setf-pair-from-underlying-name symbol))
(t symbol)))
(defun signal-undefined-functions (htab &optional filename)
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
(format nil "Undefined function ~A" (unmangle-unfun unfun))
(make-dspec-progenitor-location dspec
(or filename
(gethash (list unfun dspec)
(defimplementation swank-compile-string (string &key buffer position filename
(declare (ignore filename policy))
(assert buffer)
(assert position)
(let* ((location (list :emacs-buffer buffer position string))
(tmpname (hcl:make-temp-file nil "lisp")))
(with-swank-compilation-unit (location)
(with-output-to-string (s)
(let ((*print-radix* t))
(print `(eval-when (:compile-toplevel)
(setq dspec::*location* (list ,@location)))
(write-string string s))
;;; xref
(defmacro defxref (name function)
`(defimplementation ,name (name)
(xref-results (,function name))))
(defxref who-calls hcl:who-calls)
(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
(defxref calls-who hcl:calls-who)
(defxref list-callers list-callers-internal)
;; (defxref list-callees list-callees-internal)
(defun list-callers-internal (name)
(let ((callers (make-array 100
:fill-pointer 0
:adjustable t)))
#'(lambda (object)
(when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
#-Harlequin-PC-Lisp (sys::callablep object)
(system::find-constant$funcallable name object))
(vector-push-extend object callers))))
;; Delay dspec:object-dspec until after sweep-all-objects
;; to reduce allocation problems.
(loop for object across callers
collect (if (symbolp object)
(list 'function object)
(or (dspec:object-dspec object) object)))))
;; only for lispworks 4.2 and above
(defxref who-references hcl:who-references)
(defxref who-binds hcl:who-binds)
(defxref who-sets hcl:who-sets))
(defimplementation who-specializes (classname)
(let ((methods (clos:class-direct-methods (find-class classname))))
(xref-results (mapcar #'dspec:object-dspec methods))))
(defun xref-results (dspecs)
(flet ((frob-locs (dspec locs)
(cond (locs
(loop for (name loc) in locs
collect (list name (make-dspec-location name loc))))
(t `((,dspec (:error "Source location not available")))))))
(loop for dspec in dspecs
append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
;;; Inspector
(defmethod emacs-inspect ((o t))
(lispworks-inspect o))
(defmethod emacs-inspect ((o function))
(lispworks-inspect o))
;; FIXME: slot-boundp-using-class in LW works with names so we can't
;; use our method in swank.lisp.
(defmethod emacs-inspect ((o standard-object))
(lispworks-inspect o))
(defun lispworks-inspect (o)
(multiple-value-bind (names values _getter _setter type)
(lw:get-inspector-values o nil)
(declare (ignore _getter _setter))
(label-value-line "Type" type)
(loop for name in names
for value in values
append (label-value-line name value)))))
;;; Miscellaneous
(defimplementation quit-lisp ()
;;; Tracing
(defun parse-fspec (fspec)
"Return a dspec for FSPEC."
(ecase (car fspec)
((:defmethod) `(method ,(cdr fspec)))))
(defun tracedp (dspec)
(member dspec (eval '(trace)) :test #'equal))
(defun toggle-trace-aux (dspec)
(cond ((tracedp dspec)
(eval `(untrace ,dspec))
(format nil "~S is now untraced." dspec))
(eval `(trace (,dspec)))
(format nil "~S is now traced." dspec))))
(defimplementation toggle-trace (fspec)
(toggle-trace-aux (parse-fspec fspec)))
;;; Multithreading
(defimplementation initialize-multiprocessing (continuation)
(cond ((not mp::*multiprocessing*)
(push (list "Initialize SLIME" '() continuation)
(t (funcall continuation))))
(defimplementation spawn (fn &key name)
(mp:process-run-function name () fn))
(defvar *id-lock* (mp:make-lock))
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(mp:with-lock (*id-lock*)
(or (getf (mp:process-plist thread) 'id)
(setf (getf (mp:process-plist thread) 'id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (mp:list-all-processes)
:key (lambda (p) (getf (mp:process-plist p) 'id))))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(format nil "~A ~D"
(mp:process-whostate thread)
(mp:process-priority thread)))
(defimplementation make-lock (&key name)
(mp:make-lock :name name))
(defimplementation call-with-lock-held (lock function)
(mp:with-lock (lock) (funcall function)))
(defimplementation current-thread ()
(defimplementation all-threads ()
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
(defimplementation kill-thread (thread)
(mp:process-kill thread))
(defimplementation thread-alive-p (thread)
(mp:process-alive-p thread))
(defstruct (mailbox (:conc-name mailbox.))
(mutex (mp:make-lock :name "thread mailbox"))
(queue '() :type list))
(defvar *mailbox-lock* (mp:make-lock))
(defun mailbox (thread)
(mp:with-lock (*mailbox-lock*)
(or (getf (mp:process-plist thread) 'mailbox)
(setf (getf (mp:process-plist thread) 'mailbox)
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox mp:*current-process*))
(lock (mailbox.mutex mbox)))
(assert (or (not timeout) (eq timeout t)))
(mp:with-lock (lock "receive-if/try")
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail)))))
(when (eq timeout t) (return (values nil t)))
"receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(mp:with-lock ((mailbox.mutex mbox))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(defimplementation set-default-initial-binding (var form)
(setq mp:*process-initial-bindings*
(acons var `(eval (quote ,form))
mp:*process-initial-bindings* )))
(defimplementation thread-attributes (thread)
(list :priority (mp:process-priority thread)
:idle (mp:process-idle-time thread)))
;;; Some intergration with the lispworks environment
(defun swank-sym (name) (find-symbol (string name) :swank))
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-kind :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak-kind :value args))