;;;; -*- indent-tabs-mode: nil -*-
;;;; SLYNK 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 slynk-*.lisp, in particular from
;;; slynk-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 SLY.
;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
(defpackage slynk-clisp
(:use cl slynk-backend))
(in-package slynk-clisp)
(eval-when (:compile-toplevel)
(unless (string< "2.44" (lisp-implementation-version))
(error "Need at least CLISP version 2.44")))
(defimplementation gray-package-name ()
"GRAY")
;;;; if this lisp has the complete CLOS then we use it, otherwise we
;;;; build up a "fake" slynk-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 slynk-clisp::*have-mop* '(cl:and) '(cl:or))
(progn
(import-slynk-mop-symbols :clos '(:slot-definition-documentation))
(defun slynk-mop:slot-definition-documentation (slot)
(clos::slot-definition-documentation slot)))
#-#.(cl:if slynk-clisp::*have-mop* '(and) '(or))
(defclass slynk-mop:standard-slot-definition ()
()
(:documentation
"Dummy class created so that slynk.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-sly-interrupts) (return :interrupt))
(timeout
(socket:socket-status streams 0 0)
(return (loop for (s nil . 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 nil . 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-sly-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))))
;;;; Slynk 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 &optional env)
(declare (ignore env))
(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)))))
(defimplementation type-specifier-p (symbol)
(or (ignore-errors
(subtypep nil symbol))
(not (eq (type-specifier-arglist symbol) :not-available))))
(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 *sly-db-backtrace*)
(defun sly-db-backtrace ()
"Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
(let* ((modes '((:all-stack-elements 1)
(:all-frames 2)
(:only-lexical-frames 3)
(:only-eval-and-apply-frames 4)
(:only-apply-frames 5)))
(mode (cadr (assoc :all-stack-elements modes))))
(do ((frames '())
(last nil frame)
(frame (sys::the-frame)
(sys::frame-up 1 frame mode)))
((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)
(*sly-db-backtrace*
(let* ((f (sys::the-frame))
(bt (sly-db-backtrace))
(rest (member f bt)))
(if rest (nthcdr 8 rest) bt))))
(funcall debugger-loop-fn)))
(defun nth-frame (index)
(nth index *sly-db-backtrace*))
(defun boring-frame-p (frame)
(member (frame-type frame) '(stack-value bind-var bind-env
compiled-tagbody compiled-block)))
(defun frame-to-string (frame)
(with-output-to-string (s)
(sys::describe-frame s frame)))
(defun frame-type (frame)
;; FIXME: should bind *print-length* etc. to small values.
(frame-string-type (frame-to-string frame)))
;; FIXME: they changed the layout in 2.44 and not all patterns have
;; been updated.
(defvar *frame-prefixes*
'(("\\[[0-9]\\+\\] 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)
("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
("\\[[0-9]\\+\\] 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)
("\\[[0-9]\\+\\] 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 *sly-db-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 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-sly-db-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) (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) '())))
(defun is-prefix-p (regexp string)
(if (regexp:match (concatenate 'string "^" regexp) string) t))
(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 `(slynk-monitor:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
slynk-monitor:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(slynk-monitor:unmonitor))
(defimplementation profile-report ()
(slynk-monitor:report-monitoring))
(defimplementation profile-reset ()
(slynk-monitor:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(slynk-monitor: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 slynk-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 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-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 :slynk-loader)
(setf (symbol-function (intern "USER-INIT-FILE" :slynk-loader))
(lambda ()
(let ((home (user-homedir-pathname)))
(and (ext:probe-directory home)
(probe-file (format nil "~A/.slynk.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-sly-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)))