summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime/swank
diff options
context:
space:
mode:
Diffstat (limited to 'vim/bundle/slimv/slime/swank')
-rw-r--r--vim/bundle/slimv/slime/swank/abcl.lisp847
-rw-r--r--vim/bundle/slimv/slime/swank/allegro.lisp1053
-rw-r--r--vim/bundle/slimv/slime/swank/backend.lisp1536
-rw-r--r--vim/bundle/slimv/slime/swank/ccl.lisp861
-rw-r--r--vim/bundle/slimv/slime/swank/clasp.lisp730
-rw-r--r--vim/bundle/slimv/slime/swank/clisp.lisp930
-rw-r--r--vim/bundle/slimv/slime/swank/cmucl.lisp2470
-rw-r--r--vim/bundle/slimv/slime/swank/corman.lisp583
-rw-r--r--vim/bundle/slimv/slime/swank/ecl.lisp845
-rw-r--r--vim/bundle/slimv/slime/swank/gray.lisp170
-rw-r--r--vim/bundle/slimv/slime/swank/lispworks.lisp1018
-rw-r--r--vim/bundle/slimv/slime/swank/match.lisp242
-rw-r--r--vim/bundle/slimv/slime/swank/mkcl.lisp933
-rw-r--r--vim/bundle/slimv/slime/swank/rpc.lisp162
-rw-r--r--vim/bundle/slimv/slime/swank/sbcl.lisp2044
-rw-r--r--vim/bundle/slimv/slime/swank/scl.lisp1726
-rw-r--r--vim/bundle/slimv/slime/swank/source-file-cache.lisp136
-rw-r--r--vim/bundle/slimv/slime/swank/source-path-parser.lisp239
18 files changed, 16525 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank/abcl.lisp b/vim/bundle/slimv/slime/swank/abcl.lisp
new file mode 100644
index 0000000..f5764d6
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/abcl.lisp
@@ -0,0 +1,847 @@
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
+;;;
+;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
+;;;
+;;; Adapted from swank-acl.lisp, Andras Simon, 2004
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/abcl
+ (:use cl swank/backend))
+
+(in-package swank/abcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :collect) ;just so that it doesn't spoil the flying letters
+ (require :pprint)
+ (require :gray-streams)
+ (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4))
+ 0.22)
+ () "This file needs ABCL version 0.22 or newer"))
+
+(defimplementation gray-package-name ()
+ "GRAY-STREAMS")
+
+;; FIXME: switch to shared Gray stream implementation when bugs are
+;; fixed in ABCL. See: http://abcl.org/trac/ticket/373.
+(progn
+ (defimplementation make-output-stream (write-string)
+ (ext:make-slime-output-stream write-string))
+
+ (defimplementation make-input-stream (read-string)
+ (ext:make-slime-input-stream read-string
+ (make-synonym-stream '*standard-output*))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (funcall function))
+
+;;; swank-mop
+
+;;dummies and definition
+
+(defclass standard-slot-definition ()())
+
+;(defun class-finalized-p (class) t)
+
+(defun slot-definition-documentation (slot)
+ (declare (ignore slot))
+ #+nil (documentation slot 't))
+
+(defun slot-definition-type (slot)
+ (declare (ignore slot))
+ t)
+
+(defun class-prototype (class)
+ (declare (ignore class))
+ nil)
+
+(defun generic-function-declarations (gf)
+ (declare (ignore gf))
+ nil)
+
+(defun specializer-direct-methods (spec)
+ (mop:class-direct-methods spec))
+
+(defun slot-definition-name (slot)
+ (mop:slot-definition-name slot))
+
+(defun class-slots (class)
+ (mop:class-slots class))
+
+(defun method-generic-function (method)
+ (mop:method-generic-function method))
+
+(defun method-function (method)
+ (mop:method-function method))
+
+(defun slot-boundp-using-class (class object slotdef)
+ (declare (ignore class))
+ (system::slot-boundp object (slot-definition-name slotdef)))
+
+(defun slot-value-using-class (class object slotdef)
+ (declare (ignore class))
+ (system::slot-value object (slot-definition-name slotdef)))
+
+(import-to-swank-mop
+ '( ;; classes
+ cl:standard-generic-function
+ standard-slot-definition ;;dummy
+ cl:method
+ cl:standard-class
+ #+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes
+ 'mop)
+ mop:compute-applicable-methods-using-classes
+ ;; standard-class readers
+ mop:class-default-initargs
+ mop:class-direct-default-initargs
+ mop:class-direct-slots
+ mop:class-direct-subclasses
+ mop:class-direct-superclasses
+ mop:eql-specializer
+ mop:class-finalized-p
+ mop:finalize-inheritance
+ cl:class-name
+ mop:class-precedence-list
+ class-prototype ;;dummy
+ class-slots
+ specializer-direct-methods
+ ;; eql-specializer accessors
+ mop::eql-specializer-object
+ ;; generic function readers
+ mop:generic-function-argument-precedence-order
+ generic-function-declarations ;;dummy
+ mop:generic-function-lambda-list
+ mop:generic-function-methods
+ mop:generic-function-method-class
+ mop:generic-function-method-combination
+ mop:generic-function-name
+ ;; method readers
+ method-generic-function
+ method-function
+ mop:method-lambda-list
+ mop:method-specializers
+ mop:method-qualifiers
+ ;; slot readers
+ mop:slot-definition-allocation
+ slot-definition-documentation ;;dummy
+ mop:slot-definition-initargs
+ mop:slot-definition-initform
+ mop:slot-definition-initfunction
+ slot-definition-name
+ slot-definition-type ;;dummy
+ mop:slot-definition-readers
+ mop:slot-definition-writers
+ slot-boundp-using-class
+ slot-value-using-class
+ mop:slot-makunbound-using-class))
+
+;;;; TCP Server
+
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (ext:make-server-socket port))
+
+(defimplementation local-port (socket)
+ (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
+
+(defimplementation close-socket (socket)
+ (ext:server-socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout))
+ (ext:get-socket-stream (ext:socket-accept socket)
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format (or external-format :default)))
+
+;;;; UTF8
+
+;; faster please!
+(defimplementation string-to-utf8 (s)
+ (jbytes-to-octets
+ (java:jcall
+ (java:jmethod "java.lang.String" "getBytes" "java.lang.String")
+ s
+ "UTF8")))
+
+(defimplementation utf8-to-string (u)
+ (java:jnew
+ (java:jconstructor "org.armedbear.lisp.SimpleString"
+ "java.lang.String")
+ (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
+ (octets-to-jbytes u)
+ "UTF8")))
+
+(defun octets-to-jbytes (octets)
+ (declare (type octets (simple-array (unsigned-byte 8) (*))))
+ (let* ((len (length octets))
+ (bytes (java:jnew-array "byte" len)))
+ (loop for byte across octets
+ for i from 0
+ do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
+ "java.lang.Object" "int" "byte")
+ "java.lang.relect.Array"
+ bytes i byte))
+ bytes))
+
+(defun jbytes-to-octets (jbytes)
+ (let* ((len (java:jarray-length jbytes))
+ (octets (make-array len :element-type '(unsigned-byte 8))))
+ (loop for i from 0 below len
+ for jbyte = (java:jarray-ref jbytes i)
+ do (setf (aref octets i) jbyte))
+ octets))
+
+;;;; External formats
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:iso-8859-1 :eol-style :lf)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ (:utf-8 "utf-8")
+ ((:utf-8 :eol-style :lf) "utf-8-unix")
+ (:euc-jp "euc-jp")
+ ((:euc-jp :eol-style :lf) "euc-jp-unix")
+ (:us-ascii "us-ascii")
+ ((:us-ascii :eol-style :lf) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x)
+ (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+;;;; Unix signals
+
+(defimplementation getpid ()
+ (handler-case
+ (let* ((runtime
+ (java:jstatic "getRuntime" "java.lang.Runtime"))
+ (command
+ (java:jnew-array-from-array
+ "java.lang.String" #("sh" "-c" "echo $PPID")))
+ (runtime-exec-jmethod
+ ;; Complicated because java.lang.Runtime.exec() is
+ ;; overloaded on a non-primitive type (array of
+ ;; java.lang.String), so we have to use the actual
+ ;; parameter instance to get java.lang.Class
+ (java:jmethod "java.lang.Runtime" "exec"
+ (java:jcall
+ (java:jmethod "java.lang.Object" "getClass")
+ command)))
+ (process
+ (java:jcall runtime-exec-jmethod runtime command))
+ (output
+ (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
+ process)))
+ (java:jcall (java:jmethod "java.lang.Process" "waitFor")
+ process)
+ (loop :with b :do
+ (setq b
+ (java:jcall (java:jmethod "java.io.InputStream" "read")
+ output))
+ :until (member b '(-1 #x0a)) ; Either EOF or LF
+ :collecting (code-char b) :into result
+ :finally (return
+ (parse-integer (coerce result 'string)))))
+ (t () 0)))
+
+(defimplementation lisp-implementation-type-name ()
+ "armedbear")
+
+(defimplementation set-default-directory (directory)
+ (let ((dir (sys::probe-directory directory)))
+ (when dir (setf *default-pathname-defaults* dir))
+ (namestring dir)))
+
+
+;;;; Misc
+
+(defimplementation arglist (fun)
+ (cond ((symbolp fun)
+ (multiple-value-bind (arglist present)
+ (sys::arglist fun)
+ (when (and (not present)
+ (fboundp fun)
+ (typep (symbol-function fun)
+ 'standard-generic-function))
+ (setq arglist
+ (mop::generic-function-lambda-list (symbol-function fun))
+ present
+ t))
+ (if present arglist :not-available)))
+ (t :not-available)))
+
+(defimplementation function-name (function)
+ (nth-value 2 (function-lambda-expression function)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (ext:macroexpand-all form env))
+
+(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 () ,(macroexpand-all form env)))))
+ (values macro-forms nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym 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
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((typep (fdefinition symbol) 'generic-function)
+ :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ ((:variable :macro)
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+
+;;;; Debugger
+
+;; Copied from swank-sbcl.lisp.
+;;
+;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
+;; so we have to make sure that the latter gets run when it was
+;; established locally by a user (i.e. changed meanwhile.)
+(defun make-invoke-debugger-hook (hook)
+ (lambda (condition old-hook)
+ (if *debugger-hook*
+ (funcall *debugger-hook* condition old-hook)
+ (funcall hook condition old-hook))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall fun)))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+
+(defvar *sldb-topframe*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
+ (*sldb-topframe*
+ (second (member magic-token (sys:backtrace)
+ :key (lambda (frame)
+ (first (sys:frame-to-list frame)))))))
+ (funcall debugger-loop-fn)))
+
+(defun backtrace (start end)
+ "A backtrace without initial SWANK frames."
+ (let ((backtrace (sys:backtrace)))
+ (subseq (or (member *sldb-topframe* backtrace) backtrace)
+ start end)))
+
+(defun nth-frame (index)
+ (nth index (backtrace 0 nil)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (backtrace start end)))
+
+(defimplementation print-frame (frame stream)
+ (write-string (sys:frame-to-string frame)
+ stream))
+
+;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET.
+;;; --ME 20150403
+(defun nth-frame-list (index)
+ (java:jcall "toLispList" (nth-frame index)))
+
+(defun match-lambda (operator values)
+ (jvm::match-lambda-list
+ (multiple-value-list
+ (jvm::parse-lambda-list (ext:arglist operator)))
+ values))
+
+(defimplementation frame-locals (index)
+ (loop
+ :for id :upfrom 0
+ :with frame = (nth-frame-list index)
+ :with operator = (first frame)
+ :with values = (rest frame)
+ :with arglist = (if (and operator (consp values) (not (null values)))
+ (handler-case
+ (match-lambda operator values)
+ (jvm::lambda-list-mismatch (e)
+ :lambda-list-mismatch))
+ :not-available)
+ :for value :in values
+ :collecting (list
+ :name (if (not (keywordp arglist))
+ (first (nth id arglist))
+ (format nil "arg~A" id))
+ :id id
+ :value value)))
+
+(defimplementation frame-var-value (index id)
+ (elt (rest (java:jcall "toLispList" (nth-frame index))) id))
+
+
+#+nil
+(defimplementation disassemble-frame (index)
+ (disassemble (debugger:frame-function (nth-frame index))))
+
+(defimplementation frame-source-location (index)
+ (let ((frame (nth-frame index)))
+ (or (source-location (nth-frame index))
+ `(:error ,(format nil "No source for frame: ~a" frame)))))
+
+#+nil
+(defimplementation eval-in-frame (form frame-number)
+ (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame (nth-frame frame-number))))
+
+#+nil
+(defimplementation return-from-frame (frame-number form)
+ (let ((frame (nth-frame frame-number)))
+ (multiple-value-call #'debugger:frame-return
+ frame (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame frame)))))
+
+;;; XXX doesn't work for frames with arguments
+#+nil
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (debugger:frame-retry frame (debugger:frame-function frame))))
+
+;;;; Compiler hooks
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defvar *abcl-signaled-conditions*)
+
+(defun handle-compiler-warning (condition)
+ (let ((loc (when (and jvm::*compile-file-pathname*
+ system::*source-position*)
+ (cons jvm::*compile-file-pathname* system::*source-position*))))
+ ;; filter condition signaled more than once.
+ (unless (member condition *abcl-signaled-conditions*)
+ (push condition *abcl-signaled-conditions*)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "~A" condition)
+ :location (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0)))
+ (loc
+ (destructuring-bind (file . pos) loc
+ (make-location
+ (list :file (namestring (truename file)))
+ (list :position (1+ pos)))))
+ (t
+ (make-location
+ (list :file (namestring *compile-filename*))
+ (list :position 1))))))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore external-format policy))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (multiple-value-bind (fn warn fail)
+ (compile-file input-file :output-file output-file)
+ (values fn warn
+ (and fn load-p
+ (not (load fn)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string)
+ (sys::*source* (make-pathname :device "emacs-buffer" :name buffer))
+ (sys::*source-position* position))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))
+ t))))
+
+#|
+;;;; Definition Finding
+
+(defun find-fspec-location (fspec type)
+ (let ((file (excl::fspec-pathname fspec type)))
+ (etypecase file
+ (pathname
+ (let ((start (scm:find-definition-in-file fspec type file)))
+ (make-location (list :file (namestring (truename file)))
+ (if start
+ (list :position (1+ start))
+ (list :function-name (string fspec))))))
+ ((member :top-level)
+ (list :error (format nil "Defined at toplevel: ~A" fspec)))
+ (null
+ (list :error (format nil "Unkown source location for ~A" fspec))))))
+
+(defun fspec-definition-locations (fspec)
+ (let ((defs (excl::find-multiple-definitions fspec)))
+ (loop for (fspec type) in defs
+ collect (list fspec (find-fspec-location fspec type)))))
+
+(defimplementation find-definitions (symbol)
+ (fspec-definition-locations symbol))
+|#
+
+(defgeneric source-location (object))
+
+(defmethod source-location ((symbol symbol))
+ (when (pathnamep (ext:source-pathname symbol))
+ (let ((pos (ext:source-file-position symbol))
+ (path (namestring (ext:source-pathname symbol))))
+ (cond ((ext:pathname-jar-p path)
+ `(:location
+ ;; strip off "jar:file:" = 9 characters
+ (:zip ,@(split-string (subseq path 9) "!/"))
+ ;; pos never seems right. Use function name.
+ (:function-name ,(string symbol))
+ (:align t)))
+ ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer")
+ ;; conspire with swank-compile-string to keep the buffer
+ ;; name in a pathname whose device is "emacs-buffer".
+ `(:location
+ (:buffer ,(pathname-name (ext:source-pathname symbol)))
+ (:function-name ,(string symbol))
+ (:align t)))
+ (t
+ `(:location
+ (:file ,path)
+ ,(if pos
+ (list :position (1+ pos))
+ (list :function-name (string symbol)))
+ (:align t)))))))
+
+(defmethod source-location ((frame sys::java-stack-frame))
+ (destructuring-bind (&key class method file line) (sys:frame-to-list frame)
+ (declare (ignore method))
+ (let ((file (or (find-file-in-path file *source-path*)
+ (let ((f (format nil "~{~a/~}~a"
+ (butlast (split-string class "\\."))
+ file)))
+ (find-file-in-path f *source-path*)))))
+ (and file
+ `(:location ,file (:line ,line) ())))))
+
+(defmethod source-location ((frame sys::lisp-stack-frame))
+ (destructuring-bind (operator &rest args) (sys:frame-to-list frame)
+ (declare (ignore args))
+ (etypecase operator
+ (function (source-location operator))
+ (list nil)
+ (symbol (source-location operator)))))
+
+(defmethod source-location ((fun function))
+ (let ((name (function-name fun)))
+ (and name (source-location name))))
+
+(defun system-property (name)
+ (java:jstatic "getProperty" "java.lang.System" name))
+
+(defun pathname-parent (pathname)
+ (make-pathname :directory (butlast (pathname-directory pathname))))
+
+(defun pathname-absolute-p (pathname)
+ (eq (car (pathname-directory pathname)) ':absolute))
+
+(defun split-string (string regexp)
+ (coerce
+ (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
+ string regexp)
+ 'list))
+
+(defun path-separator ()
+ (java:jfield "java.io.File" "pathSeparator"))
+
+(defun search-path-property (prop-name)
+ (let ((string (system-property prop-name)))
+ (and string
+ (remove nil
+ (mapcar #'truename
+ (split-string string (path-separator)))))))
+
+(defun jdk-source-path ()
+ (let* ((jre-home (truename (system-property "java.home")))
+ (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
+ (truename (probe-file src-zip)))
+ (and truename (list truename))))
+
+(defun class-path ()
+ (append (search-path-property "java.class.path")
+ (search-path-property "sun.boot.class.path")))
+
+(defvar *source-path*
+ (append (search-path-property "user.dir")
+ (jdk-source-path)
+ ;;(list (truename "/scratch/abcl/src"))
+ )
+ "List of directories to search for source files.")
+
+(defun zipfile-contains-p (zipfile-name entry-name)
+ (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile"
+ "java.lang.String")
+ zipfile-name)))
+ (java:jcall
+ (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
+ zipfile entry-name)))
+
+;; (find-file-in-path "java/lang/String.java" *source-path*)
+;; (find-file-in-path "Lisp.java" *source-path*)
+
+;; Try to find FILENAME in PATH. If found, return a file spec as
+;; needed by Emacs. We also look in zip files.
+(defun find-file-in-path (filename path)
+ (labels ((try (dir)
+ (cond ((not (pathname-type dir))
+ (let ((f (probe-file (merge-pathnames filename dir))))
+ (and f `(:file ,(namestring f)))))
+ ((equal (pathname-type dir) "zip")
+ (try-zip dir))
+ (t (error "strange path element: ~s" path))))
+ (try-zip (zip)
+ (let* ((zipfile-name (namestring (truename zip))))
+ (and (zipfile-contains-p zipfile-name filename)
+ `(:dir ,zipfile-name ,filename)))))
+ (cond ((pathname-absolute-p filename) (probe-file filename))
+ (t
+ (loop for dir in path
+ if (try dir) return it)))))
+
+(defimplementation find-definitions (symbol)
+ (ext:resolve symbol)
+ (let ((srcloc (source-location symbol)))
+ (and srcloc `((,symbol ,srcloc)))))
+
+#|
+Uncomment this if you have patched xref.lisp, as in
+http://article.gmane.org/gmane.lisp.slime.devel/2425
+Also, make sure that xref.lisp is loaded by modifying the armedbear
+part of *sysdep-pathnames* in swank.loader.lisp.
+
+;;;; XREF
+(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 (list symbol (cadar (source-location symbol))) xrefs))
+ xrefs))
+|#
+
+;;;; Inspecting
+(defmethod emacs-inspect ((o t))
+ (let ((parts (sys:inspected-parts o)))
+ `("The object is of type " ,(symbol-name (type-of o)) "." (:newline)
+ ,@(if parts
+ (loop :for (label . value) :in parts
+ :appending (label-value-line label value))
+ (list "No inspectable parts, dumping output of CL:DESCRIBE:"
+ '(:newline)
+ (with-output-to-string (desc) (describe o desc)))))))
+
+(defmethod emacs-inspect ((slot mop::slot-definition))
+ `("Name: "
+ (:value ,(mop:slot-definition-name slot))
+ (:newline)
+ "Documentation:" (:newline)
+ ,@(when (slot-definition-documentation slot)
+ `((:value ,(slot-definition-documentation slot)) (:newline)))
+ "Initialization:" (:newline)
+ " Args: " (:value ,(mop:slot-definition-initargs slot)) (:newline)
+ " Form: " ,(if (mop:slot-definition-initfunction slot)
+ `(:value ,(mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ " Function: "
+ (:value ,(mop:slot-definition-initfunction slot))
+ (:newline)))
+
+(defmethod emacs-inspect ((f function))
+ `(,@(when (function-name f)
+ `("Name: "
+ ,(princ-to-string (function-name f)) (:newline)))
+ ,@(multiple-value-bind (args present)
+ (sys::arglist f)
+ (when present
+ `("Argument list: "
+ ,(princ-to-string args) (:newline))))
+ (:newline)
+ #+nil,@(when (documentation f t)
+ `("Documentation:" (:newline)
+ ,(documentation f t) (:newline)))
+ ,@(when (function-lambda-expression f)
+ `("Lambda expression:"
+ (:newline) ,(princ-to-string
+ (function-lambda-expression f)) (:newline)))))
+
+;;; Although by convention toString() is supposed to be a
+;;; non-computationally expensive operation this isn't always the
+;;; case, so make its computation a user interaction.
+(defparameter *to-string-hashtable* (make-hash-table))
+(defmethod emacs-inspect ((o java:java-object))
+ (let ((to-string (lambda ()
+ (handler-case
+ (setf (gethash o *to-string-hashtable*)
+ (java:jcall "toString" o))
+ (t (e)
+ (setf (gethash o *to-string-hashtable*)
+ (format nil
+ "Could not invoke toString(): ~A"
+ e)))))))
+ (append
+ (if (gethash o *to-string-hashtable*)
+ (label-value-line "toString()" (gethash o *to-string-hashtable*))
+ `((:action "[compute toString()]" ,to-string) (:newline)))
+ (loop :for (label . value) :in (sys:inspected-parts o)
+ :appending (label-value-line label value)))))
+
+;;;; Multithreading
+
+(defimplementation spawn (fn &key name)
+ (threads:make-thread (lambda () (funcall fn)) :name name))
+
+(defvar *thread-plists* (make-hash-table) ; should be a weak table
+ "A hashtable mapping threads to a plist.")
+
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (threads:synchronized-on *thread-plists*
+ (or (getf (gethash thread *thread-plists*) 'id)
+ (setf (getf (gethash thread *thread-plists*) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (thread)
+ (getf (gethash thread *thread-plists*) 'id))))
+
+(defimplementation thread-name (thread)
+ (threads:thread-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
+
+(defimplementation make-lock (&key name)
+ (declare (ignore name))
+ (threads:make-thread-lock))
+
+(defimplementation call-with-lock-held (lock function)
+ (threads:with-thread-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ (threads:current-thread))
+
+(defimplementation all-threads ()
+ (copy-list (threads:mapcar-threads #'identity)))
+
+(defimplementation thread-alive-p (thread)
+ (member thread (all-threads)))
+
+(defimplementation interrupt-thread (thread fn)
+ (threads:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (threads:destroy-thread thread))
+
+(defstruct mailbox
+ (queue '()))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (threads:synchronized-on *thread-plists*
+ (or (getf (gethash thread *thread-plists*) 'mailbox)
+ (setf (getf (gethash thread *thread-plists*) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (threads:synchronized-on mbox
+ (setf (mailbox-queue mbox)
+ (nconc (mailbox-queue mbox) (list message)))
+ (threads:object-notify-all mbox))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread))))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (threads:synchronized-on mbox
+ (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)))
+ (threads:object-wait mbox 0.3))))))
+
+(defimplementation quit-lisp ()
+ (ext:exit))
+;;;
+#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext)
+(defimplementation package-local-nicknames (package)
+ (ext:package-local-nicknames package))
diff --git a/vim/bundle/slimv/slime/swank/allegro.lisp b/vim/bundle/slimv/slime/swank/allegro.lisp
new file mode 100644
index 0000000..f5918da
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/allegro.lisp
@@ -0,0 +1,1053 @@
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
+;;;
+;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/allegro
+ (:use cl swank/backend))
+
+(in-package swank/allegro)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sock)
+ (require :process)
+ #+(version>= 8 2)
+ (require 'lldb))
+
+(defimplementation gray-package-name ()
+ '#:excl)
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+
+;;;; UTF8
+
+(define-symbol-macro utf8-ef
+ (load-time-value
+ (excl:crlf-base-ef (excl:find-external-format :utf-8))
+ t))
+
+(defimplementation string-to-utf8 (s)
+ (excl:string-to-octets s :external-format utf8-ef
+ :null-terminate nil))
+
+(defimplementation utf8-to-string (u)
+ (excl:octets-to-string u :external-format utf8-ef))
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (socket:make-socket :connect :passive :local-port port
+ :local-host host :reuse-address t
+ :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+ (socket:local-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket &key external-format buffering
+ timeout)
+ (declare (ignore buffering timeout))
+ (let ((s (socket:accept-connection socket :wait t)))
+ (when external-format
+ (setf (stream-external-format s) external-format))
+ s))
+
+(defimplementation socket-fd (stream)
+ (excl::stream-input-handle stream))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")
+ (:emacs-mule "emacs-mule" "emacs-mule-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+ (and e (excl:crlf-base-ef
+ (excl:find-external-format (car e)
+ :try-variant t)))))
+
+;;;; Unix signals
+
+(defimplementation getpid ()
+ (excl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "allegro")
+
+(defimplementation set-default-directory (directory)
+ (let* ((dir (namestring (truename (merge-pathnames directory)))))
+ (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
+ dir))
+
+(defimplementation default-directory ()
+ (namestring (excl:current-directory)))
+
+;;;; Misc
+
+(defimplementation arglist (symbol)
+ (handler-case (excl:arglist symbol)
+ (simple-error () :not-available)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ #+(version>= 8 0)
+ (excl::walk-form form)
+ #-(version>= 8 0)
+ (excl::walk form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-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))))
+
+(defimplementation function-name (f)
+ (check-type f function)
+ (cross-reference::object-to-function-name f))
+
+;;;; Debugger
+
+(defvar *sldb-topframe*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let ((*sldb-topframe* (find-topframe))
+ (excl::*break-hook* nil))
+ (funcall debugger-loop-fn)))
+
+(defimplementation sldb-break-at-start (fname)
+ ;; :print-before is kind of mis-used but we just want to stuff our
+ ;; break form somewhere. This does not work for setf, :before and
+ ;; :after methods, which need special syntax in the trace call, see
+ ;; ACL's doc/debugging.htm chapter 10.
+ (eval `(trace (,fname
+ :print-before
+ ((break "Function start breakpoint of ~A" ',fname)))))
+ `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
+
+(defun find-topframe ()
+ (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
+ (find-package :swank)))
+ (top-frame (excl::int-newest-frame (excl::current-thread))))
+ (loop for frame = top-frame then (next-frame frame)
+ for i from 0
+ while (and frame (< i 30))
+ when (eq (debugger:frame-name frame) magic-symbol)
+ return (next-frame frame)
+ finally (return top-frame))))
+
+(defun next-frame (frame)
+ (let ((next (excl::int-next-older-frame frame)))
+ (cond ((not next) nil)
+ ((debugger:frame-visible-p next) next)
+ (t (next-frame next)))))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-topframe* (next-frame frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (next-frame f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (debugger:output-frame stream frame :moderate))
+
+(defimplementation frame-locals (index)
+ (let ((frame (nth-frame index)))
+ (loop for i from 0 below (debugger:frame-number-vars frame)
+ collect (list :name (debugger:frame-var-name frame i)
+ :id 0
+ :value (debugger:frame-var-value frame i)))))
+
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (debugger:frame-var-value frame var)))
+
+(defimplementation disassemble-frame (index)
+ (let ((frame (nth-frame index)))
+ (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+ (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
+ (disassemble (debugger:frame-function frame)))))
+
+(defimplementation frame-source-location (index)
+ (let* ((frame (nth-frame index)))
+ (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+ (declare (ignore x xx xxx))
+ (cond ((and pc
+ #+(version>= 8 2)
+ (pc-source-location fun pc)
+ #-(version>= 8 2)
+ (function-source-location fun)))
+ (t ; frames for unbound functions etc end up here
+ (cadr (car (fspec-definition-locations
+ (car (debugger:frame-expression frame))))))))))
+
+(defun function-source-location (fun)
+ (cadr (car (fspec-definition-locations
+ (xref::object-to-function-name fun)))))
+
+#+(version>= 8 2)
+(defun pc-source-location (fun pc)
+ (let* ((debug-info (excl::function-source-debug-info fun)))
+ (cond ((not debug-info)
+ (function-source-location fun))
+ (t
+ (let* ((code-loc (find-if (lambda (c)
+ (<= (- pc (sys::natural-width))
+ (let ((x (excl::ldb-code-pc c)))
+ (or x -1))
+ pc))
+ debug-info)))
+ (cond ((not code-loc)
+ (ldb-code-to-src-loc (aref debug-info 0)))
+ (t
+ (ldb-code-to-src-loc code-loc))))))))
+
+#+(version>= 8 2)
+(defun ldb-code-to-src-loc (code)
+ (declare (optimize debug))
+ (let* ((func (excl::ldb-code-func code))
+ (debug-info (excl::function-source-debug-info func))
+ (start (loop for i from (excl::ldb-code-index code) downto 0
+ for bpt = (aref debug-info i)
+ for start = (excl::ldb-code-start-char bpt)
+ when start return start))
+ (src-file (excl:source-file func)))
+ (cond (start
+ (buffer-or-file-location src-file start))
+ (func
+ (let* ((debug-info (excl::function-source-debug-info func))
+ (whole (aref debug-info 0))
+ (paths (source-paths-of (excl::ldb-code-source whole)
+ (excl::ldb-code-source code)))
+ (path (if paths (longest-common-prefix paths) '()))
+ (start 0))
+ (buffer-or-file
+ src-file
+ (lambda (file)
+ (make-location `(:file ,file)
+ `(:source-path (0 . ,path) ,start)))
+ (lambda (buffer bstart)
+ (make-location `(:buffer ,buffer)
+ `(:source-path (0 . ,path)
+ ,(+ bstart start)))))))
+ (t
+ nil))))
+
+(defun longest-common-prefix (sequences)
+ (assert sequences)
+ (flet ((common-prefix (s1 s2)
+ (let ((diff-pos (mismatch s1 s2)))
+ (if diff-pos (subseq s1 0 diff-pos) s1))))
+ (reduce #'common-prefix sequences)))
+
+(defun source-paths-of (whole part)
+ (let ((result '()))
+ (labels ((walk (form path)
+ (cond ((eq form part)
+ (push (reverse path) result))
+ ((consp form)
+ (loop for i from 0 while (consp form) do
+ (walk (pop form) (cons i path)))))))
+ (walk whole '())
+ (reverse result))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (nth-frame frame-number)))
+ ;; let-bind lexical variables
+ (let ((vars (loop for i below (debugger:frame-number-vars frame)
+ for name = (debugger:frame-var-name frame i)
+ if (typep name '(and symbol (not null) (not keyword)))
+ collect `(,name ',(debugger:frame-var-value frame i)))))
+ (debugger:eval-form-in-context
+ `(let* ,vars ,form)
+ (debugger:environment-of-frame frame)))))
+
+(defimplementation frame-package (frame-number)
+ (let* ((frame (nth-frame frame-number))
+ (exp (debugger:frame-expression frame)))
+ (typecase exp
+ ((cons symbol) (symbol-package (car exp)))
+ ((cons (cons (eql :internal) (cons symbol)))
+ (symbol-package (cadar exp))))))
+
+(defimplementation return-from-frame (frame-number form)
+ (let ((frame (nth-frame frame-number)))
+ (multiple-value-call #'debugger:frame-return
+ frame (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame frame)))))
+
+(defimplementation frame-restartable-p (frame)
+ (handler-case (debugger:frame-retryable-p frame)
+ (serious-condition (c)
+ (funcall (read-from-string "swank::background-message")
+ "~a ~a" frame (princ-to-string c))
+ nil)))
+
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (cond ((debugger:frame-retryable-p frame)
+ (apply #'debugger:frame-retry frame (debugger:frame-function frame)
+ (cdr (debugger:frame-expression frame))))
+ (t "Frame is not retryable"))))
+
+;;;; Compiler hooks
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+(defun compiler-note-p (object)
+ (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
+
+(defun redefinition-p (condition)
+ (and (typep condition 'style-warning)
+ (every #'char-equal "redefin" (princ-to-string condition))))
+
+(defun compiler-undefined-functions-called-warning-p (object)
+ (typep object 'excl:compiler-undefined-functions-called-warning))
+
+(deftype compiler-note ()
+ `(satisfies compiler-note-p))
+
+(deftype redefinition ()
+ `(satisfies redefinition-p))
+
+(defun signal-compiler-condition (&rest args)
+ (apply #'signal 'compiler-condition args))
+
+(defun handle-compiler-warning (condition)
+ (declare (optimize (debug 3) (speed 0) (space 0)))
+ (cond ((and #-(version>= 10 0) (not *buffer-name*)
+ (compiler-undefined-functions-called-warning-p condition))
+ (handle-undefined-functions-warning condition))
+ ((and (typep condition 'excl::compiler-note)
+ (let ((format (slot-value condition 'excl::format-control)))
+ (and (search "Closure" format)
+ (search "will be stack allocated" format))))
+ ;; Ignore "Closure <foo> will be stack allocated" notes.
+ ;; That occurs often but is usually uninteresting.
+ )
+ (t
+ (signal-compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (redefinition :redefinition)
+ (style-warning :style-warning)
+ (warning :warning)
+ (compiler-note :note)
+ (reader-error :read-error)
+ (error :error))
+ :message (format nil "~A" condition)
+ :location (compiler-warning-location condition)))))
+
+(defun condition-pathname-and-position (condition)
+ (let* ((context #+(version>= 10 0)
+ (getf (slot-value condition 'excl::plist)
+ :source-context))
+ (location-available (and context
+ (excl::source-context-start-char context))))
+ (cond (location-available
+ (values (excl::source-context-pathname context)
+ (when-let (start-char (excl::source-context-start-char context))
+ (1+ (if (listp start-char) ; HACK
+ (first start-char)
+ start-char)))))
+ ((typep condition 'reader-error)
+ (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
+ (file (pathname (stream-error-stream condition))))
+ (when (integerp pos)
+ (values file pos))))
+ (t
+ (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
+ (when loc
+ (destructuring-bind (file . pos) loc
+ (let ((start (if (consp pos) ; 8.2 and newer
+ (car pos)
+ pos)))
+ (values file (1+ start))))))))))
+
+(defun compiler-warning-location (condition)
+ (multiple-value-bind (pathname position)
+ (condition-pathname-and-position condition)
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (if position
+ (list :position position)
+ (list :offset *buffer-start-position* 0))))
+ (pathname
+ (make-location
+ (list :file (namestring (truename pathname)))
+ (list :position position)))
+ (t
+ (make-error-location "No error location available.")))))
+
+;; TODO: report it as a bug to Franz that the condition's plist
+;; slot contains (:loc nil).
+(defun handle-undefined-functions-warning (condition)
+ (let ((fargs (slot-value condition 'excl::format-arguments)))
+ (loop for (fname . locs) in (car fargs) do
+ (dolist (loc locs)
+ (multiple-value-bind (pos file) (ecase (length loc)
+ (2 (values-list loc))
+ (3 (destructuring-bind
+ (start end file) loc
+ (declare (ignore end))
+ (values start file))))
+ (signal-compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "Undefined function referenced: ~S"
+ fname)
+ :location (make-location (list :file file)
+ (list :position (1+ pos)))))))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((warning #'handle-compiler-warning)
+ (compiler-note #'handle-compiler-warning)
+ (reader-error #'handle-compiler-warning))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (handler-case
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file)
+ #+(version>= 8 2)
+ (compiler:save-source-level-debug-info-switch t)
+ (excl:*load-source-file-info* t)
+ #+(version>= 8 2)
+ (excl:*load-source-debug-info* t))
+ (compile-file *compile-filename*
+ :output-file output-file
+ :load-after-compile load-p
+ :external-format external-format)))
+ (reader-error () (values nil nil t))))
+
+(defun call-with-temp-file (fn)
+ (let ((tmpname (system:make-temp-file-name)))
+ (unwind-protect
+ (with-open-file (file tmpname :direction :output :if-exists :error)
+ (funcall fn file tmpname))
+ (delete-file tmpname))))
+
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+ "A mapping from tempfile names to Emacs buffer names.")
+
+(defun write-tracking-preamble (stream file file-offset)
+ "Instrument the top of the temporary file to be compiled.
+
+The header tells allegro that any definitions compiled in the temp
+file should be found in FILE exactly at FILE-OFFSET. To get Allegro
+to do this, this factors in the length of the inserted header itself."
+ (with-standard-io-syntax
+ (let* ((*package* (find-package :keyword))
+ (source-pathname-form
+ `(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+ (cl:setq excl::*source-pathname*
+ (pathname ,(sys::frob-source-file file)))))
+ (source-pathname-string (write-to-string source-pathname-form))
+ (position-form-length-bound 160) ; should be enough for everyone
+ (header-length (+ (length source-pathname-string)
+ position-form-length-bound))
+ (position-form
+ `(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+ (cl:setq excl::*partial-source-file-p* ,(- file-offset
+ header-length
+ 1 ; for the newline
+ ))))
+ (position-form-string (write-to-string position-form))
+ (padding-string (make-string (- position-form-length-bound
+ (length position-form-string))
+ :initial-element #\;)))
+ (write-string source-pathname-string stream)
+ (write-string position-form-string stream)
+ (write-string padding-string stream)
+ (write-char #\newline stream))))
+
+(defun compile-from-temp-file (string buffer offset file)
+ (call-with-temp-file
+ (lambda (stream filename)
+ (when (and file offset (probe-file file))
+ (write-tracking-preamble stream file offset))
+ (write-string string stream)
+ (finish-output stream)
+ (multiple-value-bind (binary-filename warnings? failure?)
+ (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension
+ #+(version>= 8 2)
+ (compiler:save-source-level-debug-info-switch t)
+ (excl:*redefinition-warnings* nil))
+ (compile-file filename))
+ (declare (ignore warnings?))
+ (when binary-filename
+ (let ((excl:*load-source-file-info* t)
+ #+(version>= 8 2)
+ (excl:*load-source-debug-info* t))
+ excl::*source-pathname*
+ (load binary-filename))
+ (when (and buffer offset (or (not file)
+ (not (probe-file file))))
+ (setf (gethash (pathname stream) *temp-file-map*)
+ (list buffer offset)))
+ (delete-file binary-filename))
+ (not failure?)))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore policy))
+ (handler-case
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (compile-from-temp-file string buffer position filename)))
+ (reader-error () nil)))
+
+;;;; Definition Finding
+
+(defun buffer-or-file (file file-fun buffer-fun)
+ (let* ((probe (gethash file *temp-file-map*)))
+ (cond (probe
+ (destructuring-bind (buffer start) probe
+ (funcall buffer-fun buffer start)))
+ (t (funcall file-fun (namestring (truename file)))))))
+
+(defun buffer-or-file-location (file offset)
+ (buffer-or-file file
+ (lambda (filename)
+ (make-location `(:file ,filename)
+ `(:position ,(1+ offset))))
+ (lambda (buffer start)
+ (make-location `(:buffer ,buffer)
+ `(:offset ,start ,offset)))))
+
+(defun fspec-primary-name (fspec)
+ (etypecase fspec
+ (symbol fspec)
+ (list (fspec-primary-name (second fspec)))))
+
+(defun find-definition-in-file (fspec type file top-level)
+ (let* ((part
+ (or (scm::find-definition-in-definition-group
+ fspec type (scm:section-file :file file)
+ :top-level top-level)
+ (scm::find-definition-in-definition-group
+ (fspec-primary-name fspec)
+ type (scm:section-file :file file)
+ :top-level top-level)))
+ (start (and part
+ (scm::source-part-start part)))
+ (pos (if start
+ (list :position (1+ start))
+ (list :function-name (string (fspec-primary-name fspec))))))
+ (make-location (list :file (namestring (truename file)))
+ pos)))
+
+(defun find-fspec-location (fspec type file top-level)
+ (handler-case
+ (etypecase file
+ (pathname
+ (let ((probe (gethash file *temp-file-map*)))
+ (cond (probe
+ (destructuring-bind (buffer offset) probe
+ (make-location `(:buffer ,buffer)
+ `(:offset ,offset 0))))
+ (t
+ (find-definition-in-file fspec type file top-level)))))
+ ((member :top-level)
+ (make-error-location "Defined at toplevel: ~A"
+ (fspec->string fspec))))
+ (error (e)
+ (make-error-location "Error: ~A" e))))
+
+(defun fspec->string (fspec)
+ (typecase fspec
+ (symbol (let ((*package* (find-package :keyword)))
+ (prin1-to-string fspec)))
+ (list (format nil "(~A ~A)"
+ (prin1-to-string (first fspec))
+ (let ((*package* (find-package :keyword)))
+ (prin1-to-string (second fspec)))))
+ (t (princ-to-string fspec))))
+
+(defun fspec-definition-locations (fspec)
+ (cond
+ ((and (listp fspec) (eq (car fspec) :internal))
+ (destructuring-bind (_internal next _n) fspec
+ (declare (ignore _internal _n))
+ (fspec-definition-locations next)))
+ (t
+ (let ((defs (excl::find-source-file fspec)))
+ (when (and (null defs)
+ (listp fspec)
+ (string= (car fspec) '#:method))
+ ;; If methods are defined in a defgeneric form, the source location is
+ ;; recorded for the gf but not for the methods. Therefore fall back to
+ ;; the gf as the likely place of definition.
+ (setq defs (excl::find-source-file (second fspec))))
+ (if (null defs)
+ (list
+ (list fspec
+ (make-error-location "Unknown source location for ~A"
+ (fspec->string fspec))))
+ (loop for (fspec type file top-level) in defs collect
+ (list (list type fspec)
+ (find-fspec-location fspec type file top-level))))))))
+
+(defimplementation find-definitions (symbol)
+ (fspec-definition-locations symbol))
+
+(defimplementation find-source-location (obj)
+ (first (rest (first (fspec-definition-locations obj)))))
+
+;;;; XREF
+
+(defmacro defxref (name relation name1 name2)
+ `(defimplementation ,name (x)
+ (xref-result (xref:get-relation ,relation ,name1 ,name2))))
+
+(defxref who-calls :calls :wild x)
+(defxref calls-who :calls x :wild)
+(defxref who-references :uses :wild x)
+(defxref who-binds :binds :wild x)
+(defxref who-macroexpands :macro-calls :wild x)
+(defxref who-sets :sets :wild x)
+
+(defun xref-result (fspecs)
+ (loop for fspec in fspecs
+ append (fspec-definition-locations fspec)))
+
+;; list-callers implemented by groveling through all fbound symbols.
+;; Only symbols are considered. Functions in the constant pool are
+;; searched recursively. Closure environments are ignored at the
+;; moment (constants in methods are therefore not found).
+
+(defun map-function-constants (function fn depth)
+ "Call FN with the elements of FUNCTION's constant pool."
+ (do ((i 0 (1+ i))
+ (max (excl::function-constant-count function)))
+ ((= i max))
+ (let ((c (excl::function-constant function i)))
+ (cond ((and (functionp c)
+ (not (eq c function))
+ (plusp depth))
+ (map-function-constants c fn (1- depth)))
+ (t
+ (funcall fn c))))))
+
+(defun in-constants-p (fun symbol)
+ (map-function-constants fun
+ (lambda (c)
+ (when (eq c symbol)
+ (return-from in-constants-p t)))
+ 3))
+
+(defun function-callers (name)
+ (let ((callers '()))
+ (do-all-symbols (sym)
+ (when (fboundp sym)
+ (let ((fn (fdefinition sym)))
+ (when (in-constants-p fn name)
+ (push sym callers)))))
+ callers))
+
+(defimplementation list-callers (name)
+ (xref-result (function-callers name)))
+
+(defimplementation list-callees (name)
+ (let ((result '()))
+ (map-function-constants (fdefinition name)
+ (lambda (c)
+ (when (fboundp c)
+ (push c result)))
+ 2)
+ (xref-result result)))
+
+;;;; Profiling
+
+;; Per-function profiling based on description in
+;; http://www.franz.com/support/documentation/8.0/\
+;; doc/runtime-analyzer.htm#data-collection-control-2
+
+(defvar *profiled-functions* ())
+(defvar *profile-depth* 0)
+
+(defmacro with-redirected-y-or-n-p (&body body)
+ ;; If the profiler is restarted when the data from the previous
+ ;; session is not reported yet, the user is warned via Y-OR-N-P.
+ ;; As the CL:Y-OR-N-P question is (for some reason) not directly
+ ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
+ ;; overruled.
+ `(let* ((pkg (find-package :common-lisp))
+ (saved-pdl (excl::package-definition-lock pkg))
+ (saved-ynp (symbol-function 'cl:y-or-n-p)))
+ (setf (excl::package-definition-lock pkg) nil
+ (symbol-function 'cl:y-or-n-p)
+ (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
+ (unwind-protect
+ (progn ,@body)
+ (setf (symbol-function 'cl:y-or-n-p) saved-ynp
+ (excl::package-definition-lock pkg) saved-pdl))))
+
+(defun start-acl-profiler ()
+ (with-redirected-y-or-n-p
+ (prof:start-profiler :type :time :count t
+ :start-sampling-p nil :verbose nil)))
+(defun acl-profiler-active-p ()
+ (not (eq (prof:profiler-status :verbose nil) :inactive)))
+
+(defun stop-acl-profiler ()
+ (prof:stop-profiler :verbose nil))
+
+(excl:def-fwrapper profile-fwrapper (&rest args)
+ ;; Ensures sampling is done during the execution of the function,
+ ;; taking into account recursion.
+ (declare (ignore args))
+ (cond ((zerop *profile-depth*)
+ (let ((*profile-depth* (1+ *profile-depth*)))
+ (prof:start-sampling)
+ (unwind-protect (excl:call-next-fwrapper)
+ (prof:stop-sampling))))
+ (t
+ (excl:call-next-fwrapper))))
+
+(defimplementation profile (fname)
+ (unless (acl-profiler-active-p)
+ (start-acl-profiler))
+ (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
+ (push fname *profiled-functions*))
+
+(defimplementation profiled-functions ()
+ *profiled-functions*)
+
+(defimplementation unprofile (fname)
+ (excl:funwrap fname 'profile-fwrapper)
+ (setq *profiled-functions* (remove fname *profiled-functions*)))
+
+(defimplementation profile-report ()
+ (prof:show-flat-profile :verbose nil)
+ (when *profiled-functions*
+ (start-acl-profiler)))
+
+(defimplementation profile-reset ()
+ (when (acl-profiler-active-p)
+ (stop-acl-profiler)
+ (start-acl-profiler))
+ "Reset profiling counters.")
+
+;;;; Inspecting
+
+(excl:without-redefinition-warnings
+(defmethod emacs-inspect ((o t))
+ (allegro-inspect o)))
+
+(defmethod emacs-inspect ((o function))
+ (allegro-inspect o))
+
+(defmethod emacs-inspect ((o standard-object))
+ (allegro-inspect o))
+
+(defun allegro-inspect (o)
+ (loop for (d dd) on (inspect::inspect-ctl o)
+ append (frob-allegro-field-def o d)
+ until (eq d dd)))
+
+(defun frob-allegro-field-def (object def)
+ (with-struct (inspect::field-def- name type access) def
+ (ecase type
+ ((:unsigned-word :unsigned-byte :unsigned-natural
+ :unsigned-long :unsigned-half-long
+ :unsigned-3byte :unsigned-long32)
+ (label-value-line name (inspect::component-ref-v object access type)))
+ ((:lisp :value :func)
+ (label-value-line name (inspect::component-ref object access)))
+ (:indirect
+ (destructuring-bind (prefix count ref set) access
+ (declare (ignore set prefix))
+ (loop for i below (funcall count object)
+ append (label-value-line (format nil "~A-~D" name i)
+ (funcall ref object i))))))))
+
+;;;; Multithreading
+
+(defimplementation initialize-multiprocessing (continuation)
+ (mp:start-scheduler)
+ (funcall continuation))
+
+(defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+(defvar *id-lock* (mp:make-process-lock :name "id lock"))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-process-lock (*id-lock*)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id mp:*all-processes*
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+(defimplementation thread-status (thread)
+ (princ-to-string (mp:process-whostate thread)))
+
+(defimplementation thread-attributes (thread)
+ (list :priority (mp:process-priority thread)
+ :times-resumed (mp:process-times-resumed thread)))
+
+(defimplementation make-lock (&key name)
+ (mp:make-process-lock :name name))
+
+(defimplementation call-with-lock-held (lock function)
+ (mp:with-process-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mp:*current-process*)
+
+(defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
+
+(defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+(defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (lock (mp:make-process-lock :name "process mailbox"))
+ (queue '() :type list)
+ (gate (mp:make-gate nil)))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-process-lock (*mailbox-lock*)
+ (or (getf (mp:process-property-list thread) 'mailbox)
+ (setf (getf (mp:process-property-list thread) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let* ((mbox (mailbox thread)))
+ (mp:with-process-lock ((mailbox.lock mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:open-gate (mailbox.gate mbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let ((mbox (mailbox mp:*current-process*)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-process-lock ((mailbox.lock mbox))
+ (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)))
+ (mp:close-gate (mailbox.gate mbox))))
+ (when (eq timeout t) (return (values nil t)))
+ (mp:process-wait-with-timeout "receive-if" 0.5
+ #'mp:gate-open-p (mailbox.gate mbox)))))
+
+(let ((alist '())
+ (lock (mp:make-process-lock :name "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (mp:with-process-lock (lock)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (mp:process
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (mp:with-process-lock (lock)
+ (cdr (assoc name alist)))))
+
+(defimplementation set-default-initial-binding (var form)
+ (push (cons var form)
+ #+(version>= 9 0)
+ excl:*required-thread-bindings*
+ #-(version>= 9 0)
+ excl::required-thread-bindings))
+
+(defimplementation quit-lisp ()
+ (excl:exit 0 :quiet t))
+
+
+;;Trace implementations
+;;In Allegro 7.0, we have:
+;; (trace <name>)
+;; (trace ((method <name> <qualifier>? (<specializer>+))))
+;; (trace ((labels <name> <label-name>)))
+;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
+;; <name> can be a normal name or a (setf name)
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ (:defgeneric (toggle-trace-generic-function-methods (second spec)))
+ ((setf :defmethod :labels :flet)
+ (toggle-trace-aux (process-fspec-for-allegro spec)))
+ (:call
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee
+ :inside (list (process-fspec-for-allegro caller)))))))
+
+(defun tracedp (fspec)
+ (member fspec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (fspec &rest args)
+ (cond ((tracedp fspec)
+ (eval `(untrace ,fspec))
+ (format nil "~S is now untraced." fspec))
+ (t
+ (eval `(trace (,fspec ,@args)))
+ (format nil "~S is now traced." fspec))))
+
+(defun toggle-trace-generic-function-methods (name)
+ (let ((methods (mop:generic-function-methods (fdefinition name))))
+ (cond ((tracedp name)
+ (eval `(untrace ,name))
+ (dolist (method methods (format nil "~S is now untraced." name))
+ (excl:funtrace (mop:method-function method))))
+ (t
+ (eval `(trace (,name)))
+ (dolist (method methods (format nil "~S is now traced." name))
+ (excl:ftrace (mop:method-function method)))))))
+
+(defun process-fspec-for-allegro (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((setf) fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod) `(method ,@(rest fspec)))
+ ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
+ ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
+ ,(third fspec)))))
+ (t
+ fspec)))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-keys t args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :values :weak args))
+
+(defimplementation hash-table-weakness (hashtable)
+ (cond ((excl:hash-table-weak-keys hashtable) :key)
+ ((eq (excl:hash-table-values hashtable) :weak) :value)))
+
+
+
+;;;; Character names
+
+(defimplementation character-completion-set (prefix matchp)
+ (loop for name being the hash-keys of excl::*name-to-char-table*
+ when (funcall matchp prefix name)
+ collect (string-capitalize name)))
+
+
+;;;; wrap interface implementation
+
+(defimplementation wrap (spec indicator &key before after replace)
+ (let ((allegro-spec (process-fspec-for-allegro spec)))
+ (excl:fwrap allegro-spec
+ indicator
+ (excl:def-fwrapper allegro-wrapper (&rest args)
+ (let (retlist completed)
+ (unwind-protect
+ (progn
+ (when before
+ (funcall before args))
+ (setq retlist (multiple-value-list
+ (if replace
+ (funcall replace args)
+ (excl:call-next-fwrapper))))
+ (setq completed t)
+ (values-list retlist))
+ (when after
+ (funcall after (if completed
+ retlist
+ :exited-non-locally)))))))
+ allegro-spec))
+
+(defimplementation unwrap (spec indicator)
+ (let ((allegro-spec (process-fspec-for-allegro spec)))
+ (excl:funwrap allegro-spec indicator)
+ allegro-spec))
+
+(defimplementation wrapped-p (spec indicator)
+ (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator))
diff --git a/vim/bundle/slimv/slime/swank/backend.lisp b/vim/bundle/slimv/slime/swank/backend.lisp
new file mode 100644
index 0000000..81023df
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/backend.lisp
@@ -0,0 +1,1536 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
+;;;
+;;; slime-backend.lisp --- SLIME backend interface.
+;;;
+;;; Created by James Bielman in 2003. Released into the public domain.
+;;;
+;;;; Frontmatter
+;;;
+;;; This file defines the functions that must be implemented
+;;; separately for each Lisp. Each is declared as a generic function
+;;; for which swank-<implementation>.lisp provides methods.
+
+(in-package swank/backend)
+
+
+;;;; Metacode
+
+(defparameter *debug-swank-backend* nil
+ "If this is true, backends should not catch errors but enter the
+debugger where appropriate. Also, they should not perform backtrace
+magic but really show every frame including SWANK related ones.")
+
+(defparameter *interface-functions* '()
+ "The names of all interface functions.")
+
+(defparameter *unimplemented-interfaces* '()
+ "List of interface functions that are not implemented.
+DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
+
+(defvar *log-output* nil) ; should be nil for image dumpers
+
+(defmacro definterface (name args documentation &rest default-body)
+ "Define an interface function for the backend to implement.
+A function is defined with NAME, ARGS, and DOCUMENTATION. This
+function first looks for a function to call in NAME's property list
+that is indicated by 'IMPLEMENTATION; failing that, it looks for a
+function indicated by 'DEFAULT. If neither is present, an error is
+signaled.
+
+If a DEFAULT-BODY is supplied, then a function with the same body and
+ARGS will be added to NAME's property list as the property indicated
+by 'DEFAULT.
+
+Backends implement these functions using DEFIMPLEMENTATION."
+ (check-type documentation string "a documentation string")
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ (labels ((gen-default-impl ()
+ `(setf (get ',name 'default) (lambda ,args ,@default-body)))
+ (args-as-list (args)
+ (destructuring-bind (req opt key rest) (parse-lambda-list args)
+ `(,@req ,@opt
+ ,@(loop for k in key append `(,(kw k) ,k))
+ ,@(or rest '(())))))
+ (parse-lambda-list (args)
+ (parse args '(&optional &key &rest)
+ (make-array 4 :initial-element nil)))
+ (parse (args keywords vars)
+ (cond ((null args)
+ (reverse (map 'list #'reverse vars)))
+ ((member (car args) keywords)
+ (parse (cdr args) (cdr (member (car args) keywords)) vars))
+ (t (push (car args) (aref vars (length keywords)))
+ (parse (cdr args) keywords vars))))
+ (kw (s) (intern (string s) :keyword)))
+ `(progn
+ (defun ,name ,args
+ ,documentation
+ (let ((f (or (get ',name 'implementation)
+ (get ',name 'default))))
+ (cond (f (apply f ,@(args-as-list args)))
+ (t (error "~S not implemented" ',name)))))
+ (pushnew ',name *interface-functions*)
+ ,(if (null default-body)
+ `(pushnew ',name *unimplemented-interfaces*)
+ (gen-default-impl))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name :swank/backend))
+ ',name)))
+
+(defmacro defimplementation (name args &body body)
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ `(progn
+ (setf (get ',name 'implementation)
+ ;; For implicit BLOCK. FLET because of interplay w/ decls.
+ (flet ((,name ,args ,@body)) #',name))
+ (if (member ',name *interface-functions*)
+ (setq *unimplemented-interfaces*
+ (remove ',name *unimplemented-interfaces*))
+ (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
+ ',name))
+
+(defun warn-unimplemented-interfaces ()
+ "Warn the user about unimplemented backend features.
+The portable code calls this function at startup."
+ (let ((*print-pretty* t))
+ (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
+ (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
+
+(defun import-to-swank-mop (symbol-list)
+ (dolist (sym symbol-list)
+ (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
+ (when swank-mop-sym
+ (unintern swank-mop-sym :swank-mop))
+ (import sym :swank-mop)
+ (export sym :swank-mop))))
+
+(defun import-swank-mop-symbols (package except)
+ "Import the mop symbols from PACKAGE to SWANK-MOP.
+EXCEPT is a list of symbol names which should be ignored."
+ (do-symbols (s :swank-mop)
+ (unless (member s except :test #'string=)
+ (let ((real-symbol (find-symbol (string s) package)))
+ (assert real-symbol () "Symbol ~A not found in package ~A" s package)
+ (unintern s :swank-mop)
+ (import real-symbol :swank-mop)
+ (export real-symbol :swank-mop)))))
+
+(definterface gray-package-name ()
+ "Return a package-name that contains the Gray stream symbols.
+This will be used like so:
+ (defpackage foo
+ (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)")
+
+
+;;;; Utilities
+
+(defmacro with-struct ((conc-name &rest names) obj &body body)
+ "Like with-slots but works only for structs."
+ (check-type conc-name symbol)
+ (flet ((reader (slot)
+ (intern (concatenate 'string
+ (symbol-name conc-name)
+ (symbol-name slot))
+ (symbol-package conc-name))))
+ (let ((tmp (gensym "OO-")))
+ ` (let ((,tmp ,obj))
+ (symbol-macrolet
+ ,(loop for name in names collect
+ (typecase name
+ (symbol `(,name (,(reader name) ,tmp)))
+ (cons `(,(first name) (,(reader (second name)) ,tmp)))
+ (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
+ ,@body)))))
+
+(defmacro when-let ((var value) &body body)
+ `(let ((,var ,value))
+ (when ,var ,@body)))
+
+(defun boolean-to-feature-expression (value)
+ "Converts a boolean VALUE to a form suitable for testing with #+."
+ (if value
+ '(:and)
+ '(:or)))
+
+(defun with-symbol (name package)
+ "Check if a symbol with a given NAME exists in PACKAGE and returns a
+form suitable for testing with #+."
+ (boolean-to-feature-expression
+ (and (find-package package)
+ (find-symbol (string name) package))))
+
+(defun choose-symbol (package name alt-package alt-name)
+ "If symbol package:name exists return that symbol, otherwise alt-package:alt-name.
+ Suitable for use with #."
+ (or (and (find-package package)
+ (find-symbol (string name) package))
+ (find-symbol (string alt-name) alt-package)))
+
+
+;;;; UFT8
+
+(deftype octet () '(unsigned-byte 8))
+(deftype octets () '(simple-array octet (*)))
+
+;; Helper function. Decode the next N bytes starting from INDEX.
+;; Return the decoded char and the new index.
+(defun utf8-decode-aux (buffer index limit byte0 n)
+ (declare (type octets buffer) (fixnum index limit byte0 n))
+ (if (< (- limit index) n)
+ (values nil index)
+ (do ((i 0 (1+ i))
+ (code byte0 (let ((byte (aref buffer (+ index i))))
+ (cond ((= (ldb (byte 2 6) byte) #b10)
+ (+ (ash code 6) (ldb (byte 6 0) byte)))
+ (t
+ (error "Invalid encoding"))))))
+ ((= i n)
+ (values (cond ((<= code #xff) (code-char code))
+ ((<= #xd800 code #xdfff)
+ (error "Invalid Unicode code point: #x~x" code))
+ ((and (< code char-code-limit)
+ (code-char code)))
+ (t
+ (error
+ "Can't represent code point: #x~x ~
+ (char-code-limit is #x~x)"
+ code char-code-limit)))
+ (+ index n))))))
+
+;; Decode one character in BUFFER starting at INDEX.
+;; Return 2 values: the character and the new index.
+;; If there aren't enough bytes between INDEX and LIMIT return nil.
+(defun utf8-decode (buffer index limit)
+ (declare (type octets buffer) (fixnum index limit))
+ (if (= index limit)
+ (values nil index)
+ (let ((b (aref buffer index)))
+ (if (<= b #x7f)
+ (values (code-char b) (1+ index))
+ (macrolet ((try (marker else)
+ (let* ((l (integer-length marker))
+ (n (- l 2)))
+ `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
+ (utf8-decode-aux buffer (1+ index) limit
+ (ldb (byte ,(- 8 l) 0) b)
+ ,n)
+ ,else))))
+ (try #b110
+ (try #b1110
+ (try #b11110
+ (try #b111110
+ (try #b1111110
+ (error "Invalid encoding")))))))))))
+
+;; Decode characters from BUFFER and write them to STRING.
+;; Return 2 values: LASTINDEX and LASTSTART where
+;; LASTINDEX is the last index in BUFFER that was not decoded
+;; and LASTSTART is the last index in STRING not written.
+(defun utf8-decode-into (buffer index limit string start end)
+ (declare (string string) (fixnum index limit start end) (type octets buffer))
+ (loop
+ (cond ((= start end)
+ (return (values index start)))
+ (t
+ (multiple-value-bind (c i) (utf8-decode buffer index limit)
+ (cond (c
+ (setf (aref string start) c)
+ (setq index i)
+ (setq start (1+ start)))
+ (t
+ (return (values index start)))))))))
+
+(defun default-utf8-to-string (octets)
+ (let* ((limit (length octets))
+ (str (make-string limit)))
+ (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
+ (if (= i limit)
+ (if (= limit s)
+ str
+ (adjust-array str s))
+ (loop
+ (let ((end (+ (length str) (- limit i))))
+ (setq str (adjust-array str end))
+ (multiple-value-bind (i2 s2)
+ (utf8-decode-into octets i limit str s end)
+ (cond ((= i2 limit)
+ (return (adjust-array str s2)))
+ (t
+ (setq i i2)
+ (setq s s2))))))))))
+
+(defmacro utf8-encode-aux (code buffer start end n)
+ `(cond ((< (- ,end ,start) ,n)
+ ,start)
+ (t
+ (setf (aref ,buffer ,start)
+ (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
+ (byte ,(- 7 n) 0)
+ ,(dpb 0 (byte 1 (- 7 n)) #xff)))
+ ,@(loop for i from 0 upto (- n 2) collect
+ `(setf (aref ,buffer (+ ,start ,(- n 1 i)))
+ (dpb (ldb (byte 6 ,(* 6 i)) ,code)
+ (byte 6 0)
+ #b10111111)))
+ (+ ,start ,n))))
+
+(defun %utf8-encode (code buffer start end)
+ (declare (type (unsigned-byte 31) code) (type octets buffer)
+ (type (and fixnum unsigned-byte) start end))
+ (cond ((<= code #x7f)
+ (cond ((< start end)
+ (setf (aref buffer start) code)
+ (1+ start))
+ (t start)))
+ ((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
+ ((<= #xd800 code #xdfff)
+ (error "Invalid Unicode code point (surrogate): #x~x" code))
+ ((<= code #xffff) (utf8-encode-aux code buffer start end 3))
+ ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
+ ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
+ (t (utf8-encode-aux code buffer start end 6))))
+
+(defun utf8-encode (char buffer start end)
+ (declare (type character char) (type octets buffer)
+ (type (and fixnum unsigned-byte) start end))
+ (%utf8-encode (char-code char) buffer start end))
+
+(defun utf8-encode-into (string start end buffer index limit)
+ (declare (string string) (type octets buffer) (fixnum start end index limit))
+ (loop
+ (cond ((= start end)
+ (return (values start index)))
+ ((= index limit)
+ (return (values start index)))
+ (t
+ (let ((i2 (utf8-encode (char string start) buffer index limit)))
+ (cond ((= i2 index)
+ (return (values start index)))
+ (t
+ (setq index i2)
+ (incf start))))))))
+
+(defun default-string-to-utf8 (string)
+ (let* ((len (length string))
+ (b (make-array len :element-type 'octet)))
+ (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
+ (if (= s len)
+ b
+ (loop
+ (let ((limit (+ (length b) (- len s))))
+ (setq b (coerce (adjust-array b limit) 'octets))
+ (multiple-value-bind (s2 i2)
+ (utf8-encode-into string s len b i limit)
+ (cond ((= s2 len)
+ (return (coerce (adjust-array b i2) 'octets)))
+ (t
+ (setq i i2)
+ (setq s s2))))))))))
+
+(definterface string-to-utf8 (string)
+ "Convert the string STRING to a (simple-array (unsigned-byte 8))"
+ (default-string-to-utf8 string))
+
+(definterface utf8-to-string (octets)
+ "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
+ (default-utf8-to-string octets))
+
+
+;;;; TCP server
+
+(definterface create-socket (host port &key backlog)
+ "Create a listening TCP socket on interface HOST and port PORT.
+BACKLOG queue length for incoming connections.")
+
+(definterface local-port (socket)
+ "Return the local port number of SOCKET.")
+
+(definterface close-socket (socket)
+ "Close the socket SOCKET.")
+
+(definterface accept-connection (socket &key external-format
+ buffering timeout)
+ "Accept a client connection on the listening socket SOCKET.
+Return a stream for the new connection.
+If EXTERNAL-FORMAT is nil return a binary stream
+otherwise create a character stream.
+BUFFERING can be one of:
+ nil ... no buffering
+ t ... enable buffering
+ :line ... enable buffering with automatic flushing on eol.")
+
+(definterface add-sigio-handler (socket fn)
+ "Call FN whenever SOCKET is readable.")
+
+(definterface remove-sigio-handlers (socket)
+ "Remove all sigio handlers for SOCKET.")
+
+(definterface add-fd-handler (socket fn)
+ "Call FN when Lisp is waiting for input and SOCKET is readable.")
+
+(definterface remove-fd-handlers (socket)
+ "Remove all fd-handlers for SOCKET.")
+
+(definterface preferred-communication-style ()
+ "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
+ nil)
+
+(definterface set-stream-timeout (stream timeout)
+ "Set the 'stream 'timeout. The timeout is either the real number
+ specifying the timeout in seconds or 'nil for no timeout."
+ (declare (ignore stream timeout))
+ nil)
+
+;;; Base condition for networking errors.
+(define-condition network-error (simple-error) ())
+
+(definterface emacs-connected ()
+ "Hook called when the first connection from Emacs is established.
+Called from the INIT-FN of the socket server that accepts the
+connection.
+
+This is intended for setting up extra context, e.g. to discover
+that the calling thread is the one that interacts with Emacs."
+ nil)
+
+
+;;;; Unix signals
+
+(defconstant +sigint+ 2)
+
+(definterface getpid ()
+ "Return the (Unix) process ID of this superior Lisp.")
+
+(definterface install-sigint-handler (function)
+ "Call FUNCTION on SIGINT (instead of invoking the debugger).
+Return old signal handler."
+ (declare (ignore function))
+ nil)
+
+(definterface call-with-user-break-handler (handler function)
+ "Install the break handler HANDLER while executing FUNCTION."
+ (let ((old-handler (install-sigint-handler handler)))
+ (unwind-protect (funcall function)
+ (install-sigint-handler old-handler))))
+
+(definterface quit-lisp ()
+ "Exit the current lisp image.")
+
+(definterface lisp-implementation-type-name ()
+ "Return a short name for the Lisp implementation."
+ (lisp-implementation-type))
+
+(definterface lisp-implementation-program ()
+ "Return the argv[0] of the running Lisp process, or NIL."
+ (let ((file (car (command-line-args))))
+ (when (and file (probe-file file))
+ (namestring (truename file)))))
+
+(definterface socket-fd (socket-stream)
+ "Return the file descriptor for SOCKET-STREAM.")
+
+(definterface make-fd-stream (fd external-format)
+ "Create a character stream for the file descriptor FD.")
+
+(definterface dup (fd)
+ "Duplicate a file descriptor.
+If the syscall fails, signal a condition.
+See dup(2).")
+
+(definterface exec-image (image-file args)
+ "Replace the current process with a new process image.
+The new image is created by loading the previously dumped
+core file IMAGE-FILE.
+ARGS is a list of strings passed as arguments to
+the new image.
+This is thin wrapper around exec(3).")
+
+(definterface command-line-args ()
+ "Return a list of strings as passed by the OS."
+ nil)
+
+
+;; pathnames are sooo useless
+
+(definterface filename-to-pathname (filename)
+ "Return a pathname for FILENAME.
+A filename in Emacs may for example contain asterisks which should not
+be translated to wildcards."
+ (parse-namestring filename))
+
+(definterface pathname-to-filename (pathname)
+ "Return the filename for PATHNAME."
+ (namestring pathname))
+
+(definterface default-directory ()
+ "Return the default directory."
+ (directory-namestring (truename *default-pathname-defaults*)))
+
+(definterface set-default-directory (directory)
+ "Set the default directory.
+This is used to resolve filenames without directory component."
+ (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
+ (default-directory))
+
+
+(definterface call-with-syntax-hooks (fn)
+ "Call FN with hooks to handle special syntax."
+ (funcall fn))
+
+(definterface default-readtable-alist ()
+ "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
+ '())
+
+
+;;;; Packages
+
+(definterface package-local-nicknames (package)
+ "Returns an alist of (local-nickname . actual-package) describing the
+nicknames local to the designated package."
+ (declare (ignore package))
+ nil)
+
+(definterface find-locally-nicknamed-package (name base-package)
+ "Return the package whose local nickname in BASE-PACKAGE matches NAME.
+Return NIL if local nicknames are not implemented or if there is no
+such package."
+ (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal)))
+
+
+;;;; Compilation
+
+(definterface call-with-compilation-hooks (func)
+ "Call FUNC with hooks to record compiler conditions.")
+
+(defmacro with-compilation-hooks ((&rest ignore) &body body)
+ "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
+ (declare (ignore ignore))
+ `(call-with-compilation-hooks (lambda () (progn ,@body))))
+
+(definterface swank-compile-string (string &key buffer position filename
+ policy)
+ "Compile source from STRING.
+During compilation, compiler conditions must be trapped and
+resignalled as COMPILER-CONDITIONs.
+
+If supplied, BUFFER and POSITION specify the source location in Emacs.
+
+Additionally, if POSITION is supplied, it must be added to source
+positions reported in compiler conditions.
+
+If FILENAME is specified it may be used by certain implementations to
+rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
+source information.
+
+If POLICY is supplied, and non-NIL, it may be used by certain
+implementations to compile with optimization qualities of its
+value.
+
+Should return T on successful compilation, NIL otherwise.
+")
+
+(definterface swank-compile-file (input-file output-file load-p
+ external-format
+ &key policy)
+ "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
+If LOAD-P is true, load the file after compilation.
+EXTERNAL-FORMAT is a value returned by find-external-format or
+:default.
+
+If POLICY is supplied, and non-NIL, it may be used by certain
+implementations to compile with optimization qualities of its
+value.
+
+Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
+like `compile-file'")
+
+(deftype severity ()
+ '(member :error :read-error :warning :style-warning :note :redefinition))
+
+;; Base condition type for compiler errors, warnings and notes.
+(define-condition compiler-condition (condition)
+ ((original-condition
+ ;; The original condition thrown by the compiler if appropriate.
+ ;; May be NIL if a compiler does not report using conditions.
+ :type (or null condition)
+ :initarg :original-condition
+ :accessor original-condition)
+
+ (severity :type severity
+ :initarg :severity
+ :accessor severity)
+
+ (message :initarg :message
+ :accessor message)
+
+ ;; Macro expansion history etc. which may be helpful in some cases
+ ;; but is often very verbose.
+ (source-context :initarg :source-context
+ :type (or null string)
+ :initform nil
+ :accessor source-context)
+
+ (references :initarg :references
+ :initform nil
+ :accessor references)
+
+ (location :initarg :location
+ :accessor location)))
+
+(definterface find-external-format (coding-system)
+ "Return a \"external file format designator\" for CODING-SYSTEM.
+CODING-SYSTEM is Emacs-style coding system name (a string),
+e.g. \"latin-1-unix\"."
+ (if (equal coding-system "iso-latin-1-unix")
+ :default
+ nil))
+
+(definterface guess-external-format (pathname)
+ "Detect the external format for the file with name pathname.
+Return nil if the file contains no special markers."
+ ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
+ (with-open-file (s pathname :if-does-not-exist nil
+ :external-format (or (find-external-format "latin-1-unix")
+ :default))
+ (if s
+ (or (let* ((line (read-line s nil))
+ (p (search "-*-" line)))
+ (when p
+ (let* ((start (+ p (length "-*-")))
+ (end (search "-*-" line :start2 start)))
+ (when end
+ (%search-coding line start end)))))
+ (let* ((len (file-length s))
+ (buf (make-string (min len 3000))))
+ (file-position s (- len (length buf)))
+ (read-sequence buf s)
+ (let ((start (search "Local Variables:" buf :from-end t))
+ (end (search "End:" buf :from-end t)))
+ (and start end (< start end)
+ (%search-coding buf start end))))))))
+
+(defun %search-coding (str start end)
+ (let ((p (search "coding:" str :start2 start :end2 end)))
+ (when p
+ (incf p (length "coding:"))
+ (loop while (and (< p end)
+ (member (aref str p) '(#\space #\tab)))
+ do (incf p))
+ (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
+ str :start p)))
+ (find-external-format (subseq str p end))))))
+
+
+;;;; Streams
+
+(definterface make-output-stream (write-string)
+ "Return a new character output stream.
+The stream calls WRITE-STRING when output is ready.")
+
+(definterface make-input-stream (read-string)
+ "Return a new character input stream.
+The stream calls READ-STRING when input is needed.")
+
+
+;;;; Documentation
+
+(definterface arglist (name)
+ "Return the lambda list for the symbol NAME. NAME can also be
+a lisp function object, on lisps which support this.
+
+The result can be a list or the :not-available keyword if the
+arglist cannot be determined."
+ (declare (ignore name))
+ :not-available)
+
+(defgeneric declaration-arglist (decl-identifier)
+ (:documentation
+ "Return the argument list of the declaration specifier belonging to the
+declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
+the keyword :NOT-AVAILABLE is returned.
+
+The different SWANK backends can specialize this generic function to
+include implementation-dependend declaration specifiers, or to provide
+additional information on the specifiers defined in ANSI Common Lisp.")
+ (:method (decl-identifier)
+ (case decl-identifier
+ (dynamic-extent '(&rest variables))
+ (ignore '(&rest variables))
+ (ignorable '(&rest variables))
+ (special '(&rest variables))
+ (inline '(&rest function-names))
+ (notinline '(&rest function-names))
+ (declaration '(&rest names))
+ (optimize '(&any compilation-speed debug safety space speed))
+ (type '(type-specifier &rest args))
+ (ftype '(type-specifier &rest function-names))
+ (otherwise
+ (flet ((typespec-p (symbol)
+ (member :type (describe-symbol-for-emacs symbol))))
+ (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
+ '(&rest variables))
+ ((and (listp decl-identifier)
+ (typespec-p (first decl-identifier)))
+ '(&rest variables))
+ (t :not-available)))))))
+
+(defgeneric type-specifier-arglist (typespec-operator)
+ (:documentation
+ "Return the argument list of the type specifier belonging to
+TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
+:NOT-AVAILABLE is returned.
+
+The different SWANK backends can specialize this generic function to
+include implementation-dependend declaration specifiers, or to provide
+additional information on the specifiers defined in ANSI Common Lisp.")
+ (:method (typespec-operator)
+ (declare (special *type-specifier-arglists*)) ; defined at end of file.
+ (typecase typespec-operator
+ (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
+ :not-available))
+ (t :not-available))))
+
+(definterface type-specifier-p (symbol)
+ "Determine if SYMBOL is a type-specifier."
+ (or (documentation symbol 'type)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+(definterface function-name (function)
+ "Return the name of the function object FUNCTION.
+
+The result is either a symbol, a list, or NIL if no function name is
+available."
+ (declare (ignore function))
+ nil)
+
+(definterface valid-function-name-p (form)
+ "Is FORM syntactically valid to name a function?
+ If true, FBOUNDP should not signal a type-error for FORM."
+ (flet ((length=2 (list)
+ (and (not (null (cdr list))) (null (cddr list)))))
+ (or (symbolp form)
+ (and (consp form) (length=2 form)
+ (eq (first form) 'setf) (symbolp (second form))))))
+
+(definterface macroexpand-all (form &optional env)
+ "Recursively expand all macros in FORM.
+Return the resulting form.")
+
+(definterface compiler-macroexpand-1 (form &optional env)
+ "Call the compiler-macro for form.
+If FORM is a function call for which a compiler-macro has been
+defined, invoke the expander function using *macroexpand-hook* and
+return the results and T. Otherwise, return the original form and
+NIL."
+ (let ((fun (and (consp form)
+ (valid-function-name-p (car form))
+ (compiler-macro-function (car form) env))))
+ (if fun
+ (let ((result (funcall *macroexpand-hook* fun form env)))
+ (values result (not (eq result form))))
+ (values form nil))))
+
+(definterface compiler-macroexpand (form &optional env)
+ "Repetitively call `compiler-macroexpand-1'."
+ (labels ((frob (form expanded)
+ (multiple-value-bind (new-form newly-expanded)
+ (compiler-macroexpand-1 form env)
+ (if newly-expanded
+ (frob new-form t)
+ (values new-form expanded)))))
+ (frob form env)))
+
+(defmacro with-collected-macro-forms
+ ((forms &optional result) instrumented-form &body body)
+ "Collect macro forms by locally binding *MACROEXPAND-HOOK*.
+
+Evaluates INSTRUMENTED-FORM and collects any forms which undergo
+macro-expansion into a list. Then evaluates BODY with FORMS bound to
+the list of forms, and RESULT (optionally) bound to the value of
+INSTRUMENTED-FORM."
+ (assert (and (symbolp forms) (not (null forms))))
+ (assert (symbolp result))
+ (let ((result-symbol (or result (gensym))))
+ `(call-with-collected-macro-forms
+ (lambda (,forms ,result-symbol)
+ (declare (ignore ,@(and (not result)
+ `(,result-symbol))))
+ ,@body)
+ (lambda () ,instrumented-form))))
+
+(defun call-with-collected-macro-forms (body-fn instrumented-fn)
+ (let ((return-value nil)
+ (collected-forms '()))
+ (let* ((real-macroexpand-hook *macroexpand-hook*)
+ (*macroexpand-hook*
+ (lambda (macro-function form environment)
+ (let ((result (funcall real-macroexpand-hook
+ macro-function form environment)))
+ (unless (eq result form)
+ (push form collected-forms))
+ result))))
+ (setf return-value (funcall instrumented-fn)))
+ (funcall body-fn collected-forms return-value)))
+
+(definterface collect-macro-forms (form &optional env)
+ "Collect subforms of FORM which undergo (compiler-)macro expansion.
+Returns two values: a list of macro forms and a list of compiler macro
+forms."
+ (with-collected-macro-forms (macro-forms expansion)
+ (ignore-errors (macroexpand-all form env))
+ (with-collected-macro-forms (compiler-macro-forms)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors
+ (compile nil `(lambda () ,expansion))))
+ (values macro-forms compiler-macro-forms))))
+
+(definterface format-string-expand (control-string)
+ "Expand the format string CONTROL-STRING."
+ (macroexpand `(formatter ,control-string)))
+
+(definterface describe-symbol-for-emacs (symbol)
+ "Return a property list describing SYMBOL.
+
+The property list has an entry for each interesting aspect of the
+symbol. The recognised keys are:
+
+ :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
+ :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
+
+The value of each property is the corresponding documentation string,
+or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
+not listed here (but slime-print-apropos in Emacs must know about
+them).
+
+Properties should be included if and only if they are applicable to
+the symbol. For example, only (and all) fbound symbols should include
+the :FUNCTION property.
+
+Example:
+\(describe-symbol-for-emacs 'vector)
+ => (:CLASS :NOT-DOCUMENTED
+ :TYPE :NOT-DOCUMENTED
+ :FUNCTION \"Constructs a simple-vector from the given objects.\")")
+
+(definterface describe-definition (name type)
+ "Describe the definition NAME of TYPE.
+TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
+
+Return a documentation string, or NIL if none is available.")
+
+
+;;;; Debugging
+
+(definterface install-debugger-globally (function)
+ "Install FUNCTION as the debugger for all threads/processes. This
+usually involves setting *DEBUGGER-HOOK* and, if the implementation
+permits, hooking into BREAK as well."
+ (setq *debugger-hook* function))
+
+(definterface call-with-debugging-environment (debugger-loop-fn)
+ "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
+
+This function is called recursively at each debug level to invoke the
+debugger loop. The purpose is to setup any necessary environment for
+other debugger callbacks that will be called within the debugger loop.
+
+For example, this is a reasonable place to compute a backtrace, switch
+to safe reader/printer settings, and so on.")
+
+(definterface call-with-debugger-hook (hook fun)
+ "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
+
+HOOK should be called for both BREAK and INVOKE-DEBUGGER."
+ (let ((*debugger-hook* hook))
+ (funcall fun)))
+
+(define-condition sldb-condition (condition)
+ ((original-condition
+ :initarg :original-condition
+ :accessor original-condition))
+ (:report (lambda (condition stream)
+ (format stream "Condition in debugger code~@[: ~A~]"
+ (original-condition condition))))
+ (:documentation
+ "Wrapper for conditions that should not be debugged.
+
+When a condition arises from the internals of the debugger, it is not
+desirable to debug it -- we'd risk entering an endless loop trying to
+debug the debugger! Instead, such conditions can be reported to the
+user without (re)entering the debugger by wrapping them as
+`sldb-condition's."))
+
+;;; The following functions in this section are supposed to be called
+;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
+
+(definterface compute-backtrace (start end)
+ "Returns a backtrace of the condition currently being debugged,
+that is an ordered list consisting of frames. ``Ordered list''
+means that an integer I can be mapped back to the i-th frame of this
+backtrace.
+
+START and END are zero-based indices constraining the number of frames
+returned. Frame zero is defined as the frame which invoked the
+debugger. If END is nil, return the frames from START to the end of
+the stack.")
+
+(definterface print-frame (frame stream)
+ "Print frame to stream.")
+
+(definterface frame-restartable-p (frame)
+ "Is the frame FRAME restartable?.
+Return T if `restart-frame' can safely be called on the frame."
+ (declare (ignore frame))
+ nil)
+
+(definterface frame-source-location (frame-number)
+ "Return the source location for the frame associated to FRAME-NUMBER.")
+
+(definterface frame-catch-tags (frame-number)
+ "Return a list of catch tags for being printed in a debugger stack
+frame."
+ (declare (ignore frame-number))
+ '())
+
+(definterface frame-locals (frame-number)
+ "Return a list of ((&key NAME ID VALUE) ...) where each element of
+the list represents a local variable in the stack frame associated to
+FRAME-NUMBER.
+
+NAME, a symbol; the name of the local variable.
+
+ID, an integer; used as primary key for the local variable, unique
+relatively to the frame under operation.
+
+value, an object; the value of the local variable.")
+
+(definterface frame-var-value (frame-number var-id)
+ "Return the value of the local variable associated to VAR-ID
+relatively to the frame associated to FRAME-NUMBER.")
+
+(definterface disassemble-frame (frame-number)
+ "Disassemble the code for the FRAME-NUMBER.
+The output should be written to standard output.
+FRAME-NUMBER is a non-negative integer.")
+
+(definterface eval-in-frame (form frame-number)
+ "Evaluate a Lisp form in the lexical context of a stack frame
+in the debugger.
+
+FRAME-NUMBER must be a positive integer with 0 indicating the
+frame which invoked the debugger.
+
+The return value is the result of evaulating FORM in the
+appropriate context.")
+
+(definterface frame-package (frame-number)
+ "Return the package corresponding to the frame at FRAME-NUMBER.
+Return nil if the backend can't figure it out."
+ (declare (ignore frame-number))
+ nil)
+
+(definterface frame-call (frame-number)
+ "Return a string representing a call to the entry point of a frame.")
+
+(definterface return-from-frame (frame-number form)
+ "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
+produced by evaluating FORM in the frame context to its caller.
+
+Execute any clean-up code from unwind-protect forms above the frame
+during unwinding.
+
+Return a string describing the error if it's not possible to return
+from the frame.")
+
+(definterface restart-frame (frame-number)
+ "Restart execution of the frame FRAME-NUMBER with the same arguments
+as it was called originally.")
+
+(definterface print-condition (condition stream)
+ "Print a condition for display in SLDB."
+ (princ condition stream))
+
+(definterface condition-extras (condition)
+ "Return a list of extra for the debugger.
+The allowed elements are of the form:
+ (:SHOW-FRAME-SOURCE frame-number)
+ (:REFERENCES &rest refs)
+"
+ (declare (ignore condition))
+ '())
+
+(definterface gdb-initial-commands ()
+ "List of gdb commands supposed to be executed first for the
+ ATTACH-GDB restart."
+ nil)
+
+(definterface activate-stepping (frame-number)
+ "Prepare the frame FRAME-NUMBER for stepping.")
+
+(definterface sldb-break-on-return (frame-number)
+ "Set a breakpoint in the frame FRAME-NUMBER.")
+
+(definterface sldb-break-at-start (symbol)
+ "Set a breakpoint on the beginning of the function for SYMBOL.")
+
+(definterface sldb-stepper-condition-p (condition)
+ "Return true if SLDB was invoked due to a single-stepping condition,
+false otherwise. "
+ (declare (ignore condition))
+ nil)
+
+(definterface sldb-step-into ()
+ "Step into the current single-stepper form.")
+
+(definterface sldb-step-next ()
+ "Step to the next form in the current function.")
+
+(definterface sldb-step-out ()
+ "Stop single-stepping temporarily, but resume it once the current function
+returns.")
+
+
+;;;; Definition finding
+
+(defstruct (:location (:type list) :named
+ (:constructor make-location
+ (buffer position &optional hints)))
+ buffer position
+ ;; Hints is a property list optionally containing:
+ ;; :snippet SOURCE-TEXT
+ ;; This is a snippet of the actual source text at the start of
+ ;; the definition, which could be used in a text search.
+ hints)
+
+(defstruct (:error (:type list) :named (:constructor)) message)
+
+;;; Valid content for BUFFER slot
+(defstruct (:file (:type list) :named (:constructor)) name)
+(defstruct (:buffer (:type list) :named (:constructor)) name)
+(defstruct (:etags-file (:type list) :named (:constructor)) filename)
+
+;;; Valid content for POSITION slot
+(defstruct (:position (:type list) :named (:constructor)) pos)
+(defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
+
+(defmacro converting-errors-to-error-location (&body body)
+ "Catches errors during BODY and converts them to an error location."
+ (let ((gblock (gensym "CONVERTING-ERRORS+")))
+ `(block ,gblock
+ (handler-bind ((error
+ #'(lambda (e)
+ (if *debug-swank-backend*
+ nil ;decline
+ (return-from ,gblock
+ (make-error-location e))))))
+ ,@body))))
+
+(defun make-error-location (datum &rest args)
+ (cond ((typep datum 'condition)
+ `(:error ,(format nil "Error: ~A" datum)))
+ ((symbolp datum)
+ `(:error ,(format nil "Error: ~A"
+ (apply #'make-condition datum args))))
+ (t
+ (assert (stringp datum))
+ `(:error ,(apply #'format nil datum args)))))
+
+(definterface find-definitions (name)
+ "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
+
+NAME is a \"definition specifier\".
+
+DSPEC is a \"definition specifier\" describing the
+definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
+\(DEFVAR FOO).
+
+LOCATION is the source location for the definition.")
+
+(definterface find-source-location (object)
+ "Returns the source location of OBJECT, or NIL.
+
+That is the source location of the underlying datastructure of
+OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
+respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
+respective DEFSTRUCT definition, and so on."
+ ;; This returns one source location and not a list of locations. It's
+ ;; supposed to return the location of the DEFGENERIC definition on
+ ;; #'SOME-GENERIC-FUNCTION.
+ (declare (ignore object))
+ (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~
+ this implementation."))
+
+(definterface buffer-first-change (filename)
+ "Called for effect the first time FILENAME's buffer is modified.
+CMUCL/SBCL use this to cache the unmodified file and use the
+unmodified text to improve the precision of source locations."
+ (declare (ignore filename))
+ nil)
+
+
+
+;;;; XREF
+
+(definterface who-calls (function-name)
+ "Return the call sites of FUNCTION-NAME (a symbol).
+The results is a list ((DSPEC LOCATION) ...)."
+ (declare (ignore function-name))
+ :not-implemented)
+
+(definterface calls-who (function-name)
+ "Return the call sites of FUNCTION-NAME (a symbol).
+The results is a list ((DSPEC LOCATION) ...)."
+ (declare (ignore function-name))
+ :not-implemented)
+
+(definterface who-references (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is referenced.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
+
+(definterface who-binds (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is bound.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
+
+(definterface who-sets (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is set.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
+
+(definterface who-macroexpands (macro-name)
+ "Return the locations where MACRO-NAME (a symbol) is expanded.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore macro-name))
+ :not-implemented)
+
+(definterface who-specializes (class-name)
+ "Return the locations where CLASS-NAME (a symbol) is specialized.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore class-name))
+ :not-implemented)
+
+;;; Simpler variants.
+
+(definterface list-callers (function-name)
+ "List the callers of FUNCTION-NAME.
+This function is like WHO-CALLS except that it is expected to use
+lower-level means. Whereas WHO-CALLS is usually implemented with
+special compiler support, LIST-CALLERS is usually implemented by
+groveling for constants in function objects throughout the heap.
+
+The return value is as for WHO-CALLS.")
+
+(definterface list-callees (function-name)
+ "List the functions called by FUNCTION-NAME.
+See LIST-CALLERS for a description of the return value.")
+
+
+;;;; Profiling
+
+;;; The following functions define a minimal profiling interface.
+
+(definterface profile (fname)
+ "Marks symbol FNAME for profiling.")
+
+(definterface profiled-functions ()
+ "Returns a list of profiled functions.")
+
+(definterface unprofile (fname)
+ "Marks symbol FNAME as not profiled.")
+
+(definterface unprofile-all ()
+ "Marks all currently profiled functions as not profiled."
+ (dolist (f (profiled-functions))
+ (unprofile f)))
+
+(definterface profile-report ()
+ "Prints profile report.")
+
+(definterface profile-reset ()
+ "Resets profile counters.")
+
+(definterface profile-package (package callers-p methods)
+ "Wrap profiling code around all functions in PACKAGE. If a function
+is already profiled, then unprofile and reprofile (useful to notice
+function redefinition.)
+
+If CALLERS-P is T names have counts of the most common calling
+functions recorded.
+
+When called with arguments :METHODS T, profile all methods of all
+generic functions having names in the given package. Generic functions
+themselves, that is, their dispatch functions, are left alone.")
+
+
+;;;; Trace
+
+(definterface toggle-trace (spec)
+ "Toggle tracing of the function(s) given with SPEC.
+SPEC can be:
+ (setf NAME) ; a setf function
+ (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
+ (:defgeneric NAME) ; a generic function with all methods
+ (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
+ (:labels TOPLEVEL LOCAL)
+ (:flet TOPLEVEL LOCAL) ")
+
+
+;;;; Inspector
+
+(defgeneric emacs-inspect (object)
+ (:documentation
+ "Explain to Emacs how to inspect OBJECT.
+
+Returns a list specifying how to render the object for inspection.
+
+Every element of the list must be either a string, which will be
+inserted into the buffer as is, or a list of the form:
+
+ (:value object &optional format) - Render an inspectable
+ object. If format is provided it must be a string and will be
+ rendered in place of the value, otherwise use princ-to-string.
+
+ (:newline) - Render a \\n
+
+ (:action label lambda &key (refresh t)) - Render LABEL (a text
+ string) which when clicked will call LAMBDA. If REFRESH is
+ non-NIL the currently inspected object will be re-inspected
+ after calling the lambda.
+"))
+
+(defmethod emacs-inspect ((object t))
+ "Generic method for inspecting any kind of object.
+
+Since we don't know how to deal with OBJECT we simply dump the
+output of CL:DESCRIBE."
+ `("Type: " (:value ,(type-of object)) (:newline)
+ "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
+ (:newline) (:newline)
+ ,(with-output-to-string (desc) (describe object desc))))
+
+(definterface eval-context (object)
+ "Return a list of bindings corresponding to OBJECT's slots."
+ (declare (ignore object))
+ '())
+
+;;; Utilities for inspector methods.
+;;;
+
+(defun label-value-line (label value &key (newline t))
+ "Create a control list which prints \"LABEL: VALUE\" in the inspector.
+If NEWLINE is non-NIL a `(:newline)' is added to the result."
+ (list* (princ-to-string label) ": " `(:value ,value)
+ (if newline '((:newline)) nil)))
+
+(defmacro label-value-line* (&rest label-values)
+ ` (append ,@(loop for (label value) in label-values
+ collect `(label-value-line ,label ,value))))
+
+(definterface describe-primitive-type (object)
+ "Return a string describing the primitive type of object."
+ (declare (ignore object))
+ "N/A")
+
+
+;;;; Multithreading
+;;;
+;;; The default implementations are sufficient for non-multiprocessing
+;;; implementations.
+
+(definterface initialize-multiprocessing (continuation)
+ "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
+
+Depending on the impleimentaion, this function may never return."
+ (funcall continuation))
+
+(definterface spawn (fn &key name)
+ "Create a new thread to call FN.")
+
+(definterface thread-id (thread)
+ "Return an Emacs-parsable object to identify THREAD.
+
+Ids should be comparable with equal, i.e.:
+ (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
+ thread)
+
+(definterface find-thread (id)
+ "Return the thread for ID.
+ID should be an id previously obtained with THREAD-ID.
+Can return nil if the thread no longer exists."
+ (declare (ignore id))
+ (current-thread))
+
+(definterface thread-name (thread)
+ "Return the name of THREAD.
+Thread names are short strings meaningful to the user. They do not
+have to be unique."
+ (declare (ignore thread))
+ "The One True Thread")
+
+(definterface thread-status (thread)
+ "Return a string describing THREAD's state."
+ (declare (ignore thread))
+ "")
+
+(definterface thread-attributes (thread)
+ "Return a plist of implementation-dependent attributes for THREAD"
+ (declare (ignore thread))
+ '())
+
+(definterface current-thread ()
+ "Return the currently executing thread."
+ 0)
+
+(definterface all-threads ()
+ "Return a fresh list of all threads."
+ '())
+
+(definterface thread-alive-p (thread)
+ "Test if THREAD is termintated."
+ (member thread (all-threads)))
+
+(definterface interrupt-thread (thread fn)
+ "Cause THREAD to execute FN.")
+
+(definterface kill-thread (thread)
+ "Terminate THREAD immediately.
+Don't execute unwind-protected sections, don't raise conditions.
+(Do not pass go, do not collect $200.)"
+ (declare (ignore thread))
+ nil)
+
+(definterface send (thread object)
+ "Send OBJECT to thread THREAD."
+ (declare (ignore thread))
+ object)
+
+(definterface receive (&optional timeout)
+ "Return the next message from current thread's mailbox."
+ (receive-if (constantly t) timeout))
+
+(definterface receive-if (predicate &optional timeout)
+ "Return the first message satisfiying PREDICATE.")
+
+(definterface register-thread (name thread)
+ "Associate the thread THREAD with the symbol NAME.
+The thread can then be retrieved with `find-registered'.
+If THREAD is nil delete the association."
+ (declare (ignore name thread))
+ nil)
+
+(definterface find-registered (name)
+ "Find the thread that was registered for the symbol NAME.
+Return nil if the no thread was registred or if the tread is dead."
+ (declare (ignore name))
+ nil)
+
+(definterface set-default-initial-binding (var form)
+ "Initialize special variable VAR by default with FORM.
+
+Some implementations initialize certain variables in each newly
+created thread. This function sets the form which is used to produce
+the initial value."
+ (set var (eval form)))
+
+;; List of delayed interrupts.
+;; This should only have thread-local bindings, so no init form.
+(defvar *pending-slime-interrupts*)
+
+(defun check-slime-interrupts ()
+ "Execute pending interrupts if any.
+This should be called periodically in operations which
+can take a long time to complete.
+Return a boolean indicating whether any interrupts was processed."
+ (when (and (boundp '*pending-slime-interrupts*)
+ *pending-slime-interrupts*)
+ (funcall (pop *pending-slime-interrupts*))
+ t))
+
+(defvar *interrupt-queued-handler* nil
+ "Function to call on queued interrupts.
+Interrupts get queued when an interrupt occurs while interrupt
+handling is disabled.
+
+Backends can use this function to abort slow operations.")
+
+(definterface wait-for-input (streams &optional timeout)
+ "Wait for input on a list of streams. Return those that are ready.
+STREAMS is a list of streams
+TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
+which are ready (or have reached end-of-file) without waiting.
+If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
+return nil.
+
+Return :interrupt if an interrupt occurs while waiting.")
+
+
+;;;; Locks
+
+;; Please use locks only in swank-gray.lisp. Locks are too low-level
+;; for our taste.
+
+(definterface make-lock (&key name)
+ "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
+but that thread may hold it more than once."
+ (declare (ignore name))
+ :null-lock)
+
+(definterface call-with-lock-held (lock function)
+ "Call FUNCTION with LOCK held, queueing if necessary."
+ (declare (ignore lock)
+ (type function function))
+ (funcall function))
+
+
+;;;; Weak datastructures
+
+(definterface make-weak-key-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
+ (apply #'make-hash-table args))
+
+(definterface make-weak-value-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
+ (apply #'make-hash-table args))
+
+(definterface hash-table-weakness (hashtable)
+ "Return nil or one of :key :value :key-or-value :key-and-value"
+ (declare (ignore hashtable))
+ nil)
+
+
+;;;; Character names
+
+(definterface character-completion-set (prefix matchp)
+ "Return a list of names of characters that match PREFIX."
+ ;; Handle the standard and semi-standard characters.
+ (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
+ "Linefeed" "Return" "Backspace")
+ when (funcall matchp prefix name)
+ collect name))
+
+
+(defparameter *type-specifier-arglists*
+ '((and . (&rest type-specifiers))
+ (array . (&optional element-type dimension-spec))
+ (base-string . (&optional size))
+ (bit-vector . (&optional size))
+ (complex . (&optional type-specifier))
+ (cons . (&optional car-typespec cdr-typespec))
+ (double-float . (&optional lower-limit upper-limit))
+ (eql . (object))
+ (float . (&optional lower-limit upper-limit))
+ (function . (&optional arg-typespec value-typespec))
+ (integer . (&optional lower-limit upper-limit))
+ (long-float . (&optional lower-limit upper-limit))
+ (member . (&rest eql-objects))
+ (mod . (n))
+ (not . (type-specifier))
+ (or . (&rest type-specifiers))
+ (rational . (&optional lower-limit upper-limit))
+ (real . (&optional lower-limit upper-limit))
+ (satisfies . (predicate-symbol))
+ (short-float . (&optional lower-limit upper-limit))
+ (signed-byte . (&optional size))
+ (simple-array . (&optional element-type dimension-spec))
+ (simple-base-string . (&optional size))
+ (simple-bit-vector . (&optional size))
+ (simple-string . (&optional size))
+ (single-float . (&optional lower-limit upper-limit))
+ (simple-vector . (&optional size))
+ (string . (&optional size))
+ (unsigned-byte . (&optional size))
+ (values . (&rest typespecs))
+ (vector . (&optional element-type size))
+ ))
+
+;;; Heap dumps
+
+(definterface save-image (filename &optional restart-function)
+ "Save a heap image to the file FILENAME.
+RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
+
+(definterface background-save-image (filename &key restart-function
+ completion-function)
+ "Request saving a heap image to the file FILENAME.
+RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
+COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
+
+(defun deinit-log-output ()
+ ;; Can't hang on to an fd-stream from a previous session.
+ (setf *log-output* nil))
+
+
+;;;; Wrapping
+
+(definterface wrap (spec indicator &key before after replace)
+ "Intercept future calls to SPEC and surround them in callbacks.
+
+INDICATOR is a symbol identifying a particular wrapping, and is used
+to differentiate between multiple wrappings.
+
+Implementations intercept calls to SPEC and call, in this order:
+
+* the BEFORE callback, if it's provided, with a single argument set to
+ the list of arguments passed to the intercepted call;
+
+* the original definition of SPEC recursively honouring any wrappings
+ previously established under different values of INDICATOR. If the
+ compatible function REPLACE is provided, call that instead.
+
+* the AFTER callback, if it's provided, with a single set to the list
+ of values returned by the previous call, or, if that call exited
+ non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY."
+ (declare (ignore indicator))
+ (assert (symbolp spec) nil
+ "The default implementation for WRAP allows only simple names")
+ (assert (null (get spec 'slime-wrap)) nil
+ "The default implementation for WRAP allows a single wrapping")
+ (let* ((saved (symbol-function spec))
+ (replacement (lambda (&rest args)
+ (let (retlist completed)
+ (unwind-protect
+ (progn
+ (when before
+ (funcall before args))
+ (setq retlist (multiple-value-list
+ (apply (or replace
+ saved) args)))
+ (setq completed t)
+ (values-list retlist))
+ (when after
+ (funcall after (if completed
+ retlist
+ :exited-non-locally))))))))
+ (setf (get spec 'slime-wrap) (list saved replacement))
+ (setf (symbol-function spec) replacement))
+ spec)
+
+(definterface unwrap (spec indicator)
+ "Remove from SPEC any wrappings tagged with INDICATOR."
+ (if (wrapped-p spec indicator)
+ (setf (symbol-function spec) (first (get spec 'slime-wrap)))
+ (cerror "All right, so I did"
+ "Hmmm, ~a is not correctly wrapped, you probably redefined it"
+ spec))
+ (setf (get spec 'slime-wrap) nil)
+ spec)
+
+(definterface wrapped-p (spec indicator)
+ "Returns true if SPEC is wrapped with INDICATOR."
+ (declare (ignore indicator))
+ (and (symbolp spec)
+ (let ((prop-value (get spec 'slime-wrap)))
+ (cond ((and prop-value
+ (not (eq (second prop-value)
+ (symbol-function spec))))
+ (warn "~a appears to be incorrectly wrapped" spec)
+ nil)
+ (prop-value t)
+ (t nil)))))
diff --git a/vim/bundle/slimv/slime/swank/ccl.lisp b/vim/bundle/slimv/slime/swank/ccl.lisp
new file mode 100644
index 0000000..66195c5
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/ccl.lisp
@@ -0,0 +1,861 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
+;;;
+;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
+;;;
+;;; This program is licensed under the terms of the Lisp Lesser GNU
+;;; Public License, known as the LLGPL, and distributed with Clozure CL
+;;; as the file "LICENSE". The LLGPL consists of a preamble and the
+;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
+;;; these conflict, the preamble takes precedence.
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+(defpackage swank/ccl
+ (:use cl swank/backend))
+
+(in-package swank/ccl)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (assert (and (= ccl::*openmcl-major-version* 1)
+ (>= ccl::*openmcl-minor-version* 4))
+ () "This file needs CCL version 1.4 or newer"))
+
+(defimplementation gray-package-name ()
+ "CCL")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (multiple-value-bind (ok err) (ignore-errors (require 'xref))
+ (unless ok
+ (warn "~a~%" err))))
+
+;;; swank-mop
+
+(import-to-swank-mop
+ '( ;; classes
+ cl:standard-generic-function
+ ccl:standard-slot-definition
+ cl:method
+ cl:standard-class
+ ccl:eql-specializer
+ openmcl-mop:finalize-inheritance
+ openmcl-mop:compute-applicable-methods-using-classes
+ ;; standard-class readers
+ openmcl-mop:class-default-initargs
+ openmcl-mop:class-direct-default-initargs
+ openmcl-mop:class-direct-slots
+ openmcl-mop:class-direct-subclasses
+ openmcl-mop:class-direct-superclasses
+ openmcl-mop:class-finalized-p
+ cl:class-name
+ openmcl-mop:class-precedence-list
+ openmcl-mop:class-prototype
+ openmcl-mop:class-slots
+ openmcl-mop:specializer-direct-methods
+ ;; eql-specializer accessors
+ openmcl-mop:eql-specializer-object
+ ;; generic function readers
+ openmcl-mop:generic-function-argument-precedence-order
+ openmcl-mop:generic-function-declarations
+ openmcl-mop:generic-function-lambda-list
+ openmcl-mop:generic-function-methods
+ openmcl-mop:generic-function-method-class
+ openmcl-mop:generic-function-method-combination
+ openmcl-mop:generic-function-name
+ ;; method readers
+ openmcl-mop:method-generic-function
+ openmcl-mop:method-function
+ openmcl-mop:method-lambda-list
+ openmcl-mop:method-specializers
+ openmcl-mop:method-qualifiers
+ ;; slot readers
+ openmcl-mop:slot-definition-allocation
+ openmcl-mop:slot-definition-documentation
+ openmcl-mop:slot-value-using-class
+ openmcl-mop:slot-definition-initargs
+ openmcl-mop:slot-definition-initform
+ openmcl-mop:slot-definition-initfunction
+ openmcl-mop:slot-definition-name
+ openmcl-mop:slot-definition-type
+ openmcl-mop:slot-definition-readers
+ openmcl-mop:slot-definition-writers
+ openmcl-mop:slot-boundp-using-class
+ openmcl-mop:slot-makunbound-using-class))
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (ccl:encode-string-to-octets string :external-format :utf-8))
+
+(defimplementation utf8-to-string (octets)
+ (ccl:decode-string-from-octets octets :external-format :utf-8))
+
+;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (ccl:make-socket :connect :passive :local-port port
+ :local-host host :reuse-address t
+ :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+ (ccl:local-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket &key external-format
+ buffering timeout)
+ (declare (ignore buffering timeout))
+ (let ((stream-args (and external-format
+ `(:external-format ,external-format))))
+ (ccl:accept-connection socket :wait t :stream-args stream-args)))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defimplementation socket-fd (stream)
+ (ccl::ioblock-device (ccl::stream-ioblock stream t)))
+
+;;; Unix signals
+
+(defimplementation getpid ()
+ (ccl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "ccl")
+
+;;; Arglist
+
+(defimplementation arglist (fname)
+ (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
+ (ccl:arglist fname))
+ (if binding
+ arglist
+ :not-available)))
+
+(defimplementation function-name (function)
+ (ccl:function-name function))
+
+(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
+ (let ((flags (ccl:declaration-information decl-identifier)))
+ (if flags
+ `(&any ,flags)
+ (call-next-method))))
+
+;;; Compilation
+
+(defun handle-compiler-warning (condition)
+ "Resignal a ccl:compiler-warning as swank/backend:compiler-warning."
+ (signal 'compiler-condition
+ :original-condition condition
+ :message (compiler-warning-short-message condition)
+ :source-context nil
+ :severity (compiler-warning-severity condition)
+ :location (source-note-to-source-location
+ (ccl:compiler-warning-source-note condition)
+ (lambda () "Unknown source")
+ (ccl:compiler-warning-function-name condition))))
+
+(defgeneric compiler-warning-severity (condition))
+(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
+(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
+
+(defgeneric compiler-warning-short-message (condition))
+
+;; Pretty much the same as ccl:report-compiler-warning but
+;; without the source position and function name stuff.
+(defmethod compiler-warning-short-message ((c ccl:compiler-warning))
+ (with-output-to-string (stream)
+ (ccl:report-compiler-warning c stream :short t)))
+
+;; Needed because `ccl:report-compiler-warning' would return
+;; "Nonspecific warning".
+(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
+ (princ-to-string c))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
+ (let ((ccl:*merge-compiler-warnings* nil))
+ (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (compile-file input-file
+ :output-file output-file
+ :load load-p
+ :external-format external-format)))
+
+;; Use a temp file rather than in-core compilation in order to handle
+;; eval-when's as compile-time.
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((temp-file-name (ccl:temp-pathname))
+ (ccl:*save-source-locations* t))
+ (unwind-protect
+ (progn
+ (with-open-file (s temp-file-name :direction :output
+ :if-exists :error :external-format :utf-8)
+ (write-string string s))
+ (let ((binary-filename (compile-temp-file
+ temp-file-name filename buffer position)))
+ (delete-file binary-filename)))
+ (delete-file temp-file-name)))))
+
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+ "A mapping from tempfile names to Emacs buffer names.")
+
+(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
+ (compile-file temp-file-name
+ :load t
+ :compile-file-original-truename
+ (or buffer-file-name
+ (progn
+ (setf (gethash temp-file-name *temp-file-map*)
+ buffer-name)
+ temp-file-name))
+ :compile-file-original-buffer-offset (1- offset)
+ :external-format :utf-8))
+
+(defimplementation save-image (filename &optional restart-function)
+ (ccl:save-application filename :toplevel-function restart-function))
+
+;;; Cross-referencing
+
+(defun xref-locations (relation name &optional inverse)
+ (delete-duplicates
+ (mapcan #'find-definitions
+ (if inverse
+ (ccl::get-relation relation name :wild :exhaustive t)
+ (ccl::get-relation relation :wild name :exhaustive t)))
+ :test 'equal))
+
+(defimplementation who-binds (name)
+ (xref-locations :binds name))
+
+(defimplementation who-macroexpands (name)
+ (xref-locations :macro-calls name t))
+
+(defimplementation who-references (name)
+ (remove-duplicates
+ (append (xref-locations :references name)
+ (xref-locations :sets name)
+ (xref-locations :binds name))
+ :test 'equal))
+
+(defimplementation who-sets (name)
+ (xref-locations :sets name))
+
+(defimplementation who-calls (name)
+ (remove-duplicates
+ (append
+ (xref-locations :direct-calls name)
+ (xref-locations :indirect-calls name)
+ (xref-locations :macro-calls name t))
+ :test 'equal))
+
+(defimplementation who-specializes (class)
+ (when (symbolp class)
+ (setq class (find-class class nil)))
+ (when class
+ (delete-duplicates
+ (mapcar (lambda (m)
+ (car (find-definitions m)))
+ (ccl:specializer-direct-methods class))
+ :test 'equal)))
+
+(defimplementation list-callees (name)
+ (remove-duplicates
+ (append
+ (xref-locations :direct-calls name t)
+ (xref-locations :macro-calls name nil))
+ :test 'equal))
+
+(defimplementation list-callers (symbol)
+ (delete-duplicates
+ (mapcan #'find-definitions (ccl:caller-functions symbol))
+ :test #'equal))
+
+;;; Profiling (alanr: lifted from swank-clisp)
+
+(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))
+
+;;; Debugging
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* (;;(*debugger-hook* nil)
+ ;; don't let error while printing error take us down
+ (ccl:*signal-printing-errors* nil))
+ (funcall debugger-loop-fn)))
+
+;; This is called for an async interrupt and is running in a random
+;; thread not selected by the user, so don't use thread-local vars
+;; such as *emacs-connection*.
+(defun find-repl-thread ()
+ (let* ((*break-on-signals* nil)
+ (conn (swank::default-connection)))
+ (and (swank::multithreaded-connection-p conn)
+ (swank::mconn.repl-thread conn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (ccl:*break-hook* hook)
+ (ccl:*select-interactive-process-hook* 'find-repl-thread))
+ (funcall fun)))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq ccl:*break-hook* function)
+ (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
+ )
+
+(defun map-backtrace (function &optional
+ (start-frame-number 0)
+ end-frame-number)
+ "Call FUNCTION passing information about each stack frame
+ from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
+ (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
+ (ccl:map-call-frames function
+ :origin ccl:*top-error-frame*
+ :start-frame-number start-frame-number
+ :count (- end-frame-number start-frame-number))))
+
+(defimplementation compute-backtrace (start-frame-number end-frame-number)
+ (let (result)
+ (map-backtrace (lambda (p context)
+ (push (list :frame p context) result))
+ start-frame-number end-frame-number)
+ (nreverse result)))
+
+(defimplementation print-frame (frame stream)
+ (assert (eq (first frame) :frame))
+ (destructuring-bind (p context) (rest frame)
+ (let ((lfun (ccl:frame-function p context)))
+ (format stream "(~S" (or (ccl:function-name lfun) lfun))
+ (let* ((unavailable (cons nil nil))
+ (args (ccl:frame-supplied-arguments p context
+ :unknown-marker unavailable)))
+ (declare (dynamic-extent unavailable))
+ (if (eq args unavailable)
+ (format stream " #<Unknown Arguments>")
+ (dolist (arg args)
+ (if (eq arg unavailable)
+ (format stream " #<Unavailable>")
+ (format stream " ~s" arg)))))
+ (format stream ")"))))
+
+(defmacro with-frame ((p context) frame-number &body body)
+ `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
+
+(defun call/frame (frame-number if-found)
+ (map-backtrace
+ (lambda (p context)
+ (return-from call/frame
+ (funcall if-found p context)))
+ frame-number))
+
+(defimplementation frame-call (frame-number)
+ (with-frame (p context) frame-number
+ (with-output-to-string (stream)
+ (print-frame (list :frame p context) stream))))
+
+(defimplementation frame-var-value (frame var)
+ (with-frame (p context) frame
+ (cdr (nth var (ccl:frame-named-variables p context)))))
+
+(defimplementation frame-locals (index)
+ (with-frame (p context) index
+ (loop for (name . value) in (ccl:frame-named-variables p context)
+ collect (list :name name :value value :id 0))))
+
+(defimplementation frame-source-location (index)
+ (with-frame (p context) index
+ (multiple-value-bind (lfun pc) (ccl:frame-function p context)
+ (if pc
+ (pc-source-location lfun pc)
+ (function-source-location lfun)))))
+
+(defun function-name-package (name)
+ (etypecase name
+ (null nil)
+ (symbol (symbol-package name))
+ ((cons (eql ccl::traced)) (function-name-package (second name)))
+ ((cons (eql setf)) (symbol-package (second name)))
+ ((cons (eql :internal)) (function-name-package (car (last name))))
+ ((cons (and symbol (not keyword)) (cons list null))
+ (symbol-package (car name)))
+ (standard-method (function-name-package (ccl:method-name name)))))
+
+(defimplementation frame-package (frame-number)
+ (with-frame (p context) frame-number
+ (let* ((lfun (ccl:frame-function p context))
+ (name (ccl:function-name lfun)))
+ (function-name-package name))))
+
+(defimplementation eval-in-frame (form index)
+ (with-frame (p context) index
+ (let ((vars (ccl:frame-named-variables p context)))
+ (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
+ (declare (ignorable ,@(mapcar #'car vars)))
+ ,form)))))
+
+(defimplementation return-from-frame (index form)
+ (let ((values (multiple-value-list (eval-in-frame form index))))
+ (with-frame (p context) index
+ (declare (ignore context))
+ (ccl:apply-in-frame p #'values values))))
+
+(defimplementation restart-frame (index)
+ (with-frame (p context) index
+ (ccl:apply-in-frame p
+ (ccl:frame-function p context)
+ (ccl:frame-supplied-arguments p context))))
+
+(defimplementation disassemble-frame (the-frame-number)
+ (with-frame (p context) the-frame-number
+ (multiple-value-bind (lfun pc) (ccl:frame-function p context)
+ (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
+ (disassemble lfun))))
+
+;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
+;; contains some interesting details:
+;;
+;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
+;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
+;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
+;; positions are file positions (not character positions). The text will
+;; be NIL unless text recording was on at read-time. If the original
+;; file is still available, you can force missing source text to be read
+;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
+;;
+;; Source-note's are associated with definitions (via record-source-file)
+;; and also stored in function objects (including anonymous and nested
+;; functions). The former can be retrieved via
+;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
+;;
+;; The recording behavior is controlled by the new variable
+;; CCL:*SAVE-SOURCE-LOCATIONS*:
+;;
+;; If NIL, don't store source-notes in function objects, and store only
+;; the filename for definitions (the latter only if
+;; *record-source-file* is true).
+;;
+;; If T, store source-notes, including a copy of the original source
+;; text, for function objects and definitions (the latter only if
+;; *record-source-file* is true).
+;;
+;; If :NO-TEXT, store source-notes, but without saved text, for
+;; function objects and defintions (the latter only if
+;; *record-source-file* is true). This is the default.
+;;
+;; PC to source mapping is controlled by the new variable
+;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
+;; compressed table mapping pc offsets to corresponding source locations.
+;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
+;; which returns a source-note for the source at offset pc in the
+;; function.
+
+(defun function-source-location (function)
+ (source-note-to-source-location
+ (or (ccl:function-source-note function)
+ (function-name-source-note function))
+ (lambda ()
+ (format nil "Function has no source note: ~A" function))
+ (ccl:function-name function)))
+
+(defun pc-source-location (function pc)
+ (source-note-to-source-location
+ (or (ccl:find-source-note-at-pc function pc)
+ (ccl:function-source-note function)
+ (function-name-source-note function))
+ (lambda ()
+ (format nil "No source note at PC: ~a[~d]" function pc))
+ (ccl:function-name function)))
+
+(defun function-name-source-note (fun)
+ (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
+ (and defs
+ (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
+ (declare (ignore type name srclocs))
+ srcloc))))
+
+(defun source-note-to-source-location (source if-nil-thunk &optional name)
+ (labels ((filename-to-buffer (filename)
+ (cond ((gethash filename *temp-file-map*)
+ (list :buffer (gethash filename *temp-file-map*)))
+ ((probe-file filename)
+ (list :file (ccl:native-translated-namestring
+ (truename filename))))
+ (t (error "File ~s doesn't exist" filename)))))
+ (handler-case
+ (cond ((ccl:source-note-p source)
+ (let* ((full-text (ccl:source-note-text source))
+ (file-name (ccl:source-note-filename source))
+ (start-pos (ccl:source-note-start-pos source)))
+ (make-location
+ (when file-name (filename-to-buffer (pathname file-name)))
+ (when start-pos (list :position (1+ start-pos)))
+ (when full-text
+ (list :snippet (subseq full-text 0
+ (min 40 (length full-text))))))))
+ ((and source name)
+ ;; This branch is probably never used
+ (make-location
+ (filename-to-buffer source)
+ (list :function-name (princ-to-string
+ (if (functionp name)
+ (ccl:function-name name)
+ name)))))
+ (t `(:error ,(funcall if-nil-thunk))))
+ (error (c) `(:error ,(princ-to-string c))))))
+
+(defun alphatizer-definitions (name)
+ (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
+ (and alpha (ccl:find-definition-sources alpha))))
+
+(defun p2-definitions (name)
+ (let ((nx1-op (gethash name ccl::*nx1-operators*)))
+ (and nx1-op
+ (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
+ (and (array-in-bounds-p dispatch nx1-op)
+ (let ((p2 (aref dispatch nx1-op)))
+ (and p2
+ (ccl:find-definition-sources p2))))))))
+
+(defimplementation find-definitions (name)
+ (let ((defs (append (or (ccl:find-definition-sources name)
+ (and (symbolp name)
+ (fboundp name)
+ (ccl:find-definition-sources
+ (symbol-function name))))
+ (alphatizer-definitions name)
+ (p2-definitions name))))
+ (loop for ((type . name) . sources) in defs
+ collect (list (definition-name type name)
+ (source-note-to-source-location
+ (find-if-not #'null sources)
+ (lambda () "No source-note available")
+ name)))))
+
+(defimplementation find-source-location (obj)
+ (let* ((defs (ccl:find-definition-sources obj))
+ (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
+ (car defs)))
+ (note (find-if-not #'null (cdr best-def))))
+ (when note
+ (source-note-to-source-location
+ note
+ (lambda () "No source note available")))))
+
+(defun definition-name (type object)
+ (case (ccl:definition-type-name type)
+ (method (ccl:name-of object))
+ (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
+
+;;; Utilities
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-function-name (ccl:setf-function-spec-name
+ `(setf ,symbol))))
+ (when (fboundp setf-function-name)
+ (doc 'function setf-function-name))))
+ (maybe-push
+ :type (when (ccl:type-specifier-p symbol)
+ (doc 'type)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:setf
+ (describe (ccl:setf-function-spec-name `(setf ,symbol))))
+ (:class
+ (describe (find-class symbol)))
+ (:type
+ (describe (or (find-class symbol nil) symbol)))))
+
+;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
+(defun parse-defmethod-spec (spec)
+ (values (second spec)
+ (subseq spec 2 (position-if #'consp spec))
+ (find-if #'consp (cddr spec))))
+
+(defimplementation toggle-trace (spec)
+ "We currently ignore just about everything."
+ (let ((what (ecase (first spec)
+ ((setf)
+ spec)
+ ((:defgeneric)
+ (second spec))
+ ((:defmethod)
+ (multiple-value-bind (name qualifiers specializers)
+ (parse-defmethod-spec spec)
+ (find-method (fdefinition name)
+ qualifiers
+ specializers))))))
+ (cond ((member what (trace) :test #'equal)
+ (ccl::%untrace what)
+ (format nil "~S is now untraced." what))
+ (t
+ (ccl:trace-function what)
+ (format nil "~S is now traced." what)))))
+
+;;; Macroexpansion
+
+(defimplementation macroexpand-all (form &optional env)
+ (ccl:macroexpand-all form env))
+
+;;;; Inspection
+
+(defun comment-type-p (type)
+ (or (eq type :comment)
+ (and (consp type) (eq (car type) :comment))))
+
+(defmethod emacs-inspect ((o t))
+ (let* ((inspector:*inspector-disassembly* t)
+ (i (inspector:make-inspector o))
+ (count (inspector:compute-line-count i)))
+ (loop for l from 0 below count append
+ (multiple-value-bind (value label type) (inspector:line-n i l)
+ (etypecase type
+ ((member nil :normal)
+ `(,(or label "") (:value ,value) (:newline)))
+ ((member :colon)
+ (label-value-line label value))
+ ((member :static)
+ (list (princ-to-string label) " " `(:value ,value) '(:newline)))
+ ((satisfies comment-type-p)
+ (list (princ-to-string label) '(:newline))))))))
+
+(defmethod emacs-inspect :around ((o t))
+ (if (or (uvector-inspector-p o)
+ (not (ccl:uvectorp o)))
+ (call-next-method)
+ (let ((value (call-next-method)))
+ (cond ((listp value)
+ (append value
+ `((:newline)
+ (:value ,(make-instance 'uvector-inspector :object o)
+ "Underlying UVECTOR"))))
+ (t value)))))
+
+(defmethod emacs-inspect ((f function))
+ (append
+ (label-value-line "Name" (function-name f))
+ `("Its argument list is: "
+ ,(princ-to-string (arglist f)) (:newline))
+ (label-value-line "Documentation" (documentation f t))
+ (when (function-lambda-expression f)
+ (label-value-line "Lambda Expression"
+ (function-lambda-expression f)))
+ (when (ccl:function-source-note f)
+ (label-value-line "Source note"
+ (ccl:function-source-note f)))
+ (when (typep f 'ccl:compiled-lexical-closure)
+ (append
+ (label-value-line "Inner function" (ccl::closure-function f))
+ '("Closed over values:" (:newline))
+ (loop for (name value) in (ccl::closure-closed-over-values f)
+ append (label-value-line (format nil " ~a" name)
+ value))))))
+
+(defclass uvector-inspector ()
+ ((object :initarg :object)))
+
+(defgeneric uvector-inspector-p (object)
+ (:method ((object t)) nil)
+ (:method ((object uvector-inspector)) t))
+
+(defmethod emacs-inspect ((uv uvector-inspector))
+ (with-slots (object) uv
+ (loop for i below (ccl:uvsize object) append
+ (label-value-line (princ-to-string i) (ccl:uvref object i)))))
+
+(defimplementation type-specifier-p (symbol)
+ (or (ccl:type-specifier-p symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+;;; Multiprocessing
+
+(defvar *known-processes*
+ (make-hash-table :size 20 :weak :key :test #'eq)
+ "A map from threads to mailboxes.")
+
+(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (mutex (ccl:make-lock "thread mailbox"))
+ (semaphore (ccl:make-semaphore))
+ (queue '() :type list))
+
+(defimplementation spawn (fun &key name)
+ (ccl:process-run-function (or name "Anonymous (Swank)")
+ fun))
+
+(defimplementation thread-id (thread)
+ (ccl:process-serial-number thread))
+
+(defimplementation find-thread (id)
+ (find id (ccl:all-processes) :key #'ccl:process-serial-number))
+
+(defimplementation thread-name (thread)
+ (ccl:process-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "~A" (ccl:process-whostate thread)))
+
+(defimplementation thread-attributes (thread)
+ (list :priority (ccl:process-priority thread)))
+
+(defimplementation make-lock (&key name)
+ (ccl:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+ (ccl:with-lock-grabbed (lock)
+ (funcall function)))
+
+(defimplementation current-thread ()
+ ccl:*current-process*)
+
+(defimplementation all-threads ()
+ (ccl:all-processes))
+
+(defimplementation kill-thread (thread)
+ ;;(ccl:process-kill thread) ; doesn't cut it
+ (ccl::process-initial-form-exited thread :kill))
+
+(defimplementation thread-alive-p (thread)
+ (not (ccl:process-exhausted-p thread)))
+
+(defimplementation interrupt-thread (thread function)
+ (ccl:process-interrupt
+ thread
+ (lambda ()
+ (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
+ (funcall function)))))
+
+(defun mailbox (thread)
+ (ccl:with-lock-grabbed (*known-processes-lock*)
+ (or (gethash thread *known-processes*)
+ (setf (gethash thread *known-processes*) (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (assert message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (ccl:with-lock-grabbed (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (ccl:signal-semaphore (mailbox.semaphore mbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox ccl:*current-process*))
+ (mutex (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (ccl:with-lock-grabbed (mutex)
+ (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)))
+ (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
+
+(let ((alist '())
+ (lock (ccl:make-lock "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (ccl:with-lock-grabbed (lock)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (ccl:process
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (ccl:with-lock-grabbed (lock)
+ (cdr (assoc name alist)))))
+
+(defimplementation set-default-initial-binding (var form)
+ (eval `(ccl::def-standard-initial-binding ,var ,form)))
+
+(defimplementation quit-lisp ()
+ (ccl:quit))
+
+(defimplementation set-default-directory (directory)
+ (let ((dir (truename (merge-pathnames directory))))
+ (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
+ (ccl:cwd dir)
+ (default-directory)))
+
+;;; Weak datastructures
+
+(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 hash-table-weakness (hashtable)
+ (ccl:hash-table-weak-p hashtable))
+
+(pushnew 'deinit-log-output ccl:*save-exit-functions*)
diff --git a/vim/bundle/slimv/slime/swank/clasp.lisp b/vim/bundle/slimv/slime/swank/clasp.lisp
new file mode 100644
index 0000000..3e0c4ef
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/clasp.lisp
@@ -0,0 +1,730 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-clasp.lisp --- SLIME backend for CLASP.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/clasp
+ (:use cl swank/backend))
+
+(in-package swank/clasp)
+
+
+(defmacro cslime-log (fmt &rest fmt-args)
+ `(format t ,fmt ,@fmt-args))
+
+;; Hard dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sockets))
+
+;; Soft dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (probe-file "sys:profile.fas")
+ (require :profile)
+ (pushnew :profile *features*))
+ (when (probe-file "sys:serve-event")
+ (require :serve-event)
+ (pushnew :serve-event *features*)))
+
+(declaim (optimize (debug 3)))
+
+;;; Swank-mop
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import-swank-mop-symbols
+ :clos
+ `(:eql-specializer
+ :eql-specializer-object
+ :generic-function-declarations
+ :specializer-direct-methods
+ ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
+ '(:compute-applicable-methods-using-classes)))))
+
+(defimplementation gray-package-name ()
+ "GRAY")
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ ;; CLASP does not provide threads yet.
+ ;; ECLs swank implementation says that CLOS is not thread safe and
+ ;; I use ECLs CLOS implementation - this is a worry for the future.
+ nil
+ )
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket (or backlog 5))
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t
+ :input t
+ :buffering (ecase buffering
+ ((t) :full)
+ ((nil) :none)
+ (:line :line))
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format))
+(defun accept (socket)
+ "Like socket-accept, but retry on EAGAIN."
+ (loop (handler-case
+ (return (sb-bsd-sockets:socket-accept socket))
+ (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
+ (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+ (file-stream (si:file-stream-fd socket))))
+
+(defvar *external-format-to-coding-system*
+ '((:latin-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (ext:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, CLASP uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+;;;; Unix Integration
+
+;;; If CLASP is built with thread support, it'll spawn a helper thread
+;;; executing the SIGINT handler. We do not want to BREAK into that
+;;; helper but into the main thread, though. This is coupled with the
+;;; current choice of NIL as communication-style in so far as CLASP's
+;;; main-thread is also the Slime's REPL thread.
+
+#+clasp-working
+(defimplementation call-with-user-break-handler (real-handler function)
+ (let ((old-handler #'si:terminal-interrupt))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (make-interrupt-handler real-handler))
+ (unwind-protect (funcall function)
+ (setf (symbol-function 'si:terminal-interrupt) old-handler))))
+
+#+threads
+(defun make-interrupt-handler (real-handler)
+ (let ((main-thread (find 'si:top-level (mp:all-processes)
+ :key #'mp:process-name)))
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (mp:interrupt-process main-thread real-handler))))
+
+#-threads
+(defun make-interrupt-handler (real-handler)
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (funcall real-handler)))
+
+
+(defimplementation getpid ()
+ (si:getpid))
+
+(defimplementation set-default-directory (directory)
+ (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:getcwd)))
+
+(defimplementation quit-lisp ()
+ (core:quit))
+
+
+
+;;; Instead of busy waiting with communication-style NIL, use select()
+;;; on the sockets' streams.
+#+serve-event
+(progn
+ (defun poll-streams (streams timeout)
+ (let* ((serve-event::*descriptor-handlers*
+ (copy-list serve-event::*descriptor-handlers*))
+ (active-fds '())
+ (fd-stream-alist
+ (loop for s in streams
+ for fd = (socket-fd s)
+ collect (cons fd s)
+ do (serve-event:add-fd-handler fd :input
+ #'(lambda (fd)
+ (push fd active-fds))))))
+ (serve-event:serve-event timeout)
+ (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
+
+ (defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (poll-streams streams 0)))
+ (t
+ (when-let (ready (poll-streams streams 0.2))
+ (return ready))))))
+
+) ; #+serve-event (progn ...
+
+#-serve-event
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (remove-if-not #'listen streams)))
+ (t
+ (let ((ready (remove-if-not #'listen streams)))
+ (if ready (return ready))
+ (sleep 0.1))))))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+
+(defun signal-compiler-condition (&rest args)
+ (apply #'signal 'compiler-condition args))
+
+#-clasp-bytecmp
+(defun handle-compiler-message (condition)
+ ;; CLASP emits lots of noise in compiler-notes, like "Invoking
+ ;; external command".
+ (unless (typep condition 'c::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (cmp:compiler-fatal-error :error)
+ (cmp:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+#-clasp-bytecmp
+(defun condition-location (condition)
+ (let ((file (cmp:compiler-message-file condition))
+ (position (cmp:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (funcall function))
+#|| #-clasp-bytecmp
+ (handler-bind ((c:compiler-message #'handle-compiler-message))
+ (funcall function)))
+||#
+
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file)
+ ;; Ignore the output-file and generate our own
+ (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-"))))
+ (format t "Using tmp-output-file: ~a~%" tmp-output-file)
+ (multiple-value-bind (fasl warnings-p failure-p)
+ (with-compilation-hooks ()
+ (compile-file input-file :output-file tmp-output-file
+ :external-format external-format))
+ (values fasl warnings-p
+ (or failure-p
+ (when load-p
+ (not (load fasl))))))))
+
+(defvar *tmpfile-map* (make-hash-table :test #'equal))
+
+(defun note-buffer-tmpfile (tmp-file buffer-name)
+ ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
+ (let ((tmp-namestring (namestring (truename tmp-file))))
+ (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
+ tmp-namestring))
+
+(defun tmpfile-to-buffer (tmp-file)
+ (gethash tmp-file *tmpfile-map*))
+
+(defimplementation swank-compile-string (string &key buffer position filename policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer) ; for compilation hooks
+ (*buffer-start-position* position))
+ (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-"))
+ (fasl-file)
+ (warnings-p)
+ (failure-p))
+ (unwind-protect
+ (with-open-file (tmp-stream tmp-file :direction :output
+ :if-exists :supersede)
+ (write-string string tmp-stream)
+ (finish-output tmp-stream)
+ (multiple-value-setq (fasl-file warnings-p failure-p)
+ (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer))))
+ (compile-file tmp-file
+ :source-debug-namestring truename
+ :source-debug-offset (1- position)))))
+ (when fasl-file (load fasl-file))
+ (when (probe-file tmp-file)
+ (delete-file tmp-file))
+ (when fasl-file
+ (delete-file fasl-file)))
+ (not failure-p)))))
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+ (multiple-value-bind (arglist foundp)
+ (core:function-lambda-list name) ;; Uses bc-split
+ (if foundp arglist :not-available)))
+
+(defimplementation function-name (f)
+ (typecase f
+ (generic-function (clos::generic-function-name f))
+ (function (ext:compiled-function-name f))))
+
+;; FIXME
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (macroexpand form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((frob (type boundp)
+ (when (funcall boundp symbol)
+ (let ((doc (describe-definition symbol type)))
+ (setf result (list* type doc result))))))
+ (frob :VARIABLE #'boundp)
+ (frob :FUNCTION #'fboundp)
+ (frob :CLASS (lambda (x) (find-class x nil))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+(defimplementation type-specifier-p (symbol)
+ (or (subtypep nil symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+#+frs si::*frs-base*
+#+frs si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+#+frs si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+#+frs si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defun make-invoke-debugger-hook (hook)
+ (when hook
+ #'(lambda (condition old-hook)
+ ;; Regard *debugger-hook* if set by user.
+ (if *debugger-hook*
+ nil ; decline, *DEBUGGER-HOOK* will be tried next.
+ (funcall hook condition old-hook)))))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))
+ )
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall fun))
+ )
+
+(defvar *backtrace* '())
+
+;;; Commented out; it's not clear this is a good way of doing it. In
+;;; particular because it makes errors stemming from this file harder
+;;; to debug, and given the "young" age of CLASP's swank backend, that's
+;;; a bad idea.
+
+;; (defun in-swank-package-p (x)
+;; (and
+;; (symbolp x)
+;; (member (symbol-package x)
+;; (list #.(find-package :swank)
+;; #.(find-package :swank/backend)
+;; #.(ignore-errors (find-package :swank-mop))
+;; #.(ignore-errors (find-package :swank-loader))))
+;; t))
+
+;; (defun is-swank-source-p (name)
+;; (setf name (pathname name))
+;; (pathname-match-p
+;; name
+;; (make-pathname :defaults swank-loader::*source-directory*
+;; :name (pathname-name name)
+;; :type (pathname-type name)
+;; :version (pathname-version name))))
+
+;; (defun is-ignorable-fun-p (x)
+;; (or
+;; (in-swank-package-p (frame-name x))
+;; (multiple-value-bind (file position)
+;; (ignore-errors (si::bc-file (car x)))
+;; (declare (ignore position))
+;; (if file (is-swank-source-p file)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* ((*ihs-top* (or #+#.(swank/backend:with-symbol '*stack-top-hint* 'core)
+ core:*stack-top-hint*
+ (ihs-top)))
+ (*ihs-current* *ihs-top*)
+#+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
+#+frs (*frs-top* (frs-top))
+ (*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ ihs))))
+ (declare (special *ihs-current*))
+#+frs (loop for f from *frs-base* until *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (si::fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (nreverse *backtrace*))
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation compute-backtrace (start end)
+ (subseq *backtrace* start
+ (and (numberp end)
+ (min end (length *backtrace*)))))
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun frame-function (frame-number)
+ (let ((x (first (elt *backtrace* frame-number))))
+ (etypecase x
+ (symbol
+ (and (fboundp x)
+ (fdefinition x)))
+ (function
+ x))))
+
+(defimplementation print-frame (frame stream)
+ (format stream "(~s~{ ~s~})" (function-name (first frame))
+ #+#.(swank/backend:with-symbol 'ihs-arguments 'core)
+ (coerce (core:ihs-arguments (third frame)) 'list)
+ #-#.(swank/backend:with-symbol 'ihs-arguments 'core)
+ nil))
+
+(defimplementation frame-source-location (frame-number)
+ (source-location (frame-function frame-number)))
+
+#+clasp-working
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defun ihs-frame-id (frame-number)
+ (- (core:ihs-top) frame-number))
+
+(defimplementation frame-locals (frame-number)
+ (let* ((frame (elt *backtrace* frame-number))
+ (env (second frame))
+ (locals (loop for x = env then (core:get-parent-environment x)
+ while x
+ nconc (loop for name across (core:environment-debug-names x)
+ for value across (core:environment-debug-values x)
+ collect (list :name name :id 0 :value value)))))
+ (nconc
+ (loop for arg across (core:ihs-arguments (third frame))
+ for i from 0
+ collect (list :name (intern (format nil "ARG~d" i) #.*package*)
+ :id 0
+ :value arg))
+ locals)))
+
+(defimplementation frame-var-value (frame-number var-number)
+ (let* ((frame (elt *backtrace* frame-number))
+ (env (second frame))
+ (args (core:ihs-arguments (third frame))))
+ (if (< var-number (length args))
+ (svref args var-number)
+ (elt (frame-locals frame-number) var-number))))
+
+#+clasp-working
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-function frame-number)))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (core:compile-form-and-eval-with-env form env)))
+
+#+clasp-working
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+#+clasp-working
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+
+
+;;;; Inspector
+
+;;; FIXME: Would be nice if it was possible to inspect objects
+;;; implemented in C.
+
+
+;;;; Definitions
+
+(defun make-file-location (file file-position)
+ ;; File positions in CL start at 0, but Emacs' buffer positions
+ ;; start at 1. We specify (:ALIGN T) because the positions comming
+ ;; from CLASP point at right after the toplevel form appearing before
+ ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
+ (make-location `(:file ,(namestring (translate-logical-pathname file)))
+ `(:position ,(1+ file-position))
+ `(:align t)))
+
+(defun make-buffer-location (buffer-name start-position &optional (offset 0))
+ (make-location `(:buffer ,buffer-name)
+ `(:offset ,start-position ,offset)
+ `(:align t)))
+
+(defun translate-location (location)
+ (make-location (list :file (namestring (ext:source-location-pathname location)))
+ (list :position (ext:source-location-offset location))
+ '(:align t)))
+
+(defimplementation find-definitions (name)
+ (loop for kind in ext:*source-location-kinds*
+ for locations = (ext:source-location name kind)
+ when locations
+ nconc (loop for location in locations
+ collect (list kind (translate-location location)))))
+
+(defun source-location (object)
+ (let ((location (ext:source-location object t)))
+ (when location
+ (translate-location (car location)))))
+
+(defimplementation find-source-location (object)
+ (or (source-location object)
+ (make-error-location "Source definition of ~S not found." object)))
+
+
+;;;; Profiling
+
+#+profile
+(progn
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+) ; #+profile (progn ...
+
+
+;;;; Threads
+
+#+threads
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ (defvar *thread-id-map-lock*
+ (mp:make-lock :name "thread id map lock"))
+
+ (defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+ (defimplementation thread-id (target-thread)
+ (block thread-id
+ (mp:with-lock (*thread-id-map-lock*)
+ ;; Does TARGET-THREAD have an id already?
+ (maphash (lambda (id thread-pointer)
+ (let ((thread (si:weak-pointer-value thread-pointer)))
+ (cond ((not thread)
+ (remhash id *thread-id-map*))
+ ((eq thread target-thread)
+ (return-from thread-id id)))))
+ *thread-id-map*)
+ ;; TARGET-THREAD not found in *THREAD-ID-MAP*
+ (let ((id (incf *thread-id-counter*))
+ (thread-pointer (si:make-weak-pointer target-thread)))
+ (setf (gethash id *thread-id-map*) thread-pointer)
+ id))))
+
+ (defimplementation find-thread (id)
+ (mp:with-lock (*thread-id-map-lock*)
+ (let* ((thread-ptr (gethash id *thread-id-map*))
+ (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
+ (unless thread
+ (remhash id *thread-id-map*))
+ thread)))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (if (mp:process-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (mp:make-lock :name name :recursive t))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mp:with-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (mp:all-processes))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:interrupt-process thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+ (defimplementation thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+ (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
+ (defvar *mailboxes* (list))
+ (declaim (type list *mailboxes*))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (mutex (mp:make-lock))
+ (cvar (mp:make-condition-variable))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:with-lock (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock (mutex)
+ (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:condition-variable-timedwait (mailbox.cvar mbox)
+ mutex
+ 0.2)))))
+
+ ) ; #+threads (progn ...
+
+
+(defmethod emacs-inspect ((object core:cxx-object))
+ (let ((encoded (core:encode object)))
+ (loop for (key . value) in encoded
+ append (list (string key) ": " (list :value value) (list :newline)))))
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)))
diff --git a/vim/bundle/slimv/slime/swank/cmucl.lisp b/vim/bundle/slimv/slime/swank/cmucl.lisp
new file mode 100644
index 0000000..12d4282
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/cmucl.lisp
@@ -0,0 +1,2470 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; License: Public Domain
+;;;
+;;;; Introduction
+;;;
+;;; This is the CMUCL implementation of the `swank/backend' package.
+
+(defpackage swank/cmucl
+ (:use cl swank/backend swank/source-path-parser swank/source-file-cache
+ fwrappers))
+
+(in-package swank/cmucl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (let ((min-version #x20c))
+ (assert (>= c:byte-fasl-file-version min-version)
+ () "This file requires CMUCL version ~x or newer" min-version))
+
+ (require 'gray-streams))
+
+
+(import-swank-mop-symbols :pcl '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+;;; UTF8
+
+(locally (declare (optimize (ext:inhibit-warnings 3)))
+ ;; Compile and load the utf8 format, if not already loaded.
+ (stream::find-external-format :utf-8))
+
+(defimplementation string-to-utf8 (string)
+ (let ((ef (load-time-value (stream::find-external-format :utf-8) t)))
+ (stream:string-to-octets string :external-format ef)))
+
+(defimplementation utf8-to-string (octets)
+ (let ((ef (load-time-value (stream::find-external-format :utf-8) t)))
+ (stream:octets-to-string octets :external-format ef)))
+
+
+;;;; TCP server
+;;;
+;;; In CMUCL we support all communication styles. By default we use
+;;; `:SIGIO' because it is the most responsive, but it's somewhat
+;;; dangerous: CMUCL is not in general "signal safe", and you don't
+;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
+;;; `:SPAWN' are reasonable alternatives.
+
+(defimplementation preferred-communication-style ()
+ :sigio)
+
+#-(or darwin mips)
+(defimplementation create-socket (host port &key backlog)
+ (let* ((addr (resolve-hostname host))
+ (addr (if (not (find-symbol "SOCKET-ERROR" :ext))
+ (ext:htonl addr)
+ addr)))
+ (ext:create-inet-listener port :stream :reuse-address t :host addr
+ :backlog (or backlog 5))))
+
+;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
+#+(or darwin mips)
+(defimplementation create-socket (host port &key backlog)
+ (declare (ignore host))
+ (ext:create-inet-listener port :stream :reuse-address t))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (let ((fd (socket-fd socket)))
+ (sys:invalidate-descriptor fd)
+ (ext:close-socket fd)))
+
+(defimplementation accept-connection (socket &key
+ external-format buffering timeout)
+ (declare (ignore timeout))
+ (make-socket-io-stream (ext:accept-tcp-connection socket)
+ (ecase buffering
+ ((t) :full)
+ (:line :line)
+ ((nil) :none))
+ external-format))
+
+;;;;; Sockets
+
+(defimplementation socket-fd (socket)
+ "Return the filedescriptor for the socket represented by SOCKET."
+ (etypecase socket
+ (fixnum socket)
+ (sys:fd-stream (sys:fd-stream-fd socket))))
+
+(defun resolve-hostname (hostname)
+ "Return the IP address of HOSTNAME as an integer (in host byte-order)."
+ (let ((hostent (ext:lookup-host-entry hostname)))
+ (car (ext:host-entry-addr-list hostent))))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1 "iso-latin-1-unix")
+ #+unicode
+ (:utf-8 "utf-8-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (fd buffering external-format)
+ "Create a new input/output fd-stream for FD."
+ (cond (external-format
+ (sys:make-fd-stream fd :input t :output t
+ :element-type 'character
+ :buffering buffering
+ :external-format external-format))
+ (t
+ (sys:make-fd-stream fd :input t :output t
+ :element-type '(unsigned-byte 8)
+ :buffering buffering))))
+
+(defimplementation make-fd-stream (fd external-format)
+ (make-socket-io-stream fd :full external-format))
+
+(defimplementation dup (fd)
+ (multiple-value-bind (clone error) (unix:unix-dup fd)
+ (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error)))
+ clone))
+
+(defimplementation command-line-args ()
+ ext:*command-line-strings*)
+
+(defimplementation exec-image (image-file args)
+ (multiple-value-bind (ok error)
+ (unix:unix-execve (car (command-line-args))
+ (list* (car (command-line-args))
+ "-core" image-file
+ "-noinit"
+ args))
+ (error "~a" (unix:get-unix-error-msg error))
+ ok))
+
+;;;;; Signal-driven I/O
+
+(defimplementation install-sigint-handler (function)
+ (sys:enable-interrupt :sigint (lambda (signal code scp)
+ (declare (ignore signal code scp))
+ (funcall function))))
+
+(defvar *sigio-handlers* '()
+ "List of (key . function) pairs.
+All functions are called on SIGIO, and the key is used for removing
+specific functions.")
+
+(defun reset-sigio-handlers () (setq *sigio-handlers* '()))
+;; All file handlers are invalid afer reload.
+(pushnew 'reset-sigio-handlers ext:*after-save-initializations*)
+
+(defun set-sigio-handler ()
+ (sys:enable-interrupt :sigio (lambda (signal code scp)
+ (sigio-handler signal code scp))))
+
+(defun sigio-handler (signal code scp)
+ (declare (ignore signal code scp))
+ (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
+
+(defun fcntl (fd command arg)
+ "fcntl(2) - manipulate a file descriptor."
+ (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
+ (cond (ok)
+ (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
+
+(defimplementation add-sigio-handler (socket fn)
+ (set-sigio-handler)
+ (let ((fd (socket-fd socket)))
+ (fcntl fd unix:f-setown (unix:unix-getpid))
+ (let ((old-flags (fcntl fd unix:f-getfl 0)))
+ (fcntl fd unix:f-setfl (logior old-flags unix:fasync)))
+ (assert (not (assoc fd *sigio-handlers*)))
+ (push (cons fd fn) *sigio-handlers*)))
+
+(defimplementation remove-sigio-handlers (socket)
+ (let ((fd (socket-fd socket)))
+ (when (assoc fd *sigio-handlers*)
+ (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
+ (let ((old-flags (fcntl fd unix:f-getfl 0)))
+ (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync)))
+ (sys:invalidate-descriptor fd))
+ (assert (not (assoc fd *sigio-handlers*)))
+ (when (null *sigio-handlers*)
+ (sys:default-interrupt :sigio))))
+
+;;;;; SERVE-EVENT
+
+(defimplementation add-fd-handler (socket fn)
+ (let ((fd (socket-fd socket)))
+ (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
+
+(defimplementation remove-fd-handlers (socket)
+ (sys:invalidate-descriptor (socket-fd socket)))
+
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (let ((ready (remove-if-not #'listen streams)))
+ (when ready (return ready)))
+ (when timeout (return nil))
+ (multiple-value-bind (in out) (make-pipe)
+ (let* ((f (constantly t))
+ (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams))
+ collect (add-one-shot-handler s f))))
+ (unwind-protect
+ (let ((*interrupt-queued-handler* (lambda ()
+ (write-char #\! out))))
+ (when (check-slime-interrupts) (return :interrupt))
+ (sys:serve-event))
+ (mapc #'sys:remove-fd-handler handlers)
+ (close in)
+ (close out))))))
+
+(defun to-fd-stream (stream)
+ (etypecase stream
+ (sys:fd-stream stream)
+ (synonym-stream
+ (to-fd-stream
+ (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (to-fd-stream (two-way-stream-input-stream stream)))))
+
+(defun add-one-shot-handler (stream function)
+ (let (handler)
+ (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input
+ (lambda (fd)
+ (declare (ignore fd))
+ (sys:remove-fd-handler handler)
+ (funcall function stream))))))
+
+(defun make-pipe ()
+ (multiple-value-bind (in out) (unix:unix-pipe)
+ (values (sys:make-fd-stream in :input t :buffering :none)
+ (sys:make-fd-stream out :output t :buffering :none))))
+
+
+;;;; Stream handling
+
+(defimplementation gray-package-name ()
+ "EXT")
+
+
+;;;; Compilation Commands
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *buffer-name* nil
+ "The name of the Emacs buffer we are compiling from.
+NIL if we aren't compiling from a buffer.")
+
+(defvar *buffer-start-position* nil)
+(defvar *buffer-substring* nil)
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((*previous-compiler-condition* nil)
+ (*previous-context* nil)
+ (*print-readably* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (clear-xref-info input-file)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (compile-file input-file :output-file output-file
+ :external-format external-format)
+ (values output-file warnings-p
+ (or failure-p
+ (when load-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get input-file
+ (file-write-date input-file))
+ (not (load output-file)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-substring* string)
+ (source-info (list :emacs-buffer buffer
+ :emacs-buffer-offset position
+ :emacs-buffer-string string)))
+ (with-input-from-string (stream string)
+ (let ((failurep (ext:compile-from-stream stream :source-info
+ source-info)))
+ (not failurep))))))
+
+
+;;;;; Trapping notes
+;;;
+;;; We intercept conditions from the compiler and resignal them as
+;;; `SWANK:COMPILER-CONDITION's.
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (unless (eq condition *previous-compiler-condition*)
+ (let ((context (c::find-error-context nil)))
+ (setq *previous-compiler-condition* condition)
+ (setq *previous-context* context)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :message (compiler-condition-message condition)
+ :source-context (compiler-error-context context)
+ :location (if (read-error-p condition)
+ (read-error-location condition)
+ (compiler-note-location context))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of CONDITION."
+ (etypecase condition
+ ((satisfies read-error-p) :read-error)
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun read-error-p (condition)
+ (eq (type-of condition) 'c::compiler-read-error))
+
+(defun compiler-condition-message (condition)
+ "Briefly describe a compiler error for Emacs.
+When Emacs presents the message it already has the source popped up
+and the source form highlighted. This makes much of the information in
+the error-context redundant."
+ (princ-to-string condition))
+
+(defun compiler-error-context (error-context)
+ "Describe context information for Emacs."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (c::compiler-error-context-enclosing-source error-context)
+ (c::compiler-error-context-source error-context)))
+ (if (or enclosing source)
+ (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~
+ ~@[==>~{~&~A~}~]"
+ enclosing source))))
+
+(defun read-error-location (condition)
+ (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
+ (file (c::file-info-name finfo))
+ (pos (c::compiler-read-error-position condition)))
+ (cond ((and (eq file :stream) *buffer-name*)
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* pos)))
+ ((and (pathnamep file) (not *buffer-name*))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ pos))))
+ (t (break)))))
+
+(defun compiler-note-location (context)
+ "Derive the location of a complier message from its context.
+Return a `location' record, or (:error REASON) on failure."
+ (if (null context)
+ (note-error-location)
+ (with-struct (c::compiler-error-context- file-name
+ original-source
+ original-source-path) context
+ (or (locate-compiler-note file-name original-source
+ (reverse original-source-path))
+ (note-error-location)))))
+
+(defun note-error-location ()
+ "Pseudo-location for notes that can't be located."
+ (cond (*compile-file-truename*
+ (make-location (list :file (unix-truename *compile-file-truename*))
+ (list :eof)))
+ (*buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*)))
+ (t (list :error "No error location available."))))
+
+(defun locate-compiler-note (file source source-path)
+ (cond ((and (eq file :stream) *buffer-name*)
+ ;; Compiling from a buffer
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; No location known, but we have the source form.
+ ;; XXX How is this case triggered? -luke (16/May/2004)
+ ;; This can happen if the compiler needs to expand a macro
+ ;; but the macro-expander is not yet compiled. Calling the
+ ;; (interpreted) macro-expander triggers IR1 conversion of
+ ;; the lambda expression for the expander and invokes the
+ ;; compiler recursively.
+ (make-location (list :source-form source)
+ (list :position 1)))))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+;;;; XREF
+;;;
+;;; Cross-reference support is based on the standard CMUCL `XREF'
+;;; package. This package has some caveats: XREF information is
+;;; recorded during compilation and not preserved in fasl files, and
+;;; XREF recording is disabled by default. Redefining functions can
+;;; also cause duplicate references to accumulate, but
+;;; `swank-compile-file' will automatically clear out any old records
+;;; from the same filename.
+;;;
+;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
+;;; clear out the XREF database call `xref:init-xref-database'.
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls xref:who-calls)
+(defxref who-references xref:who-references)
+(defxref who-binds xref:who-binds)
+(defxref who-sets xref:who-sets)
+
+;;; More types of XREF information were added since 18e:
+;;;
+
+(defxref who-macroexpands xref:who-macroexpands)
+;; XXX
+(defimplementation who-specializes (symbol)
+ (let* ((methods (xref::who-specializes (find-class symbol)))
+ (locations (mapcar #'method-location methods)))
+ (mapcar #'list methods locations)))
+
+(defun xref-results (contexts)
+ (mapcar (lambda (xref)
+ (list (xref:xref-context-name xref)
+ (resolve-xref-location xref)))
+ contexts))
+
+(defun resolve-xref-location (xref)
+ (let ((name (xref:xref-context-name xref))
+ (file (xref:xref-context-file xref))
+ (source-path (xref:xref-context-source-path xref)))
+ (cond ((and file source-path)
+ (let ((position (source-path-file-position source-path file)))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ position)))))
+ (file
+ (make-location (list :file (unix-truename file))
+ (list :function-name (string name))))
+ (t
+ `(:error ,(format nil "Unknown source location: ~S ~S ~S "
+ name file source-path))))))
+
+(defun clear-xref-info (namestring)
+ "Clear XREF notes pertaining to NAMESTRING.
+This is a workaround for a CMUCL bug: XREF records are cumulative."
+ (when c:*record-xref-info*
+ (let ((filename (truename namestring)))
+ (dolist (db (list xref::*who-calls*
+ xref::*who-is-called*
+ xref::*who-macroexpands*
+ xref::*who-references*
+ xref::*who-binds*
+ xref::*who-sets*))
+ (maphash (lambda (target contexts)
+ ;; XXX update during traversal?
+ (setf (gethash target db)
+ (delete filename contexts
+ :key #'xref:xref-context-file
+ :test #'equalp)))
+ db)))))
+
+
+;;;; Find callers and callees
+;;;
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t))
+ (map-cpool (code fun)
+ (declare (type kernel:code-component code) (type function fun))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data code)
+ do (funcall fun (kernel:code-header-ref code i))))
+
+ (callees (fun)
+ (let ((callees (make-stack)))
+ (map-cpool (vm::find-code-object fun)
+ (lambda (o)
+ (when (kernel:fdefn-p o)
+ (vector-push-extend (kernel:fdefn-function o)
+ callees))))
+ (coerce callees 'list)))
+
+ (callers (fun)
+ (declare (function fun))
+ (let ((callers (make-stack)))
+ (ext:gc :full t)
+ ;; scan :dynamic first to avoid the need for even more gcing
+ (dolist (space '(:dynamic :read-only :static))
+ (vm::map-allocated-objects
+ (lambda (obj header size)
+ (declare (type fixnum header) (ignore size))
+ (when (= vm:code-header-type header)
+ (map-cpool obj
+ (lambda (c)
+ (when (and (kernel:fdefn-p c)
+ (eq (kernel:fdefn-function c) fun))
+ (vector-push-extend obj callers))))))
+ space)
+ (ext:gc))
+ (coerce callers 'list)))
+
+ (entry-points (code)
+ (loop for entry = (kernel:%code-entry-points code)
+ then (kernel::%function-next entry)
+ while entry
+ collect entry))
+
+ (guess-main-entry-point (entry-points)
+ (or (find-if (lambda (fun)
+ (ext:valid-function-name-p
+ (kernel:%function-name fun)))
+ entry-points)
+ (car entry-points)))
+
+ (fun-dspec (fun)
+ (list (kernel:%function-name fun) (function-location fun)))
+
+ (code-dspec (code)
+ (let ((eps (entry-points code))
+ (di (kernel:%code-debug-info code)))
+ (cond (eps (fun-dspec (guess-main-entry-point eps)))
+ (di (list (c::debug-info-name di)
+ (debug-info-function-name-location di)))
+ (t (list (princ-to-string code)
+ `(:error "No src-loc available")))))))
+ (declare (inline map-cpool))
+
+ (defimplementation list-callers (symbol)
+ (mapcar #'code-dspec (callers (coerce symbol 'function) )))
+
+ (defimplementation list-callees (symbol)
+ (mapcar #'fun-dspec (callees symbol))))
+
+(defun test-list-callers (count)
+ (let ((funsyms '()))
+ (do-all-symbols (s)
+ (when (and (fboundp s)
+ (functionp (symbol-function s))
+ (not (macro-function s))
+ (not (special-operator-p s)))
+ (push s funsyms)))
+ (let ((len (length funsyms)))
+ (dotimes (i count)
+ (let ((sym (nth (random len) funsyms)))
+ (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym))))))))
+
+;; (test-list-callers 100)
+
+
+;;;; Resolving source locations
+;;;
+;;; Our mission here is to "resolve" references to code locations into
+;;; actual file/buffer names and character positions. The references
+;;; we work from come out of the compiler's statically-generated debug
+;;; information, such as `code-location''s and `debug-source''s. For
+;;; more details, see the "Debugger Programmer's Interface" section of
+;;; the CMUCL manual.
+;;;
+;;; The first step is usually to find the corresponding "source-path"
+;;; for the location. Once we have the source-path we can pull up the
+;;; source file and `READ' our way through to the right position. The
+;;; main source-code groveling work is done in
+;;; `source-path-parser.lisp'.
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+This is useful when debugging the definition-finding code.")
+
+(defmacro safe-definition-finding (&body body)
+ "Execute BODY and return the source-location it returns.
+If an error occurs and `*debug-definition-finding*' is false, then
+return an error pseudo-location.
+
+The second return value is NIL if no error occurs, otherwise it is the
+condition object."
+ `(flet ((body () ,@body))
+ (if *debug-definition-finding*
+ (body)
+ (handler-case (values (progn ,@body) nil)
+ (error (c) (values `(:error ,(trim-whitespace (princ-to-string c)))
+ c))))))
+
+(defun trim-whitespace (string)
+ (string-trim #(#\newline #\space #\tab) string))
+
+(defun code-location-source-location (code-location)
+ "Safe wrapper around `code-location-from-source-location'."
+ (safe-definition-finding
+ (source-location-from-code-location code-location)))
+
+(defun source-location-from-code-location (code-location)
+ "Return the source location for CODE-LOCATION."
+ (let ((debug-fun (di:code-location-debug-function code-location)))
+ (when (di::bogus-debug-function-p debug-fun)
+ ;; Those lousy cheapskates! They've put in a bogus debug source
+ ;; because the code was compiled at a low debug setting.
+ (error "Bogus debug function: ~A" debug-fun)))
+ (let* ((debug-source (di:code-location-debug-source code-location))
+ (from (di:debug-source-from debug-source))
+ (name (di:debug-source-name debug-source)))
+ (ecase from
+ (:file
+ (location-in-file name code-location debug-source))
+ (:stream
+ (location-in-stream code-location debug-source))
+ (:lisp
+ ;; The location comes from a form passed to `compile'.
+ ;; The best we can do is return the form itself for printing.
+ (make-location
+ (list :source-form (with-output-to-string (*standard-output*)
+ (debug::print-code-location-source-form
+ code-location 100 t)))
+ (list :position 1))))))
+
+(defun location-in-file (filename code-location debug-source)
+ "Resolve the source location for CODE-LOCATION in FILENAME."
+ (let* ((code-date (di:debug-source-created debug-source))
+ (root-number (di:debug-source-root-number debug-source))
+ (source-code (get-source-code filename code-date)))
+ (with-input-from-string (s source-code)
+ (make-location (list :file (unix-truename filename))
+ (list :position (1+ (code-location-stream-position
+ code-location s root-number)))
+ `(:snippet ,(read-snippet s))))))
+
+(defun location-in-stream (code-location debug-source)
+ "Resolve the source location for a CODE-LOCATION from a stream.
+This only succeeds if the code was compiled from an Emacs buffer."
+ (unless (debug-source-info-from-emacs-buffer-p debug-source)
+ (error "The code is compiled from a non-SLIME stream."))
+ (let* ((info (c::debug-source-info debug-source))
+ (string (getf info :emacs-buffer-string))
+ (position (code-location-string-offset
+ code-location
+ string)))
+ (make-location
+ (list :buffer (getf info :emacs-buffer))
+ (list :offset (getf info :emacs-buffer-offset) position)
+ (list :snippet (with-input-from-string (s string)
+ (file-position s position)
+ (read-snippet s))))))
+
+;;;;; Function-name locations
+;;;
+(defun debug-info-function-name-location (debug-info)
+ "Return a function-name source-location for DEBUG-INFO.
+Function-name source-locations are a fallback for when precise
+positions aren't available."
+ (with-struct (c::debug-info- (fname name) source) debug-info
+ (with-struct (c::debug-source- info from name) (car source)
+ (ecase from
+ (:file
+ (make-location (list :file (namestring (truename name)))
+ (list :function-name (string fname))))
+ (:stream
+ (assert (debug-source-info-from-emacs-buffer-p (car source)))
+ (make-location (list :buffer (getf info :emacs-buffer))
+ (list :function-name (string fname))))
+ (:lisp
+ (make-location (list :source-form (princ-to-string (aref name 0)))
+ (list :position 1)))))))
+
+(defun debug-source-info-from-emacs-buffer-p (debug-source)
+ "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
+This is true for functions that were compiled directly from buffers."
+ (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
+
+(defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info))))
+
+
+;;;;; Groveling source-code for positions
+
+(defun code-location-stream-position (code-location stream root)
+ "Return the byte offset of CODE-LOCATION in STREAM. Extract the
+toplevel-form-number and form-number from CODE-LOCATION and use that
+to find the position of the corresponding form.
+
+Finish with STREAM positioned at the start of the code location."
+ (let* ((location (debug::maybe-block-start-location code-location))
+ (tlf-offset (- (di:code-location-top-level-form-offset location)
+ root))
+ (form-number (di:code-location-form-number location)))
+ (let ((pos (form-number-stream-position tlf-offset form-number stream)))
+ (file-position stream pos)
+ pos)))
+
+(defun form-number-stream-position (tlf-number form-number stream)
+ "Return the starting character position of a form in STREAM.
+TLF-NUMBER is the top-level-form number.
+FORM-NUMBER is an index into a source-path table for the TLF."
+ (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
+ (let* ((path-table (di:form-number-translations tlf 0))
+ (source-path
+ (if (<= (length path-table) form-number) ; source out of sync?
+ (list 0) ; should probably signal a condition
+ (reverse (cdr (aref path-table form-number))))))
+ (source-path-source-position source-path tlf position-map))))
+
+(defun code-location-string-offset (code-location string)
+ "Return the byte offset of CODE-LOCATION in STRING.
+See CODE-LOCATION-STREAM-POSITION."
+ (with-input-from-string (s string)
+ (code-location-stream-position code-location s 0)))
+
+
+;;;; Finding definitions
+
+;;; There are a great many different types of definition for us to
+;;; find. We search for definitions of every kind and return them in a
+;;; list.
+
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (setf-definitions name)
+ (variable-definitions name)
+ (class-definitions name)
+ (type-definitions name)
+ (compiler-macro-definitions name)
+ (source-transform-definitions name)
+ (function-info-definitions name)
+ (ir1-translator-definitions name)
+ (template-definitions name)
+ (primitive-definitions name)
+ (vm-support-routine-definitions name)
+ ))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; CMUCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the CMUCL manual for more details.
+
+(defun function-definitions (name)
+ "Return definitions for NAME in the \"function namespace\", i.e.,
+regular functions, generic functions, methods and macros.
+NAME can any valid function name (e.g, (setf car))."
+ (let ((macro? (and (symbolp name) (macro-function name)))
+ (function? (and (ext:valid-function-name-p name)
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
+ (cond (macro?
+ (list `((defmacro ,name)
+ ,(function-location (macro-function name)))))
+ (function?
+ (let ((function (fdefinition name)))
+ (if (genericp function)
+ (gf-definitions name function)
+ (list (list `(function ,name)
+ (function-location function)))))))))
+
+;;;;;; Ordinary (non-generic/macro/special) functions
+;;;
+;;; First we test if FUNCTION is a closure created by defstruct, and
+;;; if so extract the defstruct-description (`dd') from the closure
+;;; and find the constructor for the struct. Defstruct creates a
+;;; defun for the default constructor and we use that as an
+;;; approximation to the source location of the defstruct.
+;;;
+;;; For an ordinary function we return the source location of the
+;;; first code-location we find.
+;;;
+(defun function-location (function)
+ "Return the source location for FUNCTION."
+ (cond ((struct-closure-p function)
+ (struct-closure-location function))
+ ((c::byte-function-or-closure-p function)
+ (byte-function-location function))
+ (t
+ (compiled-function-location function))))
+
+(defun compiled-function-location (function)
+ "Return the location of a regular compiled function."
+ (multiple-value-bind (code-location error)
+ (safe-definition-finding (function-first-code-location function))
+ (cond (error (list :error (princ-to-string error)))
+ (t (code-location-source-location code-location)))))
+
+(defun function-first-code-location (function)
+ "Return the first code-location we can find for FUNCTION."
+ (and (function-has-debug-function-p function)
+ (di:debug-function-start-location
+ (di:function-debug-function function))))
+
+(defun function-has-debug-function-p (function)
+ (di:function-debug-function function))
+
+(defun function-code-object= (closure function)
+ (and (eq (vm::find-code-object closure)
+ (vm::find-code-object function))
+ (not (eq closure function))))
+
+(defun byte-function-location (fun)
+ "Return the location of the byte-compiled function FUN."
+ (etypecase fun
+ ((or c::hairy-byte-function c::simple-byte-function)
+ (let* ((di (kernel:%code-debug-info (c::byte-function-component fun))))
+ (if di
+ (debug-info-function-name-location di)
+ `(:error
+ ,(format nil "Byte-function without debug-info: ~a" fun)))))
+ (c::byte-closure
+ (byte-function-location (c::byte-closure-function fun)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
+;;; `defstruct''d structure.
+
+(defun struct-closure-p (function)
+ "Is FUNCTION a closure created by defstruct?"
+ (or (function-code-object= function #'kernel::structure-slot-accessor)
+ (function-code-object= function #'kernel::structure-slot-setter)
+ (function-code-object= function #'kernel::%defstruct)))
+
+(defun struct-closure-location (function)
+ "Return the location of the structure that FUNCTION belongs to."
+ (assert (struct-closure-p function))
+ (safe-definition-finding
+ (dd-location (struct-closure-dd function))))
+
+(defun struct-closure-dd (function)
+ "Return the defstruct-definition (dd) of FUNCTION."
+ (assert (= (kernel:get-type function) vm:closure-header-type))
+ (flet ((find-layout (function)
+ (sys:find-if-in-closure
+ (lambda (x)
+ (let ((value (if (di::indirect-value-cell-p x)
+ (c:value-cell-ref x)
+ x)))
+ (when (kernel::layout-p value)
+ (return-from find-layout value))))
+ function)))
+ (kernel:layout-info (find-layout function))))
+
+(defun dd-location (dd)
+ "Return the location of a `defstruct'."
+ (let ((ctor (struct-constructor dd)))
+ (cond (ctor
+ (function-location (coerce ctor 'function)))
+ (t
+ (let ((name (kernel:dd-name dd)))
+ (multiple-value-bind (location foundp)
+ (ext:info :source-location :defvar name)
+ (cond (foundp
+ (resolve-source-location location))
+ (t
+ (error "No location for defstruct: ~S" name)))))))))
+
+(defun struct-constructor (dd)
+ "Return the name of the constructor from a defstruct definition."
+ (let* ((constructor (or (kernel:dd-default-constructor dd)
+ (car (kernel::dd-constructors dd)))))
+ (if (consp constructor) (car constructor) constructor)))
+
+;;;;;; Generic functions and methods
+
+(defun gf-definitions (name function)
+ "Return the definitions of a generic function and its methods."
+ (cons (list `(defgeneric ,name) (gf-location function))
+ (gf-method-definitions function)))
+
+(defun gf-location (gf)
+ "Return the location of the generic function GF."
+ (definition-source-location gf (pcl::generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+ "Return the locations of all methods of the generic function GF."
+ (mapcar #'method-definition (pcl::generic-function-methods gf)))
+
+(defun method-definition (method)
+ (list (method-dspec method)
+ (method-location method)))
+
+(defun method-dspec (method)
+ "Return a human-readable \"definition specifier\" for METHOD."
+ (let* ((gf (pcl:method-generic-function method))
+ (name (pcl:generic-function-name gf))
+ (specializers (pcl:method-specializers method))
+ (qualifiers (pcl:method-qualifiers method)))
+ `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
+
+(defun method-location (method)
+ (typecase method
+ (pcl::standard-accessor-method
+ (definition-source-location
+ (cond ((pcl::definition-source method)
+ method)
+ (t
+ (pcl::slot-definition-class
+ (pcl::accessor-method-slot-definition method))))
+ (pcl::accessor-method-slot-name method)))
+ (t
+ (function-location (or (pcl::method-fast-function method)
+ (pcl:method-function method))))))
+
+(defun genericp (fn)
+ (typep fn 'generic-function))
+
+;;;;;; Types and classes
+
+(defun type-definitions (name)
+ "Return `deftype' locations for type NAME."
+ (maybe-make-definition (ext:info :type :expander name) 'deftype name))
+
+(defun maybe-make-definition (function kind name)
+ "If FUNCTION is non-nil then return its definition location."
+ (if function
+ (list (list `(,kind ,name) (function-location function)))))
+
+(defun class-definitions (name)
+ "Return the definition locations for the class called NAME."
+ (if (symbolp name)
+ (let ((class (kernel::find-class name nil)))
+ (etypecase class
+ (null '())
+ (kernel::structure-class
+ (list (list `(defstruct ,name) (dd-location (find-dd name)))))
+ #+(or)
+ (conditions::condition-class
+ (list (list `(define-condition ,name)
+ (condition-class-location class))))
+ (kernel::standard-class
+ (list (list `(defclass ,name)
+ (pcl-class-location (find-class name)))))
+ ((or kernel::built-in-class
+ conditions::condition-class
+ kernel:funcallable-structure-class)
+ (list (list `(class ,name) (class-location class))))))))
+
+(defun pcl-class-location (class)
+ "Return the `defclass' location for CLASS."
+ (definition-source-location class (pcl:class-name class)))
+
+;; FIXME: eval used for backward compatibility.
+(defun class-location (class)
+ (declare (type kernel::class class))
+ (let ((name (kernel:%class-name class)))
+ (multiple-value-bind (loc found?)
+ (let ((x (ignore-errors
+ (multiple-value-list
+ (eval `(ext:info :source-location :class ',name))))))
+ (values-list x))
+ (cond (found? (resolve-source-location loc))
+ (`(:error
+ ,(format nil "No location recorded for class: ~S" name)))))))
+
+(defun find-dd (name)
+ "Find the defstruct-definition by the name of its structure-class."
+ (let ((layout (ext:info :type :compiler-layout name)))
+ (if layout
+ (kernel:layout-info layout))))
+
+(defun condition-class-location (class)
+ (let ((slots (conditions::condition-class-slots class))
+ (name (conditions::condition-class-name class)))
+ (cond ((null slots)
+ `(:error ,(format nil "No location info for condition: ~A" name)))
+ (t
+ ;; Find the class via one of its slot-reader methods.
+ (let* ((slot (first slots))
+ (gf (fdefinition
+ (first (conditions::condition-slot-readers slot)))))
+ (method-location
+ (first
+ (pcl:compute-applicable-methods-using-classes
+ gf (list (find-class name))))))))))
+
+(defun make-name-in-file-location (file string)
+ (multiple-value-bind (filename c)
+ (ignore-errors
+ (unix-truename (merge-pathnames (make-pathname :type "lisp")
+ file)))
+ (cond (filename (make-location `(:file ,filename)
+ `(:function-name ,(string string))))
+ (t (list :error (princ-to-string c))))))
+
+(defun source-location-form-numbers (location)
+ (c::decode-form-numbers (c::form-numbers-form-numbers location)))
+
+(defun source-location-tlf-number (location)
+ (nth-value 0 (source-location-form-numbers location)))
+
+(defun source-location-form-number (location)
+ (nth-value 1 (source-location-form-numbers location)))
+
+(defun resolve-file-source-location (location)
+ (let ((filename (c::file-source-location-pathname location))
+ (tlf-number (source-location-tlf-number location))
+ (form-number (source-location-form-number location)))
+ (with-open-file (s filename)
+ (let ((pos (form-number-stream-position tlf-number form-number s)))
+ (make-location `(:file ,(unix-truename filename))
+ `(:position ,(1+ pos)))))))
+
+(defun resolve-stream-source-location (location)
+ (let ((info (c::stream-source-location-user-info location))
+ (tlf-number (source-location-tlf-number location))
+ (form-number (source-location-form-number location)))
+ ;; XXX duplication in frame-source-location
+ (assert (info-from-emacs-buffer-p info))
+ (destructuring-bind (&key emacs-buffer emacs-buffer-string
+ emacs-buffer-offset) info
+ (with-input-from-string (s emacs-buffer-string)
+ (let ((pos (form-number-stream-position tlf-number form-number s)))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:offset ,emacs-buffer-offset ,pos)))))))
+
+;; XXX predicates for 18e backward compatibilty. Remove them when
+;; we're 19a only.
+(defun file-source-location-p (object)
+ (when (fboundp 'c::file-source-location-p)
+ (c::file-source-location-p object)))
+
+(defun stream-source-location-p (object)
+ (when (fboundp 'c::stream-source-location-p)
+ (c::stream-source-location-p object)))
+
+(defun source-location-p (object)
+ (or (file-source-location-p object)
+ (stream-source-location-p object)))
+
+(defun resolve-source-location (location)
+ (etypecase location
+ ((satisfies file-source-location-p)
+ (resolve-file-source-location location))
+ ((satisfies stream-source-location-p)
+ (resolve-stream-source-location location))))
+
+(defun definition-source-location (object name)
+ (let ((source (pcl::definition-source object)))
+ (etypecase source
+ (null
+ `(:error ,(format nil "No source info for: ~A" object)))
+ ((satisfies source-location-p)
+ (resolve-source-location source))
+ (pathname
+ (make-name-in-file-location source name))
+ (cons
+ (destructuring-bind ((dg name) pathname) source
+ (declare (ignore dg))
+ (etypecase pathname
+ (pathname (make-name-in-file-location pathname (string name)))
+ (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
+
+(defun setf-definitions (name)
+ (let ((f (or (ext:info :setf :inverse name)
+ (ext:info :setf :expander name)
+ (and (symbolp name)
+ (fboundp `(setf ,name))
+ (fdefinition `(setf ,name))))))
+ (if f
+ `(((setf ,name) ,(function-location (cond ((functionp f) f)
+ ((macro-function f))
+ ((fdefinition f)))))))))
+
+(defun variable-location (symbol)
+ (multiple-value-bind (location foundp)
+ ;; XXX for 18e compatibilty. rewrite this when we drop 18e
+ ;; support.
+ (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
+ (if (and foundp location)
+ (resolve-source-location location)
+ `(:error ,(format nil "No source info for variable ~S" symbol)))))
+
+(defun variable-definitions (name)
+ (if (symbolp name)
+ (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
+ (if recorded-p
+ (list (list `(variable ,kind ,name)
+ (variable-location name)))))))
+
+(defun compiler-macro-definitions (symbol)
+ (maybe-make-definition (compiler-macro-function symbol)
+ 'define-compiler-macro
+ symbol))
+
+(defun source-transform-definitions (name)
+ (maybe-make-definition (ext:info :function :source-transform name)
+ 'c:def-source-transform
+ name))
+
+(defun function-info-definitions (name)
+ (let ((info (ext:info :function :info name)))
+ (if info
+ (append (loop for transform in (c::function-info-transforms info)
+ collect (list `(c:deftransform ,name
+ ,(c::type-specifier
+ (c::transform-type transform)))
+ (function-location (c::transform-function
+ transform))))
+ (maybe-make-definition (c::function-info-derive-type info)
+ 'c::derive-type name)
+ (maybe-make-definition (c::function-info-optimizer info)
+ 'c::optimizer name)
+ (maybe-make-definition (c::function-info-ltn-annotate info)
+ 'c::ltn-annotate name)
+ (maybe-make-definition (c::function-info-ir2-convert info)
+ 'c::ir2-convert name)
+ (loop for template in (c::function-info-templates info)
+ collect (list `(,(type-of template)
+ ,(c::template-name template))
+ (function-location
+ (c::vop-info-generator-function
+ template))))))))
+
+(defun ir1-translator-definitions (name)
+ (maybe-make-definition (ext:info :function :ir1-convert name)
+ 'c:def-ir1-translator name))
+
+(defun template-definitions (name)
+ (let* ((templates (c::backend-template-names c::*backend*))
+ (template (gethash name templates)))
+ (etypecase template
+ (null)
+ (c::vop-info
+ (maybe-make-definition (c::vop-info-generator-function template)
+ (type-of template) name)))))
+
+;; for cases like: (%primitive NAME ...)
+(defun primitive-definitions (name)
+ (let ((csym (find-symbol (string name) 'c)))
+ (and csym
+ (not (eq csym name))
+ (template-definitions csym))))
+
+(defun vm-support-routine-definitions (name)
+ (let ((sr (c::backend-support-routines c::*backend*))
+ (name (find-symbol (string name) 'c)))
+ (and name
+ (slot-exists-p sr name)
+ (maybe-make-definition (slot-value sr name)
+ (find-symbol (string 'vm-support-routine) 'c)
+ name))))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (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 (multiple-value-bind (kind recorded-p)
+ (ext:info variable kind symbol)
+ (declare (ignore kind))
+ (if (or (boundp symbol) recorded-p)
+ (doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (ext:info type kind symbol)
+ (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (maybe-push
+ :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+ (doc 'alien-type)))
+ (maybe-push
+ :alien-struct (if (ext:info alien-type struct symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-union (if (ext:info alien-type union symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-enum (if (ext:info alien-type enum symbol)
+ (doc nil)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (describe (ecase namespace
+ (:variable
+ symbol)
+ ((:function :generic-function)
+ (symbol-function symbol))
+ (:setf
+ (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol)))
+ (:type
+ (kernel:values-specifier-type symbol))
+ (:class
+ (find-class symbol))
+ (:alien-struct
+ (ext:info :alien-type :struct symbol))
+ (:alien-union
+ (ext:info :alien-type :union symbol))
+ (:alien-enum
+ (ext:info :alien-type :enum symbol))
+ (:alien-type
+ (ecase (ext:info :alien-type :kind symbol)
+ (:primitive
+ (let ((alien::*values-type-okay* t))
+ (funcall (ext:info :alien-type :translator symbol)
+ (list symbol))))
+ ((:defined)
+ (ext:info :alien-type :definition symbol))
+ (:unknown :unkown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
+
+(defun function-arglist (fun)
+ (let ((arglist
+ (cond ((eval:interpreted-function-p fun)
+ (eval:interpreted-function-arglist fun))
+ ((pcl::generic-function-p fun)
+ (pcl:generic-function-lambda-list fun))
+ ((c::byte-function-or-closure-p fun)
+ (byte-code-function-arglist fun))
+ ((kernel:%function-arglist (kernel:%function-self fun))
+ (handler-case (read-arglist fun)
+ (error () :not-available)))
+ ;; this should work both for compiled-debug-function
+ ;; and for interpreted-debug-function
+ (t
+ (handler-case (debug-function-arglist
+ (di::function-debug-function fun))
+ (di:unhandled-condition () :not-available))))))
+ (check-type arglist (or list (member :not-available)))
+ arglist))
+
+(defimplementation function-name (function)
+ (cond ((eval:interpreted-function-p function)
+ (eval:interpreted-function-name function))
+ ((pcl::generic-function-p function)
+ (pcl::generic-function-name function))
+ ((c::byte-function-or-closure-p function)
+ (c::byte-function-name function))
+ (t (kernel:%function-name (kernel:%function-self function)))))
+
+;;; A simple case: the arglist is available as a string that we can
+;;; `read'.
+
+(defun read-arglist (fn)
+ "Parse the arglist-string of the function object FN."
+ (let ((string (kernel:%function-arglist
+ (kernel:%function-self fn)))
+ (package (find-package
+ (c::compiled-debug-info-package
+ (kernel:%code-debug-info
+ (vm::find-code-object fn))))))
+ (with-standard-io-syntax
+ (let ((*package* (or package *package*)))
+ (read-from-string string)))))
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+ "Derive the argument list of DEBUG-FUNCTION from debug info."
+ (let ((args (di::debug-function-lambda-list debug-function))
+ (required '())
+ (optional '())
+ (rest '())
+ (key '()))
+ ;; collect the names of debug-vars
+ (dolist (arg args)
+ (etypecase arg
+ (di::debug-variable
+ (push (di::debug-variable-symbol arg) required))
+ ((member :deleted)
+ (push ':deleted required))
+ (cons
+ (ecase (car arg)
+ (:keyword
+ (push (second arg) key))
+ (:optional
+ (push (debug-variable-symbol-or-deleted (second arg)) optional))
+ (:rest
+ (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+ ;; intersperse lambda keywords as needed
+ (append (nreverse required)
+ (if optional (cons '&optional (nreverse optional)))
+ (if rest (cons '&rest (nreverse rest)))
+ (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+ (etypecase var
+ (di:debug-variable
+ (di::debug-variable-symbol var))
+ ((member :deleted)
+ '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+ "Return FNAME's debug-function-arglist and %function-arglist.
+A utility for debugging DEBUG-FUNCTION-ARGLIST."
+ (let ((fn (fdefinition fname)))
+ (values (debug-function-arglist (di::function-debug-function fn))
+ (kernel:%function-arglist (kernel:%function-self fn)))))
+
+;;; Deriving arglists for byte-compiled functions:
+;;;
+(defun byte-code-function-arglist (fn)
+ ;; There doesn't seem to be much arglist information around for
+ ;; byte-code functions. Use the arg-count and return something like
+ ;; (arg0 arg1 ...)
+ (etypecase fn
+ (c::simple-byte-function
+ (loop for i from 0 below (c::simple-byte-function-num-args fn)
+ collect (make-arg-symbol i)))
+ (c::hairy-byte-function
+ (hairy-byte-function-arglist fn))
+ (c::byte-closure
+ (byte-code-function-arglist (c::byte-closure-function fn)))))
+
+(defun make-arg-symbol (i)
+ (make-symbol (format nil "~A~D" (string 'arg) i)))
+
+;;; A "hairy" byte-function is one that takes a variable number of
+;;; arguments. `hairy-byte-function' is a type from the bytecode
+;;; interpreter.
+;;;
+(defun hairy-byte-function-arglist (fn)
+ (let ((counter -1))
+ (flet ((next-arg () (make-arg-symbol (incf counter))))
+ (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
+ keywords-p keywords) fn
+ (let ((arglist '())
+ (optional (- max-args min-args)))
+ ;; XXX isn't there a better way to write this?
+ ;; (Looks fine to me. -luke)
+ (dotimes (i min-args)
+ (push (next-arg) arglist))
+ (when (plusp optional)
+ (push '&optional arglist)
+ (dotimes (i optional)
+ (push (next-arg) arglist)))
+ (when rest-arg-p
+ (push '&rest arglist)
+ (push (next-arg) arglist))
+ (when keywords-p
+ (push '&key arglist)
+ (loop for (key _ __) in keywords
+ do (push key arglist))
+ (when (eq keywords-p :allow-others)
+ (push '&allow-other-keys arglist)))
+ (nreverse arglist))))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form &optional env)
+ (walker:macroexpand-all form env))
+
+(defimplementation compiler-macroexpand-1 (form &optional env)
+ (ext:compiler-macroexpand-1 form env))
+
+(defimplementation compiler-macroexpand (form &optional env)
+ (ext:compiler-macroexpand form env))
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:default-directory)))
+
+(defimplementation getpid ()
+ (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "cmucl")
+
+(defimplementation quit-lisp ()
+ (ext::quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into
+;;; source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (unix:unix-sigsetmask 0)
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (debug:*stack-top-hint* nil)
+ (kernel:*current-level* 0))
+ (handler-bind ((di::unhandled-condition
+ (lambda (condition)
+ (error 'sldb-condition
+ :original-condition condition))))
+ (unwind-protect
+ (progn
+ #+(or)(sys:scrub-control-stack)
+ (funcall debugger-loop-fn))
+ #+(or)(sys:scrub-control-stack)
+ ))))
+
+(defun frame-down (frame)
+ (handler-case (di:frame-down frame)
+ (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (frame-down f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let ((*standard-output* stream))
+ (handler-case
+ (debug::print-frame-call frame :verbosity 1 :number nil)
+ (error (e)
+ (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location (index)
+ (let ((frame (nth-frame index)))
+ (cond ((foreign-frame-p frame) (foreign-frame-source-location frame))
+ ((code-location-source-location (di:frame-code-location frame))))))
+
+(defimplementation eval-in-frame (form index)
+ (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (let ((loc (di:frame-code-location frame)))
+ (remove-if
+ (lambda (v)
+ (not (eq (di:debug-variable-validity v loc) :valid)))
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))))
+
+(defun debug-var-value (var frame)
+ (let* ((loc (di:frame-code-location frame))
+ (validity (di:debug-variable-validity var loc)))
+ (ecase validity
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+ (let ((frame (nth-frame index)))
+ (loop for v across (frame-debug-vars frame)
+ collect (list :name (di:debug-variable-symbol v)
+ :id (di:debug-variable-id v)
+ :value (debug-var-value v frame)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame)))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation frame-package (frame-number)
+ (let* ((frame (nth-frame frame-number))
+ (dbg-fun (di:frame-debug-function frame)))
+ (typecase dbg-fun
+ (di::compiled-debug-function
+ (let* ((comp (di::compiled-debug-function-component dbg-fun))
+ (dbg-info (kernel:%code-debug-info comp)))
+ (typecase dbg-info
+ (c::compiled-debug-info
+ (find-package (c::compiled-debug-info-package dbg-info)))))))))
+
+(defimplementation return-from-frame (index form)
+ (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
+ :debug-internals)))
+ (if sym
+ (let* ((frame (nth-frame index))
+ (probe (funcall sym frame)))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame))))
+ "return-from-frame is not implemented in this version of CMUCL.")))
+
+(defimplementation activate-stepping (frame)
+ (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+ (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+ (let* ((caller (di:frame-down frame))
+ (cl (di:frame-code-location caller)))
+ (flet ((hook (frame bp)
+ (when (frame-pointer= frame caller)
+ (di:delete-breakpoint bp)
+ (signal-breakpoint bp frame))))
+ (let* ((info (ecase (di:code-location-kind cl)
+ ((:single-value-return :unknown-return) nil)
+ (:known-return (debug-function-returns
+ (di:frame-debug-function frame)))))
+ (bp (di:make-breakpoint #'hook cl :kind :code-location
+ :info info)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+ "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+ (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info. Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+ "Like `debug::next-code-locations' but be careful in escaped frames."
+ (let ((next (debug::next-code-locations code-location)))
+ (flet ((adjust-pc ()
+ (let ((cl (di::copy-compiled-code-location code-location)))
+ (incf (di::compiled-code-location-pc cl)
+ vm:single-value-return-byte-offset)
+ cl)))
+ (cond ((and (di::compiled-frame-escaped frame)
+ (eq (di:code-location-kind code-location)
+ :single-value-return)
+ (= (length next) 1)
+ (di:code-location= (car next) (adjust-pc)))
+ (debug::next-code-locations (car next)))
+ (t
+ next)))))
+
+(defun set-step-breakpoints (frame)
+ (let ((cl (di:frame-code-location frame)))
+ (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+ (error "Cannot step in elsewhere code"))
+ (let* ((debug::*bad-code-location-types*
+ (remove :call-site debug::*bad-code-location-types*))
+ (next (next-code-locations frame cl)))
+ (cond (next
+ (let ((steppoints '()))
+ (flet ((hook (bp-frame bp)
+ (signal-breakpoint bp bp-frame)
+ (mapc #'di:delete-breakpoint steppoints)))
+ (dolist (code-location next)
+ (let ((bp (di:make-breakpoint #'hook code-location
+ :kind :code-location)))
+ (di:activate-breakpoint bp)
+ (push bp steppoints))))))
+ (t
+ (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext)
+ (let ((*breakpoint-sigcontext* sigcontext)
+ (*breakpoint-pc* offset))
+ (call-next-function)))
+(set-fwrappers 'di::handle-breakpoint '())
+(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext)
+
+(defun sigcontext-object (sc index)
+ "Extract the lisp object in sigcontext SC at offset INDEX."
+ (kernel:make-lisp-obj (vm:sigcontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+ (let ((fp (system:int-sap (vm:sigcontext-register sigcontext
+ vm::cfp-offset))))
+ (system:without-gcing
+ (loop for sc-offset across sc-offsets
+ collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; CMUCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case. The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+ "Return the list of return values for a return point."
+ (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+ (let ((sc (locally (declare (optimize (speed 0)))
+ (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext))))
+ (cl (di:breakpoint-what breakpoint)))
+ (ecase (di:code-location-kind cl)
+ (:single-value-return
+ (list (1st sc)))
+ (:known-return
+ (let ((info (di:breakpoint-info breakpoint)))
+ (if (vectorp info)
+ (known-return-point-values sc info)
+ (progn
+ ;;(break)
+ (list "<<known-return convention not supported>>" info)))))
+ (:unknown-return
+ (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+ (if (= mv-return-pc *breakpoint-pc*)
+ (mv-function-end-breakpoint-values sc)
+ (list (1st sc)))))))))
+
+;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in
+;; newer versions of CMUCL (after ~March 2005).
+(defun mv-function-end-breakpoint-values (sigcontext)
+ (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
+ (cond (sym (funcall sym sigcontext))
+ (t (funcall 'di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+ "Return the return style of DEBUG-FUN."
+ (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+ (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition)
+ ((message :initarg :message :reader breakpoint.message)
+ (values :initarg :values :reader breakpoint.values))
+ (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+(defimplementation condition-extras (condition)
+ (typecase condition
+ (breakpoint
+ ;; pop up the source buffer
+ `((:show-frame-source 0)))
+ (t '())))
+
+(defun signal-breakpoint (breakpoint frame)
+ "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+ (flet ((brk (values fstring &rest args)
+ (let ((msg (apply #'format nil fstring args))
+ (debug:*stack-top-hint* frame))
+ (break 'breakpoint :message msg :values values))))
+ (with-struct (di::breakpoint- kind what) breakpoint
+ (case kind
+ (:code-location
+ (case (di:code-location-kind what)
+ ((:single-value-return :known-return :unknown-return)
+ (let ((values (breakpoint-values breakpoint)))
+ (brk values "Return value: ~{~S ~}" values)))
+ (t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
+ (brk nil "Breakpoint: ~S ~S"
+ (di:code-location-kind what)
+ (di::compiled-code-location-pc what)))))
+ (:function-start
+ (brk nil "Function start breakpoint"))
+ (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+(defimplementation sldb-break-at-start (fname)
+ (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+ (cond ((not debug-fun)
+ `(:error ,(format nil "~S has no debug-function" fname)))
+ (t
+ (flet ((hook (frame bp &optional args cookie)
+ (declare (ignore args cookie))
+ (signal-breakpoint bp frame)))
+ (let ((bp (di:make-breakpoint #'hook debug-fun
+ :kind :function-start)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ (di::interpreted-debug-function -1)
+ (di::bogus-debug-function
+ #-x86
+ (let* ((real (di::frame-real-frame (di::frame-up frame)))
+ (fp (di::frame-pointer real)))
+ ;;#+(or)
+ (progn
+ (format *debug-io* "Frame-real-frame = ~S~%" real)
+ (format *debug-io* "fp = ~S~%" fp)
+ (format *debug-io* "lra = ~S~%"
+ (kernel:stack-ref fp vm::lra-save-offset)))
+ (values
+ (sys:int-sap
+ (- (kernel:get-lisp-obj-address
+ (kernel:stack-ref fp vm::lra-save-offset))
+ (- (ash vm:function-code-offset vm:word-shift)
+ vm:function-pointer-type)))
+ 0))
+ #+x86
+ (let ((fp (di::frame-pointer (di:frame-up frame))))
+ (multiple-value-bind (ra ofp) (di::x86-call-context fp)
+ (declare (ignore ofp))
+ (values ra 0))))))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+~8X Stack Pointer
+~8X Frame Pointer
+~8X Instruction Pointer
+~8X Saved Frame Pointer
+~8X Saved Instruction Pointer~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
+(defvar *gdb-program-name*
+ (ext:enumerate-search-list (p "path:gdb")
+ (when (probe-file p)
+ (return p))))
+
+(defimplementation disassemble-frame (frame-number)
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (cond ((probe-file *gdb-program-name*)
+ (let ((ip (sys:sap-int (frame-ip frame))))
+ (princ (gdb-command "disas 0x~x" ip))))
+ (t
+ (format t "~%[Disassembling bogus frames not implemented]")))))))
+
+(defmacro with-temporary-file ((stream filename) &body body)
+ `(call/temporary-file (lambda (,stream ,filename) . ,body)))
+
+(defun call/temporary-file (fun)
+ (let ((name (system::pick-temporary-file-name)))
+ (unwind-protect
+ (with-open-file (stream name :direction :output :if-exists :supersede)
+ (funcall fun stream name))
+ (delete-file name))))
+
+(defun gdb-command (format-string &rest args)
+ (let ((str (gdb-exec (format nil
+ "interpreter-exec mi2 \"attach ~d\"~%~
+ interpreter-exec console ~s~%detach"
+ (getpid)
+ (apply #'format nil format-string args))))
+ (prompt (format nil
+ #-(and darwin x86) "~%^done~%(gdb) ~%"
+ #+(and darwin x86)
+"~%^done,thread-id=\"1\"~%(gdb) ~%")))
+ (subseq str (+ (or (search prompt str) 0) (length prompt)))))
+
+(defun gdb-exec (cmd)
+ (with-temporary-file (file filename)
+ (write-string cmd file)
+ (force-output file)
+ (let* ((output (make-string-output-stream))
+ ;; gdb on sparc needs to know the executable to find the
+ ;; symbols. Without this, gdb can't disassemble anything.
+ ;; NOTE: We assume that the first entry in
+ ;; lisp::*cmucl-lib* is the bin directory where lisp is
+ ;; located. If this is not true, we'll have to do
+ ;; something better to find the lisp executable.
+ (lisp-path
+ #+sparc
+ (list
+ (namestring
+ (probe-file
+ (merge-pathnames "lisp" (car (lisp::parse-unix-search-path
+ lisp::*cmucl-lib*))))))
+ #-sparc
+ nil)
+ (proc (ext:run-program *gdb-program-name*
+ `(,@lisp-path "-batch" "-x" ,filename)
+ :wait t
+ :output output)))
+ (assert (eq (ext:process-status proc) :exited))
+ (assert (eq (ext:process-exit-code proc) 0))
+ (get-output-stream-string output))))
+
+(defun foreign-frame-p (frame)
+ #-x86
+ (let ((ip (frame-ip frame)))
+ (and (sys:system-area-pointer-p ip)
+ (typep (di::frame-debug-function frame) 'di::bogus-debug-function)))
+ #+x86
+ (let ((ip (frame-ip frame)))
+ (and (sys:system-area-pointer-p ip)
+ (multiple-value-bind (pc code)
+ (di::compute-lra-data-from-pc ip)
+ (declare (ignore pc))
+ (not code)))))
+
+(defun foreign-frame-source-location (frame)
+ (let ((ip (sys:sap-int (frame-ip frame))))
+ (cond ((probe-file *gdb-program-name*)
+ (parse-gdb-line-info (gdb-command "info line *0x~x" ip)))
+ (t `(:error "no srcloc available for ~a" frame)))))
+
+;; The output of gdb looks like:
+;; Line 215 of "../../src/lisp/x86-assem.S"
+;; starts at address 0x805318c <Ldone+11>
+;; and ends at 0x805318e <Ldone+13>.
+;; The ../../ are fixed up with the "target:" search list which might
+;; be wrong sometimes.
+(defun parse-gdb-line-info (string)
+ (with-input-from-string (*standard-input* string)
+ (let ((w1 (read-word)))
+ (cond ((equal w1 "Line")
+ (let ((line (read-word)))
+ (assert (equal (read-word) "of"))
+ (let* ((file (read-from-string (read-word)))
+ (pathname
+ (or (probe-file file)
+ (probe-file (format nil "target:lisp/~a" file))
+ file)))
+ (make-location (list :file (unix-truename pathname))
+ (list :line (parse-integer line))))))
+ (t
+ `(:error ,string))))))
+
+(defun read-word (&optional (stream *standard-input*))
+ (peek-char t stream)
+ (concatenate 'string (loop until (whitespacep (peek-char nil stream))
+ collect (read-char stream))))
+
+(defun whitespacep (char)
+ (member char '(#\space #\newline)))
+
+
+;;;; Inspecting
+
+(defconstant +lowtag-symbols+
+ '(vm:even-fixnum-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:list-pointer-type
+ vm:odd-fixnum-type
+ vm:instance-pointer-type
+ vm:other-immediate-1-type
+ vm:other-pointer-type)
+ "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+ (labels ((suffixp (suffix string)
+ (and (>= (length string) (length suffix))
+ (string= string suffix :start1 (- (length string)
+ (length suffix)))))
+ (header-type-symbol-p (x)
+ (and (suffixp "-TYPE" (symbol-name x))
+ (not (member x +lowtag-symbols+))
+ (boundp x)
+ (typep (symbol-value x) 'fixnum))))
+ (remove-if-not #'header-type-symbol-p
+ (append (apropos-list "-TYPE" "VM")
+ (apropos-list "-TYPE" "BIGNUM"))))
+ "A list of names of the type codes in boxed objects.")
+
+(defimplementation describe-primitive-type (object)
+ (with-output-to-string (*standard-output*)
+ (let* ((lowtag (kernel:get-lowtag object))
+ (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
+
+(defmethod emacs-inspect ((o t))
+ (cond ((di::indirect-value-cell-p o)
+ `("Value: " (:value ,(c:value-cell-ref o))))
+ ((alien::alien-value-p o)
+ (inspect-alien-value o))
+ (t
+ (cmucl-inspect o))))
+
+(defun cmucl-inspect (o)
+ (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
+ (list* (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (loop for value in parts for i from 0
+ append (label-value-line i value))))))
+
+(defmethod emacs-inspect ((o function))
+ (let ((header (kernel:get-type o)))
+ (cond ((= header vm:function-header-type)
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s)))))
+ ((= header vm:closure-header-type)
+ (list* (format nil "~A is a closure.~%" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (1- (kernel:get-closure-length o))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
+ ((eval::interpreted-function-p o)
+ (cmucl-inspect o))
+ (t
+ (call-next-method)))))
+
+(defmethod emacs-inspect ((o kernel:funcallable-instance))
+ (append (label-value-line*
+ (:function (kernel:%funcallable-instance-function o))
+ (:lexenv (kernel:%funcallable-instance-lexenv o))
+ (:layout (kernel:%funcallable-instance-layout o)))
+ (cmucl-inspect o)))
+
+(defmethod emacs-inspect ((o kernel:code-component))
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:"
+ (:newline)
+ , (with-output-to-string (*standard-output*)
+ (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o))
+ (disassem:disassemble-code-component o))
+ ((or
+ (c::debug-info-p (kernel:%code-debug-info o))
+ (consp (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ (c:disassem-byte-component o))
+ (t
+ (disassem:disassemble-memory
+ (disassem::align
+ (+ (logandc2 (kernel:get-lisp-obj-address o)
+ vm:lowtag-mask)
+ (* vm:code-constants-offset vm:word-bytes))
+ (ash 1 vm:lowtag-bits))
+ (ash (kernel:%code-code-size o) vm:word-shift))))))))
+
+(defmethod emacs-inspect ((o kernel:fdefn))
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
+
+#+(or)
+(defmethod emacs-inspect ((o array))
+ (if (typep o 'simple-array)
+ (call-next-method)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+
+(defmethod emacs-inspect ((o simple-vector))
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (loop for i below (length o)
+ append (label-value-line i (aref o i)))))
+
+(defun inspect-alien-record (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (declare (optimize (speed 0)))
+ (label-value-line slot (alien:slot alien slot))))))))
+
+(defun inspect-alien-pointer (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien)))))
+
+(defun inspect-alien-value (alien)
+ (typecase (alien::alien-value-type alien)
+ (alien::alien-record-type (inspect-alien-record alien))
+ (alien::alien-pointer-type (inspect-alien-pointer alien))
+ (t (cmucl-inspect alien))))
+
+(defimplementation eval-context (obj)
+ (cond ((typep (class-of obj) 'structure-class)
+ (let* ((dd (kernel:layout-info (kernel:layout-of obj)))
+ (slots (kernel:dd-slots dd)))
+ (list* (cons '*package*
+ (symbol-package (if slots
+ (kernel:dsd-name (car slots))
+ (kernel:dd-name dd))))
+ (loop for slot in slots collect
+ (cons (kernel:dsd-name slot)
+ (funcall (kernel:dsd-accessor slot) obj))))))))
+
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (eval `(profile:unprofile))
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+ (eval `(profile:reset-time))
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ :methods methods))
+
+
+;;;; Multiprocessing
+
+#+mp
+(progn
+ (defimplementation initialize-multiprocessing (continuation)
+ (mp::init-multi-processing)
+ (mp:make-process continuation :name "swank")
+ ;; Threads magic: this never returns! But top-level becomes
+ ;; available again.
+ (unless mp::*idle-process*
+ (mp::startup-idle-and-top-level-loops)))
+
+ (defimplementation spawn (fn &key name)
+ (mp:make-process fn :name (or name "Anonymous")))
+
+ (defvar *thread-id-counter* 0)
+
+ (defimplementation thread-id (thread)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*))))
+
+ (defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (mp:process-whostate thread))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:destroy-process thread))
+
+ (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ (mutex (mp:make-lock "process mailbox"))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock-held (*mailbox-lock*)
+ (or (getf (mp:process-property-list thread) 'mailbox)
+ (setf (getf (mp:process-property-list thread) 'mailbox)
+ (make-mailbox)))))
+
+ (defimplementation send (thread message)
+ (check-slime-interrupts)
+ (let* ((mbox (mailbox thread)))
+ (mp:with-lock-held ((mailbox.mutex mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let ((mbox (mailbox mp:*current-process*)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock-held ((mailbox.mutex mbox))
+ (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:process-wait-with-timeout
+ "receive-if" 0.5
+ (lambda () (some test (mailbox.queue mbox)))))))
+
+
+ ) ;; #+mp
+
+
+
+;;;; GC hooks
+;;;
+;;; Display GC messages in the echo area to avoid cluttering the
+;;; normal output.
+;;;
+
+;; this should probably not be here, but where else?
+(defun background-message (message)
+ (swank::background-message message))
+
+(defun print-bytes (nbytes &optional stream)
+ "Print the number NBYTES to STREAM in KB, MB, or GB units."
+ (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb))))
+ (multiple-value-bind (power name)
+ (loop for ((p1 n1) (p2 n2)) on names
+ while n2 do
+ (when (<= (expt 2 p1) nbytes (1- (expt 2 p2)))
+ (return (values p1 n1))))
+ (cond (name
+ (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name))
+ (t
+ (format stream "~:D bytes" nbytes))))))
+
+(defconstant gc-generations 6)
+
+#+gencgc
+(defun generation-stats ()
+ "Return a string describing the size distribution among the generations."
+ (let* ((alloc (loop for i below gc-generations
+ collect (lisp::gencgc-stats i)))
+ (sum (coerce (reduce #'+ alloc) 'float)))
+ (format nil "~{~3F~^/~}"
+ (mapcar (lambda (size) (/ size sum))
+ alloc))))
+
+(defvar *gc-start-time* 0)
+
+(defun pre-gc-hook (bytes-in-use)
+ (setq *gc-start-time* (get-internal-real-time))
+ (let ((msg (format nil "[Commencing GC with ~A in use.]"
+ (print-bytes bytes-in-use))))
+ (background-message msg)))
+
+(defun post-gc-hook (bytes-retained bytes-freed trigger)
+ (declare (ignore trigger))
+ (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*)
+ internal-time-units-per-second))
+ (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]"
+ (print-bytes bytes-freed)
+ (print-bytes bytes-retained)
+ #+gencgc(generation-stats)
+ #-gencgc""
+ seconds)))
+ (background-message msg)))
+
+(defun install-gc-hooks ()
+ (setq ext:*gc-notify-before* #'pre-gc-hook)
+ (setq ext:*gc-notify-after* #'post-gc-hook))
+
+(defun remove-gc-hooks ()
+ (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before)
+ (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after))
+
+(defvar *install-gc-hooks* t
+ "If non-nil install GC hooks")
+
+(defimplementation emacs-connected ()
+ (when *install-gc-hooks*
+ (install-gc-hooks)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;;In CMUCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;; <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec ,@options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ (cond ((fboundp `(method ,@(cdr spec)))
+ (toggle-trace-aux `(method ,(cdr spec))))
+ ;; Man, is this ugly
+ ((fboundp `(pcl::fast-method ,@(cdr spec)))
+ (toggle-trace-aux `(pcl::fast-method ,@(cdr spec))))
+ (t
+ (error 'undefined-function :name (cdr spec)))))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))
+ ;; doesn't work properly
+ ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec)))
+ ))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec))))
+ ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec))))))
+ (t
+ fspec)))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
+
+
+;;; Save image
+
+(defimplementation save-image (filename &optional restart-function)
+ (multiple-value-bind (pid error) (unix:unix-fork)
+ (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error)))
+ (cond ((= pid 0)
+ (apply #'ext:save-lisp
+ filename
+ (if restart-function
+ `(:init-function ,restart-function))))
+ (t
+ (let ((status (waitpid pid)))
+ (destructuring-bind (&key exited? status &allow-other-keys) status
+ (assert (and exited? (equal status 0)) ()
+ "Invalid exit status: ~a" status)))))))
+
+(defun waitpid (pid)
+ (alien:with-alien ((status c-call:int))
+ (let ((code (alien:alien-funcall
+ (alien:extern-alien
+ waitpid (alien:function c-call:int c-call:int
+ (* c-call:int) c-call:int))
+ pid (alien:addr status) 0)))
+ (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg)))
+ (t (assert (= code pid))
+ (decode-wait-status status))))))
+
+(defun decode-wait-status (status)
+ (let ((output (with-output-to-string (s)
+ (call-program (list (process-status-program)
+ (format nil "~d" status))
+ :output s))))
+ (read-from-string output)))
+
+(defun call-program (args &key output)
+ (destructuring-bind (program &rest args) args
+ (let ((process (ext:run-program program args :output output)))
+ (when (not program) (error "fork failed"))
+ (unless (and (eq (ext:process-status process) :exited)
+ (= (ext:process-exit-code process) 0))
+ (error "Non-zero exit status")))))
+
+(defvar *process-status-program* nil)
+
+(defun process-status-program ()
+ (or *process-status-program*
+ (setq *process-status-program*
+ (compile-process-status-program))))
+
+(defun compile-process-status-program ()
+ (let ((infile (system::pick-temporary-file-name
+ "/tmp/process-status~d~c.c")))
+ (with-open-file (stream infile :direction :output :if-exists :supersede)
+ (format stream "
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <assert.h>
+
+#define FLAG(value) (value ? \"t\" : \"nil\")
+
+int main (int argc, char** argv) {
+ assert (argc == 2);
+ {
+ char* endptr = NULL;
+ char* arg = argv[1];
+ long int status = strtol (arg, &endptr, 10);
+ assert (endptr != arg && *endptr == '\\0');
+ printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\"
+ \" :stopped? %s :stopsig %d)\\n\",
+ FLAG(WIFEXITED(status)), WEXITSTATUS(status),
+ FLAG(WIFSIGNALED(status)), WTERMSIG(status),
+ FLAG(WCOREDUMP(status)),
+ FLAG(WIFSTOPPED(status)), WSTOPSIG(status));
+ fflush (NULL);
+ return 0;
+ }
+}
+")
+ (finish-output stream))
+ (let* ((outfile (system::pick-temporary-file-name))
+ (args (list "cc" "-o" outfile infile)))
+ (warn "Running cc: ~{~a ~}~%" args)
+ (call-program args :output t)
+ (delete-file infile)
+ outfile)))
+
+;; FIXME: lisp:unicode-complete introduced in version 20d.
+#+#.(swank/backend:with-symbol 'unicode-complete 'lisp)
+(defun match-semi-standard (prefix matchp)
+ ;; Handle the CMUCL's short character names.
+ (loop for name in lisp::char-name-alist
+ when (funcall matchp prefix (car name))
+ collect (car name)))
+
+#+#.(swank/backend:with-symbol 'unicode-complete 'lisp)
+(defimplementation character-completion-set (prefix matchp)
+ (let ((names (lisp::unicode-complete prefix)))
+ ;; Match prefix against semistandard names. If there's a match,
+ ;; add it to our list of matches.
+ (let ((semi-standard (match-semi-standard prefix matchp)))
+ (when semi-standard
+ (setf names (append semi-standard names))))
+ (setf names (mapcar #'string-capitalize names))
+ (loop for n in names
+ when (funcall matchp prefix n)
+ collect n)))
diff --git a/vim/bundle/slimv/slime/swank/corman.lisp b/vim/bundle/slimv/slime/swank/corman.lisp
new file mode 100644
index 0000000..80d9ddd
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/corman.lisp
@@ -0,0 +1,583 @@
+;;;
+;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
+;;;
+;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
+;;;
+;;; License
+;;; =======
+;;; This software is provided 'as-is', without any express or implied
+;;; warranty. In no event will the author be held liable for any damages
+;;; arising from the use of this software.
+;;;
+;;; Permission is granted to anyone to use this software for any purpose,
+;;; including commercial applications, and to alter it and redistribute
+;;; it freely, subject to the following restrictions:
+;;;
+;;; 1. The origin of this software must not be misrepresented; you must
+;;; not claim that you wrote the original software. If you use this
+;;; software in a product, an acknowledgment in the product documentation
+;;; would be appreciated but is not required.
+;;;
+;;; 2. Altered source versions must be plainly marked as such, and must
+;;; not be misrepresented as being the original software.
+;;;
+;;; 3. This notice may not be removed or altered from any source
+;;; distribution.
+;;;
+;;; Notes
+;;; =====
+;;; You will need CCL 2.51, and you will *definitely* need to patch
+;;; CCL with the patches at
+;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
+;;; will blow up in your face. You should also follow the
+;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
+;;;
+;;; The only communication style currently supported is NIL.
+;;;
+;;; Starting CCL inside emacs (with M-x slime) seems to work for me
+;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
+;;; (sometimes it works, other times it hangs on start or hangs when
+;;; initializing WinSock) - starting CCL externally and using M-x
+;;; slime-connect always works fine.
+;;;
+;;; Sometimes CCL gets confused and starts giving you random memory
+;;; access violation errors on startup; if this happens, try redumping
+;;; your image.
+;;;
+;;; What works
+;;; ==========
+;;; * Basic editing and evaluation
+;;; * Arglist display
+;;; * Compilation
+;;; * Loading files
+;;; * apropos/describe
+;;; * Debugger
+;;; * Inspector
+;;;
+;;; TODO
+;;; ====
+;;; * More debugger functionality (missing bits: restart-frame,
+;;; return-from-frame, disassemble-frame, activate-stepping,
+;;; toggle-trace)
+;;; * XREF
+;;; * Profiling
+;;; * More sophisticated communication styles than NIL
+;;;
+
+(in-package :swank/backend)
+
+;;; Pull in various needed bits
+(require :composite-streams)
+(require :sockets)
+(require :winbase)
+(require :lp)
+
+(use-package :gs)
+
+;; MOP stuff
+
+(defclass swank-mop:standard-slot-definition ()
+ ()
+ (:documentation
+ "Dummy class created so that swank.lisp will compile and load."))
+
+(defun named-by-gensym-p (c)
+ (null (symbol-package (class-name c))))
+
+(deftype swank-mop:eql-specializer ()
+ '(satisfies named-by-gensym-p))
+
+(defun swank-mop:eql-specializer-object (specializer)
+ (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
+ (loop (multiple-value-bind (more key value)
+ (next-entry)
+ (unless more (return nil))
+ (when (eq specializer value)
+ (return key))))))
+
+(defun swank-mop:class-finalized-p (class)
+ (declare (ignore class))
+ t)
+
+(defun swank-mop:class-prototype (class)
+ (make-instance class))
+
+(defun swank-mop:specializer-direct-methods (obj)
+ (declare (ignore obj))
+ nil)
+
+(defun swank-mop:generic-function-argument-precedence-order (gf)
+ (generic-function-lambda-list gf))
+
+(defun swank-mop:generic-function-method-combination (gf)
+ (declare (ignore gf))
+ :standard)
+
+(defun swank-mop:generic-function-declarations (gf)
+ (declare (ignore gf))
+ nil)
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (declare (ignore slot))
+ (getf slot :documentation nil))
+
+(defun swank-mop:slot-definition-type (slot)
+ (declare (ignore slot))
+ t)
+
+(import-swank-mop-symbols :cl '(;; classes
+ :standard-slot-definition
+ :eql-specializer
+ :eql-specializer-object
+ ;; standard class readers
+ :class-default-initargs
+ :class-direct-default-initargs
+ :class-finalized-p
+ :class-prototype
+ :specializer-direct-methods
+ ;; gf readers
+ :generic-function-argument-precedence-order
+ :generic-function-declarations
+ :generic-function-method-combination
+ ;; method readers
+ ;; slot readers
+ :slot-definition-documentation
+ :slot-definition-type))
+
+;;;; swank implementations
+
+;;; Debugger
+
+(defvar *stack-trace* nil)
+(defvar *frame-trace* nil)
+
+(defstruct frame
+ name function address debug-info variables)
+
+(defimplementation call-with-debugging-environment (fn)
+ (let* ((real-stack-trace (cl::stack-trace))
+ (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
+ :key #'car)))
+ (*frame-trace*
+ (let* ((db::*debug-level* (1+ db::*debug-level*))
+ (db::*debug-frame-pointer* (db::stash-ebp
+ (ct:create-foreign-ptr)))
+ (db::*debug-max-level* (length real-stack-trace))
+ (db::*debug-min-level* 1))
+ (cdr (member #'cl:invoke-debugger
+ (cons
+ (make-frame :function nil)
+ (loop for i from db::*debug-min-level*
+ upto db::*debug-max-level*
+ until (eq (db::get-frame-function i)
+ cl::*top-level*)
+ collect
+ (make-frame
+ :function (db::get-frame-function i)
+ :address (db::get-frame-address i))))
+ :key #'frame-function)))))
+ (funcall fn)))
+
+(defimplementation compute-backtrace (start end)
+ (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
+ collect f))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~S" frame))
+
+(defun get-frame-debug-info (frame)
+ (or (frame-debug-info frame)
+ (setf (frame-debug-info frame)
+ (db::prepare-frame-debug-info (frame-function frame)
+ (frame-address frame)))))
+
+(defimplementation frame-locals (frame-number)
+ (let* ((frame (elt *frame-trace* frame-number))
+ (info (get-frame-debug-info frame)))
+ (let ((var-list
+ (loop for i from 4 below (length info) by 2
+ collect `(list :name ',(svref info i) :id 0
+ :value (db::debug-filter ,(svref info i))))))
+ (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
+ (setf (frame-variables frame) vars)))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (elt *frame-trace* frame-number)))
+ (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
+ (eval form))))
+
+(defimplementation frame-var-value (frame-number var)
+ (let ((vars (frame-variables (elt *frame-trace* frame-number))))
+ (when vars
+ (second (elt vars var)))))
+
+(defimplementation frame-source-location (frame-number)
+ (fspec-location (frame-function (elt *frame-trace* frame-number))))
+
+(defun break (&optional (format-control "Break") &rest format-arguments)
+ (with-simple-restart (continue "Return from BREAK.")
+ (let ();(*debugger-hook* nil))
+ (let ((condition
+ (make-condition 'simple-condition
+ :format-control format-control
+ :format-arguments format-arguments)))
+ ;;(format *debug-io* ";;; User break: ~A~%" condition)
+ (invoke-debugger condition))))
+ nil)
+
+;;; Socket communication
+
+(defimplementation create-socket (host port &key backlog)
+ (sockets:start-sockets)
+ (sockets:make-server-socket :host host :port port))
+
+(defimplementation local-port (socket)
+ (sockets:socket-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (sockets:make-socket-stream (sockets:accept-socket socket)))
+
+;;; Misc
+
+(defimplementation preferred-communication-style ()
+ nil)
+
+(defimplementation getpid ()
+ ccl:*current-process-id*)
+
+(defimplementation lisp-implementation-type-name ()
+ "cormanlisp")
+
+(defimplementation quit-lisp ()
+ (sockets:stop-sockets)
+ (win32:exitprocess 0))
+
+(defimplementation set-default-directory (directory)
+ (setf (ccl:current-directory) directory)
+ (directory-namestring (setf *default-pathname-defaults*
+ (truename (merge-pathnames directory)))))
+
+(defimplementation default-directory ()
+ (directory-namestring (ccl:current-directory)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (ccl:macroexpand-all form))
+
+;;; Documentation
+
+(defun fspec-location (fspec)
+ (when (symbolp fspec)
+ (setq fspec (symbol-function fspec)))
+ (let ((file (ccl::function-source-file fspec)))
+ (if file
+ (handler-case
+ (let ((truename (truename
+ (merge-pathnames file
+ ccl:*cormanlisp-directory*))))
+ (make-location (list :file (namestring truename))
+ (if (ccl::function-source-line fspec)
+ (list :line
+ (1+ (ccl::function-source-line fspec)))
+ (list :function-name
+ (princ-to-string
+ (function-name fspec))))))
+ (error (c) (list :error (princ-to-string c))))
+ (list :error (format nil "No source information available for ~S"
+ fspec)))))
+
+(defimplementation find-definitions (name)
+ (list (list name (fspec-location name))))
+
+(defimplementation arglist (name)
+ (handler-case
+ (cond ((and (symbolp name)
+ (macro-function name))
+ (ccl::macro-lambda-list (symbol-function name)))
+ (t
+ (when (symbolp name)
+ (setq name (symbol-function name)))
+ (if (eq (class-of name) cl::the-class-standard-gf)
+ (generic-function-lambda-list name)
+ (ccl:function-lambda-list name))))
+ (error () :not-available)))
+
+(defimplementation function-name (fn)
+ (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
+ (error () nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+;;; Compiler
+
+(defvar *buffer-name* nil)
+(defvar *buffer-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+;; FIXME
+(defimplementation call-with-compilation-hooks (FN)
+ (handler-bind ((error (lambda (c)
+ (signal 'compiler-condition
+ :original-condition c
+ :severity :warning
+ :message (format nil "~A" c)
+ :location
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :offset *buffer-position* 0)))
+ (*compile-filename*
+ (make-location
+ (list :file *compile-filename*)
+ (list :position 1)))
+ (t
+ (list :error "No location")))))))
+ (funcall fn)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore external-format policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (multiple-value-bind (output-file warnings? failure?)
+ (compile-file input-file :output-file output-file)
+ (values output-file warnings?
+ (or failure? (and load-p (load output-file))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-position* position)
+ (*buffer-string* string))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))
+ t)))
+
+;;;; Inspecting
+
+;; Hack to make swank.lisp load, at least
+(defclass file-stream ())
+
+(defun comma-separated (list &optional (callback (lambda (v)
+ `(:value ,v))))
+ (butlast (loop for e in list
+ collect (funcall callback e)
+ collect ", ")))
+
+(defmethod emacs-inspect ((class standard-class))
+ `("Name: "
+ (:value ,(class-name class))
+ (:newline)
+ "Super classes: "
+ ,@(comma-separated (swank-mop:class-direct-superclasses class))
+ (:newline)
+ "Direct Slots: "
+ ,@(comma-separated
+ (swank-mop:class-direct-slots class)
+ (lambda (slot)
+ `(:value ,slot
+ ,(princ-to-string
+ (swank-mop:slot-definition-name slot)))))
+ (:newline)
+ "Effective Slots: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated
+ (swank-mop:class-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(princ-to-string
+ (swank-mop:slot-definition-name slot)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(when (documentation class t)
+ `("Documentation:" (:newline) ,(documentation class t) (:newline)))
+ "Sub classes: "
+ ,@(comma-separated (swank-mop:class-direct-subclasses class)
+ (lambda (sub)
+ `(:value ,sub ,(princ-to-string (class-name sub)))))
+ (:newline)
+ "Precedence List: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated
+ (swank-mop:class-precedence-list class)
+ (lambda (class)
+ `(:value ,class
+ ,(princ-to-string (class-name class)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)))
+
+(defmethod emacs-inspect ((slot cons))
+ ;; Inspects slot definitions
+ (if (eq (car slot) :name)
+ `("Name: " (:value ,(swank-mop:slot-definition-name slot))
+ (:newline)
+ ,@(when (swank-mop:slot-definition-documentation slot)
+ `("Documentation:"
+ (:newline)
+ (:value
+ ,(swank-mop:slot-definition-documentation slot))
+ (:newline)))
+ "Init args: " (:value
+ ,(swank-mop:slot-definition-initargs slot))
+ (:newline)
+ "Init form: "
+ ,(if (swank-mop:slot-definition-initfunction slot)
+ `(:value ,(swank-mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ "Init function: "
+ (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline))
+ (call-next-method)))
+
+(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
+ (list* (if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ '(:newline)
+ (append (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname))))))
+
+(defmethod emacs-inspect ((o t))
+ (cond ((cl::structurep o) (inspect-structure o))
+ (t (call-next-method))))
+
+(defun inspect-structure (o)
+ (let* ((template (cl::uref o 1))
+ (num-slots (cl::struct-template-num-slots template)))
+ (cond ((symbolp template)
+ (loop for i below num-slots
+ append (label-value-line i (cl::uref o (+ 2 i)))))
+ (t
+ (loop for i below num-slots
+ append (label-value-line (elt template (+ 6 (* i 5)))
+ (cl::uref o (+ 2 i))))))))
+
+
+;;; Threads
+
+(require 'threads)
+
+(defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (lock (make-instance 'threads:critical-section))
+ (queue '() :type list))
+
+(defvar *mailbox-lock* (make-instance 'threads:critical-section))
+(defvar *mailboxes* (list))
+
+(defmacro with-lock (lock &body body)
+ `(threads:with-synchronization (threads:cs ,lock)
+ ,@body))
+
+(defimplementation spawn (fun &key name)
+ (declare (ignore name))
+ (th:create-thread
+ (lambda ()
+ (handler-bind ((serious-condition #'invoke-debugger))
+ (unwind-protect (funcall fun)
+ (with-lock *mailbox-lock*
+ (setq *mailboxes* (remove cormanlisp:*current-thread-id*
+ *mailboxes* :key #'mailbox.thread))))))))
+
+(defimplementation thread-id (thread)
+ thread)
+
+(defimplementation find-thread (thread)
+ (if (thread-alive-p thread)
+ thread))
+
+(defimplementation thread-alive-p (thread)
+ (if (threads:thread-handle thread) t nil))
+
+(defimplementation current-thread ()
+ cormanlisp:*current-thread-id*)
+
+;; XXX implement it
+(defimplementation all-threads ()
+ '())
+
+;; XXX something here is broken
+(defimplementation kill-thread (thread)
+ (threads:terminate-thread thread 'killed))
+
+(defun mailbox (thread)
+ (with-lock *mailbox-lock*
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (with-lock (mailbox.lock mbox)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+(defimplementation receive ()
+ (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
+ (loop
+ (with-lock (mailbox.lock mbox)
+ (when (mailbox.queue mbox)
+ (return (pop (mailbox.queue mbox)))))
+ (sleep 0.1))))
+
+
+;;; This is probably not good, but it WFM
+(in-package :common-lisp)
+
+(defvar *old-documentation* #'documentation)
+(defun documentation (thing &optional (type 'function))
+ (if (symbolp thing)
+ (funcall *old-documentation* thing type)
+ (values)))
+
+(defmethod print-object ((restart restart) stream)
+ (if (or *print-escape*
+ *print-readably*)
+ (print-unreadable-object (restart stream :type t :identity t)
+ (princ (restart-name restart) stream))
+ (when (functionp (restart-report-function restart))
+ (funcall (restart-report-function restart) stream))))
diff --git a/vim/bundle/slimv/slime/swank/ecl.lisp b/vim/bundle/slimv/slime/swank/ecl.lisp
new file mode 100644
index 0000000..2d19c64
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/ecl.lisp
@@ -0,0 +1,845 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-ecl.lisp --- SLIME backend for ECL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/ecl
+ (:use cl swank/backend))
+
+(in-package swank/ecl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun ecl-version ()
+ (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
+ (if version
+ (symbol-value version)
+ 0)))
+ (when (< (ecl-version) 100301)
+ (error "~&IMPORTANT:~% ~
+ The version of ECL you're using (~A) is too old.~% ~
+ Please upgrade to at least 10.3.1.~% ~
+ Sorry for the inconvenience.~%~%"
+ (lisp-implementation-version))))
+
+;; Hard dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sockets))
+
+;; Soft dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (probe-file "sys:profile.fas")
+ (require :profile)
+ (pushnew :profile *features*))
+ (when (probe-file "sys:serve-event.fas")
+ (require :serve-event)
+ (pushnew :serve-event *features*)))
+
+(declaim (optimize (debug 3)))
+
+;;; Swank-mop
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import-swank-mop-symbols
+ :clos
+ (and (< (ecl-version) 121201)
+ `(:eql-specializer
+ :eql-specializer-object
+ :generic-function-declarations
+ :specializer-direct-methods
+ ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
+ '(:compute-applicable-methods-using-classes))))))
+
+(defimplementation gray-package-name ()
+ "GRAY")
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ ;; While ECL does provide threads, some parts of it are not
+ ;; thread-safe (2010-02-23), including the compiler and CLOS.
+ nil
+ ;; ECL on Windows does not provide condition-variables
+ ;; (or #+(and threads (not windows)) :spawn
+ ;; nil)
+ )
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket (or backlog 5))
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t
+ :input t
+ :buffering (ecase buffering
+ ((t) :full)
+ ((nil) :none)
+ (:line :line))
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format))
+(defun accept (socket)
+ "Like socket-accept, but retry on EAGAIN."
+ (loop (handler-case
+ (return (sb-bsd-sockets:socket-accept socket))
+ (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
+ (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+ (file-stream (si:file-stream-fd socket))))
+
+(defvar *external-format-to-coding-system*
+ '((:latin-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (ext:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, ECL uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+;;;; Unix Integration
+
+;;; If ECL is built with thread support, it'll spawn a helper thread
+;;; executing the SIGINT handler. We do not want to BREAK into that
+;;; helper but into the main thread, though. This is coupled with the
+;;; current choice of NIL as communication-style in so far as ECL's
+;;; main-thread is also the Slime's REPL thread.
+
+(defimplementation call-with-user-break-handler (real-handler function)
+ (let ((old-handler #'si:terminal-interrupt))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (make-interrupt-handler real-handler))
+ (unwind-protect (funcall function)
+ (setf (symbol-function 'si:terminal-interrupt) old-handler))))
+
+#+threads
+(defun make-interrupt-handler (real-handler)
+ (let ((main-thread (find 'si:top-level (mp:all-processes)
+ :key #'mp:process-name)))
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (mp:interrupt-process main-thread real-handler))))
+
+#-threads
+(defun make-interrupt-handler (real-handler)
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (funcall real-handler)))
+
+
+(defimplementation getpid ()
+ (si:getpid))
+
+(defimplementation set-default-directory (directory)
+ (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:getcwd)))
+
+(defimplementation quit-lisp ()
+ (ext:quit))
+
+
+
+;;; Instead of busy waiting with communication-style NIL, use select()
+;;; on the sockets' streams.
+#+serve-event
+(progn
+ (defun poll-streams (streams timeout)
+ (let* ((serve-event::*descriptor-handlers*
+ (copy-list serve-event::*descriptor-handlers*))
+ (active-fds '())
+ (fd-stream-alist
+ (loop for s in streams
+ for fd = (socket-fd s)
+ collect (cons fd s)
+ do (serve-event:add-fd-handler fd :input
+ #'(lambda (fd)
+ (push fd active-fds))))))
+ (serve-event:serve-event timeout)
+ (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
+
+ (defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (poll-streams streams 0)))
+ (t
+ (when-let (ready (poll-streams streams 0.2))
+ (return ready))))))
+
+) ; #+serve-event (progn ...
+
+#-serve-event
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (remove-if-not #'listen streams)))
+ (t
+ (let ((ready (remove-if-not #'listen streams)))
+ (if ready (return ready))
+ (sleep 0.1))))))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+
+(defun signal-compiler-condition (&rest args)
+ (apply #'signal 'compiler-condition args))
+
+#-ecl-bytecmp
+(defun handle-compiler-message (condition)
+ ;; ECL emits lots of noise in compiler-notes, like "Invoking
+ ;; external command".
+ (unless (typep condition 'c::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (c:compiler-fatal-error :error)
+ (c:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+#-ecl-bytecmp
+(defun condition-location (condition)
+ (let ((file (c:compiler-message-file condition))
+ (position (c:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+
+(defimplementation call-with-compilation-hooks (function)
+ #+ecl-bytecmp
+ (funcall function)
+ #-ecl-bytecmp
+ (handler-bind ((c:compiler-message #'handle-compiler-message))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (compile-file input-file :output-file output-file
+ :load load-p
+ :external-format external-format)))
+
+(defvar *tmpfile-map* (make-hash-table :test #'equal))
+
+(defun note-buffer-tmpfile (tmp-file buffer-name)
+ ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
+ (let ((tmp-namestring (namestring (truename tmp-file))))
+ (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
+ tmp-namestring))
+
+(defun tmpfile-to-buffer (tmp-file)
+ (gethash tmp-file *tmpfile-map*))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer) ; for compilation hooks
+ (*buffer-start-position* position))
+ (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
+ (fasl-file)
+ (warnings-p)
+ (failure-p))
+ (unwind-protect
+ (with-open-file (tmp-stream tmp-file :direction :output
+ :if-exists :supersede)
+ (write-string string tmp-stream)
+ (finish-output tmp-stream)
+ (multiple-value-setq (fasl-file warnings-p failure-p)
+ (compile-file tmp-file
+ :load t
+ :source-truename (or filename
+ (note-buffer-tmpfile tmp-file buffer))
+ :source-offset (1- position))))
+ (when (probe-file tmp-file)
+ (delete-file tmp-file))
+ (when fasl-file
+ (delete-file fasl-file)))
+ (not failure-p)))))
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+ (multiple-value-bind (arglist foundp)
+ (ext:function-lambda-list name)
+ (if foundp arglist :not-available)))
+
+(defimplementation function-name (f)
+ (typecase f
+ (generic-function (clos:generic-function-name f))
+ (function (si:compiled-function-name f))))
+
+;; FIXME
+;; (defimplementation macroexpand-all (form &optional env)
+;; (declare (ignore env))
+
+(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)
+ (let ((result '()))
+ (flet ((frob (type boundp)
+ (when (funcall boundp symbol)
+ (let ((doc (describe-definition symbol type)))
+ (setf result (list* type doc result))))))
+ (frob :VARIABLE #'boundp)
+ (frob :FUNCTION #'fboundp)
+ (frob :CLASS (lambda (x) (find-class x nil))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+(defimplementation type-specifier-p (symbol)
+ (or (subtypep nil symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+ si::*frs-base*
+ si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+ si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+ si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defun make-invoke-debugger-hook (hook)
+ (when hook
+ #'(lambda (condition old-hook)
+ ;; Regard *debugger-hook* if set by user.
+ (if *debugger-hook*
+ nil ; decline, *DEBUGGER-HOOK* will be tried next.
+ (funcall hook condition old-hook)))))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall fun)))
+
+(defvar *backtrace* '())
+
+;;; Commented out; it's not clear this is a good way of doing it. In
+;;; particular because it makes errors stemming from this file harder
+;;; to debug, and given the "young" age of ECL's swank backend, that's
+;;; a bad idea.
+
+;; (defun in-swank-package-p (x)
+;; (and
+;; (symbolp x)
+;; (member (symbol-package x)
+;; (list #.(find-package :swank)
+;; #.(find-package :swank/backend)
+;; #.(ignore-errors (find-package :swank-mop))
+;; #.(ignore-errors (find-package :swank-loader))))
+;; t))
+
+;; (defun is-swank-source-p (name)
+;; (setf name (pathname name))
+;; (pathname-match-p
+;; name
+;; (make-pathname :defaults swank-loader::*source-directory*
+;; :name (pathname-name name)
+;; :type (pathname-type name)
+;; :version (pathname-version name))))
+
+;; (defun is-ignorable-fun-p (x)
+;; (or
+;; (in-swank-package-p (frame-name x))
+;; (multiple-value-bind (file position)
+;; (ignore-errors (si::bc-file (car x)))
+;; (declare (ignore position))
+;; (if file (is-swank-source-p file)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* ((*ihs-top* (ihs-top))
+ (*ihs-current* *ihs-top*)
+ (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
+ (*frs-top* (frs-top))
+ (*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ nil))))
+ (declare (special *ihs-current*))
+ (loop for f from *frs-base* until *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (si::fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (nreverse *backtrace*))
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation compute-backtrace (start end)
+ (subseq *backtrace* start
+ (and (numberp end)
+ (min end (length *backtrace*)))))
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun function-position (fun)
+ (multiple-value-bind (file position)
+ (si::bc-file fun)
+ (when file
+ (make-file-location file position))))
+
+(defun frame-function (frame)
+ (let* ((x (first frame))
+ fun position)
+ (etypecase x
+ (symbol (and (fboundp x)
+ (setf fun (fdefinition x)
+ position (function-position fun))))
+ (function (setf fun x position (function-position x))))
+ (values fun position)))
+
+(defun frame-decode-env (frame)
+ (let ((functions '())
+ (blocks '())
+ (variables '()))
+ (setf frame (si::decode-ihs-env (second frame)))
+ (dolist (record (remove-if-not #'consp frame))
+ (let* ((record0 (car record))
+ (record1 (cdr record)))
+ (cond ((or (symbolp record0) (stringp record0))
+ (setq variables (acons record0 record1 variables)))
+ ((not (si::fixnump record0))
+ (push record1 functions))
+ ((symbolp record1)
+ (push record1 blocks))
+ (t
+ ))))
+ (values functions blocks variables)))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~A" (first frame)))
+
+(defimplementation frame-source-location (frame-number)
+ (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+ (loop for (name . value) in (nth-value 2 (frame-decode-env
+ (elt *backtrace* frame-number)))
+ collect (list :name name :id 0 :value value)))
+
+(defimplementation frame-var-value (frame-number var-number)
+ (destructuring-bind (name . value)
+ (elt
+ (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ var-number)
+ (declare (ignore name))
+ value))
+
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-function (elt *backtrace* frame-number))))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (si:eval-with-env form env)))
+
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+
+
+;;;; Inspector
+
+;;; FIXME: Would be nice if it was possible to inspect objects
+;;; implemented in C.
+
+
+;;;; Definitions
+
+(defvar +TAGS+ (namestring
+ (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
+
+(defun make-file-location (file file-position)
+ ;; File positions in CL start at 0, but Emacs' buffer positions
+ ;; start at 1. We specify (:ALIGN T) because the positions comming
+ ;; from ECL point at right after the toplevel form appearing before
+ ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
+ (make-location `(:file ,(namestring (translate-logical-pathname file)))
+ `(:position ,(1+ file-position))
+ `(:align t)))
+
+(defun make-buffer-location (buffer-name start-position &optional (offset 0))
+ (make-location `(:buffer ,buffer-name)
+ `(:offset ,start-position ,offset)
+ `(:align t)))
+
+(defun make-TAGS-location (&rest tags)
+ (make-location `(:etags-file ,+TAGS+)
+ `(:tag ,@tags)))
+
+(defimplementation find-definitions (name)
+ (let ((annotations (ext:get-annotation name 'si::location :all)))
+ (cond (annotations
+ (loop for annotation in annotations
+ collect (destructuring-bind (dspec file . pos) annotation
+ `(,dspec ,(make-file-location file pos)))))
+ (t
+ (mapcan #'(lambda (type) (find-definitions-by-type name type))
+ (classify-definition-name name))))))
+
+(defun classify-definition-name (name)
+ (let ((types '()))
+ (when (fboundp name)
+ (cond ((special-operator-p name)
+ (push :special-operator types))
+ ((macro-function name)
+ (push :macro types))
+ ((typep (fdefinition name) 'generic-function)
+ (push :generic-function types))
+ ((si:mangle-name name t)
+ (push :c-function types))
+ (t
+ (push :lisp-function types))))
+ (when (boundp name)
+ (cond ((constantp name)
+ (push :constant types))
+ (t
+ (push :global-variable types))))
+ types))
+
+(defun find-definitions-by-type (name type)
+ (ecase type
+ (:lisp-function
+ (when-let (loc (source-location (fdefinition name)))
+ (list `((defun ,name) ,loc))))
+ (:c-function
+ (when-let (loc (source-location (fdefinition name)))
+ (list `((c-source ,name) ,loc))))
+ (:generic-function
+ (loop for method in (clos:generic-function-methods (fdefinition name))
+ for specs = (clos:method-specializers method)
+ for loc = (source-location method)
+ when loc
+ collect `((defmethod ,name ,specs) ,loc)))
+ (:macro
+ (when-let (loc (source-location (macro-function name)))
+ (list `((defmacro ,name) ,loc))))
+ (:constant
+ (when-let (loc (source-location name))
+ (list `((defconstant ,name) ,loc))))
+ (:global-variable
+ (when-let (loc (source-location name))
+ (list `((defvar ,name) ,loc))))
+ (:special-operator)))
+
+;;; FIXME: There ought to be a better way.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun c-function-name-p (name)
+ (and (symbolp name) (si:mangle-name name t) t))
+ (defun c-function-p (object)
+ (and (functionp object)
+ (let ((fn-name (function-name object)))
+ (and fn-name (c-function-name-p fn-name))))))
+
+(deftype c-function ()
+ `(satisfies c-function-p))
+
+(defun assert-source-directory ()
+ (unless (probe-file #P"SRC:")
+ (error "ECL's source directory ~A does not exist. ~
+ You can specify a different location via the environment ~
+ variable `ECLSRCDIR'."
+ (namestring (translate-logical-pathname #P"SYS:")))))
+
+(defun assert-TAGS-file ()
+ (unless (probe-file +TAGS+)
+ (error "No TAGS file ~A found. It should have been installed with ECL."
+ +TAGS+)))
+
+(defun package-names (package)
+ (cons (package-name package) (package-nicknames package)))
+
+(defun source-location (object)
+ (converting-errors-to-error-location
+ (typecase object
+ (c-function
+ (assert-source-directory)
+ (assert-TAGS-file)
+ (let ((lisp-name (function-name object)))
+ (assert lisp-name)
+ (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
+ (assert flag)
+ ;; In ECL's code base sometimes the mangled name is used
+ ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
+ ;; @EXT::SYMBOL is used. We cannot predict here, so we just
+ ;; provide several candidates.
+ (apply #'make-TAGS-location
+ c-name
+ (loop with s = (symbol-name lisp-name)
+ for p in (package-names (symbol-package lisp-name))
+ collect (format nil "~A::~A" p s)
+ collect (format nil "~(~A::~A~)" p s))))))
+ (function
+ (multiple-value-bind (file pos) (ext:compiled-function-file object)
+ (cond ((not file)
+ (return-from source-location nil))
+ ((tmpfile-to-buffer file)
+ (make-buffer-location (tmpfile-to-buffer file) pos))
+ (t
+ (assert (probe-file file))
+ (assert (not (minusp pos)))
+ (make-file-location file pos)))))
+ (method
+ ;; FIXME: This will always return NIL at the moment; ECL does not
+ ;; store debug information for methods yet.
+ (source-location (clos:method-function object)))
+ ((member nil t)
+ (multiple-value-bind (flag c-name) (si:mangle-name object)
+ (assert flag)
+ (make-TAGS-location c-name))))))
+
+(defimplementation find-source-location (object)
+ (or (source-location object)
+ (make-error-location "Source definition of ~S not found." object)))
+
+
+;;;; Profiling
+
+#+profile
+(progn
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+) ; #+profile (progn ...
+
+
+;;;; Threads
+
+#+threads
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ (defvar *thread-id-map-lock*
+ (mp:make-lock :name "thread id map lock"))
+
+ (defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+ (defimplementation thread-id (target-thread)
+ (block thread-id
+ (mp:with-lock (*thread-id-map-lock*)
+ ;; Does TARGET-THREAD have an id already?
+ (maphash (lambda (id thread-pointer)
+ (let ((thread (si:weak-pointer-value thread-pointer)))
+ (cond ((not thread)
+ (remhash id *thread-id-map*))
+ ((eq thread target-thread)
+ (return-from thread-id id)))))
+ *thread-id-map*)
+ ;; TARGET-THREAD not found in *THREAD-ID-MAP*
+ (let ((id (incf *thread-id-counter*))
+ (thread-pointer (si:make-weak-pointer target-thread)))
+ (setf (gethash id *thread-id-map*) thread-pointer)
+ id))))
+
+ (defimplementation find-thread (id)
+ (mp:with-lock (*thread-id-map-lock*)
+ (let* ((thread-ptr (gethash id *thread-id-map*))
+ (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
+ (unless thread
+ (remhash id *thread-id-map*))
+ thread)))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (if (mp:process-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (mp:make-lock :name name :recursive t))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mp:with-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (mp:all-processes))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:interrupt-process thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+ (defimplementation thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+ (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
+ (defvar *mailboxes* (list))
+ (declaim (type list *mailboxes*))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (mutex (mp:make-lock))
+ (cvar (mp:make-condition-variable))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:with-lock (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock (mutex)
+ (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:condition-variable-timedwait (mailbox.cvar mbox)
+ mutex
+ 0.2)))))
+
+ ) ; #+threads (progn ...
diff --git a/vim/bundle/slimv/slime/swank/gray.lisp b/vim/bundle/slimv/slime/swank/gray.lisp
new file mode 100644
index 0000000..b910a78
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/gray.lisp
@@ -0,0 +1,170 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; swank-gray.lisp --- Gray stream based IO redirection.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package swank/backend)
+
+#.(progn
+ (defvar *gray-stream-symbols*
+ '(fundamental-character-output-stream
+ stream-write-char
+ stream-write-string
+ stream-fresh-line
+ stream-force-output
+ stream-finish-output
+
+ fundamental-character-input-stream
+ stream-read-char
+ stream-peek-char
+ stream-read-line
+ stream-listen
+ stream-unread-char
+ stream-clear-input
+ stream-line-column
+ stream-read-char-no-hang))
+ nil)
+
+(defpackage swank/gray
+ (:use cl swank/backend)
+ (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
+ (:export . #.*gray-stream-symbols*))
+
+(in-package swank/gray)
+
+(defclass slime-output-stream (fundamental-character-output-stream)
+ ((output-fn :initarg :output-fn)
+ (buffer :initform (make-string 8000))
+ (fill-pointer :initform 0)
+ (column :initform 0)
+ (lock :initform (make-lock :name "buffer write lock"))))
+
+(defmacro with-slime-output-stream (stream &body body)
+ `(with-slots (lock output-fn buffer fill-pointer column) ,stream
+ (call-with-lock-held lock (lambda () ,@body))))
+
+(defmethod stream-write-char ((stream slime-output-stream) char)
+ (with-slime-output-stream stream
+ (setf (schar buffer fill-pointer) char)
+ (incf fill-pointer)
+ (incf column)
+ (when (char= #\newline char)
+ (setf column 0))
+ (when (= fill-pointer (length buffer))
+ (finish-output stream)))
+ char)
+
+(defmethod stream-write-string ((stream slime-output-stream) string
+ &optional start end)
+ (with-slime-output-stream stream
+ (let* ((start (or start 0))
+ (end (or end (length string)))
+ (len (length buffer))
+ (count (- end start))
+ (free (- len fill-pointer)))
+ (when (>= count free)
+ (stream-finish-output stream))
+ (cond ((< count len)
+ (replace buffer string :start1 fill-pointer
+ :start2 start :end2 end)
+ (incf fill-pointer count))
+ (t
+ (funcall output-fn (subseq string start end))))
+ (let ((last-newline (position #\newline string :from-end t
+ :start start :end end)))
+ (setf column (if last-newline
+ (- end last-newline 1)
+ (+ column count))))))
+ string)
+
+(defmethod stream-line-column ((stream slime-output-stream))
+ (with-slime-output-stream stream column))
+
+(defmethod stream-finish-output ((stream slime-output-stream))
+ (with-slime-output-stream stream
+ (unless (zerop fill-pointer)
+ (funcall output-fn (subseq buffer 0 fill-pointer))
+ (setf fill-pointer 0)))
+ nil)
+
+(defmethod stream-force-output ((stream slime-output-stream))
+ (stream-finish-output stream))
+
+(defmethod stream-fresh-line ((stream slime-output-stream))
+ (with-slime-output-stream stream
+ (cond ((zerop column) nil)
+ (t (terpri stream) t))))
+
+(defclass slime-input-stream (fundamental-character-input-stream)
+ ((input-fn :initarg :input-fn)
+ (buffer :initform "") (index :initform 0)
+ (lock :initform (make-lock :name "buffer read lock"))))
+
+(defmethod stream-read-char ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index input-fn) s
+ (when (= index (length buffer))
+ (let ((string (funcall input-fn)))
+ (cond ((zerop (length string))
+ (return-from stream-read-char :eof))
+ (t
+ (setf buffer string)
+ (setf index 0)))))
+ (assert (plusp (length buffer)))
+ (prog1 (aref buffer index) (incf index))))))
+
+(defmethod stream-listen ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (< index (length buffer))))))
+
+(defmethod stream-unread-char ((s slime-input-stream) char)
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (decf index)
+ (cond ((eql (aref buffer index) char)
+ (setf (aref buffer index) char))
+ (t
+ (warn "stream-unread-char: ignoring ~S (expected ~S)"
+ char (aref buffer index)))))))
+ nil)
+
+(defmethod stream-clear-input ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (setf buffer ""
+ index 0))))
+ nil)
+
+(defmethod stream-line-column ((s slime-input-stream))
+ nil)
+
+(defmethod stream-read-char-no-hang ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (when (< index (length buffer))
+ (prog1 (aref buffer index) (incf index)))))))
+
+
+;;;
+
+(defimplementation make-output-stream (write-string)
+ (make-instance 'slime-output-stream :output-fn write-string))
+
+(defimplementation make-input-stream (read-string)
+ (make-instance 'slime-input-stream :input-fn read-string))
diff --git a/vim/bundle/slimv/slime/swank/lispworks.lisp b/vim/bundle/slimv/slime/swank/lispworks.lisp
new file mode 100644
index 0000000..d4b656e
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/lispworks.lisp
@@ -0,0 +1,1018 @@
+;;; -*- 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.
+;;;
+
+(defpackage swank/lispworks
+ (:use cl swank/backend))
+
+(in-package swank/lispworks)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+(defimplementation gray-package-name ()
+ "STREAM")
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation
+ :slot-boundp-using-class
+ :slot-value-using-class
+ :slot-makunbound-using-class
+ :eql-specializer
+ :eql-specializer-object
+ :compute-applicable-methods-using-classes))
+
+(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))
+ value))
+
+(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))
+ `(progn
+ (dspec:record-definition '(defun ,name) (dspec:location)
+ :check-redefinition-p nil)
+ ,(funcall *original-defimplementation* whole env))))
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
+
+(defimplementation utf8-to-string (octets)
+ (ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
+
+;;; TCP server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defun socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (comm:socket-stream (comm:socket-stream-socket socket))))
+
+(defimplementation create-socket (host port &key backlog)
+ (multiple-value-bind (socket where errno)
+ #-(or lispworks4.1 (and macosx lispworks4.3))
+ (comm::create-tcp-socket-for-service port :address host
+ :backlog (or backlog 5))
+ #+(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))
+ 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))
+ (cond ((not external-format)
+ (make-instance 'comm:socket-stream
+ :socket fd
+ :direction :io
+ :read-timeout timeout
+ :element-type '(unsigned-byte 8)))
+ (t
+ (assert (valid-external-format-p external-format))
+ (ecase (first external-format)
+ ((:latin-1 :ascii)
+ (make-instance 'comm:socket-stream
+ :socket fd
+ :direction :io
+ :read-timeout timeout
+ :element-type 'base-char))
+ (:utf-8
+ (make-flexi-stream
+ (make-instance 'comm:socket-stream
+ :socket fd
+ :direction :io
+ :read-timeout timeout
+ :element-type '(unsigned-byte 8))
+ external-format)))))))
+
+(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."
+ external-format))
+ (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
+ stream
+ :external-format
+ (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
+ 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) "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))
+ *external-format-to-coding-system*)))
+
+;;; 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.
+ #-win32
+ (sys::set-signal-handler +sigint+
+ (make-sigint-handler mp:*current-process*)))
+
+#-win32
+(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 getpid ()
+ #+win32 (win32:get-current-process-id)
+ #-win32 (system::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "lispworks")
+
+(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)
+ (map-list
+ (lambda (x)
+ (typecase x
+ (list
+ (replace-strings-with-symbols x))
+ (symbol
+ x)
+ (string
+ (intern x))
+ (t
+ (intern (write-to-string x)))))
+ tree))
+
+(defimplementation arglist (symbol-or-function)
+ (let ((arglist (lw:function-lambda-list symbol-or-function)))
+ (etypecase arglist
+ ((member :dont-know)
+ :not-available)
+ (list
+ (replace-strings-with-symbols arglist)))))
+
+(defimplementation function-name (function)
+ (nth-value 2 (function-lambda-expression function)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (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)
+ :not-documented)))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :generic-function (if (and (fboundp symbol)
+ (generic-function-p (fdefinition symbol)))
+ (doc 'function)))
+ (maybe-push
+ :function (if (and (fboundp symbol)
+ (not (generic-function-p (fdefinition symbol))))
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
+ (if (fboundp setf-name)
+ (doc 'setf))))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(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~]~%"
+ symbol
+ (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)))
+
+(defimplementation type-specifier-p (symbol)
+ (or (ignore-errors
+ (subtypep nil symbol))
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+;;; 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))
+ (swank:swank-debugger-hook condition *debugger-hook*))
+
+(defmethod env-internals:environment-display-debugger ((env slime-env))
+ *debug-io*)
+
+(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
+ (apply #'swank: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))
+ t)
+ ((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*)
+ (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)))
+ frame)))
+
+(defun nth-frame (index)
+ (nth-next-frame *sldb-top-frame* index))
+
+(defun find-top-frame ()
+ "Return the most suitable top-frame for the debugger."
+ (flet ((find-named-frame (name)
+ (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)
+ name)))
+ (nth-next-frame frame 1)))))
+ (or (find-named-frame 'invoke-debugger)
+ (find-named-frame 'swank::safe-backtrace)
+ ;; if we can't find a likely top 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)
+ (kind nil))
+ (loop for arg in (dbg::call-frame-arglist frame)
+ if (eq kind '&rest)
+ nconc (handler-case
+ (dbg::dbg-eval arg frame)
+ (error (e) (list (format nil "<~A>" arg))))
+ and do (loop-finish)
+ else
+ if (member arg '(&rest &optional &key))
+ do (setq kind arg)
+ else
+ nconc
+ (handler-case
+ (nconc (and (eq kind '&key)
+ (list (cond ((symbolp arg)
+ (intern (symbol-name arg) :keyword))
+ ((and (consp arg) (symbolp (car arg)))
+ (intern (symbol-name (car arg))
+ :keyword))
+ (t (caar arg)))))
+ (list (dbg::dbg-eval
+ (cond ((symbolp arg) arg)
+ ((and (consp arg) (symbolp (car arg)))
+ (car arg))
+ (t (cadar arg)))
+ frame)))
+ (error (e) (list (format nil "<~A>" arg)))))))
+
+(defimplementation print-frame (frame stream)
+ (cond ((dbg::call-frame-p frame)
+ (prin1 (cons (dbg::call-frame-function-name frame)
+ (frame-actual-args frame))
+ stream))
+ (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))
+ value)))
+
+(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)))
+ (path (and (dbg::call-frame-p frame)
+ (dbg::call-frame-edit-path frame))))
+ (if dspec
+ (frame-location dspec cname path))))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (dbg::dbg-eval form frame)))
+
+(defun function-name-package (name)
+ (typecase name
+ (null nil)
+ (symbol (symbol-package name))
+ ((cons (eql hcl:subfunction))
+ (destructuring-bind (name parent) (cdr name)
+ (declare (ignore name))
+ (function-name-package parent)))
+ ((cons (eql lw:top-level-form)) nil)
+ (t nil)))
+
+(defimplementation frame-package (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (if (dbg::call-frame-p frame)
+ (function-name-package (dbg::call-frame-function-name 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
+ dbg::*debugger-stack*)))
+
+(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 edit-path)
+ (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)))
+ (path (edit-path-to-cmucl-source-path edit-path)))
+ (make-dspec-location rdspec location
+ `(:call-site ,name :edit-path ,path)))))
+ (t
+ (list :error (format nil "Source location not available for: ~S"
+ dspec))))))
+
+;; dbg::call-frame-edit-path is not documented but lets assume the
+;; binary representation of the integer EDIT-PATH should be
+;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the
+;; same as cadadddr. Something is odd with the highest bit.
+(defun edit-path-to-cmucl-source-path (edit-path)
+ (and edit-path
+ (cons 0
+ (let ((n -1))
+ (loop for i from (1- (integer-length edit-path)) downto 0
+ if (logbitp i edit-path) do (incf n)
+ else collect (prog1 n (setq n 0)))))))
+
+;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
+
+(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*
+ ,location)
+ (signal-undefined-functions compiler::*unknown-functions*
+ ,location))))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (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*)
+ pathname)))))
+ compiler::*unknown-functions*))))
+
+(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)
+ (multiple-value-bind (condition path)
+ (if (consp c) (values (car c) (cdr c)) (values c nil))
+ (funcall fn filename dspec condition path))))))
+
+(defun lispworks-severity (condition)
+ (cond ((not condition) :warning)
+ (t (etypecase condition
+ #-(or lispworks4 lispworks5)
+ (conditions:compiler-note :note)
+ (error :error)
+ (style-warning :warning)
+ (warning :warning)))))
+
+(defun signal-compiler-condition (message location condition)
+ (check-type message string)
+ (signal
+ (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)
+ (unwind-protect
+ (progn
+ (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)
+ "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
+ (let ((package (gensym))
+ (readtable (gensym)))
+ `(let ((,package *package*)
+ (,readtable *readtable*))
+ (with-standard-io-syntax
+ (let ((*package* ,package)
+ (*readtable* ,readtable))
+ ,@body)))))
+
+(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)
+ (with-fairly-standard-io-syntax
+ (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
+ ((progn)
+ (mapcar #'check-dspec
+ (cdr form)))
+ ((eval-when locally macrolet symbol-macrolet)
+ (mapcar #'check-dspec
+ (cddr form)))
+ ((in-package)
+ (let ((package (find-package (second form))))
+ (when package
+ (setq *package* package))))
+ (otherwise
+ (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)
+ (ignore-errors (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)
+ hints))))
+ (symbol
+ `(:error ,(format nil "Cannot resolve location: ~S" location)))
+ ((satisfies emacs-buffer-location-p)
+ (destructuring-bind (_ buffer offset) location
+ (declare (ignore _))
+ (make-location `(:buffer ,buffer)
+ (dspec-function-name-position dspec `(:offset ,offset 0))
+ hints)))))
+
+(defun make-dspec-progenitor-location (dspec location edit-path)
+ (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
+ (make-dspec-location
+ (if canon-dspec
+ (if (dspec:local-dspec-p canon-dspec)
+ (dspec:dspec-progenitor canon-dspec)
+ canon-dspec)
+ nil)
+ location
+ (if edit-path
+ (list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
+
+(defun signal-error-data-base (database &optional location)
+ (map-error-database
+ database
+ (lambda (filename dspec condition edit-path)
+ (signal-compiler-condition
+ (format nil "~A" condition)
+ (make-dspec-progenitor-location dspec (or location filename) edit-path)
+ condition))))
+
+(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)
+ (signal-compiler-condition
+ (format nil "Undefined function ~A" (unmangle-unfun unfun))
+ (make-dspec-progenitor-location
+ dspec
+ (or filename
+ (gethash (list unfun dspec) *undefined-functions-hash*))
+ nil)
+ nil)))
+ htab))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (assert buffer)
+ (assert position)
+ (let* ((location (list :emacs-buffer buffer position))
+ (tmpname (hcl:make-temp-file nil "lisp")))
+ (with-swank-compilation-unit (location)
+ (compile-from-temp-file
+ (with-output-to-string (s)
+ (let ((*print-radix* t))
+ (print `(eval-when (:compile-toplevel)
+ (setq dspec::*location* (list ,@location)))
+ s))
+ (write-string string s))
+ tmpname))))
+
+;;; 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)))
+ (hcl:sweep-all-objects
+ #'(lambda (object)
+ (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
+ #+Harlequin-Unix-Lisp (sys:callablep object)
+ #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
+ (sys:compiled-code-p 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)))))
+
+(defun list-callees-internal (name)
+ (let ((callees '()))
+ (system::find-constant$funcallable
+ 'junk name
+ :test #'(lambda (junk constant)
+ (declare (ignore junk))
+ (when (and (symbolp constant)
+ (fboundp constant))
+ (pushnew (list 'function constant) callees :test 'equal))
+ ;; Return nil so we iterate over all constants.
+ nil))
+ callees))
+
+;; only for lispworks 4.2 and above
+#-lispworks4.1
+(progn
+ (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))
+ (append
+ (label-value-line "Type" type)
+ (loop for name in names
+ for value in values
+ append (label-value-line name value)))))
+
+;;; Miscellaneous
+
+(defimplementation quit-lisp ()
+ (lispworks:quit))
+
+;;; 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))
+ (t
+ (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)
+ mp:*initial-processes*)
+ (mp:initialize-multiprocessing))
+ (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 ()
+ mp:*current-process*)
+
+(defimplementation all-threads ()
+ (mp:list-all-processes))
+
+(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)
+ (make-mailbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox mp:*current-process*))
+ (lock (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (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)))
+ (mp:process-wait-with-timeout
+ "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))))))
+
+(let ((alist '())
+ (lock (mp:make-lock :name "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (mp:with-lock (lock)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (mp:process
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (mp:with-lock (lock)
+ (cdr (assoc name alist)))))
+
+
+(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)))
+
+
+;;;; 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))
diff --git a/vim/bundle/slimv/slime/swank/match.lisp b/vim/bundle/slimv/slime/swank/match.lisp
new file mode 100644
index 0000000..d6200db
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/match.lisp
@@ -0,0 +1,242 @@
+;;
+;; SELECT-MATCH macro (and IN macro)
+;;
+;; Copyright 1990 Stephen Adams
+;;
+;; You are free to copy, distribute and make derivative works of this
+;; source provided that this copyright notice is displayed near the
+;; beginning of the file. No liability is accepted for the
+;; correctness or performance of the code. If you modify the code
+;; please indicate this fact both at the place of modification and in
+;; this copyright message.
+;;
+;; Stephen Adams
+;; Department of Electronics and Computer Science
+;; University of Southampton
+;; SO9 5NH, UK
+;;
+;; sra@ecs.soton.ac.uk
+;;
+
+;;
+;; Synopsis:
+;;
+;; (select-match expression
+;; (pattern action+)*)
+;;
+;; --- or ---
+;;
+;; (select-match expression
+;; pattern => expression
+;; pattern => expression
+;; ...)
+;;
+;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
+;; | symbol ;matches anything
+;; | 'anything ;must be EQUAL
+;; | (pattern = pattern) ;both patterns must match
+;; | (#'function pattern) ;predicate test
+;; | (pattern . pattern) ;cons cell
+;;
+
+;; Example
+;;
+;; (select-match item
+;; (('if e1 e2 e3) 'if-then-else) ;(1)
+;; ((#'oddp k) 'an-odd-integer) ;(2)
+;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
+;; (other 'anything-else)) ;(4)
+;;
+;; Notes
+;;
+;; . Each pattern is tested in turn. The first match is taken.
+;;
+;; . If no pattern matches, an error is signalled.
+;;
+;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
+;; numbers, strings, characters, etc.) match things which are EQUAL.
+;;
+;; . Quoted patterns (which are CONSTANTP) are constants.
+;;
+;; . Symbols match anything. The symbol is bound to the matched item
+;; for the execution of the actions.
+;; For example, (SELECT-MATCH '(1 2 3)
+;; (1 . X) => X)
+;; returns (2 3) because X is bound to the cdr of the candidate.
+;;
+;; . The two pattern match (p1 = p2) can be used to name parts
+;; of the matched structure. For example, (ALL = (HD . TL))
+;; matches a cons cell. ALL is bound to the cons cell, HD to its car
+;; and TL to its tail.
+;;
+;; . A predicate test applies the predicate to the item being matched.
+;; If the predicate returns NIL then the match fails.
+;; If it returns truth, then the nested pattern is matched. This is
+;; often just a symbol like K in the example.
+;;
+;; . Care should be taken with the domain values for predicate matches.
+;; If, in the above eg, item is not an integer, an error would occur
+;; during the test. A safer pattern would be
+;; (#'integerp (#'oddp k))
+;; This would only test for oddness of the item was an integer.
+;;
+;; . A single symbol will match anything so it can be used as a default
+;; case, like OTHER above.
+;;
+
+(in-package swank/match)
+
+(defmacro match (expression &body patterns)
+ `(select-match ,expression ,@patterns))
+
+(defmacro select-match (expression &rest patterns)
+ (let* ((do-let (not (atom expression)))
+ (key (if do-let (gensym) expression))
+ (cbody (expand-select-patterns key patterns))
+ (cform `(cond . ,cbody)))
+ (if do-let
+ `(let ((,key ,expression)) ,cform)
+ cform)))
+
+(defun expand-select-patterns (key patterns)
+ (if (eq (second patterns) '=>)
+ (expand-select-patterns-style-2 key patterns)
+ (expand-select-patterns-style-1 key patterns)))
+
+(defun expand-select-patterns-style-1 (key patterns)
+ (if (null patterns)
+ `((t (error "Case select pattern match failure on ~S" ,key)))
+ (let* ((pattern (caar patterns))
+ (actions (cdar patterns))
+ (rest (cdr patterns))
+ (test (compile-select-test key pattern))
+ (bindings (compile-select-bindings key pattern actions)))
+ `(,(if bindings `(,test (let ,bindings . ,actions))
+ `(,test . ,actions))
+ . ,(unless (eq test t)
+ (expand-select-patterns-style-1 key rest))))))
+
+(defun expand-select-patterns-style-2 (key patterns)
+ (cond ((null patterns)
+ `((t (error "Case select pattern match failure on ~S" ,key))))
+ (t (when (or (< (length patterns) 3)
+ (not (eq (second patterns) '=>)))
+ (error "Illegal patterns: ~S" patterns))
+ (let* ((pattern (first patterns))
+ (actions (list (third patterns)))
+ (rest (cdddr patterns))
+ (test (compile-select-test key pattern))
+ (bindings (compile-select-bindings key pattern actions)))
+ `(,(if bindings `(,test (let ,bindings . ,actions))
+ `(,test . ,actions))
+ . ,(unless (eq test t)
+ (expand-select-patterns-style-2 key rest)))))))
+
+(defun compile-select-test (key pattern)
+ (let ((tests (remove t (compile-select-tests key pattern))))
+ (cond
+ ;; note AND does this anyway, but this allows us to tell if
+ ;; the pattern will always match.
+ ((null tests) t)
+ ((= (length tests) 1) (car tests))
+ (t `(and . ,tests)))))
+
+(defun compile-select-tests (key pattern)
+ (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
+ ((symbolp pattern) 'eq)
+ (t 'equal))
+ ,key ,pattern)))
+ ((symbolp pattern) '(t))
+ ((select-double-match? pattern)
+ (append
+ (compile-select-tests key (first pattern))
+ (compile-select-tests key (third pattern))))
+ ((select-predicate? pattern)
+ (append
+ `((,(second (first pattern)) ,key))
+ (compile-select-tests key (second pattern))))
+ ((consp pattern)
+ (append
+ `((consp ,key))
+ (compile-select-tests (cs-car key) (car
+ pattern))
+ (compile-select-tests (cs-cdr key) (cdr
+ pattern))))
+ (t (error "Illegal select pattern: ~S" pattern))))
+
+
+(defun compile-select-bindings (key pattern action)
+ (cond ((constantp pattern) '())
+ ((symbolp pattern)
+ (if (select-in-tree pattern action)
+ `((,pattern ,key))
+ '()))
+ ((select-double-match? pattern)
+ (append
+ (compile-select-bindings key (first pattern) action)
+ (compile-select-bindings key (third pattern) action)))
+ ((select-predicate? pattern)
+ (compile-select-bindings key (second pattern) action))
+ ((consp pattern)
+ (append
+ (compile-select-bindings (cs-car key) (car pattern)
+ action)
+ (compile-select-bindings (cs-cdr key) (cdr pattern)
+ action)))))
+
+(defun select-in-tree (atom tree)
+ (or (eq atom tree)
+ (if (consp tree)
+ (or (select-in-tree atom (car tree))
+ (select-in-tree atom (cdr tree))))))
+
+(defun select-double-match? (pattern)
+ ;; (<pattern> = <pattern>)
+ (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
+ (null (cdddr pattern))
+ (eq (second pattern) '=)))
+
+(defun select-predicate? (pattern)
+ ;; ((function <f>) <pattern>)
+ (and (consp pattern)
+ (consp (cdr pattern))
+ (null (cddr pattern))
+ (consp (first pattern))
+ (consp (cdr (first pattern)))
+ (null (cddr (first pattern)))
+ (eq (caar pattern) 'function)))
+
+(defun cs-car (exp)
+ (cs-car/cdr 'car exp
+ '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
+ (cdar . cadar) (cddr . caddr)
+ (caaar . caaaar) (caadr . caaadr) (cadar . caadar)
+ (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
+ (cddar . caddar) (cdddr . cadddr))))
+
+(defun cs-cdr (exp)
+ (cs-car/cdr 'cdr exp
+ '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
+ (cdar . cddar) (cddr . cdddr)
+ (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
+ (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
+ (cddar . cdddar) (cdddr . cddddr))))
+
+(defun cs-car/cdr (op exp table)
+ (if (and (consp exp) (= (length exp) 2))
+ (let ((replacement (assoc (car exp) table)))
+ (if replacement
+ `(,(cdr replacement) ,(second exp))
+ `(,op ,exp)))
+ `(,op ,exp)))
+
+;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
+;; (setf c2 '(select-match (car y)
+;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
+;; else))))
+;; (setf c3 '(select-match (caddr y)
+;; ((all = (x y)) (list x y all))
+;; ((a '= b) (list 'assign a b))
+;; ((#'oddp k) (1+ k)))))
+
+
diff --git a/vim/bundle/slimv/slime/swank/mkcl.lisp b/vim/bundle/slimv/slime/swank/mkcl.lisp
new file mode 100644
index 0000000..53696fb
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/mkcl.lisp
@@ -0,0 +1,933 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-mkcl.lisp --- SLIME backend for MKCL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/mkcl
+ (:use cl swank/backend))
+
+(in-package swank/mkcl)
+
+;;(declaim (optimize (debug 3)))
+
+(defvar *tmp*)
+
+(defimplementation gray-package-name ()
+ '#:gray)
+
+(eval-when (:compile-toplevel :load-toplevel)
+
+ (swank/backend::import-swank-mop-symbols :clos
+ ;; '(:eql-specializer
+ ;; :eql-specializer-object
+ ;; :generic-function-declarations
+ ;; :specializer-direct-methods
+ ;; :compute-applicable-methods-using-classes)
+ nil
+ ))
+
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (mkcl:octets (si:utf-8 string)))
+
+(defimplementation utf8-to-string (octets)
+ (string (si:utf-8 octets)))
+
+
+;;;; TCP Server
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the sb-bsd-sockets package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'sockets))
+
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket (or backlog 5))
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-bsd-sockets:socket-close socket))
+
+(defun accept (socket)
+ "Like socket-accept, but retry on EINTR."
+ (loop (handler-case
+ (return (sb-bsd-sockets:socket-accept socket))
+ (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t ;; bogus
+ :input t ;; bogus
+ :buffering buffering ;; bogus
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format
+ ))
+
+(defimplementation preferred-communication-style ()
+ :spawn
+ )
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (si:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, MKCL uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+
+;;;; Unix signals
+
+(defimplementation install-sigint-handler (handler)
+ (let ((old-handler (symbol-function 'si:terminal-interrupt)))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (if (consp handler)
+ (car handler)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (funcall handler)
+ (continue))))
+ (list old-handler)))
+
+
+(defimplementation getpid ()
+ (mkcl:getpid))
+
+(defimplementation set-default-directory (directory)
+ (mk-ext::chdir (namestring directory))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (mk-ext:getcwd)))
+
+(defmacro progf (plist &rest forms)
+ `(let (_vars _vals)
+ (do ((p ,plist (cddr p)))
+ ((endp p))
+ (push (car p) _vars)
+ (push (cadr p) _vals))
+ (progv _vars _vals ,@forms)
+ )
+ )
+
+(defvar *inferior-lisp-sleeping-post* nil)
+
+(defimplementation quit-lisp ()
+ (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams.
+ (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*))
+ ;;(mk-ext:quit :verbose t)
+ ))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defun signal-compiler-condition (&rest args)
+ (signal (apply #'make-condition 'compiler-condition args)))
+
+#|
+(defun handle-compiler-warning (condition)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (format nil "~A" condition)
+ :severity :warning
+ :location
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0))
+ ;; ;; compiler::*current-form*
+ ;; (if compiler::*current-function*
+ ;; (make-location (list :file *compile-filename*)
+ ;; (list :function-name
+ ;; (symbol-name
+ ;; (slot-value compiler::*current-function*
+ ;; 'compiler::name))))
+ (list :error "No location found.")
+ ;; )
+ )))
+|#
+
+#|
+(defun condition-location (condition)
+ (let ((file (compiler:compiler-message-file condition))
+ (position (compiler:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+|#
+
+(defun condition-location (condition)
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0))
+ ;; ;; compiler::*current-form* ;
+ ;; (if compiler::*current-function* ;
+ ;; (make-location (list :file *compile-filename*) ;
+ ;; (list :function-name ;
+ ;; (symbol-name ;
+ ;; (slot-value compiler::*current-function* ;
+ ;; 'compiler::name)))) ;
+ (if (typep condition 'compiler::compiler-message)
+ (make-location (list :file (namestring (compiler:compiler-message-file condition)))
+ (list :end-position (compiler:compiler-message-file-end-position condition)))
+ (list :error "No location found."))
+ )
+ )
+
+(defun handle-compiler-message (condition)
+ (unless (typep condition 'compiler::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (compiler:compiler-fatal-error :error)
+ (compiler:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((compiler:compiler-message #'handle-compiler-message))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (handler-bind (#|
+ (compiler::compiler-note
+ #'(lambda (n)
+ (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil))
+ (compiler::compiler-warning
+ #'(lambda (w)
+ (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil))
+ (compiler::compiler-error
+ #'(lambda (e)
+ (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil))
+ |#
+ )
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (compile-file input-file :output-file output-file :external-format external-format)
+ (values output-truename warnings-p
+ (or failure-p
+ (and load-p (not (load output-truename))))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (with-input-from-string (s string)
+ (when position (file-position position))
+ (compile-from-stream s)))))
+
+(defun compile-from-stream (stream)
+ (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX"))
+ output-truename
+ warnings-p
+ failure-p
+ )
+ (with-open-file (s file :direction :output :if-exists :overwrite)
+ (do ((line (read-line stream nil) (read-line stream nil)))
+ ((not line))
+ (write-line line s)))
+ (unwind-protect
+ (progn
+ (multiple-value-setq (output-truename warnings-p failure-p)
+ (compile-file file))
+ (and (not failure-p) (load output-truename)))
+ (when (probe-file file) (delete-file file))
+ (when (probe-file output-truename) (delete-file output-truename)))))
+
+
+;;;; Documentation
+
+(defun grovel-docstring-for-arglist (name type)
+ (flet ((compute-arglist-offset (docstring)
+ (when docstring
+ (let ((pos1 (search "Args: " docstring)))
+ (if pos1
+ (+ pos1 6)
+ (let ((pos2 (search "Syntax: " docstring)))
+ (when pos2
+ (+ pos2 8))))))))
+ (let* ((docstring (si::get-documentation name type))
+ (pos (compute-arglist-offset docstring)))
+ (if pos
+ (multiple-value-bind (arglist errorp)
+ (ignore-errors
+ (values (read-from-string docstring t nil :start pos)))
+ (if (or errorp (not (listp arglist)))
+ :not-available
+ arglist
+ ))
+ :not-available ))))
+
+(defimplementation arglist (name)
+ (cond ((and (symbolp name) (special-operator-p name))
+ (let ((arglist (grovel-docstring-for-arglist name 'function)))
+ (if (consp arglist) (cdr arglist) arglist)))
+ ((and (symbolp name) (macro-function name))
+ (let ((arglist (grovel-docstring-for-arglist name 'function)))
+ (if (consp arglist) (cdr arglist) arglist)))
+ ((or (functionp name) (fboundp name))
+ (multiple-value-bind (name fndef)
+ (if (functionp name)
+ (values (function-name name) name)
+ (values name (fdefinition name)))
+ (let ((fle (function-lambda-expression fndef)))
+ (case (car fle)
+ (si:lambda-block (caddr fle))
+ (t (typecase fndef
+ (generic-function (clos::generic-function-lambda-list fndef))
+ (compiled-function (grovel-docstring-for-arglist name 'function))
+ (function :not-available)))))))
+ (t :not-available)))
+
+(defimplementation function-name (f)
+ (si:compiled-function-name f)
+ )
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the walker package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'walker))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (walker:macroexpand-all form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (dolist (type '(:VARIABLE :FUNCTION :CLASS))
+ (let ((doc (describe-definition symbol type)))
+ (when doc
+ (setf result (list* type doc result)))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+ si::*frs-base*
+ si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+ si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+ si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defvar *backtrace* '())
+
+(defun in-swank-package-p (x)
+ (and
+ (symbolp x)
+ (member (symbol-package x)
+ (list #.(find-package :swank)
+ #.(find-package :swank/backend)
+ #.(ignore-errors (find-package :swank-mop))
+ #.(ignore-errors (find-package :swank-loader))))
+ t))
+
+(defun is-swank-source-p (name)
+ (setf name (pathname name))
+ #+(or)
+ (pathname-match-p
+ name
+ (make-pathname :defaults swank-loader::*source-directory*
+ :name (pathname-name name)
+ :type (pathname-type name)
+ :version (pathname-version name)))
+ nil)
+
+(defun is-ignorable-fun-p (x)
+ (or
+ (in-swank-package-p (frame-name x))
+ (multiple-value-bind (file position)
+ (ignore-errors (si::compiled-function-file (car x)))
+ (declare (ignore position))
+ (if file (is-swank-source-p file)))))
+
+(defmacro find-ihs-top (x)
+ (declare (ignore x))
+ '(si::ihs-top))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* (;;(*tpl-commands* si::tpl-commands)
+ (*ihs-base* 0)
+ (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
+ (*ihs-current* *ihs-top*)
+ (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top))))
+ (*frs-top* (frs-top))
+ (*read-suppress* nil)
+ ;;(*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ nil))))
+ (declare (special *ihs-current*))
+ (loop for f from *frs-base* to *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (mkcl:fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
+ (setf *tmp* *backtrace*)
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
+ (funcall fun)))
+
+(defimplementation compute-backtrace (start end)
+ (when (numberp end)
+ (setf end (min end (length *backtrace*))))
+ (loop for f in (subseq *backtrace* start end)
+ collect f))
+
+(defimplementation format-sldb-condition (condition)
+ "Format a condition for display in SLDB."
+ ;;(princ-to-string condition)
+ (format nil "~A~%In thread: ~S" condition mt:*thread*)
+ )
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun function-position (fun)
+ (multiple-value-bind (file position)
+ (si::compiled-function-file fun)
+ (and file (make-location
+ `(:file ,(if (stringp file) file (namestring file)))
+ ;;`(:position ,position)
+ `(:end-position , position)))))
+
+(defun frame-function (frame)
+ (let* ((x (first frame))
+ fun position)
+ (etypecase x
+ (symbol (and (fboundp x)
+ (setf fun (fdefinition x)
+ position (function-position fun))))
+ (function (setf fun x position (function-position x))))
+ (values fun position)))
+
+(defun frame-decode-env (frame)
+ (let ((functions '())
+ (blocks '())
+ (variables '()))
+ (setf frame (si::decode-ihs-env (second frame)))
+ (dolist (record frame)
+ (let* ((record0 (car record))
+ (record1 (cdr record)))
+ (cond ((or (symbolp record0) (stringp record0))
+ (setq variables (acons record0 record1 variables)))
+ ((not (mkcl:fixnump record0))
+ (push record1 functions))
+ ((symbolp record1)
+ (push record1 blocks))
+ (t
+ ))))
+ (values functions blocks variables)))
+
+(defimplementation print-frame (frame stream)
+ (let ((function (first frame)))
+ (let ((fname
+;;; (cond ((symbolp function) function)
+;;; ((si:instancep function) (slot-value function 'name))
+;;; ((compiled-function-p function)
+;;; (or (si::compiled-function-name function) 'lambda))
+;;; (t :zombi))
+ (si::get-fname function)
+ ))
+ (if (eq fname 'si::bytecode)
+ (format stream "~A [Evaluation of: ~S]"
+ fname (function-lambda-expression function))
+ (format stream "~A" fname)
+ )
+ (when (si::closurep function)
+ (format stream
+ ", closure generated from ~A"
+ (si::get-fname (si:closure-producer function)))
+ )
+ )
+ )
+ )
+
+(defimplementation frame-source-location (frame-number)
+ (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+ (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ with i = 0
+ collect (list :name name :id (prog1 i (incf i)) :value value)))
+
+(defimplementation frame-var-value (frame-number var-id)
+ (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id)))
+
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-fun (elt *backtrace* frame-number))))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (si:eval-in-env form env)))
+
+#|
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+|#
+
+;;;; Inspector
+
+(defmethod emacs-inspect ((o t))
+ ; ecl clos support leaves some to be desired
+ (cond
+ ((streamp o)
+ (list*
+ (format nil "~S is an ordinary stream~%" o)
+ (append
+ (list
+ "Open for "
+ (cond
+ ((ignore-errors (interactive-stream-p o)) "Interactive")
+ ((and (input-stream-p o) (output-stream-p o)) "Input and output")
+ ((input-stream-p o) "Input")
+ ((output-stream-p o) "Output"))
+ `(:newline) `(:newline))
+ (label-value-line*
+ ("Element type" (stream-element-type o))
+ ("External format" (stream-external-format o)))
+ (ignore-errors (label-value-line*
+ ("Broadcast streams" (broadcast-stream-streams o))))
+ (ignore-errors (label-value-line*
+ ("Concatenated streams" (concatenated-stream-streams o))))
+ (ignore-errors (label-value-line*
+ ("Echo input stream" (echo-stream-input-stream o))))
+ (ignore-errors (label-value-line*
+ ("Echo output stream" (echo-stream-output-stream o))))
+ (ignore-errors (label-value-line*
+ ("Output String" (get-output-stream-string o))))
+ (ignore-errors (label-value-line*
+ ("Synonym symbol" (synonym-stream-symbol o))))
+ (ignore-errors (label-value-line*
+ ("Input stream" (two-way-stream-input-stream o))))
+ (ignore-errors (label-value-line*
+ ("Output stream" (two-way-stream-output-stream o)))))))
+ ((si:instancep o) ;;t
+ (let* ((cl (si:instance-class o))
+ (slots (clos::class-slots cl)))
+ (list* (format nil "~S is an instance of class ~A~%"
+ o (clos::class-name cl))
+ (loop for x in slots append
+ (let* ((name (clos::slot-definition-name x))
+ (value (if (slot-boundp o name)
+ (clos::slot-value o name)
+ "Unbound"
+ )))
+ (list
+ (format nil "~S: " name)
+ `(:value ,value)
+ `(:newline)))))))
+ (t (list (format nil "~A" o)))))
+
+;;;; Definitions
+
+(defimplementation find-definitions (name)
+ (if (fboundp name)
+ (let ((tmp (find-source-location (symbol-function name))))
+ `(((defun ,name) ,tmp)))))
+
+(defimplementation find-source-location (obj)
+ (setf *tmp* obj)
+ (or
+ (typecase obj
+ (function
+ (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj))
+ (if (and file pos)
+ (make-location
+ `(:file ,(if (stringp file) file (namestring file)))
+ `(:end-position ,pos) ;; `(:position ,pos)
+ `(:snippet
+ ,(with-open-file (s file)
+ (file-position s pos)
+ (skip-comments-and-whitespace s)
+ (read-snippet s))))))))
+ `(:error (format nil "Source definition of ~S not found" obj))))
+
+;;;; Profiling
+
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the profile package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'profile))
+
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+
+
+;;;; Threads
+
+(defvar *thread-id-counter* 0)
+
+(defvar *thread-id-counter-lock*
+ (mt:make-lock :name "thread id counter lock"))
+
+(defun next-thread-id ()
+ (mt:with-lock (*thread-id-counter-lock*)
+ (incf *thread-id-counter*))
+ )
+
+(defparameter *thread-id-map* (make-hash-table))
+(defparameter *id-thread-map* (make-hash-table))
+
+(defvar *thread-id-map-lock*
+ (mt:make-lock :name "thread id map lock"))
+
+(defparameter +default-thread-local-variables+
+ '(*macroexpand-hook*
+ *default-pathname-defaults*
+ *readtable*
+ *random-state*
+ *compile-print*
+ *compile-verbose*
+ *load-print*
+ *load-verbose*
+ *print-array*
+ *print-base*
+ *print-case*
+ *print-circle*
+ *print-escape*
+ *print-gensym*
+ *print-length*
+ *print-level*
+ *print-lines*
+ *print-miser-width*
+ *print-pprint-dispatch*
+ *print-pretty*
+ *print-radix*
+ *print-readably*
+ *print-right-margin*
+ *read-base*
+ *read-default-float-format*
+ *read-eval*
+ *read-suppress*
+ ))
+
+(defun thread-local-default-bindings ()
+ (let (local)
+ (dolist (var +default-thread-local-variables+ local)
+ (setq local (acons var (symbol-value var) local))
+ )))
+
+;; mkcl doesn't have weak pointers
+(defimplementation spawn (fn &key name initial-bindings)
+ (let* ((local-defaults (thread-local-default-bindings))
+ (thread
+ ;;(mt:make-thread :name name)
+ (mt:make-thread :name name
+ :initial-bindings (nconc initial-bindings
+ local-defaults))
+ )
+ (id (next-thread-id)))
+ (mt:with-lock (*thread-id-map-lock*)
+ (setf (gethash id *thread-id-map*) thread)
+ (setf (gethash thread *id-thread-map*) id))
+ (mt:thread-preset
+ thread
+ #'(lambda ()
+ (unwind-protect
+ (progn
+ ;;(format t "~&Starting thread: ~S.~%" name) (finish-output)
+ (mt:thread-detach nil)
+ (funcall fn))
+ (progn
+ ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output)
+ (mt:with-lock (*thread-id-map-lock*)
+ (remhash thread *id-thread-map*)
+ (remhash id *thread-id-map*))
+ ;;(format t "~&Finished thread: ~S~%" name) (finish-output)
+ ))))
+ (mt:thread-enable thread)
+ (mt:thread-yield)
+ thread
+ ))
+
+(defimplementation thread-id (thread)
+ (block thread-id
+ (mt:with-lock (*thread-id-map-lock*)
+ (or (gethash thread *id-thread-map*)
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) thread)
+ (setf (gethash thread *id-thread-map*) id)
+ id)))))
+
+(defimplementation find-thread (id)
+ (mt:with-lock (*thread-id-map-lock*)
+ (gethash id *thread-id-map*)))
+
+(defimplementation thread-name (thread)
+ (mt:thread-name thread))
+
+(defimplementation thread-status (thread)
+ (if (mt:thread-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+(defimplementation make-lock (&key name)
+ (mt:make-lock :name name :recursive t))
+
+(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mt:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mt:*thread*)
+
+(defimplementation all-threads ()
+ (mt:all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+ (mt:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (mt:interrupt-thread thread #'mt:terminate-thread)
+ )
+
+(defimplementation thread-alive-p (thread)
+ (mt:thread-active-p thread))
+
+(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock"))
+(defvar *mailboxes* (list))
+(declaim (type list *mailboxes*))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ thread
+ locked-by
+ (mutex (mt:make-lock :name "thread mailbox"))
+ (semaphore (mt:make-semaphore))
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mt:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+(defimplementation send (thread message)
+ (handler-case
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+;; (mt:interrupt-thread
+;; thread
+;; (lambda ()
+;; (mt:with-lock (mutex)
+;; (setf (mailbox.queue mbox)
+;; (nconc (mailbox.queue mbox) (list message))))))
+
+;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%"
+;; mt:*thread* thread message) (finish-output)
+ (mt:with-lock (mutex)
+ (setf (mailbox.locked-by mbox) mt:*thread*)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ ;;(format t "*") (finish-output)
+ (handler-case
+ (mt:semaphore-signal (mailbox.semaphore mbox))
+ (condition (condition)
+ (format t "Something went bad with semaphore-signal ~A" condition) (finish-output)
+ ;;(break)
+ ))
+ (setf (mailbox.locked-by mbox) nil)
+ )
+ ;;(format t "+") (finish-output)
+ )
+ (condition (condition)
+ (format t "~&Error in send: ~S~%" condition) (finish-output))
+ )
+ )
+
+;; (defimplementation receive ()
+;; (block got-mail
+;; (let* ((mbox (mailbox mt:*thread*))
+;; (mutex (mailbox.mutex mbox)))
+;; (loop
+;; (mt:with-lock (mutex)
+;; (if (mailbox.queue mbox)
+;; (return-from got-mail (pop (mailbox.queue mbox)))))
+;; ;;interrupt-thread will halt this if it takes longer than 1sec
+;; (sleep 1)))))
+
+
+(defimplementation receive-if (test &optional timeout)
+ (handler-case
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox))
+ got-one)
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ ;;(format t "~&: ~S~%" mt:*thread*) (finish-output)
+ (handler-case
+ (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2))
+ (condition (condition)
+ (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition)
+ (finish-output)
+ nil
+ )
+ )
+ (mt:with-lock (mutex)
+ (setf (mailbox.locked-by mbox) mt:*thread*)
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (when tail
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (setf (mailbox.locked-by mbox) nil)
+ ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail))
+ (return (car tail))))
+ (setf (mailbox.locked-by mbox) nil)
+ )
+
+ ;;(format t "/ ~S~%" mt:*thread*) (finish-output)
+ (when (eq timeout t) (return (values nil t)))
+;; (unless got-one
+;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%"))
+ )
+ )
+ (condition (condition)
+ (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output)
+ nil
+ )
+ )
+ )
+
+
+(defmethod stream-finish-output ((stream stream))
+ (finish-output stream))
+
+
+;;
+
+;;#+windows
+(defimplementation doze-in-repl ()
+ (setq *inferior-lisp-sleeping-post* (mt:make-semaphore))
+ ;;(loop (sleep 1))
+ (mt:semaphore-wait *inferior-lisp-sleeping-post*)
+ (mk-ext:quit :verbose t)
+ )
+
diff --git a/vim/bundle/slimv/slime/swank/rpc.lisp b/vim/bundle/slimv/slime/swank/rpc.lisp
new file mode 100644
index 0000000..e30cc2c
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/rpc.lisp
@@ -0,0 +1,162 @@
+;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
+;;;
+;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems.
+;;;
+;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package swank/rpc)
+
+
+;;;;; Input
+
+(define-condition swank-reader-error (reader-error)
+ ((packet :type string :initarg :packet
+ :reader swank-reader-error.packet)
+ (cause :type reader-error :initarg :cause
+ :reader swank-reader-error.cause)))
+
+(defun read-message (stream package)
+ (let ((packet (read-packet stream)))
+ (handler-case (values (read-form packet package))
+ (reader-error (c)
+ (error 'swank-reader-error
+ :packet packet :cause c)))))
+
+(defun read-packet (stream)
+ (let* ((length (parse-header stream))
+ (octets (read-chunk stream length)))
+ (handler-case (swank/backend:utf8-to-string octets)
+ (error (c)
+ (error 'swank-reader-error
+ :packet (asciify octets)
+ :cause c)))))
+
+(defun asciify (packet)
+ (with-output-to-string (*standard-output*)
+ (loop for code across (etypecase packet
+ (string (map 'vector #'char-code packet))
+ (vector packet))
+ do (cond ((<= code #x7f) (write-char (code-char code)))
+ (t (format t "\\x~x" code))))))
+
+(defun parse-header (stream)
+ (parse-integer (map 'string #'code-char (read-chunk stream 6))
+ :radix 16))
+
+(defun read-chunk (stream length)
+ (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
+ (count (read-sequence buffer stream)))
+ (cond ((= count length)
+ buffer)
+ ((zerop count)
+ (error 'end-of-file :stream stream))
+ (t
+ (error "Short read: length=~D count=~D" length count)))))
+
+(defparameter *validate-input* nil
+ "Set to true to require input that more strictly conforms to the protocol")
+
+(defun read-form (string package)
+ (with-standard-io-syntax
+ (let ((*package* package))
+ (if *validate-input*
+ (validating-read string)
+ (read-from-string string)))))
+
+(defun validating-read (string)
+ (with-input-from-string (*standard-input* string)
+ (simple-read)))
+
+(defun simple-read ()
+ "Read a form that conforms to the protocol, otherwise signal an error."
+ (let ((c (read-char)))
+ (case c
+ (#\( (loop collect (simple-read)
+ while (ecase (read-char)
+ (#\) nil)
+ (#\space t))))
+ (#\' `(quote ,(simple-read)))
+ (t
+ (cond
+ ((digit-char-p c)
+ (parse-integer
+ (map 'simple-string #'identity
+ (loop for ch = c then (read-char nil nil)
+ while (and ch (digit-char-p ch))
+ collect ch
+ finally (unread-char ch)))))
+ ((or (member c '(#\: #\")) (alpha-char-p c))
+ (unread-char c)
+ (read-preserving-whitespace))
+ (t (error "Invalid character ~:c" c)))))))
+
+
+;;;;; Output
+
+(defun write-message (message package stream)
+ (let* ((string (prin1-to-string-for-emacs message package))
+ (octets (handler-case (swank/backend:string-to-utf8 string)
+ (error (c) (encoding-error c string))))
+ (length (length octets)))
+ (write-header stream length)
+ (write-sequence octets stream)
+ (finish-output stream)))
+
+;; FIXME: for now just tell emacs that we and an encoding problem.
+(defun encoding-error (condition string)
+ (swank/backend:string-to-utf8
+ (prin1-to-string-for-emacs
+ `(:reader-error
+ ,(asciify string)
+ ,(format nil "Error during string-to-utf8: ~a"
+ (or (ignore-errors (asciify (princ-to-string condition)))
+ (asciify (princ-to-string (type-of condition))))))
+ (find-package :cl))))
+
+(defun write-header (stream length)
+ (declare (type (unsigned-byte 24) length))
+ ;;(format *trace-output* "length: ~d (#x~x)~%" length length)
+ (loop for c across (format nil "~6,'0x" length)
+ do (write-byte (char-code c) stream)))
+
+(defun switch-to-double-floats (x)
+ (typecase x
+ (double-float x)
+ (float (coerce x 'double-float))
+ (null x)
+ (list (loop for (x . cdr) on x
+ collect (switch-to-double-floats x) into result
+ until (atom cdr)
+ finally (return (append result (switch-to-double-floats cdr)))))
+ (t x)))
+
+(defun prin1-to-string-for-emacs (object package)
+ (with-standard-io-syntax
+ (let ((*print-case* :downcase)
+ (*print-readably* nil)
+ (*print-pretty* nil)
+ (*package* package)
+ ;; Emacs has only double floats.
+ (*read-default-float-format* 'double-float))
+ (prin1-to-string (switch-to-double-floats object)))))
+
+
+#| TEST/DEMO:
+
+(defparameter *transport*
+ (with-output-to-string (out)
+ (write-message '(:message (hello "world")) *package* out)
+ (write-message '(:return 5) *package* out)
+ (write-message '(:emacs-rex NIL) *package* out)))
+
+*transport*
+
+(with-input-from-string (in *transport*)
+ (loop while (peek-char T in NIL)
+ collect (read-message in *package*)))
+
+|#
diff --git a/vim/bundle/slimv/slime/swank/sbcl.lisp b/vim/bundle/slimv/slime/swank/sbcl.lisp
new file mode 100644
index 0000000..b54fcd5
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/sbcl.lisp
@@ -0,0 +1,2044 @@
+;;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-sbcl.lisp --- SLIME backend for SBCL.
+;;;
+;;; Created 2003, Daniel Barlow <dan@metacircles.com>
+;;;
+;;; This code has been placed in the Public Domain. All warranties are
+;;; disclaimed.
+
+;;; Requires the SB-INTROSPECT contrib.
+
+;;; Administrivia
+
+(defpackage swank/sbcl
+ (:use cl swank/backend swank/source-path-parser swank/source-file-cache))
+
+(in-package swank/sbcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sb-bsd-sockets)
+ (require 'sb-introspect)
+ (require 'sb-posix)
+ (require 'sb-cltl2))
+
+(declaim (optimize (debug 2)
+ (sb-c::insert-step-conditions 0)
+ (sb-c::insert-debug-catch 0)))
+
+;;; backwards compability tests
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Generate a form suitable for testing for stepper support (0.9.17)
+ ;; with #+.
+ (defun sbcl-with-new-stepper-p ()
+ (with-symbol 'enable-stepping 'sb-impl))
+ ;; Ditto for weak hash-tables
+ (defun sbcl-with-weak-hash-tables ()
+ (with-symbol 'hash-table-weakness 'sb-ext))
+ ;; And for xref support (1.0.1)
+ (defun sbcl-with-xref-p ()
+ (with-symbol 'who-calls 'sb-introspect))
+ ;; ... for restart-frame support (1.0.2)
+ (defun sbcl-with-restart-frame ()
+ (with-symbol 'frame-has-debug-tag-p 'sb-debug))
+ ;; ... for :setf :inverse info (1.1.17)
+ (defun sbcl-with-setf-inverse-meta-info ()
+ (boolean-to-feature-expression
+ ;; going through FIND-SYMBOL since META-INFO was renamed from
+ ;; TYPE-INFO in 1.2.10.
+ (let ((sym (find-symbol "META-INFO" "SB-C")))
+ (and sym
+ (fboundp sym)
+ (funcall sym :setf :inverse ()))))))
+
+;;; swank-mop
+
+(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (sb-pcl::documentation slot t))
+
+;; stream support
+
+(defimplementation gray-package-name ()
+ "SB-GRAY")
+
+;; Pretty printer calls this, apparently
+(defmethod sb-gray:stream-line-length
+ ((s sb-gray:fundamental-character-input-stream))
+ nil)
+
+;;; Connection info
+
+(defimplementation lisp-implementation-type-name ()
+ "sbcl")
+
+;; Declare return type explicitly to shut up STYLE-WARNINGS about
+;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
+(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
+(defimplementation getpid ()
+ (sb-posix:getpid))
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (sb-ext:string-to-octets string :external-format :utf8))
+
+(defimplementation utf8-to-string (octets)
+ (sb-ext:octets-to-string octets :external-format :utf8))
+
+;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ (cond
+ ;; fixme: when SBCL/win32 gains better select() support, remove
+ ;; this.
+ ((member :sb-thread *features*) :spawn)
+ ((member :win32 *features*) nil)
+ (t :fd-handler)))
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket (or backlog 5))
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-sys:invalidate-descriptor (socket-fd socket))
+ (sb-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket &key
+ external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (make-socket-io-stream (accept socket) external-format
+ (ecase buffering
+ ((t :full) :full)
+ ((nil :none) :none)
+ ((:line) :line))))
+
+
+;; The SIGIO stuff should probably be removed as it's unlikey that
+;; anybody uses it.
+#-win32
+(progn
+ (defimplementation install-sigint-handler (function)
+ (sb-sys:enable-interrupt sb-unix:sigint
+ (lambda (&rest args)
+ (declare (ignore args))
+ (sb-sys:invoke-interruption
+ (lambda ()
+ (sb-sys:with-interrupts
+ (funcall function)))))))
+
+ (defvar *sigio-handlers* '()
+ "List of (key . fn) pairs to be called on SIGIO.")
+
+ (defun sigio-handler (signal code scp)
+ (declare (ignore signal code scp))
+ (sb-sys:with-interrupts
+ (mapc (lambda (handler)
+ (funcall (the function (cdr handler))))
+ *sigio-handlers*)))
+
+ (defun set-sigio-handler ()
+ (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler))
+
+ (defun enable-sigio-on-fd (fd)
+ (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
+ (sb-posix::fcntl fd sb-posix::f-setown (getpid))
+ (values))
+
+ (defimplementation add-sigio-handler (socket fn)
+ (set-sigio-handler)
+ (let ((fd (socket-fd socket)))
+ (enable-sigio-on-fd fd)
+ (push (cons fd fn) *sigio-handlers*)))
+
+ (defimplementation remove-sigio-handlers (socket)
+ (let ((fd (socket-fd socket)))
+ (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
+ (sb-sys:invalidate-descriptor fd))
+ (close socket)))
+
+
+(defimplementation add-fd-handler (socket fun)
+ (let ((fd (socket-fd socket))
+ (handler nil))
+ (labels ((add ()
+ (setq handler (sb-sys:add-fd-handler fd :input #'run)))
+ (run (fd)
+ (sb-sys:remove-fd-handler handler) ; prevent recursion
+ (unwind-protect
+ (funcall fun)
+ (when (sb-unix:unix-fstat fd) ; still open?
+ (add)))))
+ (add))))
+
+(defimplementation remove-fd-handlers (socket)
+ (sb-sys:invalidate-descriptor (socket-fd socket)))
+
+(defimplementation socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+ (file-stream (sb-sys:fd-stream-fd socket))))
+
+(defimplementation command-line-args ()
+ sb-ext:*posix-argv*)
+
+(defimplementation dup (fd)
+ (sb-posix:dup fd))
+
+(defvar *wait-for-input-called*)
+
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (when (boundp '*wait-for-input-called*)
+ (setq *wait-for-input-called* t))
+ (let ((*wait-for-input-called* nil))
+ (loop
+ (let ((ready (remove-if-not #'input-ready-p streams)))
+ (when ready (return ready)))
+ (when (check-slime-interrupts)
+ (return :interrupt))
+ (when *wait-for-input-called*
+ (return :interrupt))
+ (when timeout
+ (return nil))
+ (sleep 0.1))))
+
+(defun fd-stream-input-buffer-empty-p (stream)
+ (let ((buffer (sb-impl::fd-stream-ibuf stream)))
+ (or (not buffer)
+ (= (sb-impl::buffer-head buffer)
+ (sb-impl::buffer-tail buffer)))))
+
+#-win32
+(defun input-ready-p (stream)
+ (or (not (fd-stream-input-buffer-empty-p stream))
+ #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl)
+ (eq :regular (sb-impl::fd-stream-fd-type stream))
+ (not (sb-impl::sysread-may-block-p stream))))
+
+#+win32
+(progn
+ (defun input-ready-p (stream)
+ (or (not (fd-stream-input-buffer-empty-p stream))
+ (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
+
+ (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
+ sb-win32:handle)
+
+ (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
+ sb-alien:int
+ (event sb-win32:handle))
+
+ (defconstant +fd-read+ #.(ash 1 0))
+ (defconstant +fd-close+ #.(ash 1 5))
+
+ (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
+ sb-alien:int
+ (fd sb-alien:int)
+ (handle sb-win32:handle)
+ (mask sb-alien:long))
+
+ (sb-alien:load-shared-object "kernel32.dll")
+ (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
+ wait-for-single-object-ex)
+ sb-alien:int
+ (event sb-win32:handle)
+ (milliseconds sb-alien:long)
+ (alertable sb-alien:int))
+
+ ;; see SB-WIN32:HANDLE-LISTEN
+ (defun handle-listen (handle)
+ (sb-alien:with-alien ((avail sb-win32:dword)
+ (buf (array char #.sb-win32::input-record-size)))
+ (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
+ (sb-alien:alien-sap
+ (sb-alien:addr avail))
+ nil))
+ (return-from handle-listen (plusp avail)))
+
+ (unless (zerop (sb-win32:peek-console-input handle
+ (sb-alien:alien-sap buf)
+ sb-win32::input-record-size
+ (sb-alien:alien-sap
+ (sb-alien:addr avail))))
+ (return-from handle-listen (plusp avail))))
+
+ (let ((event (wsa-create-event)))
+ (wsa-event-select handle event (logior +fd-read+ +fd-close+))
+ (let ((val (wait-for-single-object-ex event 0 0)))
+ (wsa-close-event event)
+ (unless (= val -1)
+ (return-from handle-listen (zerop val)))))
+
+ nil)
+
+ )
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")))
+
+;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
+;; 2008-08-22.
+(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
+
+(defimplementation filename-to-pathname (filename)
+ (sb-ext:parse-native-namestring filename *physical-pathname-host*))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defimplementation set-default-directory (directory)
+ (let ((directory (truename (merge-pathnames directory))))
+ (sb-posix:chdir directory)
+ (setf *default-pathname-defaults* directory)
+ (default-directory)))
+
+(defun make-socket-io-stream (socket external-format buffering)
+ (let ((args `(,@()
+ :output t
+ :input t
+ :element-type ,(if external-format
+ 'character
+ '(unsigned-byte 8))
+ :buffering ,buffering
+ ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
+ `(:external-format ,external-format))
+ (t '()))
+ :serve-events ,(eq :fd-handler swank:*communication-style*)
+ ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
+ ;; argument.
+ :allow-other-keys t)))
+ (apply #'sb-bsd-sockets:socket-make-stream socket args)))
+
+(defun accept (socket)
+ "Like socket-accept, but retry on EAGAIN."
+ (loop (handler-case
+ (return (sb-bsd-sockets:socket-accept socket))
+ (sb-bsd-sockets:interrupted-error ()))))
+
+
+;;;; Support for SBCL syntax
+
+;;; SBCL's source code is riddled with #! reader macros. Also symbols
+;;; containing `!' have special meaning. We have to work long and
+;;; hard to be able to read the source. To deal with #! reader
+;;; macros, we use a special readtable. The special symbols are
+;;; converted by a condition handler.
+
+(defun feature-in-list-p (feature list)
+ (etypecase feature
+ (symbol (member feature list :test #'eq))
+ (cons (flet ((subfeature-in-list-p (subfeature)
+ (feature-in-list-p subfeature list)))
+ ;; Don't use ECASE since SBCL also has :host-feature,
+ ;; don't need to handle it or anything else appearing in
+ ;; the future or in erronous code.
+ (case (first feature)
+ (:or (some #'subfeature-in-list-p (rest feature)))
+ (:and (every #'subfeature-in-list-p (rest feature)))
+ (:not (destructuring-bind (e) (cdr feature)
+ (not (subfeature-in-list-p e)))))))))
+
+(defun shebang-reader (stream sub-character infix-parameter)
+ (declare (ignore sub-character))
+ (when infix-parameter
+ (error "illegal read syntax: #~D!" infix-parameter))
+ (let ((next-char (read-char stream)))
+ (unless (find next-char "+-")
+ (error "illegal read syntax: #!~C" next-char))
+ ;; When test is not satisfied
+ ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
+ ;; would become "unless test is satisfied"..
+ (when (let* ((*package* (find-package "KEYWORD"))
+ (*read-suppress* nil)
+ (not-p (char= next-char #\-))
+ (feature (read stream)))
+ (if (feature-in-list-p feature *features*)
+ not-p
+ (not not-p)))
+ ;; Read (and discard) a form from input.
+ (let ((*read-suppress* t))
+ (read stream t nil t))))
+ (values))
+
+(defvar *shebang-readtable*
+ (let ((*readtable* (copy-readtable nil)))
+ (set-dispatch-macro-character #\# #\!
+ (lambda (s c n) (shebang-reader s c n))
+ *readtable*)
+ *readtable*))
+
+(defun shebang-readtable ()
+ *shebang-readtable*)
+
+(defun sbcl-package-p (package)
+ (let ((name (package-name package)))
+ (eql (mismatch "SB-" name) 3)))
+
+(defun sbcl-source-file-p (filename)
+ (when filename
+ (loop for (nil pattern) in (logical-pathname-translations "SYS")
+ thereis (pathname-match-p filename pattern))))
+
+(defun guess-readtable-for-filename (filename)
+ (if (sbcl-source-file-p filename)
+ (shebang-readtable)
+ *readtable*))
+
+(defvar *debootstrap-packages* t)
+
+(defun call-with-debootstrapping (fun)
+ (handler-bind ((sb-int:bootstrap-package-not-found
+ #'sb-int:debootstrap-package))
+ (funcall fun)))
+
+(defmacro with-debootstrapping (&body body)
+ `(call-with-debootstrapping (lambda () ,@body)))
+
+(defimplementation call-with-syntax-hooks (fn)
+ (cond ((and *debootstrap-packages*
+ (sbcl-package-p *package*))
+ (with-debootstrapping (funcall fn)))
+ (t
+ (funcall fn))))
+
+(defimplementation default-readtable-alist ()
+ (let ((readtable (shebang-readtable)))
+ (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
+ collect (cons (package-name p) readtable))))
+
+;;; Packages
+
+#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext)
+(defimplementation package-local-nicknames (package)
+ (sb-ext:package-local-nicknames package))
+
+;;; Utilities
+
+#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
+(defimplementation arglist (fname)
+ (sb-introspect:function-lambda-list fname))
+
+#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
+(defimplementation arglist (fname)
+ (sb-introspect:function-arglist fname))
+
+(defimplementation function-name (f)
+ (check-type f function)
+ (sb-impl::%fun-name f))
+
+(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
+ (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
+ (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
+ (if flags
+ ;; Symbols aren't printed with package qualifiers, but the
+ ;; FLAGS would have to be fully qualified when used inside a
+ ;; declaration. So we strip those as long as there's no
+ ;; better way. (FIXME)
+ `(&any ,@(remove-if-not
+ #'(lambda (qualifier)
+ (find-symbol (symbol-name (first qualifier)) :cl))
+ flags :key #'ensure-list))
+ (call-next-method)))))
+
+#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect)
+(defmethod type-specifier-arglist :around (typespec-operator)
+ (multiple-value-bind (arglist foundp)
+ (sb-introspect:deftype-lambda-list typespec-operator)
+ (if foundp arglist (call-next-method))))
+
+(defimplementation type-specifier-p (symbol)
+ (or (sb-ext:valid-type-specifier-p symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+(defvar *buffer-name* nil)
+(defvar *buffer-tmpfile* nil)
+(defvar *buffer-offset*)
+(defvar *buffer-substring* nil)
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning.
+This traps all compiler conditions at a lower-level than using
+C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
+craft our own error messages, which can omit a lot of redundant
+information."
+ (unless (or (eq condition *previous-compiler-condition*))
+ ;; First resignal warnings, so that outer handlers -- which may choose to
+ ;; muffle this -- get a chance to run.
+ (when (typep condition 'warning)
+ (signal condition))
+ (setq *previous-compiler-condition* condition)
+ (signal-compiler-condition (real-condition condition)
+ (sb-c::find-error-context nil))))
+
+(defun signal-compiler-condition (condition context)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (sb-ext:compiler-note :note)
+ (sb-c:compiler-error :error)
+ (reader-error :read-error)
+ (error :error)
+ #+#.(swank/backend:with-symbol redefinition-warning
+ sb-kernel)
+ (sb-kernel:redefinition-warning
+ :redefinition)
+ (style-warning :style-warning)
+ (warning :warning))
+ :references (condition-references condition)
+ :message (brief-compiler-message-for-emacs condition)
+ :source-context (compiler-error-context context)
+ :location (compiler-note-location condition context)))
+
+(defun real-condition (condition)
+ "Return the encapsulated condition or CONDITION itself."
+ (typecase condition
+ (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
+ (t condition)))
+
+(defun condition-references (condition)
+ (if (typep condition 'sb-int:reference-condition)
+ (externalize-reference
+ (sb-int:reference-condition-references condition))))
+
+(defun compiler-note-location (condition context)
+ (flet ((bailout ()
+ (return-from compiler-note-location
+ (make-error-location "No error location available"))))
+ (cond (context
+ (locate-compiler-note
+ (sb-c::compiler-error-context-file-name context)
+ (compiler-source-path context)
+ (sb-c::compiler-error-context-original-source context)))
+ ((typep condition 'reader-error)
+ (let* ((stream (stream-error-stream condition))
+ (file (pathname stream)))
+ (unless (open-stream-p stream)
+ (bailout))
+ (if (compiling-from-buffer-p file)
+ ;; The stream position for e.g. "comma not inside
+ ;; backquote" is at the character following the
+ ;; comma, :offset is 0-based, hence the 1-.
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-offset*
+ (1- (file-position stream))))
+ (progn
+ (assert (compiling-from-file-p file))
+ ;; No 1- because :position is 1-based.
+ (make-location (list :file (namestring file))
+ (list :position (file-position stream)))))))
+ (t (bailout)))))
+
+(defun compiling-from-buffer-p (filename)
+ (and *buffer-name*
+ ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
+ ;; in LOCATE-COMPILER-NOTE, and allows handling nested
+ ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
+ ;;
+ ;; PROBE-FILE to handle tempfile directory being a symlink.
+ (pathnamep filename)
+ (let ((true1 (probe-file filename))
+ (true2 (probe-file *buffer-tmpfile*)))
+ (and true1 (equal true1 true2)))))
+
+(defun compiling-from-file-p (filename)
+ (and (pathnamep filename)
+ (or (null *buffer-name*)
+ (null *buffer-tmpfile*)
+ (let ((true1 (probe-file filename))
+ (true2 (probe-file *buffer-tmpfile*)))
+ (not (and true1 (equal true1 true2)))))))
+
+(defun compiling-from-generated-code-p (filename source)
+ (and (eq filename :lisp) (stringp source)))
+
+(defun locate-compiler-note (file source-path source)
+ (cond ((compiling-from-buffer-p file)
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-offset*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ ((compiling-from-file-p file)
+ (let ((position (source-path-file-position source-path file)))
+ (make-location (list :file (namestring file))
+ (list :position (and position
+ (1+ position))))))
+ ((compiling-from-generated-code-p file source)
+ (make-location (list :source-form source)
+ (list :position 1)))
+ (t
+ (error "unhandled case in compiler note ~S ~S ~S"
+ file source-path source))))
+
+(defun brief-compiler-message-for-emacs (condition)
+ "Briefly describe a compiler error for Emacs.
+When Emacs presents the message it already has the source popped up
+and the source form highlighted. This makes much of the information in
+the error-context redundant."
+ (let ((sb-int:*print-condition-references* nil))
+ (princ-to-string condition)))
+
+(defun compiler-error-context (error-context)
+ "Describe a compiler error for Emacs including context information."
+ (declare (type (or sb-c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (sb-c::compiler-error-context-enclosing-source error-context)
+ (sb-c::compiler-error-context-source error-context)))
+ (and (or enclosing source)
+ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
+ enclosing source))))
+
+(defun compiler-source-path (context)
+ "Return the source-path for the current compiler error.
+Returns NIL if this cannot be determined by examining internal
+compiler state."
+ (cond ((sb-c::node-p context)
+ (reverse
+ (sb-c::source-path-original-source
+ (sb-c::node-source-path context))))
+ ((sb-c::compiler-error-context-p context)
+ (reverse
+ (sb-c::compiler-error-context-original-source-path context)))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (declare (type function function))
+ (handler-bind
+ ;; N.B. Even though these handlers are called HANDLE-FOO they
+ ;; actually decline, i.e. the signalling of the original
+ ;; condition continues upward.
+ ((sb-c:fatal-compiler-error #'handle-notification-condition)
+ (sb-c:compiler-error #'handle-notification-condition)
+ (sb-ext:compiler-note #'handle-notification-condition)
+ (error #'handle-notification-condition)
+ (warning #'handle-notification-condition))
+ (funcall function)))
+
+;;; HACK: SBCL 1.2.12 shipped with a bug where
+;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there
+;;; were no policy restrictions in place. This workaround ensures the
+;;; existence of at least one dummy restriction.
+(handler-case (sb-ext:restrict-compiler-policy)
+ (error () (sb-ext:restrict-compiler-policy 'debug)))
+
+(defun compiler-policy (qualities)
+ "Return compiler policy qualities present in the QUALITIES alist.
+QUALITIES is an alist with (quality . value)"
+ #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
+ (loop with policy = (sb-ext:restrict-compiler-policy)
+ for (quality) in qualities
+ collect (cons quality
+ (or (cdr (assoc quality policy))
+ 0))))
+
+(defun (setf compiler-policy) (policy)
+ (declare (ignorable policy))
+ #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
+ (loop for (qual . value) in policy
+ do (sb-ext:restrict-compiler-policy qual value)))
+
+(defmacro with-compiler-policy (policy &body body)
+ (let ((current-policy (gensym)))
+ `(let ((,current-policy (compiler-policy ,policy)))
+ (setf (compiler-policy) ,policy)
+ (unwind-protect (progn ,@body)
+ (setf (compiler-policy) ,current-policy)))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (with-compiler-policy policy
+ (with-compilation-hooks ()
+ (compile-file input-file :output-file output-file
+ :external-format external-format)))
+ (values output-file warnings-p
+ (or failure-p
+ (when load-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get input-file
+ (file-write-date input-file))
+ (not (load output-file)))))))
+
+;;;; compile-string
+
+;;; We copy the string to a temporary file in order to get adequate
+;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
+;;; which the previous approach using
+;;; (compile nil `(lambda () ,(read-from-string string)))
+;;; did not provide.
+
+(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+
+(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
+ sb-alien:c-string
+ (dir sb-alien:c-string)
+ (prefix sb-alien:c-string))
+
+)
+
+(defun temp-file-name ()
+ "Return a temporary file name to compile strings into."
+ (tempnam nil nil))
+
+(defvar *trap-load-time-warnings* t)
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position)
+ (*buffer-substring* string)
+ (*buffer-tmpfile* (temp-file-name)))
+ (labels ((load-it (filename)
+ (cond (*trap-load-time-warnings*
+ (with-compilation-hooks () (load filename)))
+ (t (load filename))))
+ (cf ()
+ (with-compiler-policy policy
+ (with-compilation-unit
+ (:source-plist (list :emacs-buffer buffer
+ :emacs-filename filename
+ :emacs-package (package-name *package*)
+ :emacs-position position
+ :emacs-string string)
+ :source-namestring filename
+ :allow-other-keys t)
+ (compile-file *buffer-tmpfile* :external-format :utf-8)))))
+ (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
+ :external-format :utf-8)
+ (write-string string s))
+ (unwind-protect
+ (multiple-value-bind (output-file warningsp failurep)
+ (with-compilation-hooks () (cf))
+ (declare (ignore warningsp))
+ (when output-file
+ (load-it output-file))
+ (not failurep))
+ (ignore-errors
+ (delete-file *buffer-tmpfile*)
+ (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
+
+;;;; Definitions
+
+(defparameter *definition-types*
+ '(:variable defvar
+ :constant defconstant
+ :type deftype
+ :symbol-macro define-symbol-macro
+ :macro defmacro
+ :compiler-macro define-compiler-macro
+ :function defun
+ :generic-function defgeneric
+ :method defmethod
+ :setf-expander define-setf-expander
+ :structure defstruct
+ :condition define-condition
+ :class defclass
+ :method-combination define-method-combination
+ :package defpackage
+ :transform :deftransform
+ :optimizer :defoptimizer
+ :vop :define-vop
+ :source-transform :define-source-transform
+ :ir1-convert :def-ir1-translator
+ :declaration declaim
+ :alien-type :define-alien-type)
+ "Map SB-INTROSPECT definition type names to Slime-friendly forms")
+
+(defun definition-specifier (type)
+ "Return a pretty specifier for NAME representing a definition of type TYPE."
+ (getf *definition-types* type))
+
+(defun make-dspec (type name source-location)
+ (list* (definition-specifier type)
+ name
+ (sb-introspect::definition-source-description source-location)))
+
+(defimplementation find-definitions (name)
+ (loop for type in *definition-types* by #'cddr
+ for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
+ append (loop for defsrc in defsrcs collect
+ (list (make-dspec type name defsrc)
+ (converting-errors-to-error-location
+ (definition-source-for-emacs defsrc
+ type name))))))
+
+(defimplementation find-source-location (obj)
+ (flet ((general-type-of (obj)
+ (typecase obj
+ (method :method)
+ (generic-function :generic-function)
+ (function :function)
+ (structure-class :structure-class)
+ (class :class)
+ (method-combination :method-combination)
+ (package :package)
+ (condition :condition)
+ (structure-object :structure-object)
+ (standard-object :standard-object)
+ (t :thing)))
+ (to-string (obj)
+ (typecase obj
+ ;; Packages are possibly named entities.
+ (package (princ-to-string obj))
+ ((or structure-object standard-object condition)
+ (with-output-to-string (s)
+ (print-unreadable-object (obj s :type t :identity t))))
+ (t (princ-to-string obj)))))
+ (converting-errors-to-error-location
+ (let ((defsrc (sb-introspect:find-definition-source obj)))
+ (definition-source-for-emacs defsrc
+ (general-type-of obj)
+ (to-string obj))))))
+
+(defmacro with-definition-source ((&rest names) obj &body body)
+ "Like with-slots but works only for structs."
+ (flet ((reader (slot)
+ ;; Use read-from-string instead of intern so that
+ ;; conc-name can be a string such as ext:struct- and not
+ ;; cause errors and not force interning ext::struct-
+ (read-from-string
+ (concatenate 'string "sb-introspect:definition-source-"
+ (string slot)))))
+ (let ((tmp (gensym "OO-")))
+ ` (let ((,tmp ,obj))
+ (symbol-macrolet
+ ,(loop for name in names collect
+ (typecase name
+ (symbol `(,name (,(reader name) ,tmp)))
+ (cons `(,(first name) (,(reader (second name)) ,tmp)))
+ (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
+ ,@body)))))
+
+(defun categorize-definition-source (definition-source)
+ (with-definition-source (pathname form-path character-offset plist)
+ definition-source
+ (let ((file-p (and pathname (probe-file pathname)
+ (or form-path character-offset))))
+ (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
+ ((getf plist :emacs-buffer) :buffer)
+ (file-p :file)
+ (pathname :file-without-position)
+ (t :invalid)))))
+
+#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
+(defun form-number-position (definition-source stream)
+ (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source)))
+ (form-number (sb-introspect:definition-source-form-number definition-source)))
+ (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
+ (let* ((path-table (sb-di::form-number-translations tlf 0))
+ (path (cond ((<= (length path-table) form-number)
+ (warn "inconsistent form-number-translations")
+ (list 0))
+ (t
+ (reverse (cdr (aref path-table form-number)))))))
+ (source-path-source-position path tlf pos-map)))))
+
+#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
+(defun file-form-number-position (definition-source)
+ (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source))
+ (filename (sb-introspect:definition-source-pathname definition-source))
+ (*readtable* (guess-readtable-for-filename filename))
+ (source-code (get-source-code filename code-date)))
+ (with-debootstrapping
+ (with-input-from-string (s source-code)
+ (form-number-position definition-source s)))))
+
+#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
+(defun string-form-number-position (definition-source string)
+ (with-input-from-string (s string)
+ (form-number-position definition-source s)))
+
+(defun definition-source-buffer-location (definition-source)
+ (with-definition-source (form-path character-offset plist) definition-source
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
+ emacs-string &allow-other-keys)
+ plist
+ (let ((*readtable* (guess-readtable-for-filename emacs-directory))
+ start
+ end)
+ (with-debootstrapping
+ (or
+ (and form-path
+ (or
+ #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
+ (setf (values start end)
+ (and (sb-introspect:definition-source-form-number definition-source)
+ (string-form-number-position definition-source emacs-string)))
+ (setf (values start end)
+ (source-path-string-position form-path emacs-string))))
+ (setf start character-offset
+ end most-positive-fixnum)))
+ (make-location
+ `(:buffer ,emacs-buffer)
+ `(:offset ,emacs-position ,start)
+ `(:snippet
+ ,(subseq emacs-string
+ start
+ (min end (+ start *source-snippet-size*)))))))))
+
+(defun definition-source-file-location (definition-source)
+ (with-definition-source (pathname form-path character-offset plist
+ file-write-date) definition-source
+ (let* ((namestring (namestring (translate-logical-pathname pathname)))
+ (pos (or (and form-path
+ (or
+ #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
+ (and (sb-introspect:definition-source-form-number definition-source)
+ (ignore-errors (file-form-number-position definition-source)))
+ (ignore-errors
+ (source-file-position namestring file-write-date
+ form-path))))
+ character-offset))
+ (snippet (source-hint-snippet namestring file-write-date pos)))
+ (make-location `(:file ,namestring)
+ ;; /file positions/ in Common Lisp start from
+ ;; 0, buffer positions in Emacs start from 1.
+ `(:position ,(1+ pos))
+ `(:snippet ,snippet)))))
+
+(defun definition-source-buffer-and-file-location (definition-source)
+ (let ((buffer (definition-source-buffer-location definition-source)))
+ (make-location (list :buffer-and-file
+ (cadr (location-buffer buffer))
+ (namestring (sb-introspect:definition-source-pathname
+ definition-source)))
+ (location-position buffer)
+ (location-hints buffer))))
+
+(defun definition-source-for-emacs (definition-source type name)
+ (with-definition-source (pathname form-path character-offset plist
+ file-write-date)
+ definition-source
+ (ecase (categorize-definition-source definition-source)
+ (:buffer-and-file
+ (definition-source-buffer-and-file-location definition-source))
+ (:buffer
+ (definition-source-buffer-location definition-source))
+ (:file
+ (definition-source-file-location definition-source))
+ (:file-without-position
+ (make-location `(:file ,(namestring
+ (translate-logical-pathname pathname)))
+ '(:position 1)
+ (when (eql type :function)
+ `(:snippet ,(format nil "(defun ~a "
+ (symbol-name name))))))
+ (:invalid
+ (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
+ meaningful information."
+ type name)))))
+
+(defun source-file-position (filename write-date form-path)
+ (let ((source (get-source-code filename write-date))
+ (*readtable* (guess-readtable-for-filename filename)))
+ (with-debootstrapping
+ (source-path-string-position form-path source))))
+
+(defun source-hint-snippet (filename write-date position)
+ (read-snippet-from-string (get-source-code filename write-date) position))
+
+(defun function-source-location (function &optional name)
+ (declare (type function function))
+ (definition-source-for-emacs (sb-introspect:find-definition-source function)
+ :function
+ (or name (function-name function))))
+
+(defun setf-expander (symbol)
+ (or
+ #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info)
+ (sb-int:info :setf :inverse symbol)
+ (sb-int:info :setf :expander symbol)))
+
+(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 (multiple-value-bind (kind recorded-p)
+ (sb-int:info :variable :kind symbol)
+ (declare (ignore kind))
+ (if (or (boundp symbol) recorded-p)
+ (doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((typep (fdefinition symbol) 'generic-function)
+ :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (and (setf-expander symbol)
+ (doc 'setf)))
+ (maybe-push
+ :type (if (sb-int:info :type :kind symbol)
+ (doc 'type)))
+ result)))
+
+(defimplementation describe-definition (symbol type)
+ (case type
+ (:variable
+ (describe symbol))
+ (:function
+ (describe (symbol-function symbol)))
+ (:setf
+ (describe (setf-expander symbol)))
+ (:class
+ (describe (find-class symbol)))
+ (:type
+ (describe (sb-kernel:values-specifier-type symbol)))))
+
+#+#.(swank/sbcl::sbcl-with-xref-p)
+(progn
+ (defmacro defxref (name &optional fn-name)
+ `(defimplementation ,name (what)
+ (sanitize-xrefs
+ (mapcar #'source-location-for-xref-data
+ (,(find-symbol (symbol-name (if fn-name
+ fn-name
+ name))
+ "SB-INTROSPECT")
+ what)))))
+ (defxref who-calls)
+ (defxref who-binds)
+ (defxref who-sets)
+ (defxref who-references)
+ (defxref who-macroexpands)
+ #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect)
+ (defxref who-specializes who-specializes-directly))
+
+(defun source-location-for-xref-data (xref-data)
+ (destructuring-bind (name . defsrc) xref-data
+ (list name (converting-errors-to-error-location
+ (definition-source-for-emacs defsrc 'function name)))))
+
+(defimplementation list-callers (symbol)
+ (let ((fn (fdefinition symbol)))
+ (sanitize-xrefs
+ (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
+
+(defimplementation list-callees (symbol)
+ (let ((fn (fdefinition symbol)))
+ (sanitize-xrefs
+ (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
+
+(defun sanitize-xrefs (xrefs)
+ (remove-duplicates
+ (remove-if (lambda (f)
+ (member f (ignored-xref-function-names)))
+ (loop for entry in xrefs
+ for name = (car entry)
+ collect (if (and (consp name)
+ (member (car name)
+ '(sb-pcl::fast-method
+ sb-pcl::slow-method
+ sb-pcl::method)))
+ (cons (cons 'defmethod (cdr name))
+ (cdr entry))
+ entry))
+ :key #'car)
+ :test (lambda (a b)
+ (and (eq (first a) (first b))
+ (equal (second a) (second b))))))
+
+(defun ignored-xref-function-names ()
+ #-#.(swank/sbcl::sbcl-with-new-stepper-p)
+ '(nil sb-c::step-form sb-c::step-values)
+ #+#.(swank/sbcl::sbcl-with-new-stepper-p)
+ '(nil))
+
+(defun function-dspec (fn)
+ "Describe where the function FN was defined.
+Return a list of the form (NAME LOCATION)."
+ (let ((name (function-name fn)))
+ (list name (converting-errors-to-error-location
+ (function-source-location fn name)))))
+
+;;; macroexpansion
+
+(defimplementation macroexpand-all (form &optional env)
+ (sb-cltl2:macroexpand-all form env))
+
+(defimplementation collect-macro-forms (form &optional environment)
+ (let ((macro-forms '())
+ (compiler-macro-forms '())
+ (function-quoted-forms '()))
+ (sb-walker:walk-form
+ form environment
+ (lambda (form context environment)
+ (declare (ignore context))
+ (when (and (consp form)
+ (symbolp (car form)))
+ (cond ((eq (car form) 'function)
+ (push (cadr form) function-quoted-forms))
+ ((member form function-quoted-forms)
+ nil)
+ ((macro-function (car form) environment)
+ (push form macro-forms))
+ ((not (eq form (compiler-macroexpand-1 form environment)))
+ (push form compiler-macro-forms))))
+ form))
+ (values macro-forms compiler-macro-forms)))
+
+
+;;; Debugging
+
+;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
+;;; than just a hook into BREAK. In particular, it'll make
+;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
+;;; than the native debugger. That should probably be considered a
+;;; feature.
+
+(defun make-invoke-debugger-hook (hook)
+ (when hook
+ #'(sb-int:named-lambda swank-invoke-debugger-hook
+ (condition old-hook)
+ (if *debugger-hook*
+ nil ; decline, *DEBUGGER-HOOK* will be tried next.
+ (funcall hook condition old-hook)))))
+
+(defun set-break-hook (hook)
+ (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+
+(defun call-with-break-hook (hook continuation)
+ (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall continuation)))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (set-break-hook function))
+
+(defimplementation condition-extras (condition)
+ (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p)
+ ((typep condition 'sb-impl::step-form-condition)
+ `((:show-frame-source 0)))
+ ((typep condition 'sb-int:reference-condition)
+ (let ((refs (sb-int:reference-condition-references condition)))
+ (if refs
+ `((:references ,(externalize-reference refs))))))))
+
+(defun externalize-reference (ref)
+ (etypecase ref
+ (null nil)
+ (cons (cons (externalize-reference (car ref))
+ (externalize-reference (cdr ref))))
+ ((or string number) ref)
+ (symbol
+ (cond ((eq (symbol-package ref) (symbol-package :test))
+ ref)
+ (t (symbol-name ref))))))
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let ((*sldb-stack-top*
+ (if (and (not *debug-swank-backend*)
+ sb-debug:*stack-top-hint*)
+ #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
+ (sb-debug::resolve-stack-top-hint)
+ #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
+ sb-debug:*stack-top-hint*
+ (sb-di:top-frame)))
+ (sb-debug:*stack-top-hint* nil))
+ (handler-bind ((sb-di:debug-condition
+ (lambda (condition)
+ (signal 'sldb-condition
+ :original-condition condition))))
+ (funcall debugger-loop-fn))))
+
+#+#.(swank/sbcl::sbcl-with-new-stepper-p)
+(progn
+ (defimplementation activate-stepping (frame)
+ (declare (ignore frame))
+ (sb-impl::enable-stepping))
+ (defimplementation sldb-stepper-condition-p (condition)
+ (typep condition 'sb-ext:step-form-condition))
+ (defimplementation sldb-step-into ()
+ (invoke-restart 'sb-ext:step-into))
+ (defimplementation sldb-step-next ()
+ (invoke-restart 'sb-ext:step-next))
+ (defimplementation sldb-step-out ()
+ (invoke-restart 'sb-ext:step-out)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ #+#.(swank/sbcl::sbcl-with-new-stepper-p)
+ (sb-ext:*stepper-hook*
+ (lambda (condition)
+ (typecase condition
+ (sb-ext:step-form-condition
+ (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
+ (sb-impl::invoke-debugger condition)))))))
+ (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p)
+ (sb-ext:step-condition #'sb-impl::invoke-stepper))
+ (call-with-break-hook hook fun))))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ "Return a list of frames starting with frame number START and
+continuing to frame number END or, if END is nil, the last frame on the
+stack."
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (sb-di:frame-down f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (sb-debug::print-frame-call frame stream))
+
+(defimplementation frame-restartable-p (frame)
+ #+#.(swank/sbcl::sbcl-with-restart-frame)
+ (not (null (sb-debug:frame-has-debug-tag-p frame))))
+
+(defimplementation frame-call (frame-number)
+ (multiple-value-bind (name args)
+ (sb-debug::frame-call (nth-frame frame-number))
+ (with-output-to-string (stream)
+ (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+ (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+ (let ((*print-length* nil)
+ (*print-level* nil))
+ (prin1 (sb-debug::ensure-printable-object name) stream))
+ (let ((args (sb-debug::ensure-printable-object args)))
+ (if (listp args)
+ (format stream "~{ ~_~S~}" args)
+ (format stream " ~S" args)))))))))
+
+;;;; Code-location -> source-location translation
+
+;;; If debug-block info is avaibale, we determine the file position of
+;;; the source-path for a code-location. If the code was compiled
+;;; with C-c C-c, we have to search the position in the source string.
+;;; If there's no debug-block info, we return the (less precise)
+;;; source-location of the corresponding function.
+
+(defun code-location-source-location (code-location)
+ (let* ((dsource (sb-di:code-location-debug-source code-location))
+ (plist (sb-c::debug-source-plist dsource))
+ (package (getf plist :emacs-package))
+ (*package* (or (and package
+ (find-package package))
+ *package*)))
+ (if (getf plist :emacs-buffer)
+ (emacs-buffer-source-location code-location plist)
+ #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
+ (ecase (sb-di:debug-source-from dsource)
+ (:file (file-source-location code-location))
+ (:lisp (lisp-source-location code-location)))
+ #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
+ (if (sb-di:debug-source-namestring dsource)
+ (file-source-location code-location)
+ (lisp-source-location code-location)))))
+
+;;; FIXME: The naming policy of source-location functions is a bit
+;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
+;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
+;;; which returns the source location for a _code-location_.
+;;;
+;;; Maybe these should be named code-location-file-source-location,
+;;; etc, turned into generic functions, or something. In the very
+;;; least the names should indicate the main entry point vs. helper
+;;; status.
+
+(defun file-source-location (code-location)
+ (if (code-location-has-debug-block-info-p code-location)
+ (source-file-source-location code-location)
+ (fallback-source-location code-location)))
+
+(defun fallback-source-location (code-location)
+ (let ((fun (code-location-debug-fun-fun code-location)))
+ (cond (fun (function-source-location fun))
+ (t (error "Cannot find source location for: ~A " code-location)))))
+
+(defun lisp-source-location (code-location)
+ (let ((source (prin1-to-string
+ (sb-debug::code-location-source-form code-location 100)))
+ (condition swank:*swank-debugger-condition*))
+ (if (and (typep condition 'sb-impl::step-form-condition)
+ (search "SB-IMPL::WITH-STEPPING-ENABLED" source
+ :test #'char-equal)
+ (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
+ ;; The initial form is utterly uninteresting -- and almost
+ ;; certainly right there in the REPL.
+ (make-error-location "Stepping...")
+ (make-location `(:source-form ,source) '(:position 1)))))
+
+(defun emacs-buffer-source-location (code-location plist)
+ (if (code-location-has-debug-block-info-p code-location)
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-string
+ &allow-other-keys)
+ plist
+ (let* ((pos (string-source-position code-location emacs-string))
+ (snipped (read-snippet-from-string emacs-string pos)))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:offset ,emacs-position ,pos)
+ `(:snippet ,snipped))))
+ (fallback-source-location code-location)))
+
+(defun source-file-source-location (code-location)
+ (let* ((code-date (code-location-debug-source-created code-location))
+ (filename (code-location-debug-source-name code-location))
+ (*readtable* (guess-readtable-for-filename filename))
+ (source-code (get-source-code filename code-date)))
+ (with-debootstrapping
+ (with-input-from-string (s source-code)
+ (let* ((pos (stream-source-position code-location s))
+ (snippet (read-snippet s pos)))
+ (make-location `(:file ,filename)
+ `(:position ,pos)
+ `(:snippet ,snippet)))))))
+
+(defun code-location-debug-source-name (code-location)
+ (namestring (truename (#.(swank/backend:choose-symbol
+ 'sb-c 'debug-source-name
+ 'sb-c 'debug-source-namestring)
+ (sb-di::code-location-debug-source code-location)))))
+
+(defun code-location-debug-source-created (code-location)
+ (sb-c::debug-source-created
+ (sb-di::code-location-debug-source code-location)))
+
+(defun code-location-debug-fun-fun (code-location)
+ (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
+
+(defun code-location-has-debug-block-info-p (code-location)
+ (handler-case
+ (progn (sb-di:code-location-debug-block code-location)
+ t)
+ (sb-di:no-debug-blocks () nil)))
+
+(defun stream-source-position (code-location stream)
+ (let* ((cloc (sb-debug::maybe-block-start-location code-location))
+ (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
+ (form-number (sb-di::code-location-form-number cloc)))
+ (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
+ (let* ((path-table (sb-di::form-number-translations tlf 0))
+ (path (cond ((<= (length path-table) form-number)
+ (warn "inconsistent form-number-translations")
+ (list 0))
+ (t
+ (reverse (cdr (aref path-table form-number)))))))
+ (source-path-source-position path tlf pos-map)))))
+
+(defun string-source-position (code-location string)
+ (with-input-from-string (s string)
+ (stream-source-position code-location s)))
+
+;;; source-path-file-position and friends are in source-path-parser
+
+(defimplementation frame-source-location (index)
+ (converting-errors-to-error-location
+ (code-location-source-location
+ (sb-di:frame-code-location (nth-frame index)))))
+
+(defvar *keep-non-valid-locals* nil)
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
+ (cond (*keep-non-valid-locals* all-vars)
+ (t (let ((loc (sb-di:frame-code-location frame)))
+ (remove-if (lambda (var)
+ (ecase (sb-di:debug-var-validity var loc)
+ (:valid nil)
+ ((:invalid :unknown) t)))
+ all-vars))))))
+
+(defun debug-var-value (var frame location)
+ (ecase (sb-di:debug-var-validity var location)
+ (:valid (sb-di:debug-var-value var frame))
+ ((:invalid :unknown) ':<not-available>)))
+
+(defun debug-var-info (var)
+ ;; Introduced by SBCL 1.0.49.76.
+ (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
+ (when (and s (fboundp s))
+ (funcall s var))))
+
+(defimplementation frame-locals (index)
+ (let* ((frame (nth-frame index))
+ (loc (sb-di:frame-code-location frame))
+ (vars (frame-debug-vars frame))
+ ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
+ ;; specially.
+ (more-name (or (find-symbol "MORE" :sb-debug) 'more))
+ (more-context nil)
+ (more-count nil)
+ (more-id 0))
+ (when vars
+ (let ((locals
+ (loop for v across vars
+ do (when (eq (sb-di:debug-var-symbol v) more-name)
+ (incf more-id))
+ (case (debug-var-info v)
+ (:more-context
+ (setf more-context (debug-var-value v frame loc)))
+ (:more-count
+ (setf more-count (debug-var-value v frame loc))))
+ collect
+ (list :name (sb-di:debug-var-symbol v)
+ :id (sb-di:debug-var-id v)
+ :value (debug-var-value v frame loc)))))
+ (when (and more-context more-count)
+ (setf locals (append locals
+ (list
+ (list :name more-name
+ :id more-id
+ :value (multiple-value-list
+ (sb-c:%more-arg-values
+ more-context
+ 0 more-count)))))))
+ locals))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (vars (frame-debug-vars frame))
+ (loc (sb-di:frame-code-location frame))
+ (dvar (if (= var (length vars))
+ ;; If VAR is out of bounds, it must be the fake var
+ ;; we made up for &MORE.
+ (let* ((context-var (find :more-context vars
+ :key #'debug-var-info))
+ (more-context (debug-var-value context-var frame
+ loc))
+ (count-var (find :more-count vars
+ :key #'debug-var-info))
+ (more-count (debug-var-value count-var frame loc)))
+ (return-from frame-var-value
+ (multiple-value-list (sb-c:%more-arg-values
+ more-context
+ 0 more-count))))
+ (aref vars var))))
+ (debug-var-value dvar frame loc)))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (sb-di:frame-catches (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+ (let ((frame (nth-frame index)))
+ (funcall (the function
+ (sb-di:preprocess-for-eval form
+ (sb-di:frame-code-location frame)))
+ frame)))
+
+(defimplementation frame-package (frame-number)
+ (let* ((frame (nth-frame frame-number))
+ (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
+ (when fun
+ (let ((name (function-name fun)))
+ (typecase name
+ (null nil)
+ (symbol (symbol-package name))
+ ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
+
+#+#.(swank/sbcl::sbcl-with-restart-frame)
+(progn
+ (defimplementation return-from-frame (index form)
+ (let* ((frame (nth-frame index)))
+ (cond ((sb-debug:frame-has-debug-tag-p frame)
+ (let ((values (multiple-value-list (eval-in-frame form index))))
+ (sb-debug:unwind-to-frame-and-call frame
+ (lambda ()
+ (values-list values)))))
+ (t (format nil "Cannot return from frame: ~S" frame)))))
+
+ (defimplementation restart-frame (index)
+ (let ((frame (nth-frame index)))
+ (when (sb-debug:frame-has-debug-tag-p frame)
+ (multiple-value-bind (fname args) (sb-debug::frame-call frame)
+ (multiple-value-bind (fun arglist)
+ (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
+ (values (fdefinition fname) args)
+ (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
+ (sb-debug::frame-args-as-list frame)))
+ (when (functionp fun)
+ (sb-debug:unwind-to-frame-and-call
+ frame
+ (lambda ()
+ ;; Ensure TCO.
+ (declare (optimize (debug 0)))
+ (apply fun arglist)))))))
+ (format nil "Cannot restart frame: ~S" frame))))
+
+;; FIXME: this implementation doesn't unwind the stack before
+;; re-invoking the function, but it's better than no implementation at
+;; all.
+#-#.(swank/sbcl::sbcl-with-restart-frame)
+(progn
+ (defun sb-debug-catch-tag-p (tag)
+ (and (symbolp tag)
+ (not (symbol-package tag))
+ (string= tag :sb-debug-catch-tag)))
+
+ (defimplementation return-from-frame (index form)
+ (let* ((frame (nth-frame index))
+ (probe (assoc-if #'sb-debug-catch-tag-p
+ (sb-di::frame-catches frame))))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame)))))
+
+ (defimplementation restart-frame (index)
+ (let ((frame (nth-frame index)))
+ (return-from-frame index (sb-debug::frame-call-as-list frame)))))
+
+;;;;; reference-conditions
+
+(defimplementation print-condition (condition stream)
+ (let ((sb-int:*print-condition-references* nil))
+ (princ condition stream)))
+
+
+;;;; Profiling
+
+(defimplementation profile (fname)
+ (when fname (eval `(sb-profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(sb-profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (sb-profile:unprofile)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (sb-profile:report))
+
+(defimplementation profile-reset ()
+ (sb-profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (sb-profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(sb-profile:profile ,(package-name (find-package package)))))
+
+
+;;;; Inspector
+
+(defmethod emacs-inspect ((o t))
+ (cond ((sb-di::indirect-value-cell-p o)
+ (label-value-line* (:value (sb-kernel:value-cell-ref o))))
+ (t
+ (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
+ (list* (string-right-trim '(#\Newline) text)
+ '(:newline)
+ (if label
+ (loop for (l . v) in parts
+ append (label-value-line l v))
+ (loop for value in parts
+ for i from 0
+ append (label-value-line i value))))))))
+
+(defmethod emacs-inspect ((o function))
+ (let ((header (sb-kernel:widetag-of o)))
+ (cond ((= header sb-vm:simple-fun-header-widetag)
+ (label-value-line*
+ (:name (sb-kernel:%simple-fun-name o))
+ (:arglist (sb-kernel:%simple-fun-arglist o))
+ (:self (sb-kernel:%simple-fun-self o))
+ (:next (sb-kernel:%simple-fun-next o))
+ (:type (sb-kernel:%simple-fun-type o))
+ (:code (sb-kernel:fun-code-header o))))
+ ((= header sb-vm:closure-header-widetag)
+ (append
+ (label-value-line :function (sb-kernel:%closure-fun o))
+ `("Closed over values:" (:newline))
+ (loop for i below (1- (sb-kernel:get-closure-length o))
+ append (label-value-line
+ i (sb-kernel:%closure-index-ref o i)))))
+ (t (call-next-method o)))))
+
+(defmethod emacs-inspect ((o sb-kernel:code-component))
+ (append
+ (label-value-line*
+ (:code-size (sb-kernel:%code-code-size o))
+ (:entry-points (sb-kernel:%code-entry-points o))
+ (:debug-info (sb-kernel:%code-debug-info o)))
+ `("Constants:" (:newline))
+ (loop for i from sb-vm:code-constants-offset
+ below
+ (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words
+ 'sb-kernel 'get-header-data)
+ o)
+ append (label-value-line i (sb-kernel:code-header-ref o i)))
+ `("Code:" (:newline)
+ , (with-output-to-string (s)
+ (cond ((sb-kernel:%code-debug-info o)
+ (sb-disassem:disassemble-code-component o :stream s))
+ (t
+ (sb-disassem:disassemble-memory
+ (sb-disassem::align
+ (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
+ sb-vm:lowtag-mask)
+ (* sb-vm:code-constants-offset
+ sb-vm:n-word-bytes))
+ (ash 1 sb-vm:n-lowtag-bits))
+ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
+ :stream s)))))))
+
+(defmethod emacs-inspect ((o sb-ext:weak-pointer))
+ (label-value-line*
+ (:value (sb-ext:weak-pointer-value o))))
+
+(defmethod emacs-inspect ((o sb-kernel:fdefn))
+ (label-value-line*
+ (:name (sb-kernel:fdefn-name o))
+ (:function (sb-kernel:fdefn-fun o))))
+
+(defmethod emacs-inspect :around ((o generic-function))
+ (append
+ (call-next-method)
+ (label-value-line*
+ (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
+ (:initial-methods (sb-pcl::generic-function-initial-methods o))
+ )))
+
+
+;;;; Multiprocessing
+
+#+(and sb-thread
+ #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD"))
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defvar *thread-id-counter-lock*
+ (sb-thread:make-mutex :name "thread id counter lock"))
+
+ (defun next-thread-id ()
+ (sb-thread:with-mutex (*thread-id-counter-lock*)
+ (incf *thread-id-counter*)))
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ ;; This should be a thread -> id map but as weak keys are not
+ ;; supported it is id -> map instead.
+ (defvar *thread-id-map-lock*
+ (sb-thread:make-mutex :name "thread id map lock"))
+
+ (defimplementation spawn (fn &key name)
+ (sb-thread:make-thread fn :name name))
+
+ (defimplementation thread-id (thread)
+ (block thread-id
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (loop for id being the hash-key in *thread-id-map*
+ using (hash-value thread-pointer)
+ do
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (cond ((null maybe-thread)
+ ;; the value is gc'd, remove it manually
+ (remhash id *thread-id-map*))
+ ((eq thread maybe-thread)
+ (return-from thread-id id)))))
+ ;; lazy numbering
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
+ id))))
+
+ (defimplementation find-thread (id)
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (let ((thread-pointer (gethash id *thread-id-map*)))
+ (if thread-pointer
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (if maybe-thread
+ maybe-thread
+ ;; the value is gc'd, remove it manually
+ (progn
+ (remhash id *thread-id-map*)
+ nil)))
+ nil))))
+
+ (defimplementation thread-name (thread)
+ ;; sometimes the name is not a string (e.g. NIL)
+ (princ-to-string (sb-thread:thread-name thread)))
+
+ (defimplementation thread-status (thread)
+ (if (sb-thread:thread-alive-p thread)
+ "Running"
+ "Stopped"))
+
+ (defimplementation make-lock (&key name)
+ (sb-thread:make-mutex :name name))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (sb-thread:with-recursive-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ sb-thread:*current-thread*)
+
+ (defimplementation all-threads ()
+ (sb-thread:list-all-threads))
+
+ (defimplementation interrupt-thread (thread fn)
+ (sb-thread:interrupt-thread thread fn))
+
+ (defimplementation kill-thread (thread)
+ (sb-thread:terminate-thread thread))
+
+ (defimplementation thread-alive-p (thread)
+ (sb-thread:thread-alive-p thread))
+
+ (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
+ (defvar *mailboxes* (list))
+ (declaim (type list *mailboxes*))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (mutex (sb-thread:make-mutex))
+ (waitqueue (sb-thread:make-waitqueue))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (sb-thread:with-mutex (*mailbox-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))
+ (mutex (mailbox.mutex mbox)))
+ (sb-thread:with-mutex (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
+
+
+ (defun condition-timed-wait (waitqueue mutex timeout)
+ (macrolet ((foo ()
+ (cond ((member :sb-lutex *features*) ; Darwin
+ '(sb-thread:condition-wait waitqueue mutex))
+ (t
+ '(handler-case
+ (let ((*break-on-signals* nil))
+ (sb-sys:with-deadline (:seconds timeout
+ :override t)
+ (sb-thread:condition-wait waitqueue mutex) t))
+ (sb-ext:timeout ()
+ nil))))))
+ (foo)))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox))
+ (waitq (mailbox.waitqueue mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (sb-thread:with-mutex (mutex)
+ (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)))
+ (condition-timed-wait waitq mutex 0.2)))))
+
+ (let ((alist '())
+ (mutex (sb-thread:make-mutex :name "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (sb-thread:with-mutex (mutex)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (sb-thread:thread
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (sb-thread:with-mutex (mutex)
+ (cdr (assoc name alist)))))
+
+ ;; Workaround for deadlocks between the world-lock and auto-flush-thread
+ ;; buffer write lock.
+ ;;
+ ;; Another alternative would be to grab the world-lock here, but that's less
+ ;; future-proof, and could introduce other lock-ordering issues in the
+ ;; future.
+ ;;
+ ;; In an ideal world we would just have an :AROUND method on
+ ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
+ ;; file is loaded -- so first we need a dummy definition that will be
+ ;; overridden by swank-gray.lisp.
+ #.(unless (find-package 'swank/gray) (make-package 'swank/gray) nil)
+ (eval-when (:load-toplevel :execute)
+ (unless (find-package 'swank/gray) (make-package 'swank/gray) nil))
+ (defclass swank/gray::slime-output-stream
+ (sb-gray:fundamental-character-output-stream)
+ ())
+ (defmethod sb-gray:stream-force-output
+ :around ((stream swank/gray::slime-output-stream))
+ (handler-case
+ (sb-sys:with-deadline (:seconds 0.1)
+ (call-next-method))
+ (sb-sys:deadline-timeout ()
+ nil)))
+ )
+
+(defimplementation quit-lisp ()
+ #+#.(swank/backend:with-symbol 'exit 'sb-ext)
+ (sb-ext:exit)
+ #-#.(swank/backend:with-symbol 'exit 'sb-ext)
+ (progn
+ #+sb-thread
+ (dolist (thread (remove (current-thread) (all-threads)))
+ (ignore-errors (sb-thread:terminate-thread thread)))
+ (sb-ext:quit)))
+
+
+
+;;Trace implementations
+;;In SBCL, we have:
+;; (trace <name>)
+;; (trace :methods '<name>) ;to trace all methods of the gf <name>
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; <name> can be a normal name or a (setf name)
+
+(defun toggle-trace-aux (fspec &rest args)
+ (cond ((member fspec (eval '(trace)) :test #'equal)
+ (eval `(untrace ,fspec))
+ (format nil "~S is now untraced." fspec))
+ (t
+ (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
+ (format nil "~S is now traced." fspec))))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod) `(method ,@(rest fspec)))
+ ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
+ (t
+ fspec)))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defmethod)
+ (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
+ ((:defgeneric)
+ (toggle-trace-aux (second spec) :methods t))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table :weakness :key args)
+ #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table :weakness :value args)
+ #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table args))
+
+(defimplementation hash-table-weakness (hashtable)
+ #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
+ (sb-ext:hash-table-weakness hashtable))
+
+#-win32
+(defimplementation save-image (filename &optional restart-function)
+ (flet ((restart-sbcl ()
+ (sb-debug::enable-debugger)
+ (setf sb-impl::*descriptor-handlers* nil)
+ (funcall restart-function)))
+ (let ((pid (sb-posix:fork)))
+ (cond ((= pid 0)
+ (sb-debug::disable-debugger)
+ (apply #'sb-ext:save-lisp-and-die filename
+ (when restart-function
+ (list :toplevel #'restart-sbcl))))
+ (t
+ (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
+ (assert (= pid rpid))
+ (assert (and (sb-posix:wifexited status)
+ (zerop (sb-posix:wexitstatus status))))))))))
+
+#+unix
+(progn
+ (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
+ (program sb-alien:c-string)
+ (argv (* sb-alien:c-string)))
+
+ (defun execv (program args)
+ "Replace current executable with another one."
+ (let ((a-args (sb-alien:make-alien sb-alien:c-string
+ (+ 1 (length args)))))
+ (unwind-protect
+ (progn
+ (loop for index from 0 by 1
+ and item in (append args '(nil))
+ do (setf (sb-alien:deref a-args index)
+ item))
+ (when (minusp
+ (sys-execv program a-args))
+ (error "execv(3) returned.")))
+ (sb-alien:free-alien a-args))))
+
+ (defun runtime-pathname ()
+ #+#.(swank/backend:with-symbol
+ '*runtime-pathname* 'sb-ext)
+ sb-ext:*runtime-pathname*
+ #-#.(swank/backend:with-symbol
+ '*runtime-pathname* 'sb-ext)
+ (car sb-ext:*posix-argv*))
+
+ (defimplementation exec-image (image-file args)
+ (loop with fd-arg =
+ (loop for arg in args
+ and key = "" then arg
+ when (string-equal key "--swank-fd")
+ return (parse-integer arg))
+ for my-fd from 3 to 1024
+ when (/= my-fd fd-arg)
+ do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
+ (let* ((self-string (pathname-to-filename (runtime-pathname))))
+ (execv
+ self-string
+ (apply 'list self-string "--core" image-file args)))))
+
+(defimplementation make-fd-stream (fd external-format)
+ (sb-sys:make-fd-stream fd :input t :output t
+ :element-type 'character
+ :buffering :full
+ :dual-channel-p t
+ :external-format external-format))
+
+#-win32
+(defimplementation background-save-image (filename &key restart-function
+ completion-function)
+ (flet ((restart-sbcl ()
+ (sb-debug::enable-debugger)
+ (setf sb-impl::*descriptor-handlers* nil)
+ (funcall restart-function)))
+ (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
+ (let ((pid (sb-posix:fork)))
+ (cond ((= pid 0)
+ (sb-posix:close pipe-in)
+ (sb-debug::disable-debugger)
+ (apply #'sb-ext:save-lisp-and-die filename
+ (when restart-function
+ (list :toplevel #'restart-sbcl))))
+ (t
+ (sb-posix:close pipe-out)
+ (sb-sys:add-fd-handler
+ pipe-in :input
+ (lambda (fd)
+ (sb-sys:invalidate-descriptor fd)
+ (sb-posix:close fd)
+ (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
+ (assert (= pid rpid))
+ (assert (sb-posix:wifexited status))
+ (funcall completion-function
+ (zerop (sb-posix:wexitstatus status))))))))))))
+
+(pushnew 'deinit-log-output sb-ext:*save-hooks*)
+
+
+;;;; wrap interface implementation
+
+(defun sbcl-version>= (&rest subversions)
+ #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
+ (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t))
+ #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
+ nil)
+
+(defimplementation wrap (spec indicator &key before after replace)
+ (when (wrapped-p spec indicator)
+ (warn "~a already wrapped with indicator ~a, unwrapping first"
+ spec indicator)
+ (sb-int:unencapsulate spec indicator))
+ (sb-int:encapsulate spec indicator
+ #-#.(swank/backend:with-symbol 'arg-list 'sb-int)
+ (lambda (function &rest args)
+ (sbcl-wrap spec before after replace function args))
+ #+#.(swank/backend:with-symbol 'arg-list 'sb-int)
+ (if (sbcl-version>= 1 1 16)
+ (lambda ()
+ (sbcl-wrap spec before after replace
+ (symbol-value 'sb-int:basic-definition)
+ (symbol-value 'sb-int:arg-list)))
+ `(sbcl-wrap ',spec ,before ,after ,replace
+ (symbol-value 'sb-int:basic-definition)
+ (symbol-value 'sb-int:arg-list)))))
+
+(defimplementation unwrap (spec indicator)
+ (sb-int:unencapsulate spec indicator))
+
+(defimplementation wrapped-p (spec indicator)
+ (sb-int:encapsulated-p spec indicator))
+
+(defun sbcl-wrap (spec before after replace function args)
+ (declare (ignore spec))
+ (let (retlist completed)
+ (unwind-protect
+ (progn
+ (when before
+ (funcall before args))
+ (setq retlist (multiple-value-list (if replace
+ (funcall replace
+ args)
+ (apply function args))))
+ (setq completed t)
+ (values-list retlist))
+ (when after
+ (funcall after (if completed retlist :exited-non-locally))))))
+
+#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl)
+(progn
+ (defmethod sexp-in-bounds-p ((s sb-impl::comma) i)
+ (= i 1))
+
+ (defmethod sexp-ref ((s sb-impl::comma) i)
+ (sb-impl::comma-expr s)))
diff --git a/vim/bundle/slimv/slime/swank/scl.lisp b/vim/bundle/slimv/slime/swank/scl.lisp
new file mode 100644
index 0000000..7327133
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/scl.lisp
@@ -0,0 +1,1726 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; Scieneer Common Lisp code for SLIME.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/scl
+ (:use cl swank/backend swank/source-path-parser swank/source-file-cache))
+
+(in-package swank/scl)
+
+
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+
+;;;; TCP server
+;;;
+;;; SCL only supports the :spawn communication style.
+;;;
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((addr (resolve-hostname host)))
+ (ext:create-inet-listener port :stream :host addr :reuse-address t
+ :backlog (or backlog 5))))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (ext:close-socket (socket-fd socket)))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (let ((buffering (or buffering :full))
+ (fd (socket-fd socket)))
+ (loop
+ (let ((ready (sys:wait-until-fd-usable fd :input timeout)))
+ (unless ready
+ (error "Timeout accepting connection on socket: ~S~%" socket)))
+ (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
+ (when new-fd
+ (return (make-socket-io-stream new-fd external-format
+ (ecase buffering
+ ((t) :full)
+ ((nil) :none)
+ (:line :line)))))))))
+
+(defimplementation set-stream-timeout (stream timeout)
+ (check-type timeout (or null real))
+ (if (fboundp 'ext::stream-timeout)
+ (setf (ext::stream-timeout stream) timeout)
+ (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout)
+ timeout)))
+
+;;;;; Sockets
+
+(defun socket-fd (socket)
+ "Return the file descriptor for the socket represented by 'socket."
+ (etypecase socket
+ (fixnum socket)
+ (stream (sys:fd-stream-fd socket))))
+
+(defun resolve-hostname (hostname)
+ "Return the IP address of 'hostname as an integer (in host byte-order)."
+ (let ((hostent (ext:lookup-host-entry hostname)))
+ (car (ext:host-entry-addr-list hostent))))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (fd external-format buffering)
+ "Create a new input/output fd-stream for 'fd."
+ (cond ((not external-format)
+ (sys:make-fd-stream fd :input t :output t :buffering buffering
+ :element-type '(unsigned-byte 8)))
+ (t
+ (let* ((stream (sys:make-fd-stream fd :input t :output t
+ :element-type 'base-char
+ :buffering buffering
+ :external-format external-format)))
+ ;; Ignore character conversion errors. Without this the
+ ;; communication channel is prone to lockup if a character
+ ;; conversion error occurs.
+ (setf (lisp::character-conversion-stream-input-error-value stream)
+ #\?)
+ (setf (lisp::character-conversion-stream-output-error-value stream)
+ #\?)
+ stream))))
+
+
+;;;; Stream handling
+
+(defimplementation gray-package-name ()
+ '#:ext)
+
+
+;;;; Compilation Commands
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *buffer-name* nil
+ "The name of the Emacs buffer we are compiling from.
+ Nil if we aren't compiling from a buffer.")
+
+(defvar *buffer-start-position* nil)
+(defvar *buffer-substring* nil)
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((*previous-compiler-condition* nil)
+ (*previous-context* nil)
+ (*print-readably* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (compile-file input-file
+ :output-file output-file
+ :external-format external-format)
+ (values output-file warnings-p
+ (or failure-p
+ (when load-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get input-file
+ (file-write-date input-file))
+ (not (load output-file)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-substring* string))
+ (with-input-from-string (stream string)
+ (ext:compile-from-stream
+ stream
+ :source-info `(:emacs-buffer ,buffer
+ :emacs-buffer-offset ,position
+ :emacs-buffer-string ,string))))))
+
+
+;;;;; Trapping notes
+;;;
+;;; We intercept conditions from the compiler and resignal them as
+;;; `swank:compiler-condition's.
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (unless (eq condition *previous-compiler-condition*)
+ (let ((context (c::find-error-context nil)))
+ (setq *previous-compiler-condition* condition)
+ (setq *previous-context* context)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :message (brief-compiler-message-for-emacs condition)
+ :source-context (compiler-error-context context)
+ :location (if (read-error-p condition)
+ (read-error-location condition)
+ (compiler-note-location context))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of 'condition."
+ (etypecase condition
+ ((satisfies read-error-p) :read-error)
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun read-error-p (condition)
+ (eq (type-of condition) 'c::compiler-read-error))
+
+(defun brief-compiler-message-for-emacs (condition)
+ "Briefly describe a compiler error for Emacs.
+ When Emacs presents the message it already has the source popped up
+ and the source form highlighted. This makes much of the information in
+ the error-context redundant."
+ (princ-to-string condition))
+
+(defun compiler-error-context (error-context)
+ "Describe a compiler error for Emacs including context information."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (c::compiler-error-context-enclosing-source error-context)
+ (c::compiler-error-context-source error-context)))
+ (if (and enclosing source)
+ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]"
+ enclosing source))))
+
+(defun read-error-location (condition)
+ (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
+ (file (c::file-info-name finfo))
+ (pos (c::compiler-read-error-position condition)))
+ (cond ((and (eq file :stream) *buffer-name*)
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* pos)))
+ ((and (pathnamep file) (not *buffer-name*))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ pos))))
+ (t (break)))))
+
+(defun compiler-note-location (context)
+ "Derive the location of a complier message from its context.
+ Return a `location' record, or (:error <reason>) on failure."
+ (if (null context)
+ (note-error-location)
+ (let ((file (c::compiler-error-context-file-name context))
+ (source (c::compiler-error-context-original-source context))
+ (path
+ (reverse
+ (c::compiler-error-context-original-source-path context))))
+ (or (locate-compiler-note file source path)
+ (note-error-location)))))
+
+(defun note-error-location ()
+ "Pseudo-location for notes that can't be located."
+ (list :error "No error location available."))
+
+(defun locate-compiler-note (file source source-path)
+ (cond ((and (eq file :stream) *buffer-name*)
+ ;; Compiling from a buffer
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; No location known, but we have the source form.
+ ;; XXX How is this case triggered? -luke (16/May/2004)
+ ;; This can happen if the compiler needs to expand a macro
+ ;; but the macro-expander is not yet compiled. Calling the
+ ;; (interpreted) macro-expander triggers IR1 conversion of
+ ;; the lambda expression for the expander and invokes the
+ ;; compiler recursively.
+ (make-location (list :source-form source)
+ (list :position 1)))))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+
+;;; TODO
+(defimplementation who-calls (name) nil)
+(defimplementation who-references (name) nil)
+(defimplementation who-binds (name) nil)
+(defimplementation who-sets (name) nil)
+(defimplementation who-specializes (symbol) nil)
+(defimplementation who-macroexpands (name) nil)
+
+
+;;;; Find callers and callees
+;;;
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(declaim (inline map-code-constants))
+(defun map-code-constants (code fn)
+ "Call 'fn for each constant in 'code's constant pool."
+ (check-type code kernel:code-component)
+ (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
+ do (funcall fn (kernel:code-header-ref code i))))
+
+(defun function-callees (function)
+ "Return 'function's callees as a list of functions."
+ (let ((callees '()))
+ (map-code-constants
+ (vm::find-code-object function)
+ (lambda (obj)
+ (when (kernel:fdefn-p obj)
+ (push (kernel:fdefn-function obj) callees))))
+ callees))
+
+(declaim (ext:maybe-inline map-allocated-code-components))
+(defun map-allocated-code-components (spaces fn)
+ "Call FN for each allocated code component in one of 'spaces. FN
+ receives the object as argument. 'spaces should be a list of the
+ symbols :dynamic, :static, or :read-only."
+ (dolist (space spaces)
+ (declare (inline vm::map-allocated-objects)
+ (optimize (ext:inhibit-warnings 3)))
+ (vm::map-allocated-objects
+ (lambda (obj header size)
+ (declare (type fixnum size) (ignore size))
+ (when (= vm:code-header-type header)
+ (funcall fn obj)))
+ space)))
+
+(declaim (ext:maybe-inline map-caller-code-components))
+(defun map-caller-code-components (function spaces fn)
+ "Call 'fn for each code component with a fdefn for 'function in its
+ constant pool."
+ (let ((function (coerce function 'function)))
+ (declare (inline map-allocated-code-components))
+ (map-allocated-code-components
+ spaces
+ (lambda (obj)
+ (map-code-constants
+ obj
+ (lambda (constant)
+ (when (and (kernel:fdefn-p constant)
+ (eq (kernel:fdefn-function constant)
+ function))
+ (funcall fn obj))))))))
+
+(defun function-callers (function &optional (spaces '(:read-only :static
+ :dynamic)))
+ "Return 'function's callers. The result is a list of code-objects."
+ (let ((referrers '()))
+ (declare (inline map-caller-code-components))
+ (map-caller-code-components function spaces
+ (lambda (code) (push code referrers)))
+ referrers))
+
+(defun debug-info-definitions (debug-info)
+ "Return the defintions for a debug-info. This should only be used
+ for code-object without entry points, i.e., byte compiled
+ code (are theree others?)"
+ ;; This mess has only been tested with #'ext::skip-whitespace, a
+ ;; byte-compiled caller of #'read-char .
+ (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
+ (let ((name (c::debug-info-name debug-info))
+ (source (c::debug-info-source debug-info)))
+ (destructuring-bind (first) source
+ (ecase (c::debug-source-from first)
+ (:file
+ (list (list name
+ (make-location
+ (list :file (unix-truename (c::debug-source-name first)))
+ (list :function-name (string name))))))))))
+
+(defun valid-function-name-p (name)
+ (or (symbolp name) (and (consp name)
+ (eq (car name) 'setf)
+ (symbolp (cadr name))
+ (not (cddr name)))))
+
+(defun code-component-entry-points (code)
+ "Return a list ((name location) ...) of function definitons for
+ the code omponent 'code."
+ (let ((names '()))
+ (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
+ ((not f))
+ (let ((name (kernel:%function-name f)))
+ (when (valid-function-name-p name)
+ (push (list name (function-location f)) names))))
+ names))
+
+(defimplementation list-callers (symbol)
+ "Return a list ((name location) ...) of callers."
+ (let ((components (function-callers symbol))
+ (xrefs '()))
+ (dolist (code components)
+ (let* ((entry (kernel:%code-entry-points code))
+ (defs (if entry
+ (code-component-entry-points code)
+ ;; byte compiled stuff
+ (debug-info-definitions
+ (kernel:%code-debug-info code)))))
+ (setq xrefs (nconc defs xrefs))))
+ xrefs))
+
+(defimplementation list-callees (symbol)
+ (let ((fns (function-callees symbol)))
+ (mapcar (lambda (fn)
+ (list (kernel:%function-name fn)
+ (function-location fn)))
+ fns)))
+
+
+;;;; Resolving source locations
+;;;
+;;; Our mission here is to "resolve" references to code locations into
+;;; actual file/buffer names and character positions. The references
+;;; we work from come out of the compiler's statically-generated debug
+;;; information, such as `code-location''s and `debug-source''s. For
+;;; more details, see the "Debugger Programmer's Interface" section of
+;;; the SCL manual.
+;;;
+;;; The first step is usually to find the corresponding "source-path"
+;;; for the location. Once we have the source-path we can pull up the
+;;; source file and `READ' our way through to the right position. The
+;;; main source-code groveling work is done in
+;;; `source-path-parser.lisp'.
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+ This is useful when debugging the definition-finding code.")
+
+(defmacro safe-definition-finding (&body body)
+ "Execute 'body and return the source-location it returns.
+ If an error occurs and `*debug-definition-finding*' is false, then
+ return an error pseudo-location.
+
+ The second return value is 'nil if no error occurs, otherwise it is the
+ condition object."
+ `(flet ((body () ,@body))
+ (if *debug-definition-finding*
+ (body)
+ (handler-case (values (progn ,@body) nil)
+ (error (c) (values (list :error (princ-to-string c)) c))))))
+
+(defun code-location-source-location (code-location)
+ "Safe wrapper around `code-location-from-source-location'."
+ (safe-definition-finding
+ (source-location-from-code-location code-location)))
+
+(defun source-location-from-code-location (code-location)
+ "Return the source location for 'code-location."
+ (let ((debug-fun (di:code-location-debug-function code-location)))
+ (when (di::bogus-debug-function-p debug-fun)
+ ;; Those lousy cheapskates! They've put in a bogus debug source
+ ;; because the code was compiled at a low debug setting.
+ (error "Bogus debug function: ~A" debug-fun)))
+ (let* ((debug-source (di:code-location-debug-source code-location))
+ (from (di:debug-source-from debug-source))
+ (name (di:debug-source-name debug-source)))
+ (ecase from
+ (:file
+ (location-in-file name code-location debug-source))
+ (:stream
+ (location-in-stream code-location debug-source))
+ (:lisp
+ ;; The location comes from a form passed to `compile'.
+ ;; The best we can do is return the form itself for printing.
+ (make-location
+ (list :source-form (with-output-to-string (*standard-output*)
+ (debug::print-code-location-source-form
+ code-location 100 t)))
+ (list :position 1))))))
+
+(defun location-in-file (filename code-location debug-source)
+ "Resolve the source location for 'code-location in 'filename."
+ (let* ((code-date (di:debug-source-created debug-source))
+ (source-code (get-source-code filename code-date)))
+ (with-input-from-string (s source-code)
+ (make-location (list :file (unix-truename filename))
+ (list :position (1+ (code-location-stream-position
+ code-location s)))
+ `(:snippet ,(read-snippet s))))))
+
+(defun location-in-stream (code-location debug-source)
+ "Resolve the source location for a 'code-location from a stream.
+ This only succeeds if the code was compiled from an Emacs buffer."
+ (unless (debug-source-info-from-emacs-buffer-p debug-source)
+ (error "The code is compiled from a non-SLIME stream."))
+ (let* ((info (c::debug-source-info debug-source))
+ (string (getf info :emacs-buffer-string))
+ (position (code-location-string-offset
+ code-location
+ string)))
+ (make-location
+ (list :buffer (getf info :emacs-buffer))
+ (list :offset (getf info :emacs-buffer-offset) position)
+ (list :snippet (with-input-from-string (s string)
+ (file-position s position)
+ (read-snippet s))))))
+
+;;;;; Function-name locations
+;;;
+(defun debug-info-function-name-location (debug-info)
+ "Return a function-name source-location for 'debug-info.
+ Function-name source-locations are a fallback for when precise
+ positions aren't available."
+ (with-struct (c::debug-info- (fname name) source) debug-info
+ (with-struct (c::debug-source- info from name) (car source)
+ (ecase from
+ (:file
+ (make-location (list :file (namestring (truename name)))
+ (list :function-name (string fname))))
+ (:stream
+ (assert (debug-source-info-from-emacs-buffer-p (car source)))
+ (make-location (list :buffer (getf info :emacs-buffer))
+ (list :function-name (string fname))))
+ (:lisp
+ (make-location (list :source-form (princ-to-string (aref name 0)))
+ (list :position 1)))))))
+
+(defun debug-source-info-from-emacs-buffer-p (debug-source)
+ "Does the `info' slot of 'debug-source contain an Emacs buffer location?
+ This is true for functions that were compiled directly from buffers."
+ (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
+
+(defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info))))
+
+
+;;;;; Groveling source-code for positions
+
+(defun code-location-stream-position (code-location stream)
+ "Return the byte offset of 'code-location in 'stream. Extract the
+ toplevel-form-number and form-number from 'code-location and use that
+ to find the position of the corresponding form.
+
+ Finish with 'stream positioned at the start of the code location."
+ (let* ((location (debug::maybe-block-start-location code-location))
+ (tlf-offset (di:code-location-top-level-form-offset location))
+ (form-number (di:code-location-form-number location)))
+ (let ((pos (form-number-stream-position tlf-offset form-number stream)))
+ (file-position stream pos)
+ pos)))
+
+(defun form-number-stream-position (tlf-number form-number stream)
+ "Return the starting character position of a form in 'stream.
+ 'tlf-number is the top-level-form number.
+ 'form-number is an index into a source-path table for the TLF."
+ (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
+ (let* ((path-table (di:form-number-translations tlf 0))
+ (source-path
+ (if (<= (length path-table) form-number) ; source out of sync?
+ (list 0) ; should probably signal a condition
+ (reverse (cdr (aref path-table form-number))))))
+ (source-path-source-position source-path tlf position-map))))
+
+(defun code-location-string-offset (code-location string)
+ "Return the byte offset of 'code-location in 'string.
+ See 'code-location-stream-position."
+ (with-input-from-string (s string)
+ (code-location-stream-position code-location s)))
+
+
+;;;; Finding definitions
+
+;;; There are a great many different types of definition for us to
+;;; find. We search for definitions of every kind and return them in a
+;;; list.
+
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (setf-definitions name)
+ (variable-definitions name)
+ (class-definitions name)
+ (type-definitions name)
+ (compiler-macro-definitions name)
+ (source-transform-definitions name)
+ (function-info-definitions name)
+ (ir1-translator-definitions name)))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; SCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the SCL manual for more details.
+
+(defun function-definitions (name)
+ "Return definitions for 'name in the \"function namespace\", i.e.,
+ regular functions, generic functions, methods and macros.
+ 'name can any valid function name (e.g, (setf car))."
+ (let ((macro? (and (symbolp name) (macro-function name)))
+ (special? (and (symbolp name) (special-operator-p name)))
+ (function? (and (valid-function-name-p name)
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
+ (cond (macro?
+ (list `((defmacro ,name)
+ ,(function-location (macro-function name)))))
+ (special?
+ (list `((:special-operator ,name)
+ (:error ,(format nil "Special operator: ~S" name)))))
+ (function?
+ (let ((function (fdefinition name)))
+ (if (genericp function)
+ (generic-function-definitions name function)
+ (list (list `(function ,name)
+ (function-location function)))))))))
+
+;;;;;; Ordinary (non-generic/macro/special) functions
+;;;
+;;; First we test if FUNCTION is a closure created by defstruct, and
+;;; if so extract the defstruct-description (`dd') from the closure
+;;; and find the constructor for the struct. Defstruct creates a
+;;; defun for the default constructor and we use that as an
+;;; approximation to the source location of the defstruct.
+;;;
+;;; For an ordinary function we return the source location of the
+;;; first code-location we find.
+;;;
+(defun function-location (function)
+ "Return the source location for FUNCTION."
+ (cond ((struct-closure-p function)
+ (struct-closure-location function))
+ ((c::byte-function-or-closure-p function)
+ (byte-function-location function))
+ (t
+ (compiled-function-location function))))
+
+(defun compiled-function-location (function)
+ "Return the location of a regular compiled function."
+ (multiple-value-bind (code-location error)
+ (safe-definition-finding (function-first-code-location function))
+ (cond (error (list :error (princ-to-string error)))
+ (t (code-location-source-location code-location)))))
+
+(defun function-first-code-location (function)
+ "Return the first code-location we can find for 'function."
+ (and (function-has-debug-function-p function)
+ (di:debug-function-start-location
+ (di:function-debug-function function))))
+
+(defun function-has-debug-function-p (function)
+ (di:function-debug-function function))
+
+(defun function-code-object= (closure function)
+ (and (eq (vm::find-code-object closure)
+ (vm::find-code-object function))
+ (not (eq closure function))))
+
+
+(defun byte-function-location (fn)
+ "Return the location of the byte-compiled function 'fn."
+ (etypecase fn
+ ((or c::hairy-byte-function c::simple-byte-function)
+ (let* ((component (c::byte-function-component fn))
+ (debug-info (kernel:%code-debug-info component)))
+ (debug-info-function-name-location debug-info)))
+ (c::byte-closure
+ (byte-function-location (c::byte-closure-function fn)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in SCL. A `dd' describes a
+;;; `defstruct''d structure.
+
+(defun struct-closure-p (function)
+ "Is 'function a closure created by defstruct?"
+ (or (function-code-object= function #'kernel::structure-slot-accessor)
+ (function-code-object= function #'kernel::structure-slot-setter)
+ (function-code-object= function #'kernel::%defstruct)))
+
+(defun struct-closure-location (function)
+ "Return the location of the structure that 'function belongs to."
+ (assert (struct-closure-p function))
+ (safe-definition-finding
+ (dd-location (struct-closure-dd function))))
+
+(defun struct-closure-dd (function)
+ "Return the defstruct-definition (dd) of FUNCTION."
+ (assert (= (kernel:get-type function) vm:closure-header-type))
+ (flet ((find-layout (function)
+ (sys:find-if-in-closure
+ (lambda (x)
+ (let ((value (if (di::indirect-value-cell-p x)
+ (c:value-cell-ref x)
+ x)))
+ (when (kernel::layout-p value)
+ (return-from find-layout value))))
+ function)))
+ (kernel:layout-info (find-layout function))))
+
+(defun dd-location (dd)
+ "Return the location of a `defstruct'."
+ ;; Find the location in a constructor.
+ (function-location (struct-constructor dd)))
+
+(defun struct-constructor (dd)
+ "Return a constructor function from a defstruct definition.
+Signal an error if no constructor can be found."
+ (let ((constructor (or (kernel:dd-default-constructor dd)
+ (car (kernel::dd-constructors dd)))))
+ (when (or (null constructor)
+ (and (consp constructor) (null (car constructor))))
+ (error "Cannot find structure's constructor: ~S"
+ (kernel::dd-name dd)))
+ (coerce (if (consp constructor) (first constructor) constructor)
+ 'function)))
+
+;;;;;; Generic functions and methods
+
+(defun generic-function-definitions (name function)
+ "Return the definitions of a generic function and its methods."
+ (cons (list `(defgeneric ,name) (gf-location function))
+ (gf-method-definitions function)))
+
+(defun gf-location (gf)
+ "Return the location of the generic function GF."
+ (definition-source-location gf (clos:generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+ "Return the locations of all methods of the generic function GF."
+ (mapcar #'method-definition (clos:generic-function-methods gf)))
+
+(defun method-definition (method)
+ (list (method-dspec method)
+ (method-location method)))
+
+(defun method-dspec (method)
+ "Return a human-readable \"definition specifier\" for METHOD."
+ (let* ((gf (clos:method-generic-function method))
+ (name (clos:generic-function-name gf))
+ (specializers (clos:method-specializers method))
+ (qualifiers (clos:method-qualifiers method)))
+ `(method ,name ,@qualifiers ,specializers
+ #+nil (clos::unparse-specializers specializers))))
+
+;; XXX maybe special case setters/getters
+(defun method-location (method)
+ (function-location (clos:method-function method)))
+
+(defun genericp (fn)
+ (typep fn 'generic-function))
+
+;;;;;; Types and classes
+
+(defun type-definitions (name)
+ "Return `deftype' locations for type NAME."
+ (maybe-make-definition (ext:info :type :expander name) 'deftype name))
+
+(defun maybe-make-definition (function kind name)
+ "If FUNCTION is non-nil then return its definition location."
+ (if function
+ (list (list `(,kind ,name) (function-location function)))))
+
+(defun class-definitions (name)
+ "Return the definition locations for the class called NAME."
+ (if (symbolp name)
+ (let ((class (find-class name nil)))
+ (etypecase class
+ (null '())
+ (structure-class
+ (list (list `(defstruct ,name)
+ (dd-location (find-dd name)))))
+ (standard-class
+ (list (list `(defclass ,name)
+ (class-location (find-class name)))))
+ ((or built-in-class
+ kernel:funcallable-structure-class)
+ (list (list `(kernel::define-type-class ,name)
+ `(:error
+ ,(format nil "No source info for ~A" name)))))))))
+
+(defun class-location (class)
+ "Return the `defclass' location for CLASS."
+ (definition-source-location class (class-name class)))
+
+(defun find-dd (name)
+ "Find the defstruct-definition by the name of its structure-class."
+ (let ((layout (ext:info :type :compiler-layout name)))
+ (if layout
+ (kernel:layout-info layout))))
+
+(defun condition-class-location (class)
+ (let ((name (class-name class)))
+ `(:error ,(format nil "No location info for condition: ~A" name))))
+
+(defun make-name-in-file-location (file string)
+ (multiple-value-bind (filename c)
+ (ignore-errors
+ (unix-truename (merge-pathnames (make-pathname :type "lisp")
+ file)))
+ (cond (filename (make-location `(:file ,filename)
+ `(:function-name ,(string string))))
+ (t (list :error (princ-to-string c))))))
+
+(defun definition-source-location (object name)
+ `(:error ,(format nil "No source info for: ~A" object)))
+
+(defun setf-definitions (name)
+ (let ((function (or (ext:info :setf :inverse name)
+ (ext:info :setf :expander name))))
+ (if function
+ (list (list `(setf ,name)
+ (function-location (coerce function 'function)))))))
+
+
+(defun variable-location (symbol)
+ `(:error ,(format nil "No source info for variable ~S" symbol)))
+
+(defun variable-definitions (name)
+ (if (symbolp name)
+ (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
+ (if recorded-p
+ (list (list `(variable ,kind ,name)
+ (variable-location name)))))))
+
+(defun compiler-macro-definitions (symbol)
+ (maybe-make-definition (compiler-macro-function symbol)
+ 'define-compiler-macro
+ symbol))
+
+(defun source-transform-definitions (name)
+ (maybe-make-definition (ext:info :function :source-transform name)
+ 'c:def-source-transform
+ name))
+
+(defun function-info-definitions (name)
+ (let ((info (ext:info :function :info name)))
+ (if info
+ (append (loop for transform in (c::function-info-transforms info)
+ collect (list `(c:deftransform ,name
+ ,(c::type-specifier
+ (c::transform-type transform)))
+ (function-location (c::transform-function
+ transform))))
+ (maybe-make-definition (c::function-info-derive-type info)
+ 'c::derive-type name)
+ (maybe-make-definition (c::function-info-optimizer info)
+ 'c::optimizer name)
+ (maybe-make-definition (c::function-info-ltn-annotate info)
+ 'c::ltn-annotate name)
+ (maybe-make-definition (c::function-info-ir2-convert info)
+ 'c::ir2-convert name)
+ (loop for template in (c::function-info-templates info)
+ collect (list `(c::vop ,(c::template-name template))
+ (function-location
+ (c::vop-info-generator-function
+ template))))))))
+
+(defun ir1-translator-definitions (name)
+ (maybe-make-definition (ext:info :function :ir1-convert name)
+ 'c:def-ir1-translator name))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (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 (multiple-value-bind (kind recorded-p)
+ (ext:info variable kind symbol)
+ (declare (ignore kind))
+ (if (or (boundp symbol) recorded-p)
+ (doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (ext:info type kind symbol)
+ (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (maybe-push
+ :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+ (doc 'alien-type)))
+ (maybe-push
+ :alien-struct (if (ext:info alien-type struct symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-union (if (ext:info alien-type union symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-enum (if (ext:info alien-type enum symbol)
+ (doc nil)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (describe (ecase namespace
+ (:variable
+ symbol)
+ ((:function :generic-function)
+ (symbol-function symbol))
+ (:setf
+ (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol)))
+ (:type
+ (kernel:values-specifier-type symbol))
+ (:class
+ (find-class symbol))
+ (:alien-struct
+ (ext:info :alien-type :struct symbol))
+ (:alien-union
+ (ext:info :alien-type :union symbol))
+ (:alien-enum
+ (ext:info :alien-type :enum symbol))
+ (:alien-type
+ (ecase (ext:info :alien-type :kind symbol)
+ (:primitive
+ (let ((alien::*values-type-okay* t))
+ (funcall (ext:info :alien-type :translator symbol)
+ (list symbol))))
+ ((:defined)
+ (ext:info :alien-type :definition symbol))
+ (:unknown :unknown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+ (multiple-value-bind (args winp)
+ (ext:function-arglist fun)
+ (if winp args :not-available)))
+
+(defimplementation function-name (function)
+ (cond ((eval:interpreted-function-p function)
+ (eval:interpreted-function-name function))
+ ((typep function 'generic-function)
+ (clos:generic-function-name function))
+ ((c::byte-function-or-closure-p function)
+ (c::byte-function-name function))
+ (t (kernel:%function-name (kernel:%function-self function)))))
+
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+ "Derive the argument list of DEBUG-FUNCTION from debug info."
+ (let ((args (di::debug-function-lambda-list debug-function))
+ (required '())
+ (optional '())
+ (rest '())
+ (key '()))
+ ;; collect the names of debug-vars
+ (dolist (arg args)
+ (etypecase arg
+ (di::debug-variable
+ (push (di::debug-variable-symbol arg) required))
+ ((member :deleted)
+ (push ':deleted required))
+ (cons
+ (ecase (car arg)
+ (:keyword
+ (push (second arg) key))
+ (:optional
+ (push (debug-variable-symbol-or-deleted (second arg)) optional))
+ (:rest
+ (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+ ;; intersperse lambda keywords as needed
+ (append (nreverse required)
+ (if optional (cons '&optional (nreverse optional)))
+ (if rest (cons '&rest (nreverse rest)))
+ (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+ (etypecase var
+ (di:debug-variable
+ (di::debug-variable-symbol var))
+ ((member :deleted)
+ '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+ "Return FNAME's debug-function-arglist and %function-arglist.
+ A utility for debugging DEBUG-FUNCTION-ARGLIST."
+ (let ((fn (fdefinition fname)))
+ (values (debug-function-arglist (di::function-debug-function fn))
+ (kernel:%function-arglist (kernel:%function-self fn)))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (macroexpand form))
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:default-directory)))
+
+(defimplementation pathname-to-filename (pathname)
+ (ext:unix-namestring pathname nil))
+
+(defimplementation getpid ()
+ (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ (if (eq ext:*case-mode* :upper) "scl" "scl-lower"))
+
+(defimplementation quit-lisp ()
+ (ext:quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into
+;;; source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (debug:*stack-top-hint* nil)
+ (kernel:*current-level* 0))
+ (handler-bind ((di::unhandled-condition
+ (lambda (condition)
+ (error 'sldb-condition
+ :original-condition condition))))
+ (funcall debugger-loop-fn))))
+
+(defun frame-down (frame)
+ (handler-case (di:frame-down frame)
+ (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (frame-down f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let ((*standard-output* stream))
+ (handler-case
+ (debug::print-frame-call frame :verbosity 1 :number nil)
+ (error (e)
+ (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location (index)
+ (code-location-source-location (di:frame-code-location (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+ (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))
+
+(defun debug-var-value (var frame location)
+ (let ((validity (di:debug-variable-validity var location)))
+ (ecase validity
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+ (let* ((frame (nth-frame index))
+ (loc (di:frame-code-location frame))
+ (vars (frame-debug-vars frame)))
+ (loop for v across vars collect
+ (list :name (di:debug-variable-symbol v)
+ :id (di:debug-variable-id v)
+ :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame (di:frame-code-location frame))))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation return-from-frame (index form)
+ (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame)
+ :debug-internals)))
+ (if sym
+ (let* ((frame (nth-frame index))
+ (probe (funcall sym frame)))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame))))
+ "return-from-frame is not implemented in this version of SCL.")))
+
+(defimplementation activate-stepping (frame)
+ (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+ (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+ (let* ((caller (di:frame-down frame))
+ (cl (di:frame-code-location caller)))
+ (flet ((hook (frame bp)
+ (when (frame-pointer= frame caller)
+ (di:delete-breakpoint bp)
+ (signal-breakpoint bp frame))))
+ (let* ((info (ecase (di:code-location-kind cl)
+ ((:single-value-return :unknown-return) nil)
+ (:known-return (debug-function-returns
+ (di:frame-debug-function frame)))))
+ (bp (di:make-breakpoint #'hook cl :kind :code-location
+ :info info)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+ "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+ (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info. Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+ "Like `debug::next-code-locations' but be careful in escaped frames."
+ (let ((next (debug::next-code-locations code-location)))
+ (flet ((adjust-pc ()
+ (let ((cl (di::copy-compiled-code-location code-location)))
+ (incf (di::compiled-code-location-pc cl)
+ vm:single-value-return-byte-offset)
+ cl)))
+ (cond ((and (di::compiled-frame-escaped frame)
+ (eq (di:code-location-kind code-location)
+ :single-value-return)
+ (= (length next) 1)
+ (di:code-location= (car next) (adjust-pc)))
+ (debug::next-code-locations (car next)))
+ (t
+ next)))))
+
+(defun set-step-breakpoints (frame)
+ (let ((cl (di:frame-code-location frame)))
+ (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+ (error "Cannot step in elsewhere code"))
+ (let* ((debug::*bad-code-location-types*
+ (remove :call-site debug::*bad-code-location-types*))
+ (next (next-code-locations frame cl)))
+ (cond (next
+ (let ((steppoints '()))
+ (flet ((hook (bp-frame bp)
+ (signal-breakpoint bp bp-frame)
+ (mapc #'di:delete-breakpoint steppoints)))
+ (dolist (code-location next)
+ (let ((bp (di:make-breakpoint #'hook code-location
+ :kind :code-location)))
+ (di:activate-breakpoint bp)
+ (push bp steppoints))))))
+ (t
+ (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+(defun sigcontext-object (sc index)
+ "Extract the lisp object in sigcontext SC at offset INDEX."
+ (kernel:make-lisp-obj (vm:ucontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+ (let ((fp (system:int-sap (vm:ucontext-register sigcontext
+ vm::cfp-offset))))
+ (system:without-gcing
+ (loop for sc-offset across sc-offsets
+ collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; SCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case. The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+ "Return the list of return values for a return point."
+ (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+ (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
+ (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext))))
+ (cl (di:breakpoint-what breakpoint)))
+ (ecase (di:code-location-kind cl)
+ (:single-value-return
+ (list (1st sc)))
+ (:known-return
+ (let ((info (di:breakpoint-info breakpoint)))
+ (if (vectorp info)
+ (known-return-point-values sc info)
+ (progn
+ ;;(break)
+ (list "<<known-return convention not supported>>" info)))))
+ (:unknown-return
+ (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+ (if (= mv-return-pc *breakpoint-pc*)
+ (mv-function-end-breakpoint-values sc)
+ (list (1st sc)))))))))
+
+(defun mv-function-end-breakpoint-values (sigcontext)
+ (let ((sym (find-symbol
+ (symbol-name '#:function-end-breakpoint-values/standard)
+ :debug-internals)))
+ (cond (sym (funcall sym sigcontext))
+ (t (di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+ "Return the return style of DEBUG-FUN."
+ (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+ (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition)
+ ((message :initarg :message :reader breakpoint.message)
+ (values :initarg :values :reader breakpoint.values))
+ (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+#+nil
+(defimplementation condition-extras ((c breakpoint))
+ ;; simply pop up the source buffer
+ `((:short-frame-source 0)))
+
+(defun signal-breakpoint (breakpoint frame)
+ "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+ (flet ((brk (values fstring &rest args)
+ (let ((msg (apply #'format nil fstring args))
+ (debug:*stack-top-hint* frame))
+ (break 'breakpoint :message msg :values values))))
+ (with-struct (di::breakpoint- kind what) breakpoint
+ (case kind
+ (:code-location
+ (case (di:code-location-kind what)
+ ((:single-value-return :known-return :unknown-return)
+ (let ((values (breakpoint-values breakpoint)))
+ (brk values "Return value: ~{~S ~}" values)))
+ (t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
+ (brk nil "Breakpoint: ~S ~S"
+ (di:code-location-kind what)
+ (di::compiled-code-location-pc what)))))
+ (:function-start
+ (brk nil "Function start breakpoint"))
+ (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+#+nil
+(defimplementation sldb-break-at-start (fname)
+ (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+ (cond ((not debug-fun)
+ `(:error ,(format nil "~S has no debug-function" fname)))
+ (t
+ (flet ((hook (frame bp &optional args cookie)
+ (declare (ignore args cookie))
+ (signal-breakpoint bp frame)))
+ (let ((bp (di:make-breakpoint #'hook debug-fun
+ :kind :function-start)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ ((or di::bogus-debug-function di::interpreted-debug-function)
+ -1)))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+CSP = ~X
+CFP = ~X
+IP = ~X
+OCFP = ~X
+LRA = ~X~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
+
+(defimplementation disassemble-frame (frame-number)
+ "Return a string with the disassembly of frames code."
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (format t "~%[Disassembling bogus frames not implemented]")))))
+
+
+;;;; Inspecting
+
+(defconstant +lowtag-symbols+
+ '(vm:even-fixnum-type
+ vm:instance-pointer-type
+ vm:other-immediate-0-type
+ vm:list-pointer-type
+ vm:odd-fixnum-type
+ vm:function-pointer-type
+ vm:other-immediate-1-type
+ vm:other-pointer-type)
+ "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+ (labels ((suffixp (suffix string)
+ (and (>= (length string) (length suffix))
+ (string= string suffix :start1 (- (length string)
+ (length suffix)))))
+ (header-type-symbol-p (x)
+ (and (suffixp (symbol-name '#:-type) (symbol-name x))
+ (not (member x +lowtag-symbols+))
+ (boundp x)
+ (typep (symbol-value x) 'fixnum))))
+ (remove-if-not #'header-type-symbol-p
+ (append (apropos-list (symbol-name '#:-type) :vm)
+ (apropos-list (symbol-name '#:-type) :bignum))))
+ "A list of names of the type codes in boxed objects.")
+
+(defimplementation describe-primitive-type (object)
+ (with-output-to-string (*standard-output*)
+ (let* ((lowtag (kernel:get-lowtag object))
+ (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
+
+(defmethod emacs-inspect ((o t))
+ (cond ((di::indirect-value-cell-p o)
+ `("Value: " (:value ,(c:value-cell-ref o))))
+ ((alien::alien-value-p o)
+ (inspect-alien-value o))
+ (t
+ (scl-inspect o))))
+
+(defun scl-inspect (o)
+ (destructuring-bind (text labeledp . parts)
+ (inspect::describe-parts o)
+ (list* (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (loop for value in parts for i from 0
+ append (label-value-line i value))))))
+
+(defmethod emacs-inspect ((o function))
+ (let ((header (kernel:get-type o)))
+ (cond ((= header vm:function-header-type)
+ (list* (format nil "~A is a function.~%" o)
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s))))))
+ ((= header vm:closure-header-type)
+ (list* (format nil "~A is a closure.~%" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (- (kernel:get-closure-length o)
+ (1- vm:closure-info-offset))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
+ ((eval::interpreted-function-p o)
+ (scl-inspect o))
+ (t
+ (call-next-method)))))
+
+
+(defmethod emacs-inspect ((o kernel:code-component))
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:" (:newline)
+ , (with-output-to-string (s)
+ (cond ((kernel:%code-debug-info o)
+ (disassem:disassemble-code-component o :stream s))
+ (t
+ (disassem:disassemble-memory
+ (disassem::align
+ (+ (logandc2 (kernel:get-lisp-obj-address o)
+ vm:lowtag-mask)
+ (* vm:code-constants-offset vm:word-bytes))
+ (ash 1 vm:lowtag-bits))
+ (ash (kernel:%code-code-size o) vm:word-shift)
+ :stream s)))))))
+
+(defmethod emacs-inspect ((o kernel:fdefn))
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
+
+(defmethod emacs-inspect ((o array))
+ (cond ((kernel:array-header-p o)
+ (list* (format nil "~A is an array.~%" o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+ (t
+ (list* (format nil "~A is an simple-array.~%" o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (length o)))))))
+
+(defmethod emacs-inspect ((o simple-vector))
+ (list* (format nil "~A is a vector.~%" o)
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (unless (eq (array-element-type o) 'nil)
+ (loop for i below (length o)
+ append (label-value-line i (aref o i)))))))
+
+(defun inspect-alien-record (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (label-value-line slot (alien:slot alien slot))))))))
+
+(defun inspect-alien-pointer (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien)))))
+
+(defun inspect-alien-value (alien)
+ (typecase (alien::alien-value-type alien)
+ (alien::alien-record-type (inspect-alien-record alien))
+ (alien::alien-pointer-type (inspect-alien-pointer alien))
+ (t (scl-inspect alien))))
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (eval `(profile:unprofile))
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+ (eval `(profile:reset-time))
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ #+nil :methods #+nil methods))
+
+
+;;;; Multiprocessing
+
+(defimplementation spawn (fn &key name)
+ (thread:thread-create fn :name (or name "Anonymous")))
+
+(defvar *thread-id-counter* 0)
+(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
+
+(defimplementation thread-id (thread)
+ (thread:with-lock-held (*thread-id-counter-lock*)
+ (or (getf (thread:thread-plist thread) 'id)
+ (setf (getf (thread:thread-plist thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (block find-thread
+ (thread:map-over-threads
+ #'(lambda (thread)
+ (when (eql (getf (thread:thread-plist thread) 'id) id)
+ (return-from find-thread thread))))))
+
+(defimplementation thread-name (thread)
+ (princ-to-string (thread:thread-name thread)))
+
+(defimplementation thread-status (thread)
+ (let ((dynamic-values (thread::thread-dynamic-values thread)))
+ (if (zerop dynamic-values) "Exited" "Running")))
+
+(defimplementation make-lock (&key name)
+ (thread:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (thread:with-lock-held (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ thread:*thread*)
+
+(defimplementation all-threads ()
+ (let ((all-threads nil))
+ (thread:map-over-threads #'(lambda (thread) (push thread all-threads)))
+ all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+ (thread:thread-interrupt thread #'(lambda ()
+ (sys:with-interrupts
+ (funcall fn)))))
+
+(defimplementation kill-thread (thread)
+ (thread:destroy-thread thread))
+
+(defimplementation thread-alive-p (thread)
+ (not (zerop (thread::thread-dynamic-values thread))))
+
+(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
+
+(defstruct (mailbox)
+ (lock (thread:make-lock "Thread mailbox" :type :error-check
+ :interruptible nil)
+ :type thread:error-check-lock)
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return 'thread's mailbox."
+ (sys:without-interrupts
+ (thread:with-lock-held (*mailbox-lock*)
+ (or (getf (thread:thread-plist thread) 'mailbox)
+ (setf (getf (thread:thread-plist thread) 'mailbox)
+ (make-mailbox))))))
+
+(defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (lock (mailbox-lock mbox)))
+ (sys:without-interrupts
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message)))))
+ (mp:process-wakeup thread)))
+
+#+nil
+(defimplementation receive ()
+ (receive-if (constantly t)))
+
+(defimplementation receive-if (test &optional timeout)
+ (let ((mbox (mailbox thread:*thread*)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (sys:without-interrupts
+ (mp:with-lock-held ((mailbox-lock mbox))
+ (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:process-wait-with-timeout
+ "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
+
+
+
+(defimplementation emacs-connected ())
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;; In SCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;; <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec ,@options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ nil)
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ;; this isn't actually supported
+ ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
+ (t
+ fspec)))
+
+;;; Weak datastructures
+
+;;; Not implemented in SCL.
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
diff --git a/vim/bundle/slimv/slime/swank/source-file-cache.lisp b/vim/bundle/slimv/slime/swank/source-file-cache.lisp
new file mode 100644
index 0000000..ac48acf
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/source-file-cache.lisp
@@ -0,0 +1,136 @@
+;;;; Source-file cache
+;;;
+;;; To robustly find source locations in CMUCL and SBCL it's useful to
+;;; have the exact source code that the loaded code was compiled from.
+;;; In this source we can accurately find the right location, and from
+;;; that location we can extract a "snippet" of code to show what the
+;;; definition looks like. Emacs can use this snippet in a best-match
+;;; search to locate the right definition, which works well even if
+;;; the buffer has been modified.
+;;;
+;;; The idea is that if a definition previously started with
+;;; `(define-foo bar' then it probably still does.
+;;;
+;;; Whenever we see that the file on disk has the same
+;;; `file-write-date' as a location we're looking for we cache the
+;;; whole file inside Lisp. That way we will still have the matching
+;;; version even if the file is later modified on disk. If the file is
+;;; later recompiled and reloaded then we replace our cache entry.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+(defpackage swank/source-file-cache
+ (:use cl)
+ (:import-from swank/backend
+ defimplementation buffer-first-change
+ guess-external-format
+ find-external-format)
+ (:export
+ get-source-code
+ source-cache-get ;FIXME: isn't it odd that both are exported?
+
+ *source-snippet-size*
+ read-snippet
+ read-snippet-from-string
+ ))
+
+(in-package swank/source-file-cache)
+
+(defvar *cache-sourcecode* t
+ "When true complete source files are cached.
+The cache is used to keep known good copies of the source text which
+correspond to the loaded code. Finding definitions is much more
+reliable when the exact source is available, so we cache it in case it
+gets edited on disk later.")
+
+(defvar *source-file-cache* (make-hash-table :test 'equal)
+ "Cache of source file contents.
+Maps from truename to source-cache-entry structure.")
+
+(defstruct (source-cache-entry
+ (:conc-name source-cache-entry.)
+ (:constructor make-source-cache-entry (text date)))
+ text date)
+
+(defimplementation buffer-first-change (filename)
+ "Load a file into the cache when the user modifies its buffer.
+This is a win if the user then saves the file and tries to M-. into it."
+ (unless (source-cached-p filename)
+ (ignore-errors
+ (source-cache-get filename (file-write-date filename))))
+ nil)
+
+(defun get-source-code (filename code-date)
+ "Return the source code for FILENAME as written on DATE in a string.
+If the exact version cannot be found then return the current one from disk."
+ (or (source-cache-get filename code-date)
+ (read-file filename)))
+
+(defun source-cache-get (filename date)
+ "Return the source code for FILENAME as written on DATE in a string.
+Return NIL if the right version cannot be found."
+ (when *cache-sourcecode*
+ (let ((entry (gethash filename *source-file-cache*)))
+ (cond ((and entry (equal date (source-cache-entry.date entry)))
+ ;; Cache hit.
+ (source-cache-entry.text entry))
+ ((or (null entry)
+ (not (equal date (source-cache-entry.date entry))))
+ ;; Cache miss.
+ (if (equal (file-write-date filename) date)
+ ;; File on disk has the correct version.
+ (let ((source (read-file filename)))
+ (setf (gethash filename *source-file-cache*)
+ (make-source-cache-entry source date))
+ source)
+ nil))))))
+
+(defun source-cached-p (filename)
+ "Is any version of FILENAME in the source cache?"
+ (if (gethash filename *source-file-cache*) t))
+
+(defun read-file (filename)
+ "Return the entire contents of FILENAME as a string."
+ (with-open-file (s filename :direction :input
+ :external-format (or (guess-external-format filename)
+ (find-external-format "latin-1")
+ :default))
+ (let* ((string (make-string (file-length s)))
+ (length (read-sequence string s)))
+ (subseq string 0 length))))
+
+;;;; Snippets
+
+(defvar *source-snippet-size* 256
+ "Maximum number of characters in a snippet of source code.
+Snippets at the beginning of definitions are used to tell Emacs what
+the definitions looks like, so that it can accurately find them by
+text search.")
+
+(defun read-snippet (stream &optional position)
+ "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM.
+If POSITION is given, set the STREAM's file position first."
+ (when position
+ (file-position stream position))
+ #+sbcl (skip-comments-and-whitespace stream)
+ (read-upto-n-chars stream *source-snippet-size*))
+
+(defun read-snippet-from-string (string &optional position)
+ (with-input-from-string (s string)
+ (read-snippet s position)))
+
+(defun skip-comments-and-whitespace (stream)
+ (case (peek-char nil stream)
+ ((#\Space #\Tab #\Newline #\Linefeed #\Page)
+ (read-char stream)
+ (skip-comments-and-whitespace stream))
+ (#\;
+ (read-line stream)
+ (skip-comments-and-whitespace stream))))
+
+(defun read-upto-n-chars (stream n)
+ "Return a string of upto N chars from STREAM."
+ (let* ((string (make-string n))
+ (chars (read-sequence string stream)))
+ (subseq string 0 chars)))
diff --git a/vim/bundle/slimv/slime/swank/source-path-parser.lisp b/vim/bundle/slimv/slime/swank/source-path-parser.lisp
new file mode 100644
index 0000000..bb9c35c
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/source-path-parser.lisp
@@ -0,0 +1,239 @@
+;;;; Source-paths
+
+;;; CMUCL/SBCL use a data structure called "source-path" to locate
+;;; subforms. The compiler assigns a source-path to each form in a
+;;; compilation unit. Compiler notes usually contain the source-path
+;;; of the error location.
+;;;
+;;; Compiled code objects don't contain source paths, only the
+;;; "toplevel-form-number" and the (sub-) "form-number". To get from
+;;; the form-number to the source-path we need the entire toplevel-form
+;;; (i.e. we have to read the source code). CMUCL has already some
+;;; utilities to do this translation, but we use some extended
+;;; versions, because we need more exact position info. Apparently
+;;; Hemlock is happy with the position of the toplevel-form; we also
+;;; need the position of subforms.
+;;;
+;;; We use a special readtable to get the positions of the subforms.
+;;; The readtable stores the start and end position for each subform in
+;;; hashtable for later retrieval.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+;;; Taken from swank-cmucl.lisp, by Helmut Eller
+
+(defpackage swank/source-path-parser
+ (:use cl)
+ (:export
+ read-source-form
+ source-path-string-position
+ source-path-file-position
+ source-path-source-position
+
+ sexp-in-bounds-p
+ sexp-ref)
+ (:shadow ignore-errors))
+
+(in-package swank/source-path-parser)
+
+;; Some test to ensure the required conformance
+(let ((rt (copy-readtable nil)))
+ (assert (or (not (get-macro-character #\space rt))
+ (nth-value 1 (get-macro-character #\space rt))))
+ (assert (not (get-macro-character #\\ rt))))
+
+(eval-when (:compile-toplevel)
+ (defmacro ignore-errors (&rest forms)
+ ;;`(progn . ,forms) ; for debugging
+ `(cl:ignore-errors . ,forms)))
+
+(defun make-sharpdot-reader (orig-sharpdot-reader)
+ (lambda (s c n)
+ ;; We want things like M-. to work regardless of any #.-fu in
+ ;; the source file that is to be visited. (For instance, when a
+ ;; file contains #. forms referencing constants that do not
+ ;; currently exist in the image.)
+ (ignore-errors (funcall orig-sharpdot-reader s c n))))
+
+(defun make-source-recorder (fn source-map)
+ "Return a macro character function that does the same as FN, but
+additionally stores the result together with the stream positions
+before and after of calling FN in the hashtable SOURCE-MAP."
+ (lambda (stream char)
+ (let ((start (1- (file-position stream)))
+ (values (multiple-value-list (funcall fn stream char)))
+ (end (file-position stream)))
+ #+(or)
+ (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
+ start values end (char-code char) char)
+ (when values
+ (destructuring-bind (&optional existing-start &rest existing-end)
+ (car (gethash (car values) source-map))
+ ;; Some macros may return what a sub-call to another macro
+ ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice,
+ ;; once from #\# and once from #\(. If the saved form
+ ;; is a subform, don't save it again.
+ (unless (and existing-start existing-end
+ (<= start existing-start end)
+ (<= start existing-end end))
+ (push (cons start end) (gethash (car values) source-map)))))
+ (values-list values))))
+
+(defun make-source-recording-readtable (readtable source-map)
+ (declare (type readtable readtable) (type hash-table source-map))
+ "Return a source position recording copy of READTABLE.
+The source locations are stored in SOURCE-MAP."
+ (flet ((install-special-sharpdot-reader (rt)
+ (let ((fun (ignore-errors
+ (get-dispatch-macro-character #\# #\. rt))))
+ (when fun
+ (let ((wrapper (make-sharpdot-reader fun)))
+ (set-dispatch-macro-character #\# #\. wrapper rt)))))
+ (install-wrappers (rt)
+ (dotimes (code 128)
+ (let ((char (code-char code)))
+ (multiple-value-bind (fun nt) (get-macro-character char rt)
+ (when fun
+ (let ((wrapper (make-source-recorder fun source-map)))
+ (set-macro-character char wrapper nt rt))))))))
+ (let ((rt (copy-readtable readtable)))
+ (install-special-sharpdot-reader rt)
+ (install-wrappers rt)
+ rt)))
+
+;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning.
+;; Should be possible as we only need the right "list structure" and
+;; not the right atoms.
+(defun read-and-record-source-map (stream)
+ "Read the next object from STREAM.
+Return the object together with a hashtable that maps
+subexpressions of the object to stream positions."
+ (let* ((source-map (make-hash-table :test #'eq))
+ (*readtable* (make-source-recording-readtable *readtable* source-map))
+ (*read-suppress* nil)
+ (start (file-position stream))
+ (form (ignore-errors (read stream)))
+ (end (file-position stream)))
+ ;; ensure that at least FORM is in the source-map
+ (unless (gethash form source-map)
+ (push (cons start end) (gethash form source-map)))
+ (values form source-map)))
+
+(defun starts-with-p (string prefix)
+ (declare (type string string prefix))
+ (not (mismatch string prefix
+ :end1 (min (length string) (length prefix))
+ :test #'char-equal)))
+
+(defun extract-package (line)
+ (declare (type string line))
+ (let ((name (cadr (read-from-string line))))
+ (find-package name)))
+
+#+(or)
+(progn
+ (assert (extract-package "(in-package cl)"))
+ (assert (extract-package "(cl:in-package cl)"))
+ (assert (extract-package "(in-package \"CL\")"))
+ (assert (extract-package "(in-package #:cl)")))
+
+;; FIXME: do something cleaner than this.
+(defun readtable-for-package (package)
+ ;; KLUDGE: due to the load order we can't reference the swank
+ ;; package.
+ (funcall (read-from-string "swank::guess-buffer-readtable")
+ (string-upcase (package-name package))))
+
+;; Search STREAM for a "(in-package ...)" form. Use that to derive
+;; the values for *PACKAGE* and *READTABLE*.
+;;
+;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends
+;; use the same heuristic and to avoid the need to access
+;; swank::guess-buffer-readtable from here.
+(defun guess-reader-state (stream)
+ (let* ((point (file-position stream))
+ (pkg *package*))
+ (file-position stream 0)
+ (loop for line = (read-line stream nil nil) do
+ (when (not line) (return))
+ (when (or (starts-with-p line "(in-package ")
+ (starts-with-p line "(cl:in-package "))
+ (let ((p (extract-package line)))
+ (when p (setf pkg p)))
+ (return)))
+ (file-position stream point)
+ (values (readtable-for-package pkg) pkg)))
+
+(defun skip-whitespace (stream)
+ (peek-char t stream nil nil))
+
+;; Skip over N toplevel forms.
+(defun skip-toplevel-forms (n stream)
+ (let ((*read-suppress* t))
+ (dotimes (i n)
+ (read stream))
+ (skip-whitespace stream)))
+
+(defun read-source-form (n stream)
+ "Read the Nth toplevel form number with source location recording.
+Return the form and the source-map."
+ (multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
+ (skip-toplevel-forms n stream)
+ (read-and-record-source-map stream)))
+
+(defun source-path-stream-position (path stream)
+ "Search the source-path PATH in STREAM and return its position."
+ (check-source-path path)
+ (destructuring-bind (tlf-number . path) path
+ (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
+ (source-path-source-position (cons 0 path) form source-map))))
+
+(defun check-source-path (path)
+ (unless (and (consp path)
+ (every #'integerp path))
+ (error "The source-path ~S is not valid." path)))
+
+(defun source-path-string-position (path string)
+ (with-input-from-string (s string)
+ (source-path-stream-position path s)))
+
+(defun source-path-file-position (path filename)
+ ;; We go this long way round, and don't directly operate on the file
+ ;; stream because FILE-POSITION (used above) is not totally savy even
+ ;; on file character streams; on SBCL, FILE-POSITION returns the binary
+ ;; offset, and not the character offset---screwing up on Unicode.
+ (let ((toplevel-number (first path))
+ (buffer))
+ (with-open-file (file filename)
+ (skip-toplevel-forms (1+ toplevel-number) file)
+ (let ((endpos (file-position file)))
+ (setq buffer (make-array (list endpos) :element-type 'character
+ :initial-element #\Space))
+ (assert (file-position file 0))
+ (read-sequence buffer file :end endpos)))
+ (source-path-string-position path buffer)))
+
+(defgeneric sexp-in-bounds-p (sexp i)
+ (:method ((list list) i)
+ (< i (loop for e on list
+ count t)))
+ (:method ((sexp t) i) nil))
+
+(defgeneric sexp-ref (sexp i)
+ (:method ((s list) i) (elt s i)))
+
+(defun source-path-source-position (path form source-map)
+ "Return the start position of PATH from FORM and SOURCE-MAP. All
+subforms along the path are considered and the start and end position
+of the deepest (i.e. smallest) possible form is returned."
+ ;; compute all subforms along path
+ (let ((forms (loop for i in path
+ for f = form then (if (sexp-in-bounds-p f i)
+ (sexp-ref f i))
+ collect f)))
+ ;; select the first subform present in source-map
+ (loop for form in (nreverse forms)
+ for ((start . end) . rest) = (gethash form source-map)
+ when (and start end (not rest))
+ return (return (values start end)))))
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-18 17:28:37 +0000