1.0.21.3: CIRCLE-SUBST did not treat raw structure slots correctly

 * Reported by Cedric St-Jean on sbcl-devel.

diff --git a/NEWS b/NEWS
index 4e53c41..4c45d3f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-1.0.22 relative to 1.0.21:
   * bug fix: ADJUST-ARRAY on multidimensional arrays used bogusly give
     them a fill pointer unless :DISPLACED-TO or :INITIAL-CONTENTS were
     provided. (reported by Cedric St-Jean)
+  * bug fix: circularity handling in the reader did not treat raw
+    structure slots correctly. (reported by Cedric St-Jean)
 
 changes in sbcl-1.0.21 relative to 1.0.20:
   * new feature: the compiler is able to track the effective type of a

diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index af7994f..a628872 100644 (file)
--- a/src/code/sharpm.lisp
+++ b/src/code/sharpm.lisp
@@ -256,13 +256,22 @@
                       (unless (eq old new)
                         (setf (aref data i) new))))))
                ((typep tree 'instance)
-                (do ((i 1 (1+ i))
-                     (end (%instance-length tree)))
-                    ((= i end))
-                  (let* ((old (%instance-ref tree i))
-                         (new (circle-subst old-new-alist old)))
-                    (unless (eq old new)
-                      (setf (%instance-ref tree i) new)))))
+                (let* ((n-untagged (layout-n-untagged-slots (%instance-layout tree)))
+                       (n-tagged (- (%instance-length tree) n-untagged)))
+                  ;; N-TAGGED includes the layout as well (at index 0), which
+                  ;; we don't grovel.
+                  (do ((i 1 (1+ i)))
+                      ((= i n-tagged))
+                    (let* ((old (%instance-ref tree i))
+                           (new (circle-subst old-new-alist old)))
+                      (unless (eq old new)
+                        (setf (%instance-ref tree i) new))))
+                  (do ((i 0 (1+ i)))
+                      ((= i n-untagged))
+                    (let* ((old (%raw-instance-ref/word tree i))
+                           (new (circle-subst old-new-alist old)))
+                      (unless (= old new)
+                        (setf (%raw-instance-ref/word tree i) new))))))
                ((typep tree 'funcallable-instance)
                 (do ((i 1 (1+ i))
                      (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset)))

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index a719bdf..4e9b596 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -414,7 +414,7 @@
     (when (layout-invalid layout)
       (error "attempt to copy an obsolete structure:~%  ~S" structure))
 
-    ;; Copy ordinary slots.
+    ;; Copy ordinary slots and layout.
     (dotimes (i (- len nuntagged))
       (declare (type index i))
       (setf (%instance-ref res i)

diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index 9919eb7..7760a6c 100644 (file)
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -210,7 +210,7 @@
                            'bit-vector)
           do (assert (bit-vector-equal r1 r2)))))
 
-(with-test (:name (adjust-array fill-pointer)) 
+(with-test (:name (adjust-array fill-pointer))
   ;; CLHS, ADJUST-ARRAY: An error of type error is signaled if
   ;; fill-pointer is supplied and non-nil but array has no fill pointer.
   (assert (eq :good

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 04e3e1c..06a4b47 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -1038,4 +1038,14 @@ redefinition."
     (assert-is pred1 instance)
     (assert-is pred2 instance)))
 
-
+(with-test (:name :raw-slot/circle-subst)
+  ;; CIRCLE-SUBSTS used %INSTANCE-REF on raw slots
+  (multiple-value-bind (list n)
+      (eval '(progn
+              (defstruct raw-slot/circle-subst
+                (x 0.0 :type single-float))
+              (read-from-string "((#1=#S(raw-slot/circle-subst :x 2.7158911)))")))
+    (destructuring-bind ((struct)) list
+      (assert (raw-slot/circle-subst-p struct))
+      (assert (eql 2.7158911 (raw-slot/circle-subst-x struct)))
+      (assert (eql 45 n)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 59dde7a..0108c9a 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.21.2"
+"1.0.21.3"