862 changes: 637 additions & 225 deletions swank/abcl.lisp
View file
Open in desktop
Expand Up @@ -3,23 +3,46 @@
;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
;;;
;;; Adapted from swank-acl.lisp, Andras Simon, 2004
;;; New work by Alan Ruttenberg, 2016-7
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;

(defpackage swank/abcl
(:use cl swank/backend))

(:use cl swank/backend)
(:import-from :java
#:jcall #:jstatic
#:jmethod
#:jfield #:jfield-name
#:jconstructor
#:jnew-array #:jarray-length #:jarray-ref #:jnew-array-from-array
#:jclass #:jnew #:jinstance-of-p #:jclass-superclass #:java-object #:jclass-interfaces
#:java-exception))
(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"))
(require :abcl-contrib)

;;; Probe for existence of a functioning abcl-introspect, loading
;;; it necessary conditions are met.
(when (ignore-errors (and
(fboundp '(setf sys::function-plist))
(progn
(require :abcl-introspect)
(find "ABCL-INTROSPECT" *modules* :test 'equal))))
;; NOT WORKING
;; Record source information for DEFIMPLEMENTATION
#+nil
(defmacro defimplementation/abcl (name args &body body)
`(sys::record-source-information-for-type ',name '(:swank-implementation ,name))
`(swank-backend:defimplementation ,name ,args &body ,body))
#+nil
(setf (symbol-function 'swank-backend:defimplementation)
(symbol-function 'swank/abcl::defimplementation/recording-source-information))))

(defimplementation gray-package-name ()
"GRAY-STREAMS")
Expand Down Expand Up @@ -84,6 +107,10 @@
(declare (ignore class))
(system::slot-value object (slot-definition-name slotdef)))

(defun (setf slot-value-using-class) (new class object slotdef )
(declare (ignore class))
(mop::%set-slot-value object (slot-definition-name slotdef) new))

(import-to-swank-mop
'( ;; classes
cl:standard-generic-function
Expand Down Expand Up @@ -135,6 +162,7 @@
mop:slot-definition-writers
slot-boundp-using-class
slot-value-using-class
set-slot-value-using-class
mop:slot-makunbound-using-class))

;;;; TCP Server
Expand All @@ -147,7 +175,7 @@
(ext:make-server-socket port))

(defimplementation local-port (socket)
(java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
(jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket))

(defimplementation close-socket (socket)
(ext:server-socket-close socket))
Expand All @@ -166,36 +194,36 @@
;; faster please!
(defimplementation string-to-utf8 (s)
(jbytes-to-octets
(java:jcall
(java:jmethod "java.lang.String" "getBytes" "java.lang.String")
(jcall
(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")))
(jnew
(jconstructor "org.armedbear.lisp.SimpleString"
"java.lang.String")
(jnew (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)))
(bytes (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))
do (jstatic (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))
(let* ((len (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)
for jbyte = (jarray-ref jbytes i)
do (setf (aref octets i) jbyte))
octets))

Expand All @@ -220,37 +248,39 @@
;;;; 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)))
(if (fboundp 'ext::get-pid)
(ext::get-pid) ;;; Introduced with abcl-1.5.0
(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")
Expand Down Expand Up @@ -279,7 +309,7 @@
(t :not-available)))

(defimplementation function-name (function)
(nth-value 2 (function-lambda-expression function)))
(sys::any-function-name function))

(defimplementation macroexpand-all (form &optional env)
(ext:macroexpand-all form env))
Expand Down Expand Up @@ -372,57 +402,86 @@
(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 jss-p ()
(and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS" "JSS")))

(defun matches-jss-call (form)
(flet ((gensymp (s) (and (symbolp s) (null (symbol-package s))))
(invokep (s) (and (symbolp s) (eq s (jss-p)))))
(let ((method
(swank/match::select-match
form
(((LAMBDA ((#'gensymp a) &REST (#'gensymp b))
((#'invokep fun) (#'stringp c) (#'gensymp d) (#'gensymp e) . args)) . args) '=> c)
(other nil))))
method)))

(defun match-lambda (operator values)
(jvm::match-lambda-list
(multiple-value-list
(jvm::parse-lambda-list (ext:arglist operator)))
values))
;; Use princ cs write-string for lisp frames as it respects (print-object (function t))
;; Rewrite jss expansions to their unexpanded state
(defimplementation print-frame (frame stream)
(if (typep frame 'sys::lisp-stack-frame)
(if (not (jss-p))
(princ (system:frame-to-list frame) stream)
;; rewrite jss forms as they would be written
(let ((form (system:frame-to-list frame)))
(if (eq (car form) (jss-p))
(format stream "(#~s ~{~s~^~})" (second form) (list* (third form) (fourth form)))
(loop initially (write-char #\( stream)
for (el . rest) on form
for method = (swank/abcl::matches-jss-call el)
do
(cond (method
(format stream "(#~s ~{~s~^~})" method (cdr el)))
(t
(prin1 el stream)))
(unless (null rest) (write-char #\space stream))
finally (write-char #\) stream)))))
(write-string (sys:frame-to-string frame) stream)))

(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)))
(when (typep (nth-frame index) 'sys::lisp-stack-frame) ;; java stack frames have no locals available
(loop
:for id :upfrom 0
:with frame = (java:jcall "toLispList" (nth-frame index))
:with operator = (first frame)
:with values = (rest frame)
:with arglist = (if (and operator (consp values))
(jvm::match-lambda-list
(multiple-value-list
(jvm::parse-lambda-list
(arglist operator)))
values)
:not-available)
:for value in values
:collecting (list
:name (if (consp arglist)
(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))
(elt (rest (java:jcall "toLispList" (nth-frame index))) id))


#+nil
(defimplementation disassemble-frame (index)
(disassemble (debugger:frame-function (nth-frame index))))

(sys::disassemble (frame-function (nth-frame index))))

(defun frame-function (frame)
(let ((list (sys::frame-to-list frame)))
(cond
((keywordp (car list))
(find (getf list :method)
(jcall "getDeclaredMethods" (jclass (getf list :class)))
:key (lambda(e)(jcall "getName" e)) :test 'equal))
(t (car list) ))))

(defimplementation frame-source-location (index)
(let ((frame (nth-frame index)))
(or (source-location (nth-frame index))
Expand All @@ -448,6 +507,7 @@
(let ((frame (nth-frame frame-number)))
(debugger:frame-retry frame (debugger:frame-function frame))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Compiler hooks

(defvar *buffer-name* nil)
Expand Down Expand Up @@ -512,59 +572,119 @@
(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))
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; source location and users of it

(defgeneric source-location (object))

;; try to find some kind of source for internals
(defun implementation-source-location (arg)
(let ((function (cond ((functionp arg)
arg)
((and (symbolp arg) (fboundp arg))
(or (symbol-function arg) (macro-function arg))))))
(when (typep function 'generic-function)
(setf function (mop::funcallable-instance-function function)))
;; functions are execute methods of class
(when (or (functionp function) (special-operator-p arg))
(let ((fclass (jcall "getClass" function)))
(let ((classname (jcall "getName" fclass)))
(destructuring-bind (class local) (if (find #\$ classname)
(split-string classname "\\$")
(list classname (jcall "replaceFirst" classname "([^.]*\\.)*" "")))
(unless (member local '("MacroObject" "CompiledClosure" "Closure") :test 'equal)
;; look for java source
(let* ((partial-path (substitute #\/ #\. class))
(java-path (concatenate 'string partial-path ".java"))
(found-in-source-path (find-file-in-path java-path *source-path*)))
;; snippet for finding the internal class within the file
(if found-in-source-path
`((:primitive , local)
(:location ,found-in-source-path
(:line 0)
(:snippet ,(format nil "class ~a" local))))
;; if not, look for the class file, and hope that
;; emacs is configured to disassemble class entries in jars.
;; I use jdc.el(copy here: https://github.com/m0smith/dotfiles/blob/master/.emacs.d/site-lisp/jdc.el)
;; with jad (https://github.com/moparisthebest/jad)
;; Also (setq sys::*disassembler* "jad -a -p")
(let ((class-in-source-path
(find-file-in-path (concatenate 'string partial-path ".class") *source-path*)))
;; no snippet, since internal class is in its own file
(if class-in-source-path `(:primitive (:location ,class-in-source-path (:line 0) nil)))
))))))))))

(defun get-declared-field (class fieldname)
(find fieldname (jcall "getDeclaredFields" class) :key 'jfield-name :test 'equal))

(defun symbol-defined-in-java (symbol)
(loop with internal-name1 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "") "-" "_")
with internal-name2 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "_") "-" "_")
for class in
(load-time-value (mapcar
'jclass
'("org.armedbear.lisp.Package"
"org.armedbear.lisp.Symbol"
"org.armedbear.lisp.Debug"
"org.armedbear.lisp.Extensions"
"org.armedbear.lisp.JavaObject"
"org.armedbear.lisp.Lisp"
"org.armedbear.lisp.Pathname"
"org.armedbear.lisp.Site")))
thereis
(or (get-declared-field class internal-name1)
(get-declared-field class internal-name2))))

(defun maybe-implementation-variable (s)
(let ((field (symbol-defined-in-java s)))
(and field
(let ((class (jcall "getName" (jcall "getDeclaringClass" field))))
(let* ((partial-path (substitute #\/ #\. class))
(java-path (concatenate 'string partial-path ".java"))
(found-in-source-path (find-file-in-path java-path *source-path*)))
(if found-in-source-path
`(symbol (:location ,found-in-source-path (:line 0) (:snippet ,(format nil "~s" (string s)))))))))))

(defun if-we-have-to-choose-one-choose-the-function (sources)
(or (loop for spec in sources
for (dspec) = spec
when (and (consp dspec) (eq (car dspec) :function))
when (and (consp dspec) (member (car dspec) '(:swank-implementation :function)))
do (return-from if-we-have-to-choose-one-choose-the-function spec))
(car sources)))

(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)))))))
(or (let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol 'sys::source))))
(and maybe (second (slime-location-from-source-annotation symbol maybe))))
;; This below should be obsolete - it uses the old sys:%source
;; leave it here for now just in case
(and (pathnamep (ext:source-pathname symbol))
(let ((pos (ext:source-file-position symbol))
(path (namestring (ext:source-pathname symbol))))
; boot.lisp gets recorded wrong
(if (equal path "boot.lisp") (setq path (second (find-file-in-path "org/armedbear/lisp/boot.lisp" *source-path*))))
(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))))))
(second (implementation-source-location symbol))))

(defmethod source-location ((frame sys::java-stack-frame))
(destructuring-bind (&key class method file line) (sys:frame-to-list frame)
Expand All @@ -586,11 +706,13 @@
(symbol (source-location operator)))))

(defmethod source-location ((fun function))
(let ((name (function-name fun)))
(and name (source-location name))))
(if (sys::local-function-p fun)
(source-location (sys::local-function-owner fun))
(let ((name (function-name fun)))
(and name (source-location name)))))

(defun system-property (name)
(java:jstatic "getProperty" "java.lang.System" name))
(jstatic "getProperty" "java.lang.System" name))

(defun pathname-parent (pathname)
(make-pathname :directory (butlast (pathname-directory pathname))))
Expand All @@ -600,12 +722,12 @@

(defun split-string (string regexp)
(coerce
(java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
(jcall (jmethod "java.lang.String" "split" "java.lang.String")
string regexp)
'list))

(defun path-separator ()
(java:jfield "java.io.File" "pathSeparator"))
(jfield "java.io.File" "pathSeparator"))

(defun search-path-property (prop-name)
(let ((string (system-property prop-name)))
Expand All @@ -625,18 +747,24 @@
(search-path-property "sun.boot.class.path")))

(defvar *source-path*
(append (search-path-property "user.dir")
(jdk-source-path)
;;(list (truename "/scratch/abcl/src"))
)
(remove nil
(append (search-path-property "user.dir")
(jdk-source-path)
;; include lib jar files. contrib has lisp code. Would be good to build abcl.jar with source code as well
(list (sys::find-system-jar)
(sys::find-contrib-jar))
;; you should tell slime where the abcl sources are. In .swank.lisp I have:
;; (push (probe-file "/Users/alanr/repos/abcl/src/") *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"
(let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile"
"java.lang.String")
zipfile-name)))
(java:jcall
(java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
(jcall
(jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
zipfile entry-name)))

;; (find-file-in-path "java/lang/String.java" *source-path*)
Expand All @@ -649,60 +777,225 @@
(cond ((not (pathname-type dir))
(let ((f (probe-file (merge-pathnames filename dir))))
(and f `(:file ,(namestring f)))))
((equal (pathname-type dir) "zip")
((member (pathname-type dir) '("zip" "jar") :test 'equal)
(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)))))
`(:zip ,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))
|#
(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."
(or (if (and (consp type) (getf *definition-types* (car type)))
`(,(getf *definition-types* (car type)) ,(second type) ,@(third type) ,@(cdddr type))
(getf *definition-types* type))
type))

(defun stringify-method-specs (type)
"return a (:method ..) location for slime"
(let ((*print-case* :downcase))
(flet ((p (a) (princ-to-string a)))
(destructuring-bind (name qualifiers specializers) (cdr type)
`(,(car type) ,(p name) ,(mapcar #'p specializers) ,@(mapcar #'p qualifiers))))))

;; for abcl source, check if it is still there, and if not, look in abcl jar instead
(defun maybe-redirect-to-jar (path)
(setq path (namestring path))
(if (probe-file path)
path
(if (search "/org/armedbear/lisp" path :test 'string=)
(let ((jarpath (format nil "jar:file:~a!~a" (namestring (sys::find-system-jar))
(subseq path (search "/org/armedbear/lisp" path)))))
(if (probe-file jarpath)
jarpath
path))
path)))

(defimplementation find-definitions (symbol)
(if (stringp symbol)
;; allow a string to be passed. If it is package prefixed, remove the prefix
(setq symbol (intern (string-upcase
(subseq symbol (1+ (or (position #\: symbol :from-end t) -1))))
'keyword)))
(let ((sources nil)
(implementation-variables nil)
(implementation-functions nil))
(loop for package in (list-all-packages)
for sym = (find-symbol (string symbol) package)
when (and sym (equal (symbol-package sym) package))
do
(when (sys::autoloadp symbol)
(sys::resolve symbol))
(let ((source (or (get sym 'ext::source) (get sym 'sys::source)))
(i-var (maybe-implementation-variable sym))
(i-fun (implementation-source-location sym)))
(when source (setq sources (append sources (or (get sym 'ext::source) (get sym 'sys::source)))))
(when i-var (push i-var implementation-variables))
(when i-fun (push i-fun implementation-functions))))
(setq sources (remove-duplicates sources :test 'equalp))
(append (remove-duplicates implementation-functions :test 'equalp)
(mapcar (lambda(s) (slime-location-from-source-annotation symbol s)) sources)
(remove-duplicates implementation-variables :test 'equalp))))

(defun slime-location-from-source-annotation (sym it)
(destructuring-bind (what path pos) it
(let* ( ;; all of these are (defxxx forms, which is what :function locations look for in slime
(isfunction (and (consp what) (member (car what) '(:function :generic-function :macro :class :compiler-macro :type :constant :variable :package :structure :condition))))
(ismethod (and (consp what) (eq (car what) :method)))
(<position> (cond (isfunction (list :function-name (princ-to-string (second what))))
(ismethod (stringify-method-specs what))
(t (list :position (1+ (or pos 0))))))
(path2 (if (eq path :top-level)
"emacs-buffer:*slime-repl lsw*"
(maybe-redirect-to-jar path))))
(when (atom what) (setq what (list what sym)))
(list (definition-specifier what)
(if (ext:pathname-jar-p path2)
`(:location
;; strip off "jar:file:" = 9 characters
(:zip ,@(split-string (subseq path2 9) "!/"))
;; pos never seems right. Use function name.
,<position>
(:align t)
)
;; conspire with swank-compile-string to keep the buffer name in a pathname whose device is "emacs-buffer".
(if (eql 0 (search "emacs-buffer:" path2))
`(:location
(:buffer ,(subseq path2 (load-time-value (length "emacs-buffer:"))))
,<position>
(:align t)
)
`(:location
(:file ,path2)
,<position>
(:align t)))
)))))

(defimplementation list-callers (thing)
(loop for caller in (sys::callers thing)
when (typep caller 'method)
append (let ((name (mop:generic-function-name
(mop:method-generic-function caller))))
(mapcar (lambda(s) (slime-location-from-source-annotation thing s))
(remove `(:method ,@(sys::method-spec-list caller))
(get
(if (consp name) (second name) name)
'sys::source)
:key 'car :test-not 'equalp)))
when (symbolp caller)
append (mapcar (lambda(s) (slime-location-from-source-annotation caller s))
(get caller 'sys::source))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Inspecting

(defvar *slime-inspector-hyperspec-in-browser* t
"If t then invoking hyperspec within the inspector browses the hyperspec in an emacs buffer, otherwise respecting the value of browse-url-browser-function")

(defun hyperspec-do (name)
(let ((form `(let ((browse-url-browser-function
,(if *slime-inspector-hyperspec-in-browser*
'(lambda(a v) (eww a))
'browse-url-browser-function)))
(slime-hyperdoc-lookup ,name))))
(swank::eval-in-emacs form t)))

;;; 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 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)))))))
(let* ((type (type-of o))
(class (ignore-errors (find-class type)))
(jclass (and (typep class 'sys::built-in-class)
(jcall "getClass" o))))
(let ((parts (sys:inspected-parts o)))
`((:label "Type: ") (:value ,(or class type)) (:Newline)
,@(if jclass
`((:label "Java type: ") (:value ,jclass) (:newline)))
,@(if parts
(loop :for (label . value) :in parts
:appending (list (list :label (string-capitalize label)) ": " (list :value value (princ-to-string value)) '(:newline)))
(list '(:label "No inspectable parts, dumping output of CL:DESCRIBE:")
'(:newline)
(with-output-to-string (desc) (describe o desc))))))))

(defmethod emacs-inspect ((string string))
(swank::lcons*
'(:label "Value: ") `(:value ,string ,(concatenate 'string "\"" string "\"")) '(:newline)
`(:action "[Edit in emacs buffer]" ,(lambda() (swank::ed-in-emacs `(:string ,string))))
'(:newline)
(if (ignore-errors (jclass string))
`(:line "Names java class" ,(jclass string))
"")
(if (and (jss-p)
(stringp (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t)))
`(:multiple
(:label "Abbreviates java class: ")
,(let ((it (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t)))
`(:value ,(jclass it)))
(:newline))
"")
(if (ignore-errors (find-package (string-upcase string)))
`(:line "Names package" ,(find-package (string-upcase string)))
"")
(let ((symbols (loop for p in (list-all-packages)
for found = (find-symbol (string-upcase string))
when (and found (eq (symbol-package found) p)
(or (fboundp found)
(boundp found)
(symbol-plist found)
(ignore-errors (find-class found))))
collect found)))
(if symbols
`(:multiple (:label "Names symbols: ")
,@(loop for s in symbols
collect
(Let ((*package* (find-package :keyword)))
`(:value ,s ,(prin1-to-string s))) collect " ") (:newline))
""))
(call-next-method)))

(defmethod emacs-inspect ((o java:java-exception))
(append (call-next-method)
(list '(:newline) '(:label "Stack trace")
'(:newline)
(let ((w (jnew "java.io.StringWriter")))
(jcall "printStackTrace" (java:java-exception-cause o) (jnew "java.io.PrintWriter" w))
(jcall "toString" w)))
))

(defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: "
Expand All @@ -712,53 +1005,153 @@ part of *sysdep-pathnames* in swank.loader.lisp.
,@(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)
(:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline)
(:label " Form: ") ,(if (mop:slot-definition-initfunction slot)
`(:value ,(mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
" Function: "
(:label " 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)
`((:label "Name: ")
,(princ-to-string (sys::any-function-name f)) (:newline)))
,@(multiple-value-bind (args present) (sys::arglist f)
(when present
`((:label "Argument list: ")
,(princ-to-string args)
(:newline))))
,@(when (documentation f t)
`("Documentation:" (:newline)
,(documentation f t) (:newline)))
,@(when (function-lambda-expression f)
`("Lambda expression:"
`((:label "Lambda expression:")
(:newline) ,(princ-to-string
(function-lambda-expression f)) (:newline)))))
(function-lambda-expression f)) (:newline)))
(:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline)
,@(when (jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f)
`((:label "Closed over: ")
,@(loop for el in (sys::compiled-closure-context f)
collect `(:value ,el)
collect " ")
(:newline)))
,@(when (sys::get-loaded-from f)
(list `(:label "Defined in: ") `(:value ,(sys::get-loaded-from f) ,(namestring (sys::get-loaded-from f))) '(:newline))
)
,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f))))
(when (plusp (length fields))
(list* '(:label "Internal fields: ") '(:newline)
(loop for field across fields
do (jcall "setAccessible" field t)
append
(let ((value (jcall "get" field f)))
(list " " `(:label ,(jcall "getName" field)) ": " `(:value ,value ,(princ-to-string value)) '(:newline)))))))
,@(when (and (function-name f) (symbolp (function-name f)) (eq (symbol-package (function-name f)) (find-package :cl)))
(list '(:newline) (list :action "Lookup in hyperspec"
(lambda () (hyperspec-do (symbol-name (function-name f))))
:refreshp nil
)
'(: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)))))
(if (jinstance-of-p o (jclass "java.lang.Class"))
(emacs-inspect-java-class o)
(let ((to-string (lambda ()
(handler-case
(setf (gethash o *to-string-hashtable*)
(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))
))))

(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)))

(defun inspector-java-fields (class)
(loop for super = class then (jclass-superclass super)
while super
for fields = (jcall "getDeclaredFields" super)
for fromline = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline))
when (and (plusp (length fields)) fromline)
append fromline
append
(loop for this across fields
for pre = (subseq (jcall "toString" this)
0
(1+ (position #\. (jcall "toString" this) :from-end t)))
collect " "
collect (list :value this pre)
collect (list :strong-value this (jcall "getName" this) )
collect '(:newline))))

(defun inspector-java-methods (class)
(loop for super = class then (jclass-superclass super)
while super
for methods = (jcall "getDeclaredMethods" super)
for fromline = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline))
when (and (plusp (length methods)) fromline) append fromline
append
(loop for this across methods
for desc = (jcall "toString" this)
for paren = (position #\( desc)
for dot = (position #\. (subseq desc 0 paren) :from-end t)
for pre = (subseq desc 0 dot)
for name = (subseq desc dot paren)
for after = (subseq desc paren)
collect " "
collect (list :value this pre)
collect (list :strong-value this name)
collect (list :value this after)
collect '(:newline))))

(defun emacs-inspect-java-class (class)
(let ((has-superclasses (jclass-superclass class))
(has-interfaces (plusp (length (jclass-interfaces class))))
(fields (inspector-java-fields class))
(path (jcall "getResource"
class
(concatenate 'string "/" (substitute #\/ #\. (jcall "getName" class)) ".class"))))
`((:label ,(format nil "Java Class: ~a" (jcall "getName" class) ))
(:newline)
,@(when path (list `(:label ,"Path: ") `(:value ,path) '(:newline)))
,@(if has-superclasses
(list* '(:label "Superclasses: ") (butlast (loop for super = (jclass-superclass class) then (jclass-superclass super)
while super collect (list :value super (jcall "getName" super)) collect ", "))))
,@(if has-interfaces
(list* '(:newline) '(:label "Implements Interfaces: ")
(butlast (loop for i across (jclass-interfaces class) collect (list :value i (jcall "getName" i)) collect ", "))))
(:newline) (:label "Methods:") (:newline)
,@(inspector-java-methods class)
,@(if fields
(list*
'(:newline) '(:label "Fields:") '(:newline)
fields)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Multithreading

(defimplementation spawn (fn &key name)
Expand Down Expand Up @@ -841,7 +1234,26 @@ part of *sysdep-pathnames* in swank.loader.lisp.

(defimplementation quit-lisp ()
(ext:exit))

(defimplementation call-with-syntax-hooks (fn)
(let ((*print-case* :downcase))
(funcall fn)))
;;;
#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext)
(defimplementation package-local-nicknames (package)
(ext:package-local-nicknames package))

;; all the defimplentations aren't compiled. Compile them. Set their
;; function name to be the same as the implementation name so
;; meta-. works.

(eval-when (:load-toplevel :execute)
(loop for s in swank-backend::*interface-functions*
for impl = (get s 'swank-backend::implementation)
do (when (and impl (not (compiled-function-p impl)))
(let ((name (gensym)))
(compile name impl)
(let ((compiled (symbol-function name)))
(system::%set-lambda-name compiled (second (sys::lambda-name impl)))
(setf (get s 'swank-backend::implementation) compiled))))))