X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=3af8709faece462e29b2dda29ebdb096f7eb5442;hb=b2036b630923934234d66247f18acf7a6c1085ec;hp=3399502284388899bafaf698c7123149d13db72a;hpb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;p=sbcl.git

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 3399502..3af8709 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -21,7 +21,7 @@
 
 ;;; TODO
 ;;; 1) structs don't have within-file location info.  problem for the
-;;;   structure itself, accessors and the predicate
+;;;   structure itself, accessors, the copier and the predicate
 ;;; 3) error handling.  Signal random errors, or handle and resignal 'our'
 ;;;   error, or return NIL?
 ;;; 4) FIXMEs
@@ -192,7 +192,8 @@ If an unsupported TYPE is requested, the function will return NIL.
        ((:function :generic-function)
         (when (and (fboundp name)
                    (or (not (symbolp name))
-                       (not (macro-function name))))
+                       (not (macro-function name))
+                       (special-operator-p name)))
           (let ((fun (real-fdefinition name)))
             (when (eq (not (typep fun 'generic-function))
                       (not (eq type :generic-function)))
@@ -356,6 +357,9 @@ If an unsupported TYPE is requested, the function will return NIL.
            ((struct-predicate-p object)
             (find-definition-source
              (struct-predicate-structure-class object)))
+           ((struct-copier-p object)
+            (find-definition-source
+             (struct-copier-structure-class object)))
            (t
             (find-function-definition-source object))))
     ((or condition standard-object structure-object)
@@ -376,9 +380,8 @@ If an unsupported TYPE is requested, the function will return NIL.
      ;; :COMPILE-TOPLEVEL).  Until that's fixed, don't return a
      ;; DEFINITION-SOURCE with a pathname.  (When that's fixed, take
      ;; out the (not (debug-source-form ...)) test.
-     (if (and (sb-c::debug-source-namestring debug-source)
-              (not (sb-c::debug-source-form debug-source)))
-         (parse-namestring (sb-c::debug-source-namestring debug-source)))
+     (when (stringp (sb-c::debug-source-namestring debug-source))
+       (parse-namestring (sb-c::debug-source-namestring debug-source)))
      :character-offset
      (if tlf
          (elt (sb-c::debug-source-start-positions debug-source) tlf))
@@ -413,6 +416,8 @@ If an unsupported TYPE is requested, the function will return NIL.
   (sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
 (defvar *struct-predicate*
   (sb-vm::%simple-fun-self #'definition-source-p))
+(defvar *struct-copier*
+  (sb-vm::%simple-fun-self #'copy-definition-source))
 
 (defun struct-accessor-p (function)
   (let ((self (sb-vm::%simple-fun-self function)))
@@ -420,6 +425,11 @@ If an unsupported TYPE is requested, the function will return NIL.
     (member self (list *struct-slotplace-reader*
                        *struct-slotplace-writer*))))
 
+(defun struct-copier-p (function)
+  (let ((self (sb-vm::%simple-fun-self function)))
+    ;; FIXME there may be other structure copier functions
+    (member self (list *struct-copier*))))
+
 (defun struct-predicate-p (function)
   (let ((self (sb-vm::%simple-fun-self function)))
     ;; FIXME there may be other structure predicate functions
@@ -491,6 +501,9 @@ value."
              type
              (sb-impl::%fun-type function-designator)))))))
 
+;;; FIXME: These three are pretty terrible. Can we place have some proper metadata
+;;; instead.
+
 (defun struct-accessor-structure-class (function)
   (let ((self (sb-vm::%simple-fun-self function)))
     (cond
@@ -501,6 +514,16 @@ value."
           (sb-kernel:%closure-index-ref function 1)))))
       )))
 
+(defun struct-copier-structure-class (function)
+  (let ((self (sb-vm::%simple-fun-self function)))
+    (cond
+      ((member self (list *struct-copier*))
+       (find-class
+        (sb-kernel::classoid-name
+         (sb-kernel::layout-classoid
+          (sb-kernel:%closure-index-ref function 0)))))
+      )))
+
 (defun struct-predicate-structure-class (function)
   (let ((self (sb-vm::%simple-fun-self function)))
     (cond
@@ -624,7 +647,7 @@ constant pool."
             (loop for i from 0 below (length array) by 2
                   for xref-name = (aref array i)
                   for xref-path = (aref array (1+ i))
-                  do (when (eql xref-name wanted-name)
+                  do (when (equal xref-name wanted-name)
                        (let ((source-location
                               (find-function-definition-source simple-fun)))
                          ;; Use the more accurate source path from
@@ -819,12 +842,12 @@ Experimental: interface subject to change."
                (let* ((addr (sb-kernel:get-lisp-obj-address object))
                       (space
                        (cond ((< sb-vm:read-only-space-start addr
-                                 (* sb-vm:*read-only-space-free-pointer*
-                                    sb-vm:n-word-bytes))
+                                 (ash sb-vm:*read-only-space-free-pointer*
+                                      sb-vm:n-fixnum-tag-bits))
                               :read-only)
                              ((< sb-vm:static-space-start addr
-                                 (* sb-vm:*static-space-free-pointer*
-                                    sb-vm:n-word-bytes))
+                                 (ash sb-vm:*static-space-free-pointer*
+                                      sb-vm:n-fixnum-tag-bits))
                               :static)
                              ((< (sb-kernel:current-dynamic-space-start) addr
                                  (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
@@ -902,7 +925,7 @@ Experimental: interface subject to change."
                (funcall fun part))))
       (when ext
         (let ((table sb-pcl::*eql-specializer-table*))
-          (call (sb-ext:with-locked-hash-table (table)
+          (call (sb-int:with-locked-system-table (table)
                   (gethash object table)))))
       (etypecase object
         ((or bignum float sb-sys:system-area-pointer fixnum))