[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] externals/sly 57b6d3f 18/47: abcl: consolidate fixes and featur
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] externals/sly 57b6d3f 18/47: abcl: consolidate fixes and features |
|
Date: |
Thu, 17 Dec 2020 18:57:16 -0500 (EST) |
branch: externals/sly
commit 57b6d3fd2d4634313cd23c83a3fbd7fa53ad55a4
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>
abcl: consolidate fixes and features
(Alan Ruttenberg)(Mark Evenson)
SLY Author João Távora: This rather chubby mega-commit appeared
like this in SLIME. Git did its best when cherry-picking and so
did I when renaming. Seems ABCL has some slime-specific symbols,
like EXT:MAKE-SLIME-OUTPUT-STREAM, and I kept those. But others
may have crept by. Untested.
Consolidated fixes and features to working across the most common ABCL
releases, namely development (1.6.0-dev), current (1.5.0) and
historical (1.4.0). A majority of the new features depend on the
ABCL-INTROSPECT tooling introduced with abcl-1.5.0, to which we
intend to conditionalize their use on a backwards compatible strategy.
From
<https://github.com/slime/slime/pull/477/commits/c7c72d7b0f5cd6473af3488202ea1eca24d58202>.
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.
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.
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.
Enables load of xref package.
Only add ABCL-INTROSPECT once to *FEATURES*.
Robustly find intended class of Java objects.
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. This should eventually be moved into
more generalized Swank facilities if useful to others.
Co-authored-by: João Távora <joaotavora@gmail.com>
Cherry-pick-from: SLIME commit 6f06402595df0ec6b305fc5a13e18f48e8989c64
---
slynk/backend/abcl.lisp | 1247 ++++++++++++++++++++++++++++++++++++-----------
1 file changed, 971 insertions(+), 276 deletions(-)
diff --git a/slynk/backend/abcl.lisp b/slynk/backend/abcl.lisp
index 7fbd34c..aedaaa6 100644
--- a/slynk/backend/abcl.lisp
+++ b/slynk/backend/abcl.lisp
@@ -3,29 +3,56 @@
;;; slynk-abcl.lisp --- Armedbear CL specific code for SLY.
;;;
;;; Adapted from slynk-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 slynk-abcl
- (:use cl slynk-backend))
-
-(in-package slynk-abcl)
+(defpackage slynk/abcl
+ (:use cl slynk/backend)
+ (:import-from :java
+ #:jcall #:jstatic
+ #:jmethod
+ #:jfield
+ #:jconstructor
+ #:jnew-array #:jarray-length #:jarray-ref
#:jnew-array-from-array
+ #:jclass #:jnew #:java-object
+ ;; be conservative and add any import java functions only for
later lisps
+ #+#.(slynk/backend:with-symbol 'jfield-name 'java)
#:jfield-name
+ #+#.(slynk/backend:with-symbol 'jinstance-of-p 'java)
#:jinstance-of-p
+ #+#.(slynk/backend:with-symbol 'jclass-superclass 'java)
#:jclass-superclass
+ #+#.(slynk/backend:with-symbol 'jclass-interfaces 'java)
#:jclass-interfaces
+ #+#.(slynk/backend:with-symbol 'java-exception 'java)
#:java-exception
+ #+#.(slynk/backend:with-symbol 'jobject-class 'java)
#:jobject-class
+ #+#.(slynk/backend:with-symbol 'jclass-name 'java)
#:jclass-name
+ #+#.(slynk/backend:with-symbol 'java-object-p 'java)
#:java-object-p))
+
+(in-package slynk/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 and load ABCL-INTROSPECT pushing to *FEATURES* on success
+ ;;; allowing us to conditionalize usage via `#+abcl-introspect` forms.
+ (when (ignore-errors (and
+ (fboundp '(setf sys::function-plist))
+ (progn
+ (require :abcl-introspect)
+ (find "ABCL-INTROSPECT" *modules* :test
+ 'equal))))
+ (pushnew :abcl-introspect *features*)))
(defimplementation gray-package-name ()
"GRAY-STREAMS")
-;; FIXME: switch to shared Gray stream implementation when bugs are
-;; fixed in ABCL. See: http://abcl.org/trac/ticket/373.
+;; FIXME: switch to shared Gray stream implementation when the
+;; architecture for booting streams allows us to replace the Java-side
+;; implementation of a Sly{Input,Output}Stream.java classes are
+;; subsumed <http://abcl.org/trac/ticket/373>.
(progn
(defimplementation make-output-stream (write-string)
(ext:make-slime-output-stream write-string))
@@ -34,20 +61,56 @@
(ext:make-slime-input-stream read-string
(make-synonym-stream '*standard-output*))))
+;;; Have CL:INSPECT use SLY
+;;;
+;;; Since Slynk may also be run in a server not running under Emacs
+;;; and potentially with other REPLs, we export a functional toggle
+;;; for the user to call after loading these definitions.
+(defun enable-cl-inspect-in-emacs ()
+ (slynk::wrap 'cl:inspect :use-sly :replace 'slynk::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))
-;;; slynk-mop
+
+;;;; MOP
;;dummies and definition
(defclass standard-slot-definition ()())
-;(defun class-finalized-p (class) t)
-
(defun slot-definition-documentation (slot)
(declare (ignore slot))
- #+nil (documentation slot 't))
+ #+abcl-introspect
+ (documentation slot 't))
(defun slot-definition-type (slot)
(declare (ignore slot))
@@ -84,14 +147,18 @@
(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-slynk-mop
'( ;; classes
cl:standard-generic-function
standard-slot-definition ;;dummy
cl:method
cl:standard-class
- #+#.(slynk-backend:with-symbol 'compute-applicable-methods-using-classes
- 'mop)
+ #+#.(slynk/backend:with-symbol
+ 'compute-applicable-methods-using-classes 'mop)
mop:compute-applicable-methods-using-classes
;; standard-class readers
mop:class-default-initargs
@@ -100,13 +167,13 @@
mop:class-direct-subclasses
mop:class-direct-superclasses
mop:eql-specializer
- mop:class-finalized-p
+ mop:class-finalized-p
mop:finalize-inheritance
cl:class-name
mop:class-precedence-list
class-prototype ;;dummy
class-slots
- specializer-direct-methods
+ specializer-direct-methods
;; eql-specializer accessors
mop::eql-specializer-object
;; generic function readers
@@ -135,11 +202,13 @@
mop:slot-definition-writers
slot-boundp-using-class
slot-value-using-class
+ set-slot-value-using-class
+ #+#.(slynk/backend:with-symbol
+ 'slot-makunbound-using-class 'mop)
mop:slot-makunbound-using-class))
;;;; TCP Server
-
(defimplementation preferred-communication-style ()
:spawn)
@@ -147,33 +216,33 @@
(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))
-(defimplementation accept-connection (socket
+(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering timeout))
(ext:get-socket-stream (ext:socket-accept socket)
- :element-type (if external-format
- 'character
+ :element-type (if external-format
+ 'character
'(unsigned-byte 8))
:external-format (or external-format :default)))
-;;;; UTF8
+;;;; UTF8
;; faster please!
(defimplementation string-to-utf8 (s)
(jbytes-to-octets
- (java:jcall
+ (java:jcall
(java:jmethod "java.lang.String" "getBytes" "java.lang.String")
s
"UTF8")))
(defimplementation utf8-to-string (u)
- (java:jnew
- (java:jconstructor "org.armedbear.lisp.SimpleString"
+ (java: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)
@@ -185,8 +254,8 @@
(bytes (java:jnew-array "byte" len)))
(loop for byte across octets
for i from 0
- do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
- "java.lang.Object" "int" "byte")
+ do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
+ "java.lang.Object" "int" "byte")
"java.lang.reflect.Array"
bytes i byte))
bytes))
@@ -203,7 +272,7 @@
(defvar *external-format-to-coding-system*
'((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
- ((:iso-8859-1 :eol-style :lf)
+ ((:iso-8859-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
(:utf-8 "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix")
@@ -220,37 +289,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")
@@ -265,11 +336,11 @@
(defimplementation arglist (fun)
(cond ((symbolp fun)
- (multiple-value-bind (arglist present)
+ (multiple-value-bind (arglist present)
(sys::arglist fun)
(when (and (not present)
(fboundp fun)
- (typep (symbol-function fun)
+ (typep (symbol-function fun)
'standard-generic-function))
(setq arglist
(mop::generic-function-lambda-list (symbol-function fun))
@@ -279,11 +350,24 @@
(t :not-available)))
(defimplementation function-name (function)
- (nth-value 2 (function-lambda-expression function)))
+ (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)
(ext:macroexpand-all form env))
+(defimplementation collect-macro-forms (form &optional env)
+ ;; Currently detects only normal macros, not compiler macros.
+ (declare (ignore env))
+ (with-collected-macro-forms (macro-forms)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors
+ (compile nil `(lambda () ,(macroexpand-all form env)))))
+ (values macro-forms nil)))
+
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind &optional (sym symbol))
@@ -297,10 +381,10 @@
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
- ((special-operator-p symbol) :special-operator)
- ((typep (fdefinition symbol) 'generic-function)
+ ((special-operator-p symbol) :special-operator)
+ ((typep (fdefinition symbol) 'generic-function)
:generic-function)
- (t :function))
+ (t :function))
(doc 'function)))
(maybe-push
:class (if (find-class symbol nil)
@@ -318,26 +402,36 @@
(defimplementation describe-definition (symbol namespace)
(ecase namespace
- (:variable
+ (:variable
(describe symbol))
((:function :generic-function)
(describe (symbol-function symbol)))
(:class
(describe (find-class symbol)))))
-
;;;; Debugger
;; Copied from slynk-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
+ ;;; XXX probably doesn't work in absence of ABCL-INTROSPECT on
abcl-1.4 and earlier
+ (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)
@@ -348,21 +442,28 @@
(setq *debugger-hook* function)
(setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
-(defvar *sly-db-topframe*)
+(defvar *sldb-topframe*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* ((magic-token (intern "SLYNK-DEBUGGER-HOOK" 'slynk))
- (*sly-db-topframe*
- (second (member magic-token (sys:backtrace)
- :key (lambda (frame)
- (first (sys:frame-to-list frame)))))))
+ (*sldb-topframe*
+ (or
+ (second (member magic-token
+ #+abcl-introspect sys::*saved-backtrace*
+ #-abcl-introspect (sys:backtrace)
+ :key (lambda (frame)
+ (first (sys:frame-to-list frame)))))
+ (car sys::*saved-backtrace*)))
+ #+#.(slynk/backend:with-symbol *debug-condition* 'ext)
+ (ext::*debug-condition* slynk::*slynk-debugger-condition*))
(funcall debugger-loop-fn)))
(defun backtrace (start end)
"A backtrace without initial SLYNK frames."
- (let ((backtrace (sys:backtrace)))
- (subseq (or (member *sly-db-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)))
@@ -371,74 +472,119 @@
(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
++#+#.(slynk/backend:with-symbol 'invoke-restargs 'jss)
+(defun jss-p ()
+ (and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS"
"JSS")))
+
++#+#.(slynk/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)))))
+ (let ((method
+ (slynk/match::select-match
+ form
+ (((LAMBDA ((#'gensymp a) &REST (#'gensymp b))
+ ((#'invokep fun) (#'stringp c) (#'gensymp d) (#'gensymp e) .
args)) . args) '=> c)
+ (other nil))))
+ method)))
+
+#-abcl-introspect
(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
+;; 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)
+ ;; make clear which functions aren't Common Lisp. Otherwise uses
+ ;; default package, which is invisible
+ (let ((*package* (or *debugger-package* *package*)))
+ (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 = (slynk/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)))))))
+
+;;; Machinery for DEFIMPLEMENTATION
+;;; FIXME can't seem to use FLET forms with DEFIMPLEMENTATION --ME 20150403
(defun nth-frame-list (index)
- (java:jcall "toLispList" (nth-frame 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)
- (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)))
+ (let ((frame (nth-frame index)))
+ ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME
+ (when (typep frame 'sys::lisp-stack-frame)
+ (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))
-#+nil
+#+abcl-introspect
(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))
`(:error ,(format nil "No source for frame: ~a" frame)))))
-#+nil
-(defimplementation eval-in-frame (form frame-number)
- (debugger:eval-form-in-context
- form
- (debugger:environment-of-frame (nth-frame frame-number))))
-
-#+nil
-(defimplementation return-from-frame (frame-number form)
- (let ((frame (nth-frame frame-number)))
- (multiple-value-call #'debugger:frame-return
- frame (debugger:eval-form-in-context
- form
- (debugger:environment-of-frame frame)))))
-
-;;; XXX doesn't work for frames with arguments
-#+nil
-(defimplementation restart-frame (frame-number)
- (let ((frame (nth-frame frame-number)))
- (debugger:frame-retry frame (debugger:frame-function frame))))
-
+
;;;; Compiler hooks
(defvar *buffer-name* nil)
@@ -449,18 +595,18 @@
(defvar *abcl-signaled-conditions*)
(defun handle-compiler-warning (condition)
- (let ((loc (when (and jvm::*compile-file-pathname*
+ (let ((loc (when (and jvm::*compile-file-pathname*
system::*source-position*)
(cons jvm::*compile-file-pathname* system::*source-position*))))
;; filter condition signaled more than once.
- (unless (member condition *abcl-signaled-conditions*)
- (push condition *abcl-signaled-conditions*)
+ (unless (member condition *abcl-signaled-conditions*)
+ (push condition *abcl-signaled-conditions*)
(signal 'compiler-condition
:original-condition condition
:severity :warning
:message (format nil "~A" condition)
:location (cond (*buffer-name*
- (make-location
+ (make-location
(list :buffer *buffer-name*)
(list :offset *buffer-start-position* 0)))
(loc
@@ -468,21 +614,21 @@
(make-location
(list :file (namestring (truename file)))
(list :position (1+ pos)))))
- (t
+ (t
(make-location
(list :file (namestring *compile-filename*))
(list :position 1))))))))
(defimplementation slynk-compile-file (input-file output-file
- load-p external-format
- &key policy)
+ load-p external-format
+ &key policy)
(declare (ignore external-format policy))
(let ((jvm::*resignal-compiler-warnings* t)
(*abcl-signaled-conditions* nil))
(handler-bind ((warning #'handle-compiler-warning))
(let ((*buffer-name* nil)
(*compile-filename* input-file))
- (multiple-value-bind (fn warn fail)
+ (multiple-value-bind (fn warn fail)
(compile-file input-file :output-file output-file)
(values fn warn
(and fn load-p
@@ -493,7 +639,7 @@
(declare (ignore filename line column policy))
(let ((jvm::*resignal-compiler-warnings* t)
(*abcl-signaled-conditions* nil))
- (handler-bind ((warning #'handle-compiler-warning))
+ (handler-bind ((warning #'handle-compiler-warning))
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-string* string)
@@ -503,59 +649,132 @@
(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
+#+abcl-introspect
+(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.
+
+ ;; Alan uses jdc.el
+ ;;
<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
+ (when 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) "\\*" "_") "-" "_")
+ 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))))
+
+#+abcl-introspect
+(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*)))
+ (when 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
+ when (and (consp dspec) (eq (car dspec) :function))
+ when (and (consp dspec) (member (car dspec)
'(:slynk-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 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 #+abcl-introspect
+ (let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol
'sys::source))))
+ (and maybe (second (sly-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
+ (when (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 slynk-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))))))
+ #+abcl-introspect
+ (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)
@@ -565,7 +784,7 @@
(butlast (split-string class "\\."))
file)))
(find-file-in-path f *source-path*)))))
- (and file
+ (and file
`(:location ,file (:line ,line) ())))))
(defmethod source-location ((frame sys::lisp-stack-frame))
@@ -577,11 +796,27 @@
(symbol (source-location operator)))))
(defmethod source-location ((fun function))
+ (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 (sly-location-from-source-annotation (function-name
method) found))))
+ #-abcl-introspect
(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))))
@@ -590,18 +825,18 @@
(eq (car (pathname-directory pathname)) ':absolute))
(defun split-string (string regexp)
- (coerce
- (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
+ (coerce
+ (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)))
(and string
- (remove nil
+ (remove nil
(mapcar #'truename
(split-string string (path-separator)))))))
@@ -616,23 +851,25 @@
(search-path-property "sun.boot.class.path")))
(defvar *source-path*
- (append (search-path-property "user.dir")
- (jdk-source-path)
- ;;(list (truename "/scratch/abcl/src"))
- )
- "List of directories to search for source files.")
+ (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
+ #+abcl-introspect
+ (list (sys::find-system-jar)
+ (sys::find-contrib-jar))))
+ ;; you should tell sly where the abcl sources are. In
.slynk.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)
- (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*)
-;; (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)
@@ -640,115 +877,549 @@
(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)))))
+ `(#+abcl-introspect
+ :zip
+ #-abcl-introspect
+ :dir
+ ,zipfile-name ,filename)))))
(cond ((pathname-absolute-p filename) (probe-file filename))
(t
(loop for dir in path
if (try dir) return it)))))
+(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 Sly-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 sly"
+ (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)))
+
+#-abcl-introspect
(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.sly.devel/2425
-Also, make sure that xref.lisp is loaded by modifying the armedbear
-part of *sysdep-pathnames* in slynk.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))
-|#
-
+#+abcl-introspect
+(defimplementation find-definitions (symbol)
+ (when (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) (sly-location-from-source-annotation symbol s))
sources)
+ (remove-duplicates implementation-variables :test 'equalp))))
+
+(defun sly-location-from-source-annotation (sym it)
+ (destructuring-bind (what path pos) it
+
+ (let* ((isfunction
+ ;; all of these are (defxxx forms, which is what :function
locations look for in sly
+ (and (consp what) (member (car what)
+ '(:function :generic-function :macro
:class :compiler-macro
+ :type :constant :variable :package
:structure :condition))))
+ (ismethod (and (consp what) (eq (car what) :method)))
+ (<position> (cond (isfunction (list :function-name (princ-to-string
(second what))))
+ (ismethod (stringify-method-specs
what))
+ (t (list :position (1+ (or pos
0))))))
+
+ (path2 (if (eq path :top-level)
+ ;; this is bogus - figure out some way to guess which is
the repl associated with :toplevel
+ ;; or get rid of this
+ "emacs-buffer:*sly-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 the PATHNAME of the jar file as first
element of a list DEVICE
+ (:zip ,@(pathname-device path2))
+ ;; pos never seems right. Use function name.
+ ,<position>
+ (:align t))
+ ;; conspire with slynk-compile-string to keep the
+ ;; buffer name in a pathname whose device is
+ ;; "emacs-buffer".
+ (if (eql 0 (search "emacs-buffer:" path2))
+ `(:location
+ (:buffer ,(subseq path2 (load-time-value (length
"emacs-buffer:"))))
+ ,<position>
+ (:align t))
+ `(:location
+ (:file ,path2)
+ ,<position>
+ (:align t))))))))
+
+#+abcl-introspect
+(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) (sly-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) (sly-location-from-source-annotation
caller s))
+ (get caller 'sys::source))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Inspecting
+
+;;; BEGIN FIXME move into generalized Slynk infrastructure, or add to contrib
mechanism
+;; this is only for hyperspec request in an inspector window
+;; TODO have sly-hyperspec-lookup respect this variable too
+(defvar *sly-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 *sly-inspector-hyperspec-in-browser*
+ '(lambda(a v) (eww a))
+ 'browse-url-browser-function)))
+ (sly-hyperdoc-lookup ,name))))
+ (slynk::eval-in-emacs form t)))
+;;; END FIXME move into generalized Slynk infrastructure, or add to contrib
mechanism
+
+;;; 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 :weakness :key))
+
(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))
+ (slynk::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() (slynk::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
+ (: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)))
+
+#+#.(slynk/backend:with-symbol 'java-exception 'java)
+(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: "
+ `("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)
+ (:label " Args: ") (:value ,(mop:slot-definition-initargs slot))
(:newline)
+ (:label " Form: ") ,(if (mop:slot-definition-initfunction slot)
`(:value ,(mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
- " Function: "
+ (:label " Function: ")
(:value ,(mop:slot-definition-initfunction slot))
(:newline)))
(defmethod emacs-inspect ((f function))
`(,@(when (function-name f)
- `("Name: "
- ,(princ-to-string (function-name f)) (:newline)))
- ,@(multiple-value-bind (args present)
- (sys::arglist f)
- (when present
- `("Argument list: "
- ,(princ-to-string args) (:newline))))
- (:newline)
- #+nil,@(when (documentation f t)
- `("Documentation:" (:newline)
- ,(documentation f t) (: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))))
+ #+abcl-introspect
+ ,@(when (documentation f t)
+ `("Documentation:" (:newline)
+ ,(documentation f t) (:newline)))
,@(when (function-lambda-expression f)
- `("Lambda expression:"
- (:newline) ,(princ-to-string
- (function-lambda-expression f)) (:newline)))))
+ `((:label "Lambda expression:")
+ (: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
+ for el in (sys::compiled-closure-context f)
+ 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)
+ (loop for field across fields
+ 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)))))))
+ #+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"
+ (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))
+ (if (jinstance-of-p o (jclass "java.lang.Class"))
+ (emacs-inspect-java-class o)
+ (emacs-inspect-java-object o)))
+
+(defvar *sly-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 o *to-string-hashtable*)
- (java:jcall "toString" o))
+ (setf (gethash object *to-string-hashtable*)
+ (jcall "toString" object))
(t (e)
- (setf (gethash o *to-string-hashtable*)
- (format nil
+ (setf (gethash object *to-string-hashtable*)
+ (format nil
"Could not invoke toString(): ~A"
- e)))))))
+ e))))))
+ (intended-class (cdr (assoc "intendedClass" (sys::inspected-parts
object)
+ :test 'equal))))
+ `((: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
*sly-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: "
+ (:value ,(mop:slot-definition-name slot))
+ (:newline)
+ "Documentation:" (:newline)
+ ,@(when (slot-definition-documentation slot)
+ `((:value ,(slot-definition-documentation slot)) (:newline)))
+ (: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))
+ "#<unspecified>") (:newline)
+ " Function: "
+ (:value ,(mop:slot-definition-initfunction slot))
+ (:newline)))
+
+(defun inspector-java-fields (class)
+ (loop
+ for super
+ = class then (jclass-superclass super)
+ while super
+ for fields
+ = (jcall "getDeclaredFields" super)
+ for fromline
+ = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName"
super)) '(:newline))
+ when (and (plusp (length fields)) fromline)
+ append fromline
+ append
+ (loop for this across fields
+ for pre = (subseq (jcall "toString" this)
+ 0
+ (1+ (position #\. (jcall "toString" this)
:from-end t)))
+ collect " "
+ collect (list :value this pre)
+ collect (list :strong-value this (jcall "getName" this) )
+ collect '(:newline))))
+
+(defun inspector-java-methods (class)
+ (loop
+ for super
+ = class then (jclass-superclass super)
+ while super
+ for methods
+ = (jcall "getDeclaredMethods" super)
+ for fromline
+ = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName"
super)) '(:newline))
+ when (and (plusp (length methods)) fromline)
+ append fromline
+ append
+ (loop for this across methods
+ for desc = (jcall "toString" this)
+ for paren = (position #\( desc)
+ for dot = (position #\. (subseq desc 0 paren) :from-end t)
+ for pre = (subseq desc 0 dot)
+ for name = (subseq desc dot paren)
+ for after = (subseq desc paren)
+ collect " "
+ collect (list :value this pre)
+ collect (list :strong-value this name)
+ collect (list :value this after)
+ collect '(:newline))))
+
+(defun emacs-inspect-java-class (class)
+ (let ((has-superclasses (jclass-superclass class))
+ (has-interfaces (plusp (length (jclass-interfaces class))))
+ (fields (inspector-java-fields class))
+ (path (jcall "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 ,"Loaded from: ")
+ `(:value ,path)
+ " "
+ `(:action "[open in emacs buffer]" ,(lambda()
(slynk::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 ", "))))
+ ,@(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)))))
+
+(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 slynk fancy inspector
+ ,@(when (slynk-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 = (slynk::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
(slynk-mop::method-generic-function method) method)))))
+ collect '(:newline)
+ if (documentation method t)
+ collect " Documentation: " and
+ collect (slynk::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
- (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)))))
+ (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
@@ -767,7 +1438,7 @@ part of *sysdep-pathnames* in slynk.loader.lisp.
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
- (find id (all-threads)
+ (find id (all-threads)
:key (lambda (thread)
(getf (gethash thread *thread-plists*) 'id))))
@@ -794,12 +1465,12 @@ part of *sysdep-pathnames* in slynk.loader.lisp.
(member thread (all-threads)))
(defimplementation interrupt-thread (thread fn)
- (threads:interrupt-thread thread fn))
+ (threads:interrupt-thread thread fn))
(defimplementation kill-thread (thread)
(threads:destroy-thread thread))
-(defstruct mailbox
+(defstruct mailbox
(queue '()))
(defun mailbox (thread)
@@ -812,7 +1483,7 @@ part of *sysdep-pathnames* in slynk.loader.lisp.
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(threads:synchronized-on mbox
- (setf (mailbox-queue mbox)
+ (setf (mailbox-queue mbox)
(nconc (mailbox-queue mbox) (list message)))
(threads:object-notify-all mbox))))
@@ -824,7 +1495,7 @@ part of *sysdep-pathnames* in slynk.loader.lisp.
(threads:synchronized-on mbox
(let* ((q (mailbox-queue mbox))
(tail (member-if test q)))
- (when tail
+ (when tail
(setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail)))
(when (eq timeout t) (return (values nil t)))
@@ -832,7 +1503,31 @@ part of *sysdep-pathnames* in slynk.loader.lisp.
(defimplementation quit-lisp ()
(ext:exit))
+
+;; FIXME 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* *inspector-print-case*))
+ (funcall fn)))
+
;;;
-#+#.(slynk-backend:with-symbol 'package-local-nicknames 'ext)
+#+#.(slynk/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.
+
+#+abcl-introspect
+(eval-when (:load-toplevel :execute)
+ (loop for s in slynk-backend::*interface-functions*
+ for impl = (get s 'slynk-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 'slynk-backend::implementation) compiled))))))
+
- [nongnu] externals/sly 1346967 38/47: Remove use of compatibility accessors, (continued)
- [nongnu] externals/sly 1346967 38/47: Remove use of compatibility accessors, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly e914200 07/47: wait-for-input: better "not implemented" error., ELPA Syncer, 2020/12/17
- [nongnu] externals/sly e883812 11/47: Fix SLYNK-SBCL:COMPILER-NOTE-LOCATION for non-file-backed streams, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 425146d 31/47: Print more code-source-location info for clasp, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 1188cfc 34/47: Ignore utf-8 encoding errors, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 4717cb9 44/47: Tolerate leading whitespace in slime-search-buffer-package, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 00cbab0 01/47: Slynk: avoid race conditions when killing threads, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 47e8d27 05/47: add architecture :aarch64 (for ECL), ELPA Syncer, 2020/12/17
- [nongnu] externals/sly f7c6048 08/47: arglist-dispatch: better handling of closer-mop wrappers., ELPA Syncer, 2020/12/17
- [nongnu] externals/sly bf157ae 10/47: Changed the name of a function in Clasp, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 57b6d3f 18/47: abcl: consolidate fixes and features,
ELPA Syncer <=
- [nongnu] externals/sly e79f9f2 23/47: sbcl: consult sb-impl:+internal-features+ when reading source files., ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 3bd8696 24/47: Move *features* binding up, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 276b18c 39/47: abcl: guard against repeated invocation to SLYNK-BACKEND:WRAP, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 47afe17 41/47: Fix #386: Unbreak Clasp common lisp for SLYfun, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 5bd0081 12/47: *architecture-features*: add ppc64, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 791f7b7 17/47: Calculate condition-location properly for clasp, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly e7f0333 40/47: abcl: fix inspector for a STRUCTURE-OBJECT with no inspectable parts, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly 5f15cf1 43/47: Use defgeneric lambda list in defmethod arglists, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly ae4bbca 45/47: Don't force mREPL to use channel thread for everything, ELPA Syncer, 2020/12/17
- [nongnu] externals/sly e927cda 47/47: Release SLY 1.0.42, ELPA Syncer, 2020/12/17