Changeset 15558

02/25/22 20:24:39 (11 months ago)
Mark Evenson

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.

1 added
2 edited


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

    r15464 r15558  
    44  :description "Introspection on compiled function to aid source location and other debugging functions."
    55  :long-description "<>"
    6   :version "2.0.0"
     6  :version "2.1.0"
    77  :depends-on (jss)
    8   :components ((:file "abcl-introspect")
    9          (:file "stacktrace")
    10                (:file "util"))
     8  :components ((:module package
     9                :pathname #p"./"
     10                :components ((:file "packages")))
     11               (:module source
     12                :pathname #p"./"
     13                :components ((:file "abcl-introspect")
     14                       (:file "stacktrace")
     15                             (:file "util"))))
    1116  :in-order-to ((test-op (test-op abcl-introspect-test))))
  • trunk/abcl/contrib/abcl-introspect/abcl-introspect.lisp

    r15555 r15558  
    130130   (lambda(top internal)
    131131     (unless (eq (if (symbolp top) (symbol-function top) top) internal)
    132        (setf (getf (function-plist internal) :internal-to-function) (or definer top))
     132       (setf (getf (sys:function-plist internal) :internal-to-function) (or definer top))
    133133       ))
    134134   nil
    174174                 (fast-function  (mop::std-method-fast-function method)))
    175175             (when (and method-function (compiled-function-p method-function))
    176                (setf (getf (function-plist method-function) :method-function) method)
     176               (setf (getf (sys:function-plist method-function) :method-function) method)
    177177               (annotate-internal-functions (list method-function) method)
    178178               (index-function-class-names (list method-function)))
    179179             (when (and fast-function (compiled-function-p fast-function))
    180                (setf (getf (function-plist fast-function) :method-fast-function) method)
     180               (setf (getf (sys:function-plist fast-function) :method-fast-function) method)
    181181               (annotate-internal-functions (list fast-function) method)
    182182               (index-function-class-names (list method-function))))))
    291291                  (eq (second internals) (intern "INVOKE-RESTARGS" :jss))
    292292                  (stringp (first internals))
    293                   (setf (getf (sys::function-plist f) :jss-function) (first internals)))))))
     293                  (setf (getf (sys:function-plist f) :jss-function) (first internals)))))))
    295295(defun local-function-p (function)
    297297  level based on function-plist annotations"
    298298  (and (and (functionp function) (not (typep function 'generic-function)))
    299        (let ((plist  (sys::function-plist function)))
     299       (let ((plist  (sys:function-plist function)))
    300300         (or (getf plist :internal-to-function)
    301301             (getf plist :method-function)
    358358(defmethod mop::add-direct-method :after (class method)
    359   (annotate-clos-methods (list method))
    360 )
    362 (defmethod mop::ensure-class-using-class :after (class name  &key direct-slots
    363                                              direct-default-initargs
    364                                              &allow-other-keys)
     359  (annotate-clos-methods (list method)))
     361(defmethod mop::ensure-class-using-class :after (class name
     362                                                 &key direct-slots
     363                                                   direct-default-initargs
     364                                                 &allow-other-keys)
     365  (declare (ignore direct-slots direct-default-initargs))
    365366  (annotate-clos-slots (mop::class-direct-slots (find-class name))))
    371372;; where kind is either :lexical-variable or :lexical-function :special-variable
    373 (defun environment-parts(env)
     374(defun environment-parts (env)
    374375  (append
    375376   (loop for binding = (jss:get-java-field env "vars" t) then (jss:get-java-field binding "next" t)
    439440;; through the iterator, when some other function call is made.
    441 (defun stack-to-list (stack)
    442   (coerce (#"toArray" stack) 'list))
     442;; BEGIN use  :abcl-introspect/system
     443(in-package :abcl-introspect/system)
    444445(defun collapse-locals (thread)
    445   (loop for bindings in (mapcar 'sys::environment-parts
    446                                 (stack-to-list (jss:get-java-field thread "envStack" t)))
    447         with last-locals
    448         with last-function
    449         for binding = (car bindings)
    450         if (eq (second binding) nil)
    451           collect (prog1
    452                       (list last-function  last-locals)
    453                     (setq last-locals nil)
    454                     (setq last-function (third binding)))
    455         else
    456           do (setq last-locals bindings)))
     446  (flet ((stack-to-list (stack)
     447             (coerce (#"toArray" stack) 'list)))
     448    (loop for bindings in (mapcar 'sys::environment-parts
     449                                  (stack-to-list (jss:get-java-field thread "envStack" t)))
     450          with last-locals
     451          with last-function
     452          for binding = (car bindings)
     453          if (eq (second binding) nil)
     454            collect (prog1
     455                        (list last-function  last-locals)
     456                      (setq last-locals nil)
     457                      (setq last-function (third binding)))
     458          else
     459            do (setq last-locals bindings))))
    458461;; Now that we have the pairings of function-executing and lexicals we need
    502505;; find-locals still has debugging code in it which will be removed after
    503506;; there has been sufficient testing.
    505 (defvar *debug-locals* nil)
     507;;; ME: presumably *debugging-locals-p* can go away now?
     508(defvar *debugging-locals-p* nil
     509  "Whether SYS:FIND-LOCALS should be looking for local variables")
    507511(defun find-locals (index backtrace)
     512  "Return local variable bindings at INDEX in BACKTRACE
     514Added by ABCL-INTROSPECT."
    508515  (let ((thread (jss:get-java-field (nth index backtrace) "thread" t)))
    509     (and *debug-locals* (print `(:collapse ,thread ,index)))
    510     (let((collapsed (collapse-locals thread)))
    511       (and *debug-locals* (map nil 'print collapsed))
     516    (and *debugging-locals-p* (print `(:collapse ,thread ,index)))
     517    (let ((collapsed (collapse-locals thread)))
     518      (and *debugging-locals-p* (map nil 'print collapsed))
    512519      (let ((alignment
    513520              (loop for function-local-association in (reverse collapsed)
    514                     with backtrace = (map 'list (if *debug-locals* 'print 'identity) backtrace)
     521                    with backtrace = (map 'list (if *debugging-locals-p* 'print 'identity) backtrace)
    515522                    for pos = (position (car function-local-association) backtrace
    516523                                        :key (lambda(frame)
    521528                                  pos
    522529                                  (cdr function-local-association)))))
    523         (and *debug-locals* (print :erase) (map nil 'print alignment))
     530        (and *debugging-locals-p* (print :erase) (map nil 'print alignment))
    524531        ;; first erasure of out of order frames
    525532        (loop for (nil pos) in alignment
    531538                        if (> pos2 pos)
    532539                          do  (setf (second pair) nil)))
    533         (and *debug-locals* (print :align) (map nil 'print alignment))
     540        (and *debugging-locals-p* (print :align) (map nil 'print alignment))
    534541        ;; second erasure of duplicate frame numbers
    535542        (loop for (nil pos) in alignment
    541548                         if (eql pos2 pos)
    542549                           do  (setf (second pair) nil)))
    543         (and *debug-locals* (map nil 'print alignment))
    544         (if *debug-locals*
     550        (and *debugging-locals-p* (map nil 'print alignment))
     551        (if *debugging-locals-p*
    545552            (print `(:find ,(cddr (find index alignment :key 'second :test 'eql)))))
    546553        ;; finally, look up the locals for the given frame index
    547554        (cddr (find index alignment :key 'second :test 'eql))))))
     555;; END use :abcl-introspect/system
     556(in-package :system)
    550558;; needs to be the last thing. Some interaction with the fasl loader
Note: See TracChangeset for help on using the changeset viewer.