[nongnu] elpa/slime 34b7e43530 09/43: abcl: implement inspection of locals in interpreted frames

[ELPA Syncer]

branch: elpa/slime
commit 34b7e4353008ed98cd2f6219439b8ea3ab731154
Author: Alan Ruttenberg <alanruttenberg@gmail.com>
Commit: Mark Evenson <evenson.not.org@gmail.com>

    abcl: implement inspection of locals in interpreted frames
    
    In order to inspect variables in interpreted frames requires a version
    of the as-yet-unreleased abcl-1.8.1 after
    
<https://github.com/armedbear/abcl/commit/83a5ea85b336a3cd39b3c6b23600fb2bc6b22ff4>
    <https://abcl.org/trac/changeset/15558>.
---
 swank/abcl.lisp | 113 +++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 92 insertions(+), 21 deletions(-)

diff --git a/swank/abcl.lisp b/swank/abcl.lisp
index c8c956e31f..32cb4d5d19 100644
--- a/swank/abcl.lisp
+++ b/swank/abcl.lisp
@@ -544,31 +544,82 @@
    (multiple-value-list
     (jvm::parse-lambda-list (ext:arglist operator)))
    values))
+
+;; Switch to enable or disable locals functionality
+#+abcl-introspect
+(defvar *enable-locals* t)
+
+#+abcl-introspect 
+(defun are-there-locals? (frame index)
+  (and *enable-locals*
+       (fboundp 'abcl-introspect/sys::find-locals)
+       (typep frame 'sys::lisp-stack-frame)
+       (let ((operator (jss::get-java-field (nth-frame index) "operator" t)))
+         (and (function-lambda-expression (if (functionp operator) operator 
(symbol-function operator)))
+              (not (member operator '(java::jcall java::jcall-static))) ;; 
WTF, length is an interpreted function??
+              (if (symbolp operator)
+                  (not (eq (symbol-package operator) (find-package 'cl)))
+                  t)))))
+
+#+abcl-introspect
+(defun abcl-introspect/frame-locals (frame index)
+    ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME
+    (or (and (are-there-locals? frame index)
+             (let ((locals (abcl-introspect/sys:find-locals index (backtrace 0 
(1+ index)))))
+               (let ((argcount (length (cdr (nth-frame-list index))))
+                     (them 
+                       (let ((operator (jss::get-java-field (nth-frame index) 
"operator" t)))
+                         (let* ((env (and (jss::jtypep operator 'lisp.closure)
+                                          (jss::get-java-field operator 
"environment" t)))
+                                (closed-count (if env (length 
(sys::environment-parts env)) 0)))
+                           (declare (ignore closed-count))
+                                        ; FIXME closed-over are in parts but 
also in locals
+                                        ; FIXME closed-over are in compiled 
functions to but are value of internal field
+                                        ; environment is the enviromnet of 
+                           (loop for (kind symbol value) in (caar locals)
+                                 when (eq kind :lexical-variable)
+                                        ; FIXME should I qualify each by 
whether arg, closed-over, let-bound?
+                                   collect (list :name symbol 
+                                                 :id 0        
+                                                 :value value))))))
+                 (declare (ignore argcount))
+                 (reverse them))))))
   
 (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)))))
+  (let ((frame (nth-frame index)))         ;;(id -1)
+    (let ((frame-locals
+            #+abcl-introspect
+            (abcl-introspect/frame-locals frame index))
+          ;;; We include the arguments to the frame to the list of
+          ;;; locals.  TODO: figure out if there is a better place,
+          ;;; and at least decorate arguments differently from locals
+          (frame-arguments 
+            (loop
+              :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
+              :for id from 0
+              :collecting (list 
+                           :name (if (not (keywordp arglist)) ;; FIXME: WHat 
does this do?
+                                     (format nil "arg-~a" (first (nth id 
arglist)))
+                                     (format nil "arg~A" id))
+                           :id 0 ;; FIXME: determine how is :ID supposed to be 
used
+                           :value value))))
+      (append frame-arguments frame-locals))))
 
+#+abcl-introspect
 (defimplementation frame-var-value (index id)
- (elt (rest (jcall "toLispList" (nth-frame index))) id))
+  (if (are-there-locals? (nth-frame index) index)
+      (third (nth id (reverse (remove :lexical-variable
+                                      (caar (abcl-introspect/sys:find-locals 
index (backtrace 0 (1+ index))))
+                                      :test-not 'eq :key 'car))))
+      (elt (rest (jcall "toLispList" (nth-frame index))) id)))
 
 #+abcl-introspect
 (defimplementation disassemble-frame (index)
@@ -1130,6 +1181,26 @@
                         (jcall "printStackTrace" (java:java-exception-cause o) 
(jnew "java.io.PrintWriter" w))
                         (jcall "toString" w)))))
 
+
+
+(defmethod emacs-inspect ((o system::environment))
+  (let ((parts (sys::environment-parts o)))
+    (let ((lexicals (mapcar 'cdr (remove :lexical-variable parts :test-not 'eq 
:key 'car)))
+         (specials (mapcar 'cdr (remove :special parts :test-not 'eq :key 
'car)))
+         (functions (mapcar 'cdr (remove :lexical-function parts :test-not 'eq 
:key 'car))))
+       `(,@(if lexicals  
+              (list* '(:label "Lexicals:") '(:newline) 
+                     (loop for (var value) in lexicals 
+                           append `("  " (:label ,(format nil "~s" var)) ": " 
(:value ,value) (:newline)))))
+        ,@(if functions  
+              (list* '(:label "Functions:") '(:newline)
+                     (loop for (var value) in functions 
+                           append `("  "(:label ,(format nil "~s" var)) ": " 
(:value ,value) (:newline)))))
+        ,@(if specials  
+              (list* '(:label "Specials:") '(:newline) 
+                     (loop for (var value) in specials 
+                           append `("  " (:label ,(format nil "~s" var)) ": " 
(:value ,value) (:newline)))))))))
+
 (defmethod emacs-inspect ((slot mop::slot-definition))
   `("Name: "
     (:value ,(mop:slot-definition-name slot))