summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime/swank/abcl.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'vim/bundle/slimv/slime/swank/abcl.lisp')
-rw-r--r--vim/bundle/slimv/slime/swank/abcl.lisp847
1 files changed, 847 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))
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-05 17:02:14 +0000