From 88dab5bc2cb92077bced88729dc95096b3b6a127 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 5 Oct 2008 09:53:31 +0000 Subject: [PATCH] 1.0.21.3: CIRCLE-SUBST did not treat raw structure slots correctly * Reported by Cedric St-Jean on sbcl-devel. --- NEWS | 2 ++ src/code/sharpm.lisp | 23 ++++++++++++++++------- src/code/target-defstruct.lisp | 2 +- tests/array.pure.lisp | 2 +- tests/defstruct.impure.lisp | 12 +++++++++++- version.lisp-expr | 2 +- 6 files changed, 32 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index 4e53c41..4c45d3f 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4