[prev in list] [next in list] [prev in thread] [next in thread] 

List:       sbcl-commits
Subject:    [Sbcl-commits] master: Extend unbound slot detection in inspect
From:       crhodes via Sbcl-commits <sbcl-commits () lists ! sourceforge ! net>
Date:       2023-04-30 17:35:44
Message-ID: 1682876144.563211.8201 () sfp-scm-4 ! v30 ! lw ! sourceforge ! com
[Download RAW message or body]

The branch "master" has been updated in SBCL:
       via  dc148c86367c37ec876d851ebdf4a5dc098057be (commit)
      from  12c21b36add503c436e62fc25ae48aca321e1d47 (commit)

- Log -----------------------------------------------------------------
commit dc148c86367c37ec876d851ebdf4a5dc098057be
Author: Christophe Rhodes <csr21@cantab.net>
Date:   Sun Apr 30 18:33:32 2023 +0100

    Extend unbound slot detection in inspect
    
    Add tests for structures and conditions.  This reveals that we're
    not properly catering for unbound structure slots: admittedly a
    niche case.  Fix that by accessing the structure using low-level
    accessors.
---
 src/code/inspect.lisp     | 20 +++++++++-----------
 src/cold/exports.lisp     |  2 +-
 tests/inspect.impure.lisp | 27 ++++++++++++++++++++++-----
 3 files changed, 32 insertions(+), 17 deletions(-)

diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp
index 1618ca44c..e79e3aa94 100644
--- a/src/code/inspect.lisp
+++ b/src/code/inspect.lisp
@@ -116,7 +116,8 @@ evaluated expressions.
   (let ((*suppress-print-errors*
          (if (subtypep 'serious-condition *suppress-print-errors*)
              *suppress-print-errors*
-             'serious-condition)))
+             'serious-condition))
+        (unbound (load-time-value (make-unprintable-object "unbound slot") t)))
     (format stream "~%~A" description)
     (loop for element in elements
        for index from 0
@@ -124,13 +125,9 @@ evaluated expressions.
               (if named-p
                   (values (cdr element) (car element))
                   element)
-            (format stream "~W. ~@[~A: ~]" index name)
-            (if (eq value sb-pcl:+slot-unbound+)
-                (print-unreadable-object
-                    (value stream :type nil :identity nil)
-                  (write-string "unbound slot" stream))
-                (write value :stream stream))
-            (terpri stream)))))
+            (when (unbound-marker-p value)
+              (setf value unbound))
+            (format stream "~W. ~@[~A: ~]~W~%" index name value)))))
 
 ;;;; INSPECTED-PARTS
 
@@ -171,9 +168,10 @@ evaluated expressions.
         (info (wrapper-info (sb-kernel:wrapper-of object))))
     (when (sb-kernel::defstruct-description-p info)
       (dolist (dd-slot (dd-slots info) (nreverse parts-list))
-        (push (cons (dsd-name dd-slot)
-                    (funcall (dsd-accessor-name dd-slot) object))
-              parts-list)))))
+        (let* ((reader (dsd-reader dd-slot (neq (dd-type info) 'structure)))
+               (index (dsd-index dd-slot))
+               (value (funcall reader object index)))
+          (push (cons (dsd-name dd-slot) value) parts-list))))))
 
 (defmethod inspected-parts ((object structure-object))
   (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%"
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 43ccad506..99ba413b3 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -2064,7 +2064,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
            "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-INT-EXPONENT"
            "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-SIGNIFICAND"
            "DSD-ACCESSOR-NAME" "DSD-ALWAYS-BOUNDP" "DSD-DEFAULT" "DSD-INDEX"
-           "DSD-NAME" "DSD-RAW-TYPE" "DSD-READ-ONLY" "DSD-TYPE"
+           "DSD-NAME" "DSD-RAW-TYPE" "DSD-READ-ONLY" "DSD-READER" "DSD-TYPE"
            "DYNAMIC-SPACE-OBJ-P"
            "DYNBIND"
            "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
diff --git a/tests/inspect.impure.lisp b/tests/inspect.impure.lisp
index 36ad9b8fe..f009997b8 100644
--- a/tests/inspect.impure.lisp
+++ b/tests/inspect.impure.lisp
@@ -28,9 +28,6 @@
   (print-unreadable-object (object stream :type t)
     (princ (slot-value object 'will-be-unbound) stream)))
 
-(defclass class-with-unbound-slot ()
-  (foo))
-
 (with-test (:name (inspect :no-error print-object :lp-454682))
   (let ((class (find-class 'class-with-prototype-print-error)))
     ;; Prototype may not be initialized at this point.
@@ -81,7 +78,27 @@
          (result (test-inspect array)))
     (assert (search "ARRAY of NIL" result))))
 
-(with-test (:name (inspect object unbound-slot))
-  (let* ((object (make-instance 'class-with-unbound-slot))
+(defclass standard-object-with-unbound-slot ()
+  (foo))
+
+(with-test (:name (inspect standard-object unbound-slot))
+  (let* ((object (make-instance 'standard-object-with-unbound-slot))
+         (result (test-inspect object)))
+    (assert (search "#<unbound slot>" result))))
+
+(defstruct (structure-with-unbound-slot
+             (:constructor make-structure-with-unbound-slot (&aux foo)))
+  foo)
+
+(with-test (:name (inspect standard-object unbound-slot))
+  (let* ((object (make-structure-with-unbound-slot))
+         (result (test-inspect object)))
+    (assert (search "#<unbound slot>" result))))
+
+(define-condition condition-with-unbound-slot ()
+  (foo))
+
+(with-test (:name (inspect condition unbound-slot))
+  (let* ((object (make-condition 'condition-with-unbound-slot))
          (result (test-inspect object)))
     (assert (search "#<unbound slot>" result))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL


_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]