sb-posix: make SYSCALL-ERROR's argument optional

[sbcl.git] / contrib / sb-introspect / introspect.lisp

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index ed8f256..c7fc14f 100644 (file)
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -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)))
@@ -376,9 +377,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))
@@ -886,7 +886,7 @@ indirect containers: FDEFINITIONs, EQL specializers, classes, and
 thread-local symbol values in other threads fall into this category.
 
 NOTE: calling MAP-ROOT with a THREAD does not currently map over
-conservative roots from the thread stack & interrupt contexts.
+conservative roots from the thread registers and interrupt contexts.
 
 Experimental: interface subject to change."
   (let ((fun (coerce function 'function))
@@ -902,7 +902,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))
@@ -927,9 +927,29 @@ Experimental: interface subject to change."
                                0)))
            (dotimes (i (- len nuntagged))
              (call (sb-kernel:%instance-ref object i))))
+         #+sb-thread
          (when (typep object 'sb-thread:thread)
-           (dolist (value (sb-thread::%thread-local-values object))
-             (call value))))
+           (cond ((eq object sb-thread:*current-thread*)
+                  (dolist (value (sb-thread::%thread-local-references))
+                    (call value))
+                  (sb-vm::map-stack-references #'call))
+                 (t
+                  ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
+                  ;; the alternative would be stopping the world...
+                  #+sb-thread
+                  (let ((sem (sb-thread:make-semaphore))
+                        (refs nil))
+                    (handler-case
+                        (progn
+                          (sb-thread:interrupt-thread
+                           object
+                           (lambda ()
+                             (setf refs (sb-thread::%thread-local-references))
+                             (sb-vm::map-stack-references (lambda (x) (push x refs)))
+                             (sb-thread:signal-semaphore sem)))
+                          (sb-thread:wait-on-semaphore sem))
+                      (sb-thread:interrupt-thread-error ()))
+                    (mapc #'call refs))))))
         (array
          (if (simple-vector-p object)
              (dotimes (i (length object))