Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

912 lines (773 sloc) 33.988 kb
;;;; -*- indent-tabs-mode: nil -*-
;;;; SWANK support for CLISP.
;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
;;;; published by the Free Software Foundation; either version 2 of
;;;; the License, or (at your option) any later version.
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;; You should have received a copy of the GNU General Public
;;;; License along with this program; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;;;; MA 02111-1307, USA.
;;; This is work in progress, but it's already usable. Many things
;;; are adapted from other swank-*.lisp, in particular from
;;; swank-allegro (I don't use allegro at all, but it's the shortest
;;; one and I found Helmut Eller's code there enlightening).
;;; This code will work better with recent versions of CLISP (say, the
;;; last release or CVS HEAD) while it may not work at all with older
;;; versions. It is reasonable to expect it to work on platforms with
;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
;;; systems, but also on Win32. This backend uses the portable xref
;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
;;; are conveniently included in SLIME.
;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
(in-package :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
;;(use-package "SOCKET")
(use-package "GRAY"))
;;;; if this lisp has the complete CLOS then we use it, otherwise we
;;;; build up a "fake" swank-mop and then override the methods in the
;;;; inspector.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *have-mop*
(and (find-package :clos)
(eql :external
(nth-value 1 (find-symbol (string ':standard-slot-definition)
:clos))))
"True in those CLISP images which have a complete MOP implementation."))
#+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
(progn
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
(clos::slot-definition-documentation slot)))
#-#.(cl:if swank-backend::*have-mop* '(and) '(or))
(defclass swank-mop:standard-slot-definition ()
()
(:documentation
"Dummy class created so that swank.lisp will compile and load."))
(let ((getpid (or (find-symbol "PROCESS-ID" :system)
;; old name prior to 2005-03-01, clisp <= 2.33.2
(find-symbol "PROGRAM-ID" :system)
#+win32 ; integrated into the above since 2005-02-24
(and (find-package :win32) ; optional modules/win32
(find-symbol "GetCurrentProcessId" :win32)))))
(defimplementation getpid () ; a required interface
(cond
(getpid (funcall getpid))
#+win32 ((ext:getenv "PID")) ; where does that come from?
(t -1))))
(defimplementation call-with-user-break-handler (handler function)
(handler-bind ((system::simple-interrupt-condition
(lambda (c)
(declare (ignore c))
(funcall handler)
(when (find-restart 'socket-status)
(invoke-restart (find-restart 'socket-status)))
(continue))))
(funcall function)))
(defimplementation lisp-implementation-type-name ()
"clisp")
(defimplementation set-default-directory (directory)
(setf (ext:default-directory) directory)
(namestring (setf *default-pathname-defaults* (ext:default-directory))))
(defimplementation filename-to-pathname (string)
(cond ((member :cygwin *features*)
(parse-cygwin-filename string))
(t (parse-namestring string))))
(defun parse-cygwin-filename (string)
(multiple-value-bind (match _ drive absolute)
(regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
(declare (ignore _))
(assert (and match (if drive absolute t)) ()
"Invalid filename syntax: ~a" string)
(let* ((sans-prefix (subseq string (regexp:match-end match)))
(path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
(path (loop for name in path collect
(cond ((equal name "..") ':back)
(t name))))
(directoryp (or (equal string "")
(find (aref string (1- (length string))) "\\/"))))
(multiple-value-bind (file type)
(cond ((and (not directoryp) (last path))
(let* ((file (car (last path)))
(pos (position #\. file :from-end t)))
(cond ((and pos (> pos 0))
(values (subseq file 0 pos)
(subseq file (1+ pos))))
(t file)))))
(make-pathname :host nil
:device nil
:directory (cons
(if absolute :absolute :relative)
(let ((path (if directoryp
path
(butlast path))))
(if drive
(cons
(regexp:match-string string drive)
path)
path)))
:name file
:type type)))))
;;;; UTF
(defimplementation string-to-utf8 (string)
(let ((enc (load-time-value
(ext:make-encoding :charset "utf-8" :line-terminator :unix)
t)))
(ext:convert-string-to-bytes string enc)))
(defimplementation utf8-to-string (octets)
(let ((enc (load-time-value
(ext:make-encoding :charset "utf-8" :line-terminator :unix)
t)))
(ext:convert-string-from-bytes octets enc)))
;;;; TCP Server
(defimplementation create-socket (host port &key backlog)
(socket:socket-server port :interface host :backlog (or backlog 5)))
(defimplementation local-port (socket)
(socket:socket-server-port socket))
(defimplementation close-socket (socket)
(socket:socket-server-close socket))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout))
(socket:socket-accept socket
:buffered buffering ;; XXX may not work if t
:element-type (if external-format
'character
'(unsigned-byte 8))
:external-format (or external-format :default)))
#-win32
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
(loop
(cond ((check-slime-interrupts) (return :interrupt))
(timeout
(socket:socket-status streams 0 0)
(return (loop for (s _ . x) in streams
if x collect s)))
(t
(with-simple-restart (socket-status "Return from socket-status.")
(socket:socket-status streams 0 500000))
(let ((ready (loop for (s _ . x) in streams
if x collect s)))
(when ready (return ready))))))))
#+win32
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(loop
(cond ((check-slime-interrupts) (return :interrupt))
(t
(let ((ready (remove-if-not #'input-available-p streams)))
(when ready (return ready)))
(when timeout (return nil))
(sleep 0.1)))))
#+win32
;; Some facts to remember (for the next time we need to debug this):
;; - interactive-sream-p returns t for socket-streams
;; - listen returns nil for socket-streams
;; - (type-of <socket-stream>) is 'stream
;; - (type-of *terminal-io*) is 'two-way-stream
;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
;; - calling socket:socket-status on non sockets signals an error,
;; but seems to mess up something internally.
;; - calling read-char-no-hang on sockets does not signal an error,
;; but seems to mess up something internally.
(defun input-available-p (stream)
(case (stream-element-type stream)
(character
(let ((c (read-char-no-hang stream nil nil)))
(cond ((not c)
nil)
(t
(unread-char c stream)
t))))
(t
(eq (socket:socket-status (cons stream :input) 0 0)
:input))))
;;;; Coding systems
(defvar *external-format-to-coding-system*
'(((:charset "iso-8859-1" :line-terminator :unix)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
((:charset "iso-8859-1")
"latin-1" "iso-latin-1" "iso-8859-1")
((:charset "utf-8") "utf-8")
((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
((:charset "euc-jp") "euc-jp")
((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
((:charset "us-ascii") "us-ascii")
((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
(defimplementation find-external-format (coding-system)
(let ((args (car (rassoc-if (lambda (x)
(member coding-system x :test #'equal))
*external-format-to-coding-system*))))
(and args (apply #'ext:make-encoding args))))
;;;; Swank functions
(defimplementation arglist (fname)
(block nil
(or (ignore-errors
(let ((exp (function-lambda-expression fname)))
(and exp (return (second exp)))))
(ignore-errors
(return (ext:arglist fname)))
:not-available)))
(defimplementation macroexpand-all (form)
(ext:expand-form form))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result ()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push :variable (when (boundp symbol) (doc 'variable)))
(when (fboundp symbol)
(maybe-push
;; Report WHEN etc. as macros, even though they may be
;; implemented as special operators.
(if (macro-function symbol) :macro
(typecase (fdefinition symbol)
(generic-function :generic-function)
(function :function)
;; (type-of 'progn) -> ext:special-operator
(t :special-operator)))
(doc 'function)))
(when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
(get symbol 'system::setf-expander)); defsetf
(maybe-push :setf (doc 'setf)))
(when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
(get symbol 'system::defstruct-description)
(get symbol 'system::deftype-expander))
(maybe-push :type (doc 'type))) ; even for 'structure
(when (find-class symbol nil)
(maybe-push :class (doc 'type)))
;; Let this code work compiled in images without FFI
(let ((types (load-time-value
(and (find-package "FFI")
(symbol-value
(find-symbol "*C-TYPE-TABLE*" "FFI"))))))
;; Use ffi::*c-type-table* so as not to suffer the overhead of
;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
;; which are not FFI type names.
(when (and types (nth-value 1 (gethash symbol types)))
;; Maybe use (case (head (ffi:deparse-c-type)))
;; to distinguish struct and union types?
(maybe-push :alien-type :not-documented)))
result)))
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable (describe symbol))
(:macro (describe (macro-function symbol)))
(:function (describe (symbol-function symbol)))
(:class (describe (find-class symbol)))))
(defun fspec-pathname (spec)
(let ((path spec)
type
lines)
(when (consp path)
(psetq type (car path)
path (cadr path)
lines (cddr path)))
(when (and path
(member (pathname-type path)
custom:*compiled-file-types* :test #'equal))
(setq path
(loop for suffix in custom:*source-file-types*
thereis (probe-file (make-pathname :defaults path
:type suffix)))))
(values path type lines)))
(defun fspec-location (name fspec)
(multiple-value-bind (file type lines)
(fspec-pathname fspec)
(list (if type (list name type) name)
(cond (file
(multiple-value-bind (truename c)
(ignore-errors (truename file))
(cond (truename
(make-location
(list :file (namestring truename))
(if (consp lines)
(list* :line lines)
(list :function-name (string name)))
(when (consp type)
(list :snippet (format nil "~A" type)))))
(t (list :error (princ-to-string c))))))
(t (list :error
(format nil "No source information available for: ~S"
fspec)))))))
(defimplementation find-definitions (name)
(mapcar #'(lambda (e) (fspec-location name e))
(documentation name 'sys::file)))
(defun trim-whitespace (string)
(string-trim #(#\newline #\space #\tab) string))
(defvar *sldb-backtrace*)
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (string< "2.44" (lisp-implementation-version))
(pushnew :clisp-2.44+ *features*)))
(defun sldb-backtrace ()
"Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
(do ((frames '())
(last nil frame)
(frame (sys::the-frame)
#+clisp-2.44+ (sys::frame-up 1 frame 1)
#-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
((eq frame last) (nreverse frames))
(unless (boring-frame-p frame)
(push frame frames))))
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* (;;(sys::*break-count* (1+ sys::*break-count*))
;;(sys::*driver* debugger-loop-fn)
;;(sys::*fasoutput-stream* nil)
(*sldb-backtrace*
(nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
(funcall debugger-loop-fn)))
(defun nth-frame (index)
(nth index *sldb-backtrace*))
(defun boring-frame-p (frame)
(member (frame-type frame) '(stack-value bind-var bind-env)))
(defun frame-to-string (frame)
(with-output-to-string (s)
(sys::describe-frame s frame)))
;; FIXME: they changed the layout in 2.44 so the frame-to-string &
;; string-matching silliness no longer works.
(defun frame-type (frame)
;; FIXME: should bind *print-length* etc. to small values.
(frame-string-type (frame-to-string frame)))
(defvar *frame-prefixes*
'(("frame binding variables" bind-var)
("<1> #<compiled-function" compiled-fun)
("<1> #<system-function" sys-fun)
("<1> #<special-operator" special-op)
("EVAL frame" eval)
("APPLY frame" apply)
("compiled tagbody frame" compiled-tagbody)
("compiled block frame" compiled-block)
("block frame" block)
("nested block frame" block)
("tagbody frame" tagbody)
("nested tagbody frame" tagbody)
("catch frame" catch)
("handler frame" handler)
("unwind-protect frame" unwind-protect)
("driver frame" driver)
("frame binding environments" bind-env)
("CALLBACK frame" callback)
("- " stack-value)
("<1> " fun)
("<2> " 2nd-frame)))
(defun frame-string-type (string)
(cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
*frame-prefixes*)))
(defimplementation compute-backtrace (start end)
(let* ((bt *sldb-backtrace*)
(len (length bt)))
(loop for f in (subseq bt start (min (or end len) len))
collect f)))
(defimplementation print-frame (frame stream)
(let* ((str (frame-to-string frame)))
(write-string (extract-frame-line str)
stream)))
(defun extract-frame-line (frame-string)
(let ((s frame-string))
(trim-whitespace
(case (frame-string-type s)
((eval special-op)
(string-match "EVAL frame .*for form \\(.*\\)" s 1))
(apply
(string-match "APPLY frame for call \\(.*\\)" s 1))
((compiled-fun sys-fun fun)
(extract-function-name s))
(t s)))))
(defun extract-function-name (string)
(let ((1st (car (split-frame-string string))))
(or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
1st
1)
(string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
1st)))
(defun split-frame-string (string)
(let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
(mapcar #'car *frame-prefixes*))))
(loop for pos = 0 then (1+ (regexp:match-start match))
for match = (regexp:match rx string :start pos)
if match collect (subseq string pos (regexp:match-start match))
else collect (subseq string pos)
while match)))
(defun string-match (pattern string n)
(let* ((match (nth-value n (regexp:match pattern string))))
(if match (regexp:match-string string match))))
(defimplementation format-sldb-condition (condition)
(trim-whitespace (princ-to-string condition)))
(defimplementation eval-in-frame (form frame-number)
(sys::eval-at (nth-frame frame-number) form))
(defimplementation frame-locals (frame-number)
(let ((frame (nth-frame frame-number)))
(loop for i below (%frame-count-vars frame)
collect (list :name (%frame-var-name frame i)
:value (%frame-var-value frame i)
:id 0))))
(defimplementation frame-var-value (frame var)
(%frame-var-value (nth-frame frame) var))
;;; Interpreter-Variablen-Environment has the shape
;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
(defun %frame-count-vars (frame)
(cond ((sys::eval-frame-p frame)
(do ((venv (frame-venv frame) (next-venv venv))
(count 0 (+ count (/ (1- (length venv)) 2))))
((not venv) count)))
((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
(length (%parse-stack-values frame)))
(t 0)))
(defun %frame-var-name (frame i)
(cond ((sys::eval-frame-p frame)
(nth-value 0 (venv-ref (frame-venv frame) i)))
(t (format nil "~D" i))))
(defun %frame-var-value (frame i)
(cond ((sys::eval-frame-p frame)
(let ((name (venv-ref (frame-venv frame) i)))
(multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
(if c
(format-sldb-condition c)
v))))
((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
(let ((str (nth i (%parse-stack-values frame))))
(trim-whitespace (subseq str 2))))
(t (break "Not implemented"))))
(defun frame-venv (frame)
(let ((env (sys::eval-at frame '(sys::the-environment))))
(svref env 0)))
(defun next-venv (venv) (svref venv (1- (length venv))))
(defun venv-ref (env i)
"Reference the Ith binding in ENV.
Return two values: NAME and VALUE"
(let ((idx (* i 2)))
(if (< idx (1- (length env)))
(values (svref env idx) (svref env (1+ idx)))
(venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
(defun %parse-stack-values (frame)
(labels ((next (fp)
#+clisp-2.44+ (sys::frame-down 1 fp 1)
#-clisp-2.44+ (sys::frame-down-1 fp 1))
(parse (fp accu)
(let ((str (frame-to-string fp)))
(cond ((is-prefix-p "- " str)
(parse (next fp) (cons str accu)))
((is-prefix-p "<1> " str)
;;(when (eq (frame-type frame) 'compiled-fun)
;; (pop accu))
(dolist (str (cdr (split-frame-string str)))
(when (is-prefix-p "- " str)
(push str accu)))
(nreverse accu))
(t (parse (next fp) accu))))))
(parse (next frame) '())))
(setq *features* (remove :clisp-2.44+ *features*))
(defun is-prefix-p (pattern string)
(not (mismatch pattern string :end2 (min (length pattern)
(length string)))))
(defimplementation return-from-frame (index form)
(sys::return-from-eval-frame (nth-frame index) form))
(defimplementation restart-frame (index)
(sys::redo-eval-frame (nth-frame index)))
(defimplementation frame-source-location (index)
`(:error
,(format nil "frame-source-location not implemented. (frame: ~A)"
(nth-frame index))))
;;;; Profiling
(defimplementation profile (fname)
(eval `(mon:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
mon:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(mon:unmonitor))
(defimplementation profile-report ()
(mon:report-monitoring))
(defimplementation profile-reset ()
(mon:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(mon:monitor-all package))
;;;; Handle compiler conditions (find out location of error etc.)
(defmacro compile-file-frobbing-notes ((&rest args) &body body)
"Pass ARGS to COMPILE-FILE, send the compiler notes to
*STANDARD-INPUT* and frob them in BODY."
`(let ((*error-output* (make-string-output-stream))
(*compile-verbose* t))
(multiple-value-prog1
(compile-file ,@args)
(handler-case
(with-input-from-string
(*standard-input* (get-output-stream-string *error-output*))
,@body)
(sys::simple-end-of-file () nil)))))
(defvar *orig-c-warn* (symbol-function 'system::c-warn))
(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
(defvar *orig-c-error* (symbol-function 'system::c-error))
(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
(defmacro dynamic-flet (names-functions &body body)
"(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
Execute BODY with NAME's function slot set to FUNCTION."
`(ext:letf* ,(loop for (name function) in names-functions
collect `((symbol-function ',name) ,function))
,@body))
(defvar *buffer-name* nil)
(defvar *buffer-offset*)
(defun compiler-note-location ()
"Return the current compiler location."
(let ((lineno1 sys::*compile-file-lineno1*)
(lineno2 sys::*compile-file-lineno2*)
(file sys::*compile-file-truename*))
(cond ((and file lineno1 lineno2)
(make-location (list ':file (namestring file))
(list ':line lineno1)))
(*buffer-name*
(make-location (list ':buffer *buffer-name*)
(list ':offset *buffer-offset* 0)))
(t
(list :error "No error location available")))))
(defun signal-compiler-warning (cstring args severity orig-fn)
(signal 'compiler-condition
:severity severity
:message (apply #'format nil cstring args)
:location (compiler-note-location))
(apply orig-fn cstring args))
(defun c-warn (cstring &rest args)
(signal-compiler-warning cstring args :warning *orig-c-warn*))
(defun c-style-warn (cstring &rest args)
(dynamic-flet ((sys::c-warn *orig-c-warn*))
(signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
(defun c-error (&rest args)
(signal 'compiler-condition
:severity :error
:message (apply #'format nil
(if (= (length args) 3)
(cdr args)
args))
:location (compiler-note-location))
(apply *orig-c-error* args))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((warning #'handle-notification-condition))
(dynamic-flet ((system::c-warn #'c-warn)
(system::c-style-warn #'c-style-warn)
(system::c-error #'c-error))
(funcall function))))
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning."
(signal 'compiler-condition
:original-condition condition
:severity :warning
:message (princ-to-string condition)
:location (compiler-note-location)))
(defimplementation swank-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(with-compilation-unit ()
(multiple-value-bind (fasl-file warningsp failurep)
(compile-file input-file
:output-file output-file
:external-format external-format)
(values fasl-file warningsp
(or failurep
(and load-p
(not (load fasl-file)))))))))
(defimplementation swank-compile-string (string &key buffer position filename
policy)
(declare (ignore filename policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-offset* position))
(funcall (compile nil (read-from-string
(format nil "(~S () ~A)" 'lambda string))))
t)))
;;;; Portable XREF from the CMU AI repository.
(setq pxref::*handle-package-forms* '(cl:in-package))
(defmacro defxref (name function)
`(defimplementation ,name (name)
(xref-results (,function name))))
(defxref who-calls pxref:list-callers)
(defxref who-references pxref:list-readers)
(defxref who-binds pxref:list-setters)
(defxref who-sets pxref:list-setters)
(defxref list-callers pxref:list-callers)
(defxref list-callees pxref:list-callees)
(defun xref-results (symbols)
(let ((xrefs '()))
(dolist (symbol symbols)
(push (fspec-location symbol symbol) xrefs))
xrefs))
(when (find-package :swank-loader)
(setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
(lambda ()
(let ((home (user-homedir-pathname)))
(and (ext:probe-directory home)
(probe-file (format nil "~A/.swank.lisp"
(namestring (truename home)))))))))
;;; Don't set *debugger-hook* to nil on break.
(ext:without-package-lock ()
(defun break (&optional (format-string "Break") &rest args)
(if (not sys::*use-clcs*)
(progn
(terpri *error-output*)
(apply #'format *error-output*
(concatenate 'string "*** - " format-string)
args)
(funcall ext:*break-driver* t))
(let ((condition
(make-condition 'simple-condition
:format-control format-string
:format-arguments args))
;;(*debugger-hook* nil)
;; Issue 91
)
(ext:with-restarts
((continue
:report (lambda (stream)
(format stream (sys::text "Return from ~S loop")
'break))
()))
(with-condition-restarts condition (list (find-restart 'continue))
(invoke-debugger condition)))))
nil))
;;;; Inspecting
(defmethod emacs-inspect ((o t))
(let* ((*print-array* nil) (*print-pretty* t)
(*print-circle* t) (*print-escape* t)
(*print-lines* custom:*inspect-print-lines*)
(*print-level* custom:*inspect-print-level*)
(*print-length* custom:*inspect-print-length*)
(sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
(tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
(*package* tmp-pack)
(sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
(let ((inspection (sys::inspect-backend o)))
(append (list
(format nil "~S~% ~A~{~%~A~}~%" o
(sys::insp-title inspection)
(sys::insp-blurb inspection)))
(loop with count = (sys::insp-num-slots inspection)
for i below count
append (multiple-value-bind (value name)
(funcall (sys::insp-nth-slot inspection)
i)
`((:value ,name) " = " (:value ,value)
(:newline))))))))
(defimplementation quit-lisp ()
#+lisp=cl (ext:quit)
#-lisp=cl (lisp:quit))
(defimplementation preferred-communication-style ()
nil)
;;; FIXME
;;;
;;; Clisp 2.48 added experimental support for threads. Basically, you
;;; can use :SPAWN now, BUT:
;;;
;;; - there are problems with GC, and threads stuffed into weak
;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
;;;
;;; See test case at
;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
;;;
;;; Even though said to be fixed, it's not:
;;;
;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
;;;
;;; - The DYNAMIC-FLET above is an implementation technique that's
;;; probably not sustainable in light of threads. This got to be
;;; rewritten.
;;;
;;; TCR (2009-07-30)
#+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
(progn
(defimplementation spawn (fn &key name)
(mp:make-thread fn :name name))
(defvar *thread-plist-table-lock*
(mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
(defvar *thread-plist-table* (make-hash-table :weak :key)
"A hashtable mapping threads to a plist.")
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(mp:with-mutex-lock (*thread-plist-table-lock*)
(or (getf (gethash thread *thread-plist-table*) 'thread-id)
(setf (getf (gethash thread *thread-plist-table*) 'thread-id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (all-threads)
:key (lambda (thread)
(getf (gethash thread *thread-plist-table*) 'thread-id))))
(defimplementation thread-name (thread)
;; To guard against returning #<UNBOUND>.
(princ-to-string (mp:thread-name thread)))
(defimplementation thread-status (thread)
(if (thread-alive-p thread)
"RUNNING"
"STOPPED"))
(defimplementation make-lock (&key name)
(mp:make-mutex :name name :recursive-p t))
(defimplementation call-with-lock-held (lock function)
(mp:with-mutex-lock (lock)
(funcall function)))
(defimplementation current-thread ()
(mp:current-thread))
(defimplementation all-threads ()
(mp:list-threads))
(defimplementation interrupt-thread (thread fn)
(mp:thread-interrupt thread :function fn))
(defimplementation kill-thread (thread)
(mp:thread-interrupt thread :function t))
(defimplementation thread-alive-p (thread)
(mp:thread-active-p thread))
(defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
(defvar *mailboxes* (list))
(defstruct (mailbox (:conc-name mailbox.))
thread
(lock (make-lock :name "MAILBOX.LOCK"))
(waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(mp:with-mutex-lock (*mailboxes-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(lock (mailbox.lock mbox)))
(mp:with-mutex-lock (lock)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(mp:exemption-broadcast (mailbox.waitqueue mbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(lock (mailbox.lock mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
(mp:with-mutex-lock (lock)
(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)))
(mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak :value args))
(defimplementation save-image (filename &optional restart-function)
(let ((args `(,filename
,@(if restart-function
`((:init-function ,restart-function))))))
(apply #'ext:saveinitmem args)))
Jump to Line
Something went wrong with that request. Please try again.