From c7c72d7b0f5cd6473af3488202ea1eca24d58202 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Mon, 5 Sep 2016 20:58:42 -0400 Subject: [PATCH 01/18] abcl: radical improvements to inspection and source locations Most of the functionality in this patch requires the as yet unreleased abcl-1.5.0 which may be built from the [abcl-1.5.0-dev][abcl-source-svn] for which [gitlab.common-lisp.net provides a convenient git bridge](https://gitlab.common-lisp.net/abcl/abcl) [abcl-source-svn]: svn://abcl.org/svn/trunk/abcl Enable goto source location to find definitions in JAR archives. For primitives compiled from Java source, return implementation source location designated by the logical pathname associated with 'SYS:SRC'. Finding functions and methods works well, other than when methods are defined as part of a DEFGENERIC form, or implicitly as with :report on condition defining PRINT-OBJECT. FIND-DEFINITIONS include symbols and specials defined in Java. Redirect source lookup to system jar if it's not where it claims to be. Show stack trace when inspecting Java conditions. Implement an inspector for Java classes. Make line labels in inspector (:labels) so they display nicely. Allow find definitions to be called even if the symbol isn't found in the current package, if *find-definitions-all-packages* is t (as it will be for ABCL). Default nil Print internal variables in Java stack traces. Prettier function name if we can glean information about otherwise anonymous function. Fix so that edit slot action in clos object inspector works. Tweak to invoke hyperspec in inspector (offered in symbol browser if a CL symbol) - *slime-inspector-hyperspec-in-browser* if t shows hyperspec in emacs buffer despite setting of browse-url-browser-function. Don't use the ABCL native printObject for frames, so we can get prettier function display. Compile DEFIMPLEMENTATION forms so that they are visible to edit definition. Fix source-location (used by view frame source) to work in general and in particular for local function - go to the source of their owner. Don't show bogus locals for Java stack frames. --- swank/abcl.lisp | 862 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 637 insertions(+), 225 deletions(-) diff --git a/swank/abcl.lisp b/swank/abcl.lisp index f5764d69d..bb97b3078 100644 --- a/swank/abcl.lisp +++ b/swank/abcl.lisp @@ -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") @@ -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 @@ -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 @@ -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)) @@ -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)) @@ -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") @@ -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)) @@ -372,7 +402,6 @@ (let ((backtrace (sys:backtrace))) (subseq (or (member *sldb-topframe* backtrace) backtrace) start end))) - (defun nth-frame (index) (nth index (backtrace 0 nil))) @@ -380,49 +409,79 @@ (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)) @@ -448,6 +507,7 @@ (let ((frame (nth-frame frame-number))) (debugger:frame-retry frame (debugger:frame-function frame)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Compiler hooks (defvar *buffer-name* nil) @@ -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) @@ -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)))) @@ -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))) @@ -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*) @@ -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))) + ( (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. + , + (: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:")))) + , + (:align t) + ) + `(:location + (:file ,path2) + , + (: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: " @@ -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)) "#") (: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)) + "#") (: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) @@ -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)))))) + From d9092c3730049c6bb31e9514ef22cd71fb950928 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Tue, 1 Nov 2016 21:12:24 -0400 Subject: [PATCH 02/18] contrib/swank-fancy-inspector: show symbols in other packages which have the same name (Alan Ruttenberg) --- contrib/swank-fancy-inspector.lisp | 45 ++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/contrib/swank-fancy-inspector.lisp b/contrib/swank-fancy-inspector.lisp index 3e46df941..bc68925dc 100644 --- a/contrib/swank-fancy-inspector.lisp +++ b/contrib/swank-fancy-inspector.lisp @@ -9,6 +9,15 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-util)) +(defun symbol-info (symbol) + (list (and (constantp symbol) (symbol-value symbol)) + (and (fboundp symbol) (symbol-function symbol)) + (and (boundp symbol) (symbol-value symbol)) + (and (find-class symbol nil) (find-class symbol)) + (find-package symbol) + #+armedbear (get symbol 'sys::structure-definition))) + + (defmethod emacs-inspect ((symbol symbol)) (let ((package (symbol-package symbol))) (multiple-value-bind (_symbol status) @@ -89,8 +98,44 @@ ;; More package (if (find-package symbol) (label-value-line "It names the package" (find-package symbol))) + + ;; Same string + (lines-for-symbol-in-other-packages symbol) + (inspect-type-specifier symbol))))) +(defun lines-for-symbol-in-other-packages (symbol) + (let ((others + (loop for p in (list-all-packages) + for candidate = (find-symbol (string symbol) p) + for found = (and (not (null candidate)) + (eq (symbol-package candidate) p) + (not (eq (symbol-package symbol) (symbol-package candidate))) + candidate) + for (constant function value class package structure) = (and found (symbol-info found)) + for specs = (and found + (append (when value + `((:value ,value + ,(if constant "constant" "bound") ", "))) + (when function + `((:value ,function "fbound" ", "))) + (when package + `((:value ,package "package" ", "))) + (when class + `((:value ,class "class") ", ")) + (when structure + `((:value ,structure "structure") ", ")))) + when found + collect + (let ((specs (butlast specs))) + (list* (list :value found (let ((*package* (find-package :keyword))) (format nil "~s" found))) + (if specs ": " "") + (append specs '((:newline)))))))) + (if others + `("In other packages: " + (:newline) + ,@(apply 'append others))))) + #-sbcl (defun inspect-type-specifier (symbol) (declare (ignore symbol))) From 02e748ad19772d14c485ffc5fc3b03a8c310c779 Mon Sep 17 00:00:00 2001 From: Mark Date: Mon, 27 Mar 2017 16:53:42 +0200 Subject: [PATCH 03/18] evenson: proposed fixes to Alan's work to align with SLIME conventions This should be a non-functional change from a behavior perspective, for which there are unfortunately no non-interactive tests. --- swank/abcl.lisp | 145 ++++++++++++++++++++++++++---------------------- 1 file changed, 79 insertions(+), 66 deletions(-) diff --git a/swank/abcl.lisp b/swank/abcl.lisp index bb97b3078..8a666aa33 100644 --- a/swank/abcl.lisp +++ b/swank/abcl.lisp @@ -309,7 +309,9 @@ (t :not-available))) (defimplementation function-name (function) - (sys::any-function-name function)) + (if (fboundp 'sys::any-function-name) ;; abcl-1.5.0 + (sys::any-function-name function) + (nth-value 2 (function-lambda-expression function)))) (defimplementation macroexpand-all (form &optional env) (ext:macroexpand-all form env)) @@ -605,14 +607,13 @@ (: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) + ;; I use jdc.el + ;; with 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))) - )))))))))) + (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)) @@ -661,8 +662,9 @@ (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*)))) + ;; 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 @@ -750,14 +752,15 @@ (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 + ;; 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)) + (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.") + +"List of directories to search for source files.") (defun zipfile-contains-p (zipfile-name entry-name) (let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile" @@ -767,9 +770,6 @@ (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) @@ -869,37 +869,44 @@ (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))) - ( (cond (isfunction (list :function-name (princ-to-string (second what)))) - (ismethod (stringify-method-specs what)) - (t (list :position (1+ (or pos 0)))))) + ;; all of these are (defxxx forms, which is what :function locations look for in slime + (let* ((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))) + ( (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*" + "emacs-buffer:*slime-repl*" (maybe-redirect-to-jar path)))) - (when (atom what) (setq what (list what sym))) + (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) "!/")) + ;; jar-pathname stores JAR path as first of DEVICE + (:zip ,@(pathname-device path2)) ;; pos never seems right. Use function name. , - (: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:")))) - , - (:align t) - ) - `(:location - (:file ,path2) - , - (:align t))) - ))))) + (: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:")))) + , + (:align t)) + `(:location + (:file ,path2) + , + (:align t)))))))) (defimplementation list-callers (thing) (loop for caller in (sys::callers thing) @@ -947,7 +954,10 @@ `((: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))) + :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)))))))) @@ -994,8 +1004,7 @@ '(:newline) (let ((w (jnew "java.io.StringWriter"))) (jcall "printStackTrace" (java:java-exception-cause o) (jnew "java.io.PrintWriter" w)) - (jcall "toString" w))) - )) + (jcall "toString" w))))) (defmethod emacs-inspect ((slot mop::slot-definition)) `("Name: " @@ -1015,45 +1024,50 @@ (defmethod emacs-inspect ((f function)) `(,@(when (function-name f) - `((:label "Name: ") - ,(princ-to-string (sys::any-function-name f)) (:newline))) + `((: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))) + `("Documentation:" (:newline) + ,(documentation f t) (:newline))) ,@(when (function-lambda-expression f) - `((:label "Lambda expression:") - (:newline) ,(princ-to-string - (function-lambda-expression f)) (:newline))) + `((:label "Lambda expression:") + (:newline) ,(princ-to-string + (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 " ") + ,@(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)) - ) + (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))) + do (jcall "setAccessible" field t) ;;; not a great idea esp. wrt. Java9 + 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))) - )) + (lambda () (hyperspec-do (symbol-name (function-name f)))) + :refreshp nil) + '(:newline))))) (defmethod emacs-inspect ((o java:java-object)) (if (jinstance-of-p o (jclass "java.lang.Class")) @@ -1072,8 +1086,7 @@ (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)) - )))) + :appending (label-value-line label value)))))) (defmethod emacs-inspect ((slot mop::slot-definition)) `("Name: " From 2b9b85d8a17df09b7c3fb25b0a22e324aa3f4170 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Tue, 1 Nov 2016 22:24:53 -0400 Subject: [PATCH 04/18] abcl: Enable load of xref package Uncertain if this is working. --- swank-loader.lisp | 2 +- swank.lisp | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/swank-loader.lisp b/swank-loader.lisp index 7bb81da9c..86c82d25c 100644 --- a/swank-loader.lisp +++ b/swank-loader.lisp @@ -43,7 +43,7 @@ #+lispworks '((swank lispworks) (swank gray)) #+allegro '((swank allegro) (swank gray)) #+clisp '(xref metering (swank clisp) (swank gray)) - #+armedbear '((swank abcl)) + #+armedbear '((swank abcl) xref) #+cormanlisp '((swank corman) (swank gray)) #+ecl '((swank ecl) (swank gray)) #+clasp '((swank clasp) (swank gray)) diff --git a/swank.lisp b/swank.lisp index 2cdaef023..1e6688f5e 100644 --- a/swank.lisp +++ b/swank.lisp @@ -3022,7 +3022,7 @@ DSPEC is a string and LOCATION a source location. NAME is a string." (defun xref>elisp (xref) (destructuring-bind (name loc) xref - (list (to-string name) loc))) + (list (if (stringp name) name (to-string name) ) loc))) ;;;;; Lazy lists From badc7cd8c19c45a9e85e73e891da21c8b3d580c7 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Mon, 12 Dec 2016 23:27:05 -0500 Subject: [PATCH 05/18] Add an inspector :strong-view for a view with a bolder face (Alan Ruttenberg) --- slime.el | 16 ++++++++++++++-- swank.lisp | 10 ++++++---- 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/slime.el b/slime.el index 5a8527395..447e21ffa 100644 --- a/slime.el +++ b/slime.el @@ -6236,6 +6236,11 @@ was called originally." "Face for labels in the inspector." :group 'slime-inspector) +(defface slime-inspector-strong-face + '((t (:inherit slime-inspector-label-face))) + "Face for parts of values that are emphasized in the inspector." + :group 'slime-inspector) + (defface slime-inspector-value-face '((t (:inherit font-lock-builtin-face))) "Face for things which can themselves be inspected." @@ -6293,13 +6298,14 @@ KILL-BUFFER hooks for the inspector buffer." (let ((inhibit-read-only t)) (erase-buffer) (pop-to-buffer (current-buffer)) + (font-lock-mode -1) (cl-destructuring-bind (&key id title content) inspected-parts (cl-macrolet ((fontify (face string) `(slime-inspector-fontify ,face ,string))) (slime-propertize-region (list 'slime-part-number id 'mouse-face 'highlight - 'face 'slime-inspector-value-face) + 'face 'slime-inspector-topline-face) (insert title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) @@ -6336,12 +6342,18 @@ If PREV resp. NEXT are true insert more-buttons as needed." (if (stringp ispec) (insert ispec) (slime-dcase ispec - ((:value string id) + ((:value string id ) (slime-propertize-region (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) (insert string))) + ((:strong-value string id ) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-strong-face) + (insert string))) ((:label string) (insert (slime-inspector-fontify label string))) ((:action string id) diff --git a/swank.lisp b/swank.lisp index 2cdaef023..fb750ab2b 100644 --- a/swank.lisp +++ b/swank.lisp @@ -3166,6 +3166,8 @@ DSPEC is a string and LOCATION a source location. NAME is a string." ((:newline) (list newline)) ((:value obj &optional str) (list (value-part obj str (istate.parts istate)))) + ((:strong-value obj &optional str) + (list (value-part obj str (istate.parts istate) t))) ((:label &rest strs) (list (list :label (apply #'cat (mapcar #'string strs))))) ((:action label lambda &key (refreshp t)) @@ -3176,10 +3178,10 @@ DSPEC is a string and LOCATION a source location. NAME is a string." (value-part value nil (istate.parts istate)) newline))))))) -(defun value-part (object string parts) - (list :value - (or string (print-part-to-string object)) - (assign-index object parts))) +(defun value-part (object string parts &optional strong?) + (list (if strong? :strong-value :value) + (or string (print-part-to-string object)) + (assign-index object parts))) (defun action-part (label lambda refreshp actions) (list :action label (assign-index (list lambda refreshp) actions))) From 0a4d470216574272ec1ef1cc1803532bf298d0c2 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Tue, 13 Dec 2016 10:27:22 -0500 Subject: [PATCH 06/18] Make line labels in inspector (:labels) so they display nicely (Alan Ruttenberg) Spell correct seperated -> separated. * * * revert a small change --- contrib/swank-fancy-inspector.lisp | 84 +++++++++++++++--------------- swank/backend.lisp | 2 +- 2 files changed, 43 insertions(+), 43 deletions(-) diff --git a/contrib/swank-fancy-inspector.lisp b/contrib/swank-fancy-inspector.lisp index bc68925dc..f220437be 100644 --- a/contrib/swank-fancy-inspector.lisp +++ b/contrib/swank-fancy-inspector.lisp @@ -48,9 +48,9 @@ ;; Function (if (fboundp symbol) (append (if (macro-function symbol) - `("It a macro with macro-function: " + `((:label "It a macro with macro-function: ") (:value ,(macro-function symbol))) - `("It is a function: " + `((:label "It is a function: ") (:value ,(symbol-function symbol)))) `(" " (:action "[unbind]" ,(lambda () (fmakunbound symbol)))) @@ -70,8 +70,8 @@ ;; ;; Package (if package - `("It is " ,(string-downcase (string status)) - " to the package: " + `((:label "It is ") (:label ,(string-downcase (string status))) + (:label " to the package: ") (:value ,package ,(package-name package)) ,@(if (eq :internal status) `(" " @@ -184,9 +184,9 @@ (cond ((not docstring) nil) ((< (+ (length label) (length docstring)) 75) - (list label ": " docstring '(:newline))) + (list `(:label ,label) ": " docstring '(:newline))) (t - (list label ":" '(:newline) " " docstring '(:newline)))))) + (list `(:label ,label) ":" '(:newline) " " docstring '(:newline)))))) (unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) (defmethod emacs-inspect ((f function)) @@ -194,13 +194,13 @@ (defun inspect-function (f) (append - (label-value-line "Name" (function-name f)) - `("Its argument list is: " + (list '(:label "Name:") (function-name f) '(:newline)) + `((:label "Argument list: ") ,(inspector-princ (arglist f)) (:newline)) (docstring-ispec "Documentation" f t) (if (function-lambda-expression f) (label-value-line "Lambda Expression" - (function-lambda-expression f))))) + (function-lambda-expression f))))) (defun method-specializers-for-inspect (method) "Return a \"pretty\" list of the method's specializers. Normal @@ -386,7 +386,7 @@ See `methods-by-applicability'.") ,@ (case (ref grouping-kind) (:all `((:newline) - "All Slots:" + (:label "All Slots:") (:newline) ,@(make-slot-listing checklist object class effective-slots direct-slots @@ -496,7 +496,7 @@ See `methods-by-applicability'.") (defmethod emacs-inspect ((gf standard-generic-function)) - (flet ((lv (label value) (label-value-line label value))) + (flet ((lv (label value) `((:label ,label)": " (:value ,value ,(princ-to-string value)) (:newline)))) (append (lv "Name" (swank-mop:generic-function-name gf)) (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) @@ -504,7 +504,7 @@ See `methods-by-applicability'.") (lv "Method class" (swank-mop:generic-function-method-class gf)) (lv "Method combination" (swank-mop:generic-function-method-combination gf)) - `("Methods: " (:newline)) + `((:label "Methods: ") (:newline)) (loop for method in (funcall *gf-method-getter* gf) append `((:value ,method ,(inspector-princ ;; drop the name of the GF @@ -520,7 +520,7 @@ See `methods-by-applicability'.") (defmethod emacs-inspect ((method standard-method)) `(,@(if (swank-mop:method-generic-function method) - `("Method defined on the generic function " + `((:label "Method defined on the generic function ") (:value ,(swank-mop:method-generic-function method) ,(inspector-princ (swank-mop:generic-function-name @@ -528,15 +528,15 @@ See `methods-by-applicability'.") '("Method without a generic function")) (:newline) ,@(docstring-ispec "Documentation" method t) - "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) + (:label "Lambda List: ") (:value ,(swank-mop:method-lambda-list method)) (:newline) - "Specializers: " (:value ,(swank-mop:method-specializers method) + (:label "Specializers: ") (:value ,(swank-mop:method-specializers method) ,(inspector-princ (method-specializers-for-inspect method))) (:newline) - "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) + (:label "Qualifiers: ") (:value ,(swank-mop:method-qualifiers method)) (:newline) - "Method function: " (:value ,(swank-mop:method-function method)) + (:label "Method function: ") (:value ,(swank-mop:method-function method)) (:newline) ,@(all-slots-for-inspector method))) @@ -553,22 +553,22 @@ See `methods-by-applicability'.") (second name))))))) (defmethod emacs-inspect ((class standard-class)) - `("Name: " + `((:label "Name: ") (:value ,(class-name class)) (:newline) - "Super classes: " - ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + (:label "Super classes: ") + ,@(common-separated-spec (swank-mop:class-direct-superclasses class)) (:newline) - "Direct Slots: " - ,@(common-seperated-spec + (:label "Direct Slots: ") + ,@(common-separated-spec (swank-mop:class-direct-slots class) (lambda (slot) `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) (:newline) - "Effective Slots: " + (:label "Effective Slots: ") ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec + (common-separated-spec (swank-mop:class-slots class) (lambda (slot) `(:value ,slot ,(inspector-princ @@ -579,16 +579,16 @@ See `methods-by-applicability'.") (:newline) ,@(let ((doc (documentation class t))) (when doc - `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) + `((:label "Documentation:") (:newline) ,(inspector-princ doc) (:newline)))) "Sub classes: " - ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) + ,@(common-separated-spec (swank-mop:class-direct-subclasses class) (lambda (sub) `(:value ,sub ,(inspector-princ (class-name sub))))) (:newline) - "Precedence List: " + (:label "Precedence List: ") ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec + (common-separated-spec (swank-mop:class-precedence-list class) (lambda (class) `(:value ,class ,(inspector-princ (class-name class))))) @@ -599,16 +599,16 @@ See `methods-by-applicability'.") (:newline) ,@(loop for method in (specializer-direct-methods class) + for method-spec = (method-for-inspect-value method) collect " " - collect `(:value ,method - ,(inspector-princ - (method-for-inspect-value method))) + collect `(:value ,method ,(inspector-princ (car method-spec))) + collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec))) collect '(:newline) if (documentation method t) collect " Documentation: " and collect (abbrev-doc (documentation method t)) and collect '(:newline)))) - "Prototype: " ,(if (swank-mop:class-finalized-p class) + (:label "Prototype: ") ,(if (swank-mop:class-finalized-p class) `(:value ,(swank-mop:class-prototype class)) '"#") (:newline) @@ -619,19 +619,19 @@ See `methods-by-applicability'.") (:value ,(swank-mop:slot-definition-name slot)) (:newline) ,@(when (swank-mop:slot-definition-documentation slot) - `("Documentation:" (:newline) + `((:label "Documentation:") (:newline) (:value ,(swank-mop:slot-definition-documentation slot)) (:newline))) - "Init args: " + (:label "Init args: ") (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) - "Init form: " + (:label "Init form: ") ,(if (swank-mop:slot-definition-initfunction slot) `(:value ,(swank-mop:slot-definition-initform slot)) "#") (:newline) - "Init function: " + (:label "Init function: ") (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline) ,@(all-slots-for-inspector slot))) @@ -806,21 +806,21 @@ SPECIAL-OPERATOR groups." external-symbols (sort external-symbols #'string<) inherited-symbols (sort inherited-symbols #'string<)) `("" ;; dummy to preserve indentation. - "Name: " (:value ,package-name) (:newline) + (:label "Name: ") (:value ,package-name) (:newline) - "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + (:label "Nick names: ") ,@(common-separated-spec package-nicknames) (:newline) ,@(when (documentation package t) - `("Documentation:" (:newline) + `((:label "Documentation:") (:newline) ,(documentation package t) (:newline))) - "Use list: " ,@(common-seperated-spec + "Uses packages: " ,@(common-separated-spec package-use-list (lambda (package) `(:value ,package ,(package-name package)))) (:newline) - "Used by list: " ,@(common-seperated-spec + (:label "Used by packages: ") ,@(common-separated-spec package-used-by-list (lambda (package) `(:value ,package ,(package-name package)))) @@ -1031,7 +1031,7 @@ SPECIAL-OPERATOR groups." (make-file-stream-ispec stream)) content)))) -(defun common-seperated-spec (list &optional (callback (lambda (v) +(defun common-separated-spec (list &optional (callback (lambda (v) `(:value ,v)))) (butlast (loop diff --git a/swank/backend.lisp b/swank/backend.lisp index 8403fd865..9ea1901b5 100644 --- a/swank/backend.lisp +++ b/swank/backend.lisp @@ -1225,7 +1225,7 @@ output of CL:DESCRIBE." (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) + (list* (list :label (princ-to-string label)) ": " `(:value ,value) (if newline '((:newline)) nil))) (defmacro label-value-line* (&rest label-values) From 9bbef86b9ed869f6d1916c745d2d55eabda4f82d Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Fri, 23 Dec 2016 01:23:55 -0500 Subject: [PATCH 07/18] Strings may edited in an emacs buffer from the inspector (Alan Ruttenberg) Allow (:multiple ..) in inspector specs to make life a bit easier. --- slime.el | 9 ++++++++- swank.lisp | 13 +++++++++---- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/slime.el b/slime.el index 447e21ffa..35e39a9af 100644 --- a/slime.el +++ b/slime.el @@ -3890,6 +3890,7 @@ WHAT can be: A filename (string), A list (:filename FILENAME &key LINE COLUMN POSITION), A function name (:function-name STRING) + A string (:string STRING) nil. This is for use in the implementation of COMMON-LISP:ED." @@ -3908,7 +3909,13 @@ This is for use in the implementation of COMMON-LISP:ED." (byte-to-position position) position)))) ((:function-name name) - (slime-edit-definition name))))) + (slime-edit-definition name)) + ((:string string) + (with-output-to-temp-buffer "*edit-string*" + (switch-to-buffer "*edit-string*") + (princ string) + (fundamental-mode) + (setq buffer-read-only nil)))))) (defun slime-goto-line (line-number) "Move to line LINE-NUMBER (1-based). diff --git a/swank.lisp b/swank.lisp index fb750ab2b..8c8d43db6 100644 --- a/swank.lisp +++ b/swank.lisp @@ -1948,14 +1948,17 @@ N.B. this is not an actual package name or nickname." WHAT can be: A pathname or a string, + A literal string (:string STRING) A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION), A function name (symbol or cons), NIL. " (flet ((canonicalize-filename (filename) (pathname-to-filename (or (probe-file filename) filename)))) (let ((target - (etypecase what - (null nil) + (etypecase what + (null nil) + ((cons (eql :string) (cons string)) + what) ((or string pathname) `(:filename ,(canonicalize-filename what))) ((cons (or string pathname) *) @@ -3162,6 +3165,8 @@ DSPEC is a string and LOCATION a source location. NAME is a string." (let ((newline '#.(string #\newline))) (etypecase part (string (list part)) + ((cons (eql :multiple)) + (mapcan (lambda(p) (prepare-part p istate)) (cdr part))) (cons (dcase part ((:newline) (list newline)) ((:value obj &optional str) @@ -3174,7 +3179,7 @@ DSPEC is a string and LOCATION a source location. NAME is a string." (list (action-part label lambda refreshp (istate.actions istate)))) ((:line label value) - (list (princ-to-string label) ": " + (list `(:label ,(princ-to-string label)) ": " (value-part value nil (istate.parts istate)) newline))))))) @@ -3406,7 +3411,7 @@ Return NIL if LIST is circular." (iline "Adjustable" (adjustable-array-p array)) (iline "Fill pointer" (if (array-has-fill-pointer-p array) (fill-pointer array))) - "Contents:" '(:newline) + `(:label "Contents:") '(:newline) (labels ((k (i max) (cond ((= i max) '()) (t (lcons (iline i (row-major-aref array i)) From fde90d8230ed273dd97a08b3daa8f26440208b4f Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Sat, 24 Dec 2016 17:57:54 -0500 Subject: [PATCH 08/18] Refactor utilties used by inspectors into swank/backend.lisp (Alan Ruttenberg) WITH-STRUCT*, LCONS, LCONS*, LCONS-CDR, LLIST-RANGE, LLIST-SKIP, LLIST-TAKE and ILINE are potentially useful in implementation-specific inspector functions and implementations are loaded before swank.lisp. --- packages.lisp | 9 ++++++++ swank.lisp | 57 ---------------------------------------------- swank/backend.lisp | 57 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 66 insertions(+), 57 deletions(-) diff --git a/packages.lisp b/packages.lisp index df7b9290b..4e11c9c16 100644 --- a/packages.lisp +++ b/packages.lisp @@ -60,6 +60,15 @@ profile-reset profile-package + with-struct* + lcons + lcons* + lcons-cdr + llist-range + llist-skip + llist-take + iline + with-collected-macro-forms)) (defpackage swank/rpc diff --git a/swank.lisp b/swank.lisp index 8c8d43db6..06471ea5e 100644 --- a/swank.lisp +++ b/swank.lisp @@ -501,17 +501,6 @@ corresponding values in the CDR of VALUE." (check-type msg string) `(call-with-retry-restart ,msg (lambda () ,@body))) -(defmacro with-struct* ((conc-name get obj) &body body) - (let ((var (gensym))) - `(let ((,var ,obj)) - (macrolet ((,get (slot) - (let ((getter (intern (concatenate 'string - ',(string conc-name) - (string slot)) - (symbol-package ',conc-name)))) - `(,getter ,',var)))) - ,@body)))) - (defmacro define-special (name doc) "Define a special variable NAME with doc string DOC. This is like defvar, but NAME will not be initialized." @@ -3027,52 +3016,6 @@ DSPEC is a string and LOCATION a source location. NAME is a string." (destructuring-bind (name loc) xref (list (to-string name) loc))) - -;;;;; Lazy lists - -(defstruct (lcons (:constructor %lcons (car %cdr)) - (:predicate lcons?)) - car - (%cdr nil :type (or null lcons function)) - (forced? nil)) - -(defmacro lcons (car cdr) - `(%lcons ,car (lambda () ,cdr))) - -(defmacro lcons* (car cdr &rest more) - (cond ((null more) `(lcons ,car ,cdr)) - (t `(lcons ,car (lcons* ,cdr ,@more))))) - -(defun lcons-cdr (lcons) - (with-struct* (lcons- @ lcons) - (cond ((@ forced?) - (@ %cdr)) - (t - (let ((value (funcall (@ %cdr)))) - (setf (@ forced?) t - (@ %cdr) value)))))) - -(defun llist-range (llist start end) - (llist-take (llist-skip llist start) (- end start))) - -(defun llist-skip (lcons index) - (do ((i 0 (1+ i)) - (l lcons (lcons-cdr l))) - ((or (= i index) (null l)) - l))) - -(defun llist-take (lcons count) - (let ((result '())) - (do ((i 0 (1+ i)) - (l lcons (lcons-cdr l))) - ((or (= i count) - (null l))) - (push (lcons-car l) result)) - (nreverse result))) - -(defun iline (label value) - `(:line ,label ,value)) - ;;;; Inspecting diff --git a/swank/backend.lisp b/swank/backend.lisp index 9ea1901b5..1a7efb85c 100644 --- a/swank/backend.lisp +++ b/swank/backend.lisp @@ -1183,6 +1183,63 @@ SPEC can be: ;;;; Inspector +(defmacro with-struct* ((conc-name get obj) &body body) + (let ((var (gensym))) + `(let ((,var ,obj)) + (macrolet ((,get (slot) + (let ((getter (intern (concatenate 'string + ',(string conc-name) + (string slot)) + (symbol-package ',conc-name)))) + `(,getter ,',var)))) + ,@body)))) + +;;;;; Lazy lists (moved from swank.lisp) + +(defstruct (lcons (:constructor %lcons (car %cdr)) + (:predicate lcons?)) + car + (%cdr nil :type (or null lcons function)) + (forced? nil)) + +(defmacro lcons (car cdr) + `(%lcons ,car (lambda () ,cdr))) + +(defmacro lcons* (car cdr &rest more) + (cond ((null more) `(lcons ,car ,cdr)) + (t `(lcons ,car (lcons* ,cdr ,@more))))) + +(defun lcons-cdr (lcons) + (with-struct* (lcons- @ lcons) + (cond ((@ forced?) + (@ %cdr)) + (t + (let ((value (funcall (@ %cdr)))) + (setf (@ forced?) t + (@ %cdr) value)))))) + +(defun llist-range (llist start end) + (llist-take (llist-skip llist start) (- end start))) + +(defun llist-skip (lcons index) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i index) (null l)) + l))) + +(defun llist-take (lcons count) + (let ((result '())) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i count) + (null l))) + (push (lcons-car l) result)) + (nreverse result))) + +(defun iline (label value) + `(:line ,label ,value)) + + (defgeneric emacs-inspect (object) (:documentation "Explain to Emacs how to inspect OBJECT. From a667ad117e733a8261f9737fa4ad9d2da099d398 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Sat, 5 Nov 2016 02:01:49 -0400 Subject: [PATCH 09/18] Fixes for searching for functions and methods (Alan Ruttenberg) Searching for functions and methods was broken in cases where a) Either the (def or the name was package prefixed or b) where there initial arguments of a method which weren't specialized. Fix a) by adding a regex that matches the package optionally. fix b) by instead of removing T specializers, replacing them with \>[[:word:]]+\<. --- slime.el | 52 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/slime.el b/slime.el index 35e39a9af..d7221fb3e 100644 --- a/slime.el +++ b/slime.el @@ -3176,6 +3176,8 @@ you should check twice before modifying.") (set-buffer buffer) (goto-char (point-min)))))) +(defvar optional-package-regex "\\([[:word:]]+:\\{1,2\\}\\)\\{0,1\\}") + (defun slime-goto-location-position (position) (slime-dcase position ((:position pos) @@ -3195,10 +3197,10 @@ you should check twice before modifying.") (goto-char (point-min)) (when (or (re-search-forward - (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" - (regexp-quote name)) nil t) + (format "\\s *(%sdef\\(\\s_\\|\\sw\\)*\\s +(*%s%s\\S_" + optional-package-regex optional-package-regex (regexp-quote name)) nil t) (re-search-forward - (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) + (format "[( \t]%s%s\\>\\(\\s \\|$\\)" optional-package-regex name) nil t)) (goto-char (match-beginning 0))))) ((:method name specializers &rest qualifiers) (slime-search-method-location name specializers qualifiers)) @@ -3230,27 +3232,33 @@ you should check twice before modifying.") ;; qualifers specializers don't look for "T" since it isn't requires ;; (arg without t) as class is taken as such. (let* ((case-fold-search t) - (name (regexp-quote name)) + (name (regexp-quote name)) (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) qualifiers "")) - (specializers (mapconcat - (lambda (el) - (if (eql (aref el 0) ?\() - (let ((spec (read el))) - (if (eq (car spec) 'EQL) - (concat - ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" - (format "%s" (cl-second spec)) ")") - (error "don't understand specializer: %s,%s" - el (car spec)))) - (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) - (remove "T" specializers) "")) - (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name - qualifiers specializers))) - (or (and (re-search-forward regexp nil t) - (goto-char (match-beginning 0))) - ;; (slime-goto-location-position `(:function-name ,name)) - ))) + (specializers (mapconcat + (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat + ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" + (format "%s" (cl-second spec)) ")") + (error "don't understand specializer: %s,%s" + el (car spec)))) + (concat ".*?\\n\\{0,1\\}.*?\\<" el "\\>"))) + (subst "[[:word:]]+" "t" specializers :test 'equalp) "")) + (regexp (format "\\s *(%sdef\\(\\s_\\|\\sw\\)*\\s +%s%s\\s +%s%s" + optional-package-regex + optional-package-regex name + qualifiers specializers))) + (or (and + (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + (and + (re-search-backward regexp nil t) + (goto-char (match-beginning 0))) + ;; (slime-goto-location-position `(:function-name ,name)) + ))) (defun slime-search-call-site (fname) "Move to the place where FNAME called. From 8158f240cf0e447aaff9ddfa0d9aca53ed9a00ae Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Mon, 12 Dec 2016 02:06:08 -0500 Subject: [PATCH 10/18] load swank matcher earlier Gives user-specific implementations earlier use of the matcher. --- swank-loader.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/swank-loader.lisp b/swank-loader.lisp index 7bb81da9c..9fb8221bb 100644 --- a/swank-loader.lisp +++ b/swank-loader.lisp @@ -240,7 +240,7 @@ If LOAD is true, load the fasl file." (defvar *swank-files* `(packages - (swank backend) ,@*sysdep-files* (swank match) (swank rpc) + (swank backend) (swank match) (swank rpc) ,@*sysdep-files* swank)) (defvar *contribs* From e15c4163cfca6cfdb042e6c8a9003e77f4527ca8 Mon Sep 17 00:00:00 2001 From: Alan Ruttenberg Date: Sat, 17 Dec 2016 01:05:27 -0500 Subject: [PATCH 11/18] Find definitions even if the symbol isn't found in the current package The new special *FIND-DEFINITIONS-ALL-PACKAGES* controls this behavior. --- swank.lisp | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/swank.lisp b/swank.lisp index 06471ea5e..f1048d0c0 100644 --- a/swank.lisp +++ b/swank.lisp @@ -120,6 +120,9 @@ Backend code should treat the connection structure as opaque.") (defvar *after-init-hook* '() "Hook run after user init files are loaded.") +(defvar *find-definitions-all-packages* nil + "If t then find-definitions will be called even if there is no symbol in the current package") + ;;;; Connections ;;; @@ -2974,8 +2977,10 @@ If non-nil, called with two arguments SPEC and TRACED-P." ) DSPEC is a string and LOCATION a source location. NAME is a string." (multiple-value-bind (symbol found) (find-definitions-find-symbol-or-package name) - (when found - (mapcar #'xref>elisp (find-definitions symbol))))) + (if *find-definitions-all-packages* + (mapcar #'xref>elisp (find-definitions (or symbol name))) + (when found + (mapcar #'xref>elisp (find-definitions (or symbol name))))))) ;;; Generic function so contribs can extend it. (defgeneric xref-doit (type thing) From f1a4cbcea583e2b549761f76b3ad678019036803 Mon Sep 17 00:00:00 2001 From: Michael White Date: Sat, 15 Apr 2017 19:07:24 -0700 Subject: [PATCH 12/18] kawa: add eval-and-grab-output for slime-eval-print-last-expression Note that this implementation does not capture values printed to standard output. It is not clear that dynamically rebinding the standard output port is possible in Kawa. --- contrib/swank-kawa.scm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/contrib/swank-kawa.scm b/contrib/swank-kawa.scm index 843037bae..3dd9c07ab 100644 --- a/contrib/swank-kawa.scm +++ b/contrib/swank-kawa.scm @@ -809,6 +809,12 @@ (l (values-to-list (eval form env)))) (apply cat (map pprint-to-string l)))) +(defslimefun eval-and-grab-output (env string) + (let ((form (read (open-input-string string)))) + (let-values ((values (eval form env))) + (list "" + (format #f "~{~S~^~%~}" values))))) + (df call-with-abort (f) (try-catch (f) (ex (exception-message ex)))) From 480e1367afe4d5de01d6a076d9870f14d38cee26 Mon Sep 17 00:00:00 2001 From: drmeister Date: Sat, 18 Mar 2017 10:15:02 -0400 Subject: [PATCH 13/18] Added multithreading to clasp. --- swank/clasp.lisp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/swank/clasp.lisp b/swank/clasp.lisp index 74622262c..88e6784a6 100644 --- a/swank/clasp.lisp +++ b/swank/clasp.lisp @@ -51,10 +51,11 @@ ;;;; TCP Server (defimplementation preferred-communication-style () - ;; CLASP does not provide threads yet. + ;; As of March 2017 CLASP provides threads. + ;; But it's experimental. ;; ECLs swank implementation says that CLOS is not thread safe and ;; I use ECLs CLOS implementation - this is a worry for the future. - nil + :spawn ;; nil or :spawn ) (defun resolve-hostname (name) From 2a04c27cfd299e5c1fadc39a72cf70e4f371846e Mon Sep 17 00:00:00 2001 From: drmeister Date: Sun, 19 Mar 2017 17:11:52 -0400 Subject: [PATCH 14/18] Only use :SPAWN if *features* has :threads --- swank/clasp.lisp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/swank/clasp.lisp b/swank/clasp.lisp index 88e6784a6..6a6a001da 100644 --- a/swank/clasp.lisp +++ b/swank/clasp.lisp @@ -55,7 +55,9 @@ ;; But it's experimental. ;; ECLs swank implementation says that CLOS is not thread safe and ;; I use ECLs CLOS implementation - this is a worry for the future. - :spawn ;; nil or :spawn + ;; nil or :spawn + #+threads :spawn + #-threads nil ) (defun resolve-hostname (name) From 433e55895c4b6b7430bc9dd058af46726027e93c Mon Sep 17 00:00:00 2001 From: drmeister Date: Wed, 19 Apr 2017 15:05:25 -0400 Subject: [PATCH 15/18] Added support for clasp threads --- swank/clasp.lisp | 39 +++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/swank/clasp.lisp b/swank/clasp.lisp index 6a6a001da..ee8278329 100644 --- a/swank/clasp.lisp +++ b/swank/clasp.lisp @@ -56,8 +56,10 @@ ;; ECLs swank implementation says that CLOS is not thread safe and ;; I use ECLs CLOS implementation - this is a worry for the future. ;; nil or :spawn - #+threads :spawn + :spawn +#| #+threads :spawn #-threads nil +|# ) (defun resolve-hostname (name) @@ -702,31 +704,48 @@ (defimplementation wake-thread (thread) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) + (format t "About to with-lock in wake-thread~%") (mp:with-lock (mutex) + (format t "In wake-thread~%") (mp:condition-variable-broadcast (mailbox.cvar mbox))))) (defimplementation send (thread message) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) + (swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message mutex) + (swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + (swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) (mp:with-lock (mutex) + (swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + (swank::log-event "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) + (swank::log-event "clasp.lisp: send about to broadcast~%") (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + (defimplementation receive-if (test &optional timeout) + (slime-dbg "Entered receive-if") (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox))) + (slime-dbg "receive-if assert") (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-wait (mailbox.cvar mbox) mutex))))) + (slime-dbg "receive-if check-slime-interrupts") + (check-slime-interrupts) + (slime-dbg "receive-if with-lock") + (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)))) + (slime-dbg "receive-if when (eq") + (when (eq timeout t) (return (values nil t))) + (slime-dbg "receive-if condition-variable-timedwait") + (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 + (slime-dbg "came out of condition-variable-timedwait") + (core:check-pending-interrupts))))) ) ; #+threads (progn ... From 90771f1abde64cbe2015f981d83d365c75bcda71 Mon Sep 17 00:00:00 2001 From: drmeister Date: Wed, 19 Apr 2017 15:05:44 -0400 Subject: [PATCH 16/18] Added collect-macro-forms support --- swank/clasp.lisp | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/swank/clasp.lisp b/swank/clasp.lisp index ee8278329..db72512ab 100644 --- a/swank/clasp.lisp +++ b/swank/clasp.lisp @@ -13,9 +13,12 @@ (in-package swank/clasp) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq swank::*log-output* (open "/tmp/slime.log" :direction :output)) + (setq swank:*log-events* t)) -(defmacro cslime-log (fmt &rest fmt-args) - `(format t ,fmt ,@fmt-args)) +(defmacro slime-dbg (fmt &rest args) + `(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) ;; Hard dependencies. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -334,6 +337,33 @@ (declare (ignore env)) (macroexpand form)) +;;; modified from sbcl.lisp +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (format t "In collect-macro-forms~%") + (cmp:code-walk + form environment + :code-walker-function + (lambda (form environment) + (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 (core:compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form)) + (values macro-forms compiler-macro-forms))) + + + + + (defimplementation describe-symbol-for-emacs (symbol) (let ((result '())) (flet ((frob (type boundp) From 7dc97e11f0d7efecc3adadfbc24dcc69fe0709fb Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Fri, 21 Apr 2017 17:10:11 -0400 Subject: [PATCH 17/18] Use predicates, not widetags --- swank/sbcl.lisp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/swank/sbcl.lisp b/swank/sbcl.lisp index aaa2604c6..9b21d800f 100644 --- a/swank/sbcl.lisp +++ b/swank/sbcl.lisp @@ -1581,22 +1581,21 @@ stack." 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) + (cond ((sb-kernel:simple-fun-p o) (label-value-line* (:name (sb-kernel:%simple-fun-name o)) (:arglist (sb-kernel:%simple-fun-arglist 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) + ((sb-kernel:closurep o) (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))))) + (t (call-next-method o)))) (defmethod emacs-inspect ((o sb-kernel:code-component)) (append From 94e372e591b6e0350dfd4c5e9bd80617d63c990f Mon Sep 17 00:00:00 2001 From: Mark Date: Sun, 23 Apr 2017 12:53:09 +0200 Subject: [PATCH 18/18] Manual merge of changes from Working in abcl-1.5.0-dev and abcl-1.4.0. --- swank/abcl.lisp | 484 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 362 insertions(+), 122 deletions(-) diff --git a/swank/abcl.lisp b/swank/abcl.lisp index 8a666aa33..d1ff99cf0 100644 --- a/swank/abcl.lisp +++ b/swank/abcl.lisp @@ -14,11 +14,20 @@ (:import-from :java #:jcall #:jstatic #:jmethod - #:jfield #:jfield-name + #:jfield #:jconstructor #:jnew-array #:jarray-length #:jarray-ref #:jnew-array-from-array - #:jclass #:jnew #:jinstance-of-p #:jclass-superclass #:java-object #:jclass-interfaces - #:java-exception)) + #:jclass #:jnew #:java-object + ;; be conservative and add any import java functions only for later lisps + #+#.(swank/backend:with-symbol 'jfield-name 'java) #:jfield-name + #+#.(swank/backend:with-symbol 'jinstance-of-p 'java) #:jinstance-of-p + #+#.(swank/backend:with-symbol 'jclass-superclass 'java) #:jclass-superclass + #+#.(swank/backend:with-symbol 'jclass-interfaces 'java) #:jclass-interfaces + #+#.(swank/backend:with-symbol 'java-exception 'java) #:java-exception + #+#.(swank/backend:with-symbol 'jobject-class 'java) #:jobject-class + #+#.(swank/backend:with-symbol 'jclass-name 'java) #:jclass-name + #+#.(swank/backend:with-symbol 'java-object-p 'java) #:java-object-p)) + (in-package swank/abcl) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -30,19 +39,11 @@ ;;; Probe for existence of a functioning abcl-introspect, loading ;;; it necessary conditions are met. (when (ignore-errors (and - (fboundp '(setf sys::function-plist)) + (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)))) + (push :abcl-introspect *features*))) (defimplementation gray-package-name () "GRAY-STREAMS") @@ -57,6 +58,37 @@ (ext:make-slime-input-stream read-string (make-synonym-stream '*standard-output*)))) +;; Common lisp inspect should use slime +(swank::wrap 'cl:inspect :use-slime :replace 'swank::inspect-in-emacs) + +;; repair bare print object so inspector titles show java class +(defun %print-unreadable-object-java-too (object stream type identity body) + (setf stream (sys::out-synonym-of stream)) + (when *print-readably* + (error 'print-not-readable :object object)) + (format stream "#<") + (when type + (if (java-object-p object) + ;; Special handling for java objects + (if (jinstance-of-p object "java.lang.Class") + (progn + (write-string "jclass " stream) + (format stream "~a" (jclass-name object))) + (format stream "~a" (jclass-name (jobject-class object)))) + ;; usual handling + (format stream "~S" (type-of object))) + (format stream " ")) + (when body + (funcall body)) + (when identity + (when (or body (not type)) + (format stream " ")) + (format stream "{~X}" (sys::identity-hash-code object))) + (format stream ">") + nil) + +(wrap 'sys::%print-unreadable-object :more-informative :replace '%print-unreadable-object-java-too ) + (defimplementation call-with-compilation-hooks (function) (funcall function)) @@ -70,7 +102,7 @@ (defun slot-definition-documentation (slot) (declare (ignore slot)) - #+nil (documentation slot 't)) + #+abcl-introspect (documentation slot 't)) (defun slot-definition-type (slot) (declare (ignore slot)) @@ -163,6 +195,7 @@ slot-boundp-using-class slot-value-using-class set-slot-value-using-class + #+#.(swank/backend:with-symbol 'slot-makunbound-using-class 'mop) mop:slot-makunbound-using-class)) ;;;; TCP Server @@ -309,8 +342,10 @@ (t :not-available))) (defimplementation function-name (function) - (if (fboundp 'sys::any-function-name) ;; abcl-1.5.0 + (if (fboundp 'sys::any-function-name) + ;; abcl-1.5.0 (sys::any-function-name function) + ;; pre abcl-1.5.0 (nth-value 2 (function-lambda-expression function)))) (defimplementation macroexpand-all (form &optional env) @@ -370,15 +405,22 @@ ;;;; Debugger ;; Copied from swank-sbcl.lisp. +#+abcl-introspect +(defvar sys::*caught-frames*) ;; ;; 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)))) + (prog1 (let (#+abcl-introspect + (sys::*caught-frames* nil)) + ;; the next might be the right thing for earlier lisps but I don't know + (let (#+abcl-introspect + (sys::*saved-backtrace* (if (fboundp 'sys::new-backtrace) (sys::new-backtrace condition) (sys::backtrace)))) + (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) @@ -393,17 +435,25 @@ (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))))))) + (*sldb-topframe* + (or + (second (member magic-token #+abcl-intro sys::*saved-backtrace* #-abcl-intro (sys:backtrace) + :key (lambda (frame) + (first (sys:frame-to-list frame))))) + (car sys::*saved-backtrace*))) + #+#.(swank/backend:with-symbol *debug-condition* 'ext) + (ext::*debug-condition* swank::*swank-debugger-condition*)) (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))) + (let ((backtrace + #+abcl-introspect + sys::*saved-backtrace* + #-abcl-introspect + (sys:backtrace))) + (subseq (or (member *sldb-topframe* backtrace) backtrace) start end))) + (defun nth-frame (index) (nth index (backtrace 0 nil))) @@ -411,9 +461,12 @@ (let ((end (or end most-positive-fixnum))) (backtrace start end))) +;; Don't count on jss being loaded, but if it is then there's some more stuff we can do ++#+#.(swank/backend:with-symbol 'invoke-restargs 'jss) (defun jss-p () (and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS" "JSS"))) - + ++#+#.(swank/backend:with-symbol '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))))) @@ -425,53 +478,79 @@ (other nil)))) method))) +#-abcl-introspect +(defimplementation print-frame (frame stream) + (write-string (sys:frame-to-string frame) + stream)) + ;; Use princ cs write-string for lisp frames as it respects (print-object (function t)) ;; Rewrite jss expansions to their unexpanded state +;; Show java exception frames up to where a java exception happened with a "!" +;; Check if a java class corresponds to a lisp function and tell us if to +(defvar *debugger-package* (find-package 'cl-user)) +#+abcl-introspect (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))) - + (let ((*package* (or *debugger-package* *package*))) ;; make clear which functions aren't common lisp. Otherwise uses default package, which is invisible + (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))))) + (let ((classname (getf (sys:frame-to-list frame) :class))) + (if (and (fboundp 'sys::javaframe) (member (sys::javaframe frame) sys::*caught-frames* :test 'equal)) + (write-string "! " stream)) + (write-string (sys:frame-to-string frame) stream) + (if (and classname (sys::java-class-lisp-function classname)) + (format stream " = ~a" (sys::java-class-lisp-function classname))))))) + +;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET. +;;; --ME 20150403 +(defun nth-frame-list (index) + (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) - (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)))) + (let ((frame (nth-frame index))) + (if (typep frame 'sys::lisp-stack-frame) ;; java stack frames have no locals available - + (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) (declare(ignore 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)) + (elt (rest (jcall "toLispList" (nth-frame index))) id)) +#+abcl-introspect (defimplementation disassemble-frame (index) (sys::disassemble (frame-function (nth-frame index)))) @@ -580,6 +659,7 @@ (defgeneric source-location (object)) ;; try to find some kind of source for internals +#+abcl-introspect (defun implementation-source-location (arg) (let ((function (cond ((functionp arg) arg) @@ -601,7 +681,7 @@ (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) + `((:primitive ,local) (:location ,found-in-source-path (:line 0) (:snippet ,(format nil "class ~a" local)))) @@ -615,9 +695,11 @@ ;; no snippet, since internal class is in its own file (if class-in-source-path `(:primitive (:location ,class-in-source-path (:line 0) nil))))))))))))) +#+abcl-introspect (defun get-declared-field (class fieldname) (find fieldname (jcall "getDeclaredFields" class) :key 'jfield-name :test 'equal)) +#+abcl-introspect (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) "\\*" "_") "-" "_") @@ -636,6 +718,7 @@ (or (get-declared-field class internal-name1) (get-declared-field class internal-name2)))) +#+abcl-introspect (defun maybe-implementation-variable (s) (let ((field (symbol-defined-in-java s))) (and field @@ -646,6 +729,7 @@ (if found-in-source-path `(symbol (:location ,found-in-source-path (:line 0) (:snippet ,(format nil "~s" (string s))))))))))) +#+abcl-introspect (defun if-we-have-to-choose-one-choose-the-function (sources) (or (loop for spec in sources for (dspec) = spec @@ -653,18 +737,19 @@ 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)) - (or (let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol 'sys::source)))) + (or #+abcl-introspect + (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*)))) + ; 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 @@ -686,6 +771,7 @@ (list :position (1+ pos)) (list :function-name (string symbol))) (:align t)))))) + #+abcl-introspect (second (implementation-source-location symbol)))) (defmethod source-location ((frame sys::java-stack-frame)) @@ -708,11 +794,25 @@ (symbol (source-location operator))))) (defmethod source-location ((fun function)) - (if (sys::local-function-p fun) + (if #+abcl-introspect + (sys::local-function-p fun) + #-abcl-introspect + nil (source-location (sys::local-function-owner fun)) (let ((name (function-name fun))) (and name (source-location name))))) +(defmethod source-location ((method method)) + #+abcl-introspect + (let ((found + (find `(:method ,@(sys::method-spec-list method)) + (get (function-name method) 'sys::source) + :key 'car :test 'equalp))) + (and found (second (slime-location-from-source-annotation (function-name method) found)))) + #-abcl-introspect + (let ((name (function-name fun))) + (and name (source-location name)))) + (defun system-property (name) (jstatic "getProperty" "java.lang.System" name)) @@ -752,14 +852,12 @@ (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) + ;; include lib jar files. contrib has lisp code. Would be good to build abcl.jar with source code as well + #+abcl-introspect + (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 of directories to search for source files.") (defun zipfile-contains-p (zipfile-name entry-name) @@ -783,7 +881,11 @@ (try-zip (zip) (let* ((zipfile-name (namestring (truename zip)))) (and (zipfile-contains-p zipfile-name filename) - `(:zip ,zipfile-name ,filename))))) + `(#+abcl-introspect + :zip + #-abcl-introspect + :dir + ,zipfile-name ,filename))))) (cond ((pathname-absolute-p filename) (probe-file filename)) (t (loop for dir in path @@ -841,6 +943,13 @@ path)) path))) +#-abcl-introspect +(defimplementation find-definitions (symbol) + (ext:resolve symbol) + (let ((srcloc (source-location symbol))) + (and srcloc `((,symbol ,srcloc))))) + +#+abcl-introspect (defimplementation find-definitions (symbol) (if (stringp symbol) ;; allow a string to be passed. If it is package prefixed, remove the prefix @@ -869,28 +978,28 @@ (defun slime-location-from-source-annotation (sym it) (destructuring-bind (what path pos) it - ;; all of these are (defxxx forms, which is what :function locations look for in slime - (let* ((isfunction (and (consp what) - (member (car what) - '(:function :generic-function :macro :class - :compiler-macro :type :constant :variable - :package :structure :condition)))) + + (let* ((isfunction + ;; all of these are (defxxx forms, which is what :function locations look for in slime + (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))) - ( (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*" - (maybe-redirect-to-jar path)))) + ( (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) + ;; this is bogus - figure out some way to guess which is the repl associated with :toplevel + ;; or get rid of this + "emacs-buffer:*slime-repl*" + (maybe-redirect-to-jar path)))) (when (atom what) (setq what (list what sym))) (list (definition-specifier what) (if (ext:pathname-jar-p path2) `(:location - ;; jar-pathname stores JAR path as first of DEVICE + ;; JAR-PATHNAME stores the PATHNAME of the jar file as first element of a list DEVICE (:zip ,@(pathname-device path2)) ;; pos never seems right. Use function name. , @@ -908,6 +1017,7 @@ , (:align t)))))))) +#+abcl-introspect (defimplementation list-callers (thing) (loop for caller in (sys::callers thing) when (typep caller 'method) @@ -926,6 +1036,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Inspecting +;; this is only for hyperspec request in an inspector window +;; TODO have slime-hyperspec-lookup respect this variable too (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") @@ -940,8 +1052,7 @@ ;;; 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)) - +(defparameter *to-string-hashtable* (make-hash-table :weakness :key)) (defmethod emacs-inspect ((o t)) (let* ((type (type-of o)) @@ -965,11 +1076,13 @@ (defmethod emacs-inspect ((string string)) (swank::lcons* '(:label "Value: ") `(:value ,string ,(concatenate 'string "\"" string "\"")) '(:newline) + #+abcl-introspect ;; ??? This doesn't appear depend on ABCL-INTROSPECT. Why disable? `(:action "[Edit in emacs buffer]" ,(lambda() (swank::ed-in-emacs `(:string ,string)))) '(:newline) (if (ignore-errors (jclass string)) `(:line "Names java class" ,(jclass string)) "") + #+abcl-introspect (if (and (jss-p) (stringp (funcall (intern "LOOKUP-CLASS-NAME" :jss) string :return-ambiguous t :muffle-warning t))) `(:multiple @@ -998,6 +1111,7 @@ "")) (call-next-method))) +#+#.(swank/backend:with-symbol 'java-exception 'java) (defmethod emacs-inspect ((o java:java-exception)) (append (call-next-method) (list '(:newline) '(:label "Stack trace") @@ -1031,6 +1145,7 @@ `((:label "Argument list: ") ,(princ-to-string args) (:newline)))) + #+abcl-introspect ,@(when (documentation f t) `("Documentation:" (:newline) ,(documentation f t) (:newline))) @@ -1039,6 +1154,7 @@ (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))) (:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline) + #+abcl-introspect ,@(when (jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f) `((:label "Closed over: ") ,@(loop @@ -1046,10 +1162,12 @@ collect `(:value ,el) collect " ") (:newline))) + #+abcl-introspect ,@(when (sys::get-loaded-from f) (list `(:label "Defined in: ") `(:value ,(sys::get-loaded-from f) ,(namestring (sys::get-loaded-from f))) '(:newline))) + ;; I think this should work in older lisps too -- alanr ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f)))) (when (plusp (length fields)) (list* '(:label "Internal fields: ") '(:newline) @@ -1062,6 +1180,7 @@ ": " `(:value ,value ,(princ-to-string value)) '(:newline))))))) + #+abcl-introspect ,@(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" @@ -1070,23 +1189,57 @@ '(:newline))))) (defmethod emacs-inspect ((o java:java-object)) - (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)))))) + (if #+abcl-introspect + (jinstance-of-p o (jclass "java.lang.Class")) + #-abcl-introspect + nil + (emacs-inspect-java-class o))) + +(defvar *slime-tostring-on-demand* nil + "Set to t if you don't want to automatically show toString() for java objects and instead have inspector action to compute") + +(defun static-field? (field) + ;; (plusp (logand #"reflect.Modifier.STATIC" (jcall "getModifiers" field))) + ;; ugly replace with answer to avoid using jss + (plusp (logand 8 (jcall "getModifiers" field)))) + +(defun inspector-java-object-fields (object) + (loop for super = (java::jobject-class object) then (jclass-superclass super) + while super + ;;; NOTE: In the next line, if I write #'(lambda.... then I get an error compiling "Attempt to throw to the nonexistent tag DUPLICATABLE-CODE-P.". WTF + for fields = (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x) (jcall "getName" x))) + 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 value = (jcall "get" (progn (jcall "setAccessible" this t) this) object) + for line = `(" " (:label ,(jcall "getName" this)) ": " (:value ,value) (:newline)) + if (static-field? this) + append line into statics + else append line into members + finally (return (append + (if members `((:label "Member fields: ") (:newline) ,@members)) + (if statics `((:label "Static fields: ") (:newline) ,@statics))))))) + +(defun emacs-inspect-java-object (object) + (let ((to-string (lambda () + (handler-case + (setf (gethash object *to-string-hashtable*) + (jcall "toString" object)) + (t (e) + (setf (gethash object *to-string-hashtable*) + (format nil + "Could not invoke toString(): ~A" + e)))))) + (intended-class (cdr (car (last (sys::inspected-parts object)))))) + `((:label "Class: ") (:value ,(jcall "getClass" object) ,(jcall "getName" (jcall "getClass" object) )) (:newline) + ,@(if (and intended-class (not (equal intended-class (jcall "getName" (jcall "getClass" object))))) + `((:label "Intended Class: ") (:value ,(jclass intended-class) ,intended-class) (:newline))) + ,@(if (or (gethash object *to-string-hashtable*) (not *slime-tostring-on-demand*)) + (label-value-line "toString()" (funcall to-string)) + `((:action "[compute toString()]" ,to-string) (:newline))) + ,@(inspector-java-object-fields object)))) (defmethod emacs-inspect ((slot mop::slot-definition)) `("Name: " @@ -1095,9 +1248,10 @@ "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) + (:label "Initialization:") (:newline) + (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) + (:label " Form: ") + ,(if (mop:slot-definition-initfunction slot) `(:value ,(mop:slot-definition-initform slot)) "#") (:newline) " Function: " @@ -1145,12 +1299,20 @@ (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")))) + (path (jcall "replaceFirst" + (jcall "replaceFirst" + (jcall "toString" (jcall "getResource" + class + (concatenate 'string + "/" (substitute #\/ #\. (jcall "getName" class)) + ".class"))) + "jar:file:" "") "!.*" ""))) `((:label ,(format nil "Java Class: ~a" (jcall "getName" class) )) (:newline) - ,@(when path (list `(:label ,"Path: ") `(:value ,path) '(:newline))) + ,@(when path (list `(:label ,"Loaded from: ") + `(:value ,path) + " " + `(:action "[open in emacs buffer]" ,(lambda() (swank::ed-in-emacs `( ,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 ", ")))) @@ -1164,6 +1326,79 @@ '(:newline) '(:label "Fields:") '(:newline) fields))))) +(defmethod emacs-inspect ((object sys::structure-object)) + (let ((structure-def (get (type-of object) 'system::structure-definition ))) + `((:label "Type: ") (:value ,(type-of object)) (:newline) + (:label "Class: ") (:value ,(class-of object)) (:newline) + ,@(inspector-structure-slot-names-and-values object)))) + +(defun inspector-structure-slot-names-and-values (structure) + (let ((structure-def (get (type-of structure) 'system::structure-definition))) + `((:label "Slots: ") (:newline) + ,@(loop for slotdef in (sys::dd-slots structure-def) + for name = (sys::dsd-name slotdef) + for reader = (sys::dsd-reader slotdef) + for value = (eval `(,reader ,structure)) + append + `(" " (:label ,(string-downcase (string name))) ": " (:value ,value) (:newline)))))) + +(defmethod emacs-inspect ((object sys::structure-class)) + (let* ((name (jss::get-java-field object "name" t)) + (def (get name 'system::structure-definition))) + `((:label "Class: ") (:value ,object) (:newline) + (:label "Raw defstruct definition: ") (:value ,def ,(let ((*print-array* nil)) (prin1-to-string def))) (:newline) + ,@(parts-for-structure-def name) + ;; copy-paste from swank fancy inspector + ,@(when (swank-mop:specializer-direct-methods object) + `((:label "It is used as a direct specializer in the following methods:") + (:newline) + ,@(loop + for method in (specializer-direct-methods object) + for method-spec = (swank::method-for-inspect-value method) + collect " " + collect `(:value ,method ,(string-downcase (string (car method-spec)))) + collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec))) + append (let ((method method)) + `(" " (:action "[remove]" + ,(lambda () (remove-method (swank-mop::method-generic-function method) method))))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (swank::abbrev-doc (documentation method t)) and + collect '(:newline))))))) + +(defun parts-for-structure-def-slot (def) + `((:label ,(string-downcase (sys::dsd-name def))) " reader: " (:value ,(sys::dsd-reader def) ,(string-downcase (string (sys::dsdreader def)))) + ", index: " (:value ,(sys::dsd-index def)) + ,@(if (sys::dsd-initform def) + `(", initform: " (:value ,(sys::dsd-initform def)))) + ,@(if (sys::dsd-read-only def) + '(", Read only")))) + +(defun parts-for-structure-def (name) + (let ((structure-def (get name 'system::structure-definition ))) + (append + (loop for accessor in '(dd-name dd-conc-name dd-default-constructor dd-constructors dd-copier dd-include dd-type + dd-named dd-initial-offset dd-predicate dd-print-function dd-print-object + dd-inherited-accessors) + for key = (intern (subseq (string accessor) 3) 'keyword) + for fsym = (find-symbol (string accessor) 'system) + for value = (eval `(,fsym ,structure-def)) + append `((:label ,(string-capitalize (string key))) ": " (:value ,value) (:newline))) + (let* ((direct (sys::dd-direct-slots structure-def) ) + (all (sys::dd-slots structure-def)) + (inherited (set-difference all direct))) + `((:label "Direct slots: ") (:newline) + ,@(loop for slotdef in direct + append `(" " ,@(parts-for-structure-def-slot slotdef) + (:newline))) + ,@(if inherited + (append '((:label "Inherited slots: ") (:newline)) + (loop for slotdef in inherited + append `(" " (:label ,(string-downcase (string (sys::dsd-name slotdef)))) + (:value ,slotdef "slot definition") + (:newline)))))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Multithreading @@ -1248,9 +1483,13 @@ (defimplementation quit-lisp () (ext:exit)) +;; probably should be promoted to other lisps but I don't want to mess with them +(defvar *inspector-print-case* *print-case*) + (defimplementation call-with-syntax-hooks (fn) - (let ((*print-case* :downcase)) + (let ((*print-case* *inspector-print-case*)) (funcall fn))) + ;;; #+#.(swank/backend:with-symbol 'package-local-nicknames 'ext) (defimplementation package-local-nicknames (package) @@ -1260,6 +1499,7 @@ ;; function name to be the same as the implementation name so ;; meta-. works. +#+abcl-introspect (eval-when (:load-toplevel :execute) (loop for s in swank-backend::*interface-functions* for impl = (get s 'swank-backend::implementation)