diff options
Diffstat (limited to 'vim/bundle/slimv/slime/swank/clisp.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/swank/clisp.lisp | 930 |
1 files changed, 930 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank/clisp.lisp b/vim/bundle/slimv/slime/swank/clisp.lisp new file mode 100644 index 0000000..27ae688 --- /dev/null +++ b/vim/bundle/slimv/slime/swank/clisp.lisp @@ -0,0 +1,930 @@ +;;;; -*- 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/ + +(defpackage swank/clisp + (:use cl swank/backend)) + +(in-package swank/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" 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/clisp::*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/clisp::*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 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-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 &optional env) + (declare (ignore env)) + (ext:expand-form form)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,form)))) + (values macro-forms nil))) + +(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 *sldb-backtrace*) + +(defun sldb-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) + (*sldb-backtrace* + (let* ((f (sys::the-frame)) + (bt (sldb-backtrace)) + (rest (member f bt))) + (if rest (nthcdr 8 rest) bt)))) + (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 + 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 *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 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) (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 `(swank-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + swank-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (swank-monitor:unmonitor)) + +(defimplementation profile-report () + (swank-monitor:report-monitoring)) + +(defimplementation profile-reset () + (swank-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (swank-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 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))) |