1537 lines
63 KiB
Common Lisp
1537 lines
63 KiB
Common Lisp
|
;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
|
|||
|
|
;;;
|
|||
|
|
;;; 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)
|
|||
|
|
(: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
|
|||
|
|
#+#.(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)
|
|||
|
|
(require :collect) ;just so that it doesn't spoil the flying letters
|
|||
|
|
(require :pprint)
|
|||
|
|
(require :gray-streams)
|
|||
|
|
(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 the
|
|||
|
|
;; architecture for booting streams allows us to replace the Java-side
|
|||
|
|
;; implementation of a Slime{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))
|
|||
|
|
|
|||
|
|
(defimplementation make-input-stream (read-string)
|
|||
|
|
(ext:make-slime-input-stream read-string
|
|||
|
|
(make-synonym-stream '*standard-output*))))
|
|||
|
|
|
|||
|
|
;;; Have CL:INSPECT use SLIME
|
|||
|
|
;;;
|
|||
|
|
;;; Since Swank 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 ()
|
|||
|
|
(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)
|
|||
|
|
|
|||
|
|
;;; TODO: move such invocations out of toplevel?
|
|||
|
|
(eval-when (:load-toplevel)
|
|||
|
|
(unless (get 'sys::%print-unreadable-object 'swank/backend::slime-wrap)
|
|||
|
|
(wrap 'sys::%print-unreadable-object :more-informative :replace '%print-unreadable-object-java-too)))
|
|||
|
|
|
|||
|
|
(defimplementation call-with-compilation-hooks (function)
|
|||
|
|
(funcall function))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;; MOP
|
|||
|
|
|
|||
|
|
;;dummies and definition
|
|||
|
|
|
|||
|
|
(defclass standard-slot-definition ()())
|
|||
|
|
|
|||
|
|
(defun slot-definition-documentation (slot)
|
|||
|
|
(declare (ignore slot))
|
|||
|
|
#+abcl-introspect
|
|||
|
|
(documentation slot 't))
|
|||
|
|
|
|||
|
|
(defun slot-definition-type (slot)
|
|||
|
|
(declare (ignore slot))
|
|||
|
|
t)
|
|||
|
|
|
|||
|
|
(defun class-prototype (class)
|
|||
|
|
(declare (ignore class))
|
|||
|
|
nil)
|
|||
|
|
|
|||
|
|
(defun generic-function-declarations (gf)
|
|||
|
|
(declare (ignore gf))
|
|||
|
|
nil)
|
|||
|
|
|
|||
|
|
(defun specializer-direct-methods (spec)
|
|||
|
|
(mop:class-direct-methods spec))
|
|||
|
|
|
|||
|
|
(defun slot-definition-name (slot)
|
|||
|
|
(mop:slot-definition-name slot))
|
|||
|
|
|
|||
|
|
(defun class-slots (class)
|
|||
|
|
(mop:class-slots class))
|
|||
|
|
|
|||
|
|
(defun method-generic-function (method)
|
|||
|
|
(mop:method-generic-function method))
|
|||
|
|
|
|||
|
|
(defun method-function (method)
|
|||
|
|
(mop:method-function method))
|
|||
|
|
|
|||
|
|
(defun slot-boundp-using-class (class object slotdef)
|
|||
|
|
(declare (ignore class))
|
|||
|
|
(system::slot-boundp object (slot-definition-name slotdef)))
|
|||
|
|
|
|||
|
|
(defun slot-value-using-class (class object slotdef)
|
|||
|
|
(declare (ignore class))
|
|||
|
|
(system::slot-value object (slot-definition-name slotdef)))
|
|||
|
|
|
|||
|
|
(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
|
|||
|
|
standard-slot-definition ;;dummy
|
|||
|
|
cl:method
|
|||
|
|
cl:standard-class
|
|||
|
|
#+#.(swank/backend:with-symbol
|
|||
|
|
'compute-applicable-methods-using-classes 'mop)
|
|||
|
|
mop:compute-applicable-methods-using-classes
|
|||
|
|
;; standard-class readers
|
|||
|
|
mop:class-default-initargs
|
|||
|
|
mop:class-direct-default-initargs
|
|||
|
|
mop:class-direct-slots
|
|||
|
|
mop:class-direct-subclasses
|
|||
|
|
mop:class-direct-superclasses
|
|||
|
|
mop:eql-specializer
|
|||
|
|
mop:class-finalized-p
|
|||
|
|
mop:finalize-inheritance
|
|||
|
|
cl:class-name
|
|||
|
|
mop:class-precedence-list
|
|||
|
|
class-prototype ;;dummy
|
|||
|
|
class-slots
|
|||
|
|
specializer-direct-methods
|
|||
|
|
;; eql-specializer accessors
|
|||
|
|
mop::eql-specializer-object
|
|||
|
|
;; generic function readers
|
|||
|
|
mop:generic-function-argument-precedence-order
|
|||
|
|
generic-function-declarations ;;dummy
|
|||
|
|
mop:generic-function-lambda-list
|
|||
|
|
mop:generic-function-methods
|
|||
|
|
mop:generic-function-method-class
|
|||
|
|
mop:generic-function-method-combination
|
|||
|
|
mop:generic-function-name
|
|||
|
|
;; method readers
|
|||
|
|
method-generic-function
|
|||
|
|
method-function
|
|||
|
|
mop:method-lambda-list
|
|||
|
|
mop:method-specializers
|
|||
|
|
mop:method-qualifiers
|
|||
|
|
;; slot readers
|
|||
|
|
mop:slot-definition-allocation
|
|||
|
|
slot-definition-documentation ;;dummy
|
|||
|
|
mop:slot-definition-initargs
|
|||
|
|
mop:slot-definition-initform
|
|||
|
|
mop:slot-definition-initfunction
|
|||
|
|
slot-definition-name
|
|||
|
|
slot-definition-type ;;dummy
|
|||
|
|
mop:slot-definition-readers
|
|||
|
|
mop:slot-definition-writers
|
|||
|
|
slot-boundp-using-class
|
|||
|
|
slot-value-using-class
|
|||
|
|
set-slot-value-using-class
|
|||
|
|
#+#.(swank/backend:with-symbol
|
|||
|
|
'slot-makunbound-using-class 'mop)
|
|||
|
|
mop:slot-makunbound-using-class))
|
|||
|
|
|
|||
|
|
;;;; TCP Server
|
|||
|
|
|
|||
|
|
(defimplementation preferred-communication-style ()
|
|||
|
|
:spawn)
|
|||
|
|
|
|||
|
|
(defimplementation create-socket (host port &key backlog)
|
|||
|
|
(ext:make-server-socket port))
|
|||
|
|
|
|||
|
|
(defimplementation local-port (socket)
|
|||
|
|
(jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket))
|
|||
|
|
|
|||
|
|
(defimplementation close-socket (socket)
|
|||
|
|
(ext:server-socket-close socket))
|
|||
|
|
|
|||
|
|
(defimplementation accept-connection (socket
|
|||
|
|
&key external-format buffering timeout)
|
|||
|
|
(declare (ignore buffering timeout))
|
|||
|
|
(ext:get-socket-stream (ext:socket-accept socket)
|
|||
|
|
:element-type (if external-format
|
|||
|
|
'character
|
|||
|
|
'(unsigned-byte 8))
|
|||
|
|
:external-format (or external-format :default)))
|
|||
|
|
|
|||
|
|
;;;; UTF8
|
|||
|
|
|
|||
|
|
;; faster please!
|
|||
|
|
(defimplementation string-to-utf8 (s)
|
|||
|
|
(jbytes-to-octets
|
|||
|
|
(java:jcall
|
|||
|
|
(java:jmethod "java.lang.String" "getBytes" "java.lang.String")
|
|||
|
|
s
|
|||
|
|
"UTF8")))
|
|||
|
|
|
|||
|
|
(defimplementation utf8-to-string (u)
|
|||
|
|
(java:jnew
|
|||
|
|
(java:jconstructor "org.armedbear.lisp.SimpleString"
|
|||
|
|
"java.lang.String")
|
|||
|
|
(java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
|
|||
|
|
(octets-to-jbytes u)
|
|||
|
|
"UTF8")))
|
|||
|
|
|
|||
|
|
(defun octets-to-jbytes (octets)
|
|||
|
|
(declare (type octets (simple-array (unsigned-byte 8) (*))))
|
|||
|
|
(let* ((len (length octets))
|
|||
|
|
(bytes (java:jnew-array "byte" len)))
|
|||
|
|
(loop for byte across octets
|
|||
|
|
for i from 0
|
|||
|
|
do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
|
|||
|
|
"java.lang.Object" "int" "byte")
|
|||
|
|
"java.lang.reflect.Array"
|
|||
|
|
bytes i byte))
|
|||
|
|
bytes))
|
|||
|
|
|
|||
|
|
(defun jbytes-to-octets (jbytes)
|
|||
|
|
(let* ((len (java:jarray-length jbytes))
|
|||
|
|
(octets (make-array len :element-type '(unsigned-byte 8))))
|
|||
|
|
(loop for i from 0 below len
|
|||
|
|
for jbyte = (java:jarray-ref jbytes i)
|
|||
|
|
do (setf (aref octets i) jbyte))
|
|||
|
|
octets))
|
|||
|
|
|
|||
|
|
;;;; External formats
|
|||
|
|
|
|||
|
|
(defvar *external-format-to-coding-system*
|
|||
|
|
'((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
|
|||
|
|
((:iso-8859-1 :eol-style :lf)
|
|||
|
|
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
|
|||
|
|
(:utf-8 "utf-8")
|
|||
|
|
((:utf-8 :eol-style :lf) "utf-8-unix")
|
|||
|
|
(:euc-jp "euc-jp")
|
|||
|
|
((:euc-jp :eol-style :lf) "euc-jp-unix")
|
|||
|
|
(:us-ascii "us-ascii")
|
|||
|
|
((:us-ascii :eol-style :lf) "us-ascii-unix")))
|
|||
|
|
|
|||
|
|
(defimplementation find-external-format (coding-system)
|
|||
|
|
(car (rassoc-if (lambda (x)
|
|||
|
|
(member coding-system x :test #'equal))
|
|||
|
|
*external-format-to-coding-system*)))
|
|||
|
|
|
|||
|
|
;;;; Unix signals
|
|||
|
|
|
|||
|
|
(defimplementation getpid ()
|
|||
|
|
(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")
|
|||
|
|
|
|||
|
|
(defimplementation set-default-directory (directory)
|
|||
|
|
(let ((dir (sys::probe-directory directory)))
|
|||
|
|
(when dir (setf *default-pathname-defaults* dir))
|
|||
|
|
(namestring dir)))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;; Misc
|
|||
|
|
|
|||
|
|
(defimplementation arglist (fun)
|
|||
|
|
(cond ((symbolp fun)
|
|||
|
|
(multiple-value-bind (arglist present)
|
|||
|
|
(sys::arglist fun)
|
|||
|
|
(when (and (not present)
|
|||
|
|
(fboundp fun)
|
|||
|
|
(typep (symbol-function fun)
|
|||
|
|
'standard-generic-function))
|
|||
|
|
(setq arglist
|
|||
|
|
(mop::generic-function-lambda-list (symbol-function fun))
|
|||
|
|
present
|
|||
|
|
t))
|
|||
|
|
(if present arglist :not-available)))
|
|||
|
|
(t :not-available)))
|
|||
|
|
|
|||
|
|
(defimplementation function-name (function)
|
|||
|
|
(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))
|
|||
|
|
(or (documentation sym kind) :not-documented))
|
|||
|
|
(maybe-push (property value)
|
|||
|
|
(when value
|
|||
|
|
(setf result (list* property value result)))))
|
|||
|
|
(maybe-push
|
|||
|
|
:variable (when (boundp symbol)
|
|||
|
|
(doc 'variable)))
|
|||
|
|
(when (fboundp symbol)
|
|||
|
|
(maybe-push
|
|||
|
|
(cond ((macro-function symbol) :macro)
|
|||
|
|
((special-operator-p symbol) :special-operator)
|
|||
|
|
((typep (fdefinition symbol) 'generic-function)
|
|||
|
|
:generic-function)
|
|||
|
|
(t :function))
|
|||
|
|
(doc 'function)))
|
|||
|
|
(maybe-push
|
|||
|
|
:class (if (find-class symbol nil)
|
|||
|
|
(doc 'class)))
|
|||
|
|
result)))
|
|||
|
|
|
|||
|
|
(defimplementation describe-definition (symbol namespace)
|
|||
|
|
(ecase namespace
|
|||
|
|
((:variable :macro)
|
|||
|
|
(describe symbol))
|
|||
|
|
((:function :generic-function)
|
|||
|
|
(describe (symbol-function symbol)))
|
|||
|
|
(:class
|
|||
|
|
(describe (find-class symbol)))))
|
|||
|
|
|
|||
|
|
(defimplementation describe-definition (symbol namespace)
|
|||
|
|
(ecase namespace
|
|||
|
|
(:variable
|
|||
|
|
(describe symbol))
|
|||
|
|
((:function :generic-function)
|
|||
|
|
(describe (symbol-function symbol)))
|
|||
|
|
(:class
|
|||
|
|
(describe (find-class symbol)))))
|
|||
|
|
|
|||
|
|
;;;; Debugger
|
|||
|
|
|
|||
|
|
;; Copied from swank-sbcl.lisp.
|
|||
|
|
#+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)
|
|||
|
|
(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)
|
|||
|
|
(sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
|
|||
|
|
(funcall fun)))
|
|||
|
|
|
|||
|
|
(defimplementation install-debugger-globally (function)
|
|||
|
|
(setq *debugger-hook* function)
|
|||
|
|
(setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
|
|||
|
|
|
|||
|
|
(defvar *sldb-topframe*)
|
|||
|
|
|
|||
|
|
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
|||
|
|
(let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
|
|||
|
|
(*sldb-topframe*
|
|||
|
|
(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*)))
|
|||
|
|
#+#.(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
|
|||
|
|
#+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)))
|
|||
|
|
|
|||
|
|
(defimplementation compute-backtrace (start end)
|
|||
|
|
(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)))))
|
|||
|
|
(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)))
|
|||
|
|
|
|||
|
|
#-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)
|
|||
|
|
;; 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 = (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)))))))
|
|||
|
|
|
|||
|
|
;;; Machinery for DEFIMPLEMENTATION
|
|||
|
|
;;; FIXME can't seem to use FLET forms with DEFIMPLEMENTATION --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)
|
|||
|
|
(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 (jcall "toLispList" (nth-frame index))) id))
|
|||
|
|
|
|||
|
|
#+abcl-introspect
|
|||
|
|
(defimplementation disassemble-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)))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;; Compiler hooks
|
|||
|
|
|
|||
|
|
(defvar *buffer-name* nil)
|
|||
|
|
(defvar *buffer-start-position*)
|
|||
|
|
(defvar *buffer-string*)
|
|||
|
|
(defvar *compile-filename*)
|
|||
|
|
|
|||
|
|
(defvar *abcl-signaled-conditions*)
|
|||
|
|
|
|||
|
|
(defun handle-compiler-warning (condition)
|
|||
|
|
(let ((loc (when (and jvm::*compile-file-pathname*
|
|||
|
|
system::*source-position*)
|
|||
|
|
(cons jvm::*compile-file-pathname* system::*source-position*))))
|
|||
|
|
;; filter condition signaled more than once.
|
|||
|
|
(unless (member condition *abcl-signaled-conditions*)
|
|||
|
|
(push condition *abcl-signaled-conditions*)
|
|||
|
|
(signal 'compiler-condition
|
|||
|
|
:original-condition condition
|
|||
|
|
:severity :warning
|
|||
|
|
:message (format nil "~A" condition)
|
|||
|
|
:location (cond (*buffer-name*
|
|||
|
|
(make-location
|
|||
|
|
(list :buffer *buffer-name*)
|
|||
|
|
(list :offset *buffer-start-position* 0)))
|
|||
|
|
(loc
|
|||
|
|
(destructuring-bind (file . pos) loc
|
|||
|
|
(make-location
|
|||
|
|
(list :file (namestring (truename file)))
|
|||
|
|
(list :position (1+ pos)))))
|
|||
|
|
(t
|
|||
|
|
(make-location
|
|||
|
|
(list :file (namestring *compile-filename*))
|
|||
|
|
(list :position 1))))))))
|
|||
|
|
|
|||
|
|
(defimplementation swank-compile-file (input-file output-file
|
|||
|
|
load-p external-format
|
|||
|
|
&key policy)
|
|||
|
|
(declare (ignore external-format policy))
|
|||
|
|
(let ((jvm::*resignal-compiler-warnings* t)
|
|||
|
|
(*abcl-signaled-conditions* nil))
|
|||
|
|
(handler-bind ((warning #'handle-compiler-warning))
|
|||
|
|
(let ((*buffer-name* nil)
|
|||
|
|
(*compile-filename* input-file))
|
|||
|
|
(multiple-value-bind (fn warn fail)
|
|||
|
|
(compile-file input-file :output-file output-file)
|
|||
|
|
(values fn warn
|
|||
|
|
(and fn load-p
|
|||
|
|
(not (load fn)))))))))
|
|||
|
|
|
|||
|
|
(defimplementation swank-compile-string (string &key buffer position filename
|
|||
|
|
line column policy)
|
|||
|
|
(declare (ignore filename line column policy))
|
|||
|
|
(let ((jvm::*resignal-compiler-warnings* t)
|
|||
|
|
(*abcl-signaled-conditions* nil))
|
|||
|
|
(handler-bind ((warning #'handle-compiler-warning))
|
|||
|
|
(let ((*buffer-name* buffer)
|
|||
|
|
(*buffer-start-position* position)
|
|||
|
|
(*buffer-string* string)
|
|||
|
|
(sys::*source* (make-pathname :device "emacs-buffer" :name buffer))
|
|||
|
|
(sys::*source-position* position))
|
|||
|
|
(funcall (compile nil (read-from-string
|
|||
|
|
(format nil "(~S () ~A)" 'lambda string))))
|
|||
|
|
t))))
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;; 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) '(:swank-implementation :function)))
|
|||
|
|
do (return-from if-we-have-to-choose-one-choose-the-function spec))
|
|||
|
|
(car sources)))
|
|||
|
|
|
|||
|
|
(defmethod source-location ((symbol symbol))
|
|||
|
|
(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
|
|||
|
|
(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 (length "jar:file:")) "!/"))
|
|||
|
|
;; 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))))))
|
|||
|
|
#+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)
|
|||
|
|
(declare (ignore method))
|
|||
|
|
(let ((file (or (find-file-in-path file *source-path*)
|
|||
|
|
(let ((f (format nil "~{~a/~}~a"
|
|||
|
|
(butlast (split-string class "\\."))
|
|||
|
|
file)))
|
|||
|
|
(find-file-in-path f *source-path*)))))
|
|||
|
|
(and file
|
|||
|
|
`(:location ,file (:line ,line) ())))))
|
|||
|
|
|
|||
|
|
(defmethod source-location ((frame sys::lisp-stack-frame))
|
|||
|
|
(destructuring-bind (operator &rest args) (sys:frame-to-list frame)
|
|||
|
|
(declare (ignore args))
|
|||
|
|
(etypecase operator
|
|||
|
|
(function (source-location operator))
|
|||
|
|
(list nil)
|
|||
|
|
(symbol (source-location operator)))))
|
|||
|
|
|
|||
|
|
(defmethod source-location ((fun function))
|
|||
|
|
(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))
|
|||
|
|
|
|||
|
|
(defun pathname-parent (pathname)
|
|||
|
|
(make-pathname :directory (butlast (pathname-directory pathname))))
|
|||
|
|
|
|||
|
|
(defun pathname-absolute-p (pathname)
|
|||
|
|
(eq (car (pathname-directory pathname)) ':absolute))
|
|||
|
|
|
|||
|
|
(defun split-string (string regexp)
|
|||
|
|
(coerce
|
|||
|
|
(jcall (jmethod "java.lang.String" "split" "java.lang.String")
|
|||
|
|
string regexp)
|
|||
|
|
'list))
|
|||
|
|
|
|||
|
|
(defun path-separator ()
|
|||
|
|
(jfield "java.io.File" "pathSeparator"))
|
|||
|
|
|
|||
|
|
(defun search-path-property (prop-name)
|
|||
|
|
(let ((string (system-property prop-name)))
|
|||
|
|
(and string
|
|||
|
|
(remove nil
|
|||
|
|
(mapcar #'truename
|
|||
|
|
(split-string string (path-separator)))))))
|
|||
|
|
|
|||
|
|
(defun jdk-source-path ()
|
|||
|
|
(let* ((jre-home (truename (system-property "java.home")))
|
|||
|
|
(src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
|
|||
|
|
(truename (probe-file src-zip)))
|
|||
|
|
(and truename (list truename))))
|
|||
|
|
|
|||
|
|
(defun class-path ()
|
|||
|
|
(append (search-path-property "java.class.path")
|
|||
|
|
(search-path-property "sun.boot.class.path")))
|
|||
|
|
|
|||
|
|
(defvar *source-path*
|
|||
|
|
(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 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)
|
|||
|
|
(let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile"
|
|||
|
|
"java.lang.String")
|
|||
|
|
zipfile-name)))
|
|||
|
|
(jcall
|
|||
|
|
(jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
|
|||
|
|
zipfile entry-name)))
|
|||
|
|
|
|||
|
|
;; Try to find FILENAME in PATH. If found, return a file spec as
|
|||
|
|
;; needed by Emacs. We also look in zip files.
|
|||
|
|
(defun find-file-in-path (filename path)
|
|||
|
|
(labels ((try (dir)
|
|||
|
|
(cond ((not (pathname-type dir))
|
|||
|
|
(let ((f (probe-file (merge-pathnames filename dir))))
|
|||
|
|
(and f `(:file ,(namestring f)))))
|
|||
|
|
((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)
|
|||
|
|
`(#+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 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)))
|
|||
|
|
|
|||
|
|
#-abcl-introspect
|
|||
|
|
(defimplementation find-definitions (symbol)
|
|||
|
|
(ext:resolve symbol)
|
|||
|
|
(let ((srcloc (source-location symbol)))
|
|||
|
|
(and srcloc `((,symbol ,srcloc)))))
|
|||
|
|
|
|||
|
|
#+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) (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* ((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)))
|
|||
|
|
(<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:*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
|
|||
|
|
(:zip ,@(split-string (subseq path2 (length "jar:file:")) "!/"))
|
|||
|
|
;; pos never seems right. Use function name.
|
|||
|
|
,<position>
|
|||
|
|
(:align t))
|
|||
|
|
;; conspire with swank-compile-string to keep the
|
|||
|
|
;; buffer name in a pathname whose device is
|
|||
|
|
;; "emacs-buffer".
|
|||
|
|
(if (eql 0 (search "emacs-buffer:" path2))
|
|||
|
|
`(:location
|
|||
|
|
(:buffer ,(subseq path2 (load-time-value (length "emacs-buffer:"))))
|
|||
|
|
,<position>
|
|||
|
|
(:align t))
|
|||
|
|
`(:location
|
|||
|
|
(:file ,path2)
|
|||
|
|
,<position>
|
|||
|
|
(:align t))))))))
|
|||
|
|
|
|||
|
|
#+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) (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
|
|||
|
|
|
|||
|
|
;;; BEGIN FIXME move into generalized Swank infrastructure, or add to contrib mechanism
|
|||
|
|
;; 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")
|
|||
|
|
|
|||
|
|
(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)))
|
|||
|
|
;;; END FIXME move into generalized Swank 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* ((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)
|
|||
|
|
#+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
|
|||
|
|
(: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)))
|
|||
|
|
|
|||
|
|
#+#.(swank/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: "
|
|||
|
|
(:value ,(mop:slot-definition-name slot))
|
|||
|
|
(:newline)
|
|||
|
|
"Documentation:" (:newline)
|
|||
|
|
,@(when (slot-definition-documentation slot)
|
|||
|
|
`((:value ,(slot-definition-documentation slot)) (:newline)))
|
|||
|
|
"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)
|
|||
|
|
(:label " Function: ")
|
|||
|
|
(:value ,(mop:slot-definition-initfunction slot))
|
|||
|
|
(:newline)))
|
|||
|
|
|
|||
|
|
(defmethod emacs-inspect ((f function))
|
|||
|
|
`(,@(when (function-name f)
|
|||
|
|
`((: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)
|
|||
|
|
`((: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)))))
|
|||
|
|
|
|||
|
|
(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 *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 (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 *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: "
|
|||
|
|
(: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 :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 :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() (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 ", "))))
|
|||
|
|
,@(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))
|
|||
|
|
`((: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)))
|
|||
|
|
(if structure-def
|
|||
|
|
`((: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))))
|
|||
|
|
`("No slots available for inspection."))))
|
|||
|
|
|
|||
|
|
(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
|
|||
|
|
|
|||
|
|
(defimplementation spawn (fn &key name)
|
|||
|
|
(threads:make-thread (lambda () (funcall fn)) :name name))
|
|||
|
|
|
|||
|
|
(defvar *thread-plists* (make-hash-table) ; should be a weak table
|
|||
|
|
"A hashtable mapping threads to a plist.")
|
|||
|
|
|
|||
|
|
(defvar *thread-id-counter* 0)
|
|||
|
|
|
|||
|
|
(defimplementation thread-id (thread)
|
|||
|
|
(threads:synchronized-on *thread-plists*
|
|||
|
|
(or (getf (gethash thread *thread-plists*) 'id)
|
|||
|
|
(setf (getf (gethash thread *thread-plists*) 'id)
|
|||
|
|
(incf *thread-id-counter*)))))
|
|||
|
|
|
|||
|
|
(defimplementation find-thread (id)
|
|||
|
|
(find id (all-threads)
|
|||
|
|
:key (lambda (thread)
|
|||
|
|
(getf (gethash thread *thread-plists*) 'id))))
|
|||
|
|
|
|||
|
|
(defimplementation thread-name (thread)
|
|||
|
|
(threads:thread-name thread))
|
|||
|
|
|
|||
|
|
(defimplementation thread-status (thread)
|
|||
|
|
(format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
|
|||
|
|
|
|||
|
|
(defimplementation make-lock (&key name)
|
|||
|
|
(declare (ignore name))
|
|||
|
|
(threads:make-thread-lock))
|
|||
|
|
|
|||
|
|
(defimplementation call-with-lock-held (lock function)
|
|||
|
|
(threads:with-thread-lock (lock) (funcall function)))
|
|||
|
|
|
|||
|
|
(defimplementation current-thread ()
|
|||
|
|
(threads:current-thread))
|
|||
|
|
|
|||
|
|
(defimplementation all-threads ()
|
|||
|
|
(copy-list (threads:mapcar-threads #'identity)))
|
|||
|
|
|
|||
|
|
(defimplementation thread-alive-p (thread)
|
|||
|
|
(member thread (all-threads)))
|
|||
|
|
|
|||
|
|
(defimplementation interrupt-thread (thread fn)
|
|||
|
|
(threads:interrupt-thread thread fn))
|
|||
|
|
|
|||
|
|
(defimplementation kill-thread (thread)
|
|||
|
|
(threads:destroy-thread thread))
|
|||
|
|
|
|||
|
|
(defstruct mailbox
|
|||
|
|
(queue '()))
|
|||
|
|
|
|||
|
|
(defun mailbox (thread)
|
|||
|
|
"Return THREAD's mailbox."
|
|||
|
|
(threads:synchronized-on *thread-plists*
|
|||
|
|
(or (getf (gethash thread *thread-plists*) 'mailbox)
|
|||
|
|
(setf (getf (gethash thread *thread-plists*) 'mailbox)
|
|||
|
|
(make-mailbox)))))
|
|||
|
|
|
|||
|
|
(defimplementation send (thread message)
|
|||
|
|
(let ((mbox (mailbox thread)))
|
|||
|
|
(threads:synchronized-on mbox
|
|||
|
|
(setf (mailbox-queue mbox)
|
|||
|
|
(nconc (mailbox-queue mbox) (list message)))
|
|||
|
|
(threads:object-notify-all mbox))))
|
|||
|
|
|
|||
|
|
(defimplementation receive-if (test &optional timeout)
|
|||
|
|
(let* ((mbox (mailbox (current-thread))))
|
|||
|
|
(assert (or (not timeout) (eq timeout t)))
|
|||
|
|
(loop
|
|||
|
|
(check-slime-interrupts)
|
|||
|
|
(threads:synchronized-on mbox
|
|||
|
|
(let* ((q (mailbox-queue mbox))
|
|||
|
|
(tail (member-if test q)))
|
|||
|
|
(when tail
|
|||
|
|
(setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
|
|||
|
|
(return (car tail)))
|
|||
|
|
(when (eq timeout t) (return (values nil t)))
|
|||
|
|
(threads:object-wait mbox 0.3))))))
|
|||
|
|
|
|||
|
|
(defimplementation quit-lisp ()
|
|||
|
|
(ext:exit))
|
|||
|
|
|
|||
|
|
;; 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)))
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
#+#.(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.
|
|||
|
|
|
|||
|
|
#+abcl-introspect
|
|||
|
|
(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))))))
|
|||
|
|
|