Changeset 15558

Timestamp:

02/25/22 20:24:39 (2 years ago)

Author:

Mark Evenson

Message:

abcl-introspect: home symbols in ABCL-INTROSPECT/SYSTEM

Name exported symbols explictly as such.

Add packages.lisp unit to assist the eventual move all of
abcl-introspect.lisp as homed in ABCL-INTROSPECT/SYSTEM so we can
distinguish between the ABCL core functionality and that provided for
by ABCL-INTROSPECT. For now, we just define the dictionary necessary
for inspecting interpreted forms in this manner.

Use a local function for the one-off STACK-TO-LIST.

Location:

trunk/abcl/contrib/abcl-introspect

Files:

• abcl-introspect.asd (modified) (1 diff)
• abcl-introspect.lisp (modified) (11 diffs)
• packages.lisp (added)

trunk/abcl/contrib/abcl-introspect/abcl-introspect.asd

@@ -4 +4 @@
   :description "Introspection on compiled function to aid source location and other debugging functions."
   :long-description "<urn:abcl.org/release/1.8.0/contrib/abcl-introspect#>"
-  :version "2.0.0"
+  :version "2.1.0"
   :depends-on (jss)
-  :components ((:file "abcl-introspect")
-         (:file "stacktrace")
-               (:file "util"))
+  :components ((:module package
+                :pathname #p"./"
+                :components ((:file "packages")))
+               (:module source
+                :pathname #p"./"
+                :components ((:file "abcl-introspect")
+                       (:file "stacktrace")
+                             (:file "util"))))
   :in-order-to ((test-op (test-op abcl-introspect-test))))
 

trunk/abcl/contrib/abcl-introspect/abcl-introspect.lisp

@@ -130 +130 @@
    (lambda(top internal)
      (unless (eq (if (symbolp top) (symbol-function top) top) internal)
-       (setf (getf (function-plist internal) :internal-to-function) (or definer top))
+       (setf (getf (sys:function-plist internal) :internal-to-function) (or definer top))
        ))
    nil
@@ -174 +174 @@
                  (fast-function  (mop::std-method-fast-function method)))
              (when (and method-function (compiled-function-p method-function)) 
-               (setf (getf (function-plist method-function) :method-function) method)
+               (setf (getf (sys:function-plist method-function) :method-function) method)
                (annotate-internal-functions (list method-function) method)
                (index-function-class-names (list method-function)))
              (when (and fast-function (compiled-function-p fast-function))
-               (setf (getf (function-plist fast-function) :method-fast-function) method)
+               (setf (getf (sys:function-plist fast-function) :method-fast-function) method)
                (annotate-internal-functions (list fast-function) method)
                (index-function-class-names (list method-function))))))
@@ -291 +291 @@
                   (eq (second internals) (intern "INVOKE-RESTARGS" :jss))
                   (stringp (first internals))
-                  (setf (getf (sys::function-plist f) :jss-function) (first internals)))))))
+                  (setf (getf (sys:function-plist f) :jss-function) (first internals)))))))
          
 (defun local-function-p (function)
@@ -297 +297 @@
   level based on function-plist annotations"
   (and (and (functionp function) (not (typep function 'generic-function)))
-       (let ((plist  (sys::function-plist function)))
+       (let ((plist  (sys:function-plist function)))
          (or (getf plist :internal-to-function)
              (getf plist :method-function)
@@ -357 +357 @@
 
 (defmethod mop::add-direct-method :after (class method)
-  (annotate-clos-methods (list method))
-)
-
-(defmethod mop::ensure-class-using-class :after (class name  &key direct-slots
-                                             direct-default-initargs 
-                                             &allow-other-keys)
+  (annotate-clos-methods (list method)))
+
+(defmethod mop::ensure-class-using-class :after (class name
+                                                 &key direct-slots
+                                                   direct-default-initargs 
+                                                 &allow-other-keys)
+  (declare (ignore direct-slots direct-default-initargs))
   (annotate-clos-slots (mop::class-direct-slots (find-class name))))
 
@@ -371 +372 @@
 ;; where kind is either :lexical-variable or :lexical-function :special-variable
 
-(defun environment-parts(env)
+(defun environment-parts (env)
   (append
    (loop for binding = (jss:get-java-field env "vars" t) then (jss:get-java-field binding "next" t)
@@ -439 +440 @@
 ;; through the iterator, when some other function call is made.
 
-(defun stack-to-list (stack)
-  (coerce (#"toArray" stack) 'list))
+;; BEGIN use  :abcl-introspect/system
+(in-package :abcl-introspect/system)
 
 (defun collapse-locals (thread)
-  (loop for bindings in (mapcar 'sys::environment-parts
-                                (stack-to-list (jss:get-java-field thread "envStack" t)))
-        with last-locals
-        with last-function
-        for binding = (car bindings)
-        if (eq (second binding) nil)
-          collect (prog1
-                      (list last-function  last-locals)
-                    (setq last-locals nil)
-                    (setq last-function (third binding)))
-        else
-          do (setq last-locals bindings)))
+  (flet ((stack-to-list (stack)
+             (coerce (#"toArray" stack) 'list)))
+    (loop for bindings in (mapcar 'sys::environment-parts
+                                  (stack-to-list (jss:get-java-field thread "envStack" t)))
+          with last-locals
+          with last-function
+          for binding = (car bindings)
+          if (eq (second binding) nil)
+            collect (prog1
+                        (list last-function  last-locals)
+                      (setq last-locals nil)
+                      (setq last-function (third binding)))
+          else
+            do (setq last-locals bindings))))
 
 ;; Now that we have the pairings of function-executing and lexicals we need
@@ -502 +505 @@
 ;; find-locals still has debugging code in it which will be removed after
 ;; there has been sufficient testing.
-
-(defvar *debug-locals* nil)
+;;; ME: presumably *debugging-locals-p* can go away now?
+(defvar *debugging-locals-p* nil
+  "Whether SYS:FIND-LOCALS should be looking for local variables")
 
 (defun find-locals (index backtrace)
+  "Return local variable bindings at INDEX in BACKTRACE
+
+Added by ABCL-INTROSPECT."
   (let ((thread (jss:get-java-field (nth index backtrace) "thread" t)))
-    (and *debug-locals* (print `(:collapse ,thread ,index)))
-    (let((collapsed (collapse-locals thread)))
-      (and *debug-locals* (map nil 'print collapsed))
+    (and *debugging-locals-p* (print `(:collapse ,thread ,index)))
+    (let ((collapsed (collapse-locals thread)))
+      (and *debugging-locals-p* (map nil 'print collapsed))
       (let ((alignment 
               (loop for function-local-association in (reverse collapsed)
-                    with backtrace = (map 'list (if *debug-locals* 'print 'identity) backtrace)
+                    with backtrace = (map 'list (if *debugging-locals-p* 'print 'identity) backtrace)
                     for pos = (position (car function-local-association) backtrace
                                         :key (lambda(frame)
@@ -521 +528 @@
                                   pos
                                   (cdr function-local-association)))))
-        (and *debug-locals* (print :erase) (map nil 'print alignment))
+        (and *debugging-locals-p* (print :erase) (map nil 'print alignment))
         ;; first erasure of out of order frames
         (loop for (nil pos) in alignment
@@ -531 +538 @@
                         if (> pos2 pos)
                           do  (setf (second pair) nil)))
-        (and *debug-locals* (print :align) (map nil 'print alignment))
+        (and *debugging-locals-p* (print :align) (map nil 'print alignment))
         ;; second erasure of duplicate frame numbers
         (loop for (nil pos) in alignment
@@ -541 +548 @@
                          if (eql pos2 pos)
                            do  (setf (second pair) nil)))
-        (and *debug-locals* (map nil 'print alignment))
-        (if *debug-locals*
+        (and *debugging-locals-p* (map nil 'print alignment))
+        (if *debugging-locals-p*
             (print `(:find ,(cddr (find index alignment :key 'second :test 'eql)))))
         ;; finally, look up the locals for the given frame index
         (cddr (find index alignment :key 'second :test 'eql))))))
-
+;; END use :abcl-introspect/system
+(in-package :system) 
 
 ;; needs to be the last thing. Some interaction with the fasl loader