0.8.1.5:

        * Fix bugs 3cd:
        ... flush DSD-SAFE-P if the new type is more restrictive than
            the original;
        ... make out of line structure slot readers check type for
            unsafe slots.

diff --git a/BUGS b/BUGS
index a4ed57f..ca347e1 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -84,24 +84,7 @@ WORKAROUND:
      an error may be signalled at read time and it would be good if
      SBCL did it.
 
-  c: Reading of not initialized slot sometimes causes SEGV (for inline
-     accessors it is fixed, but out-of-line still do not perform type
-     check).
-
-  d:
-    (declaim (optimize (safety 3) (speed 1) (space 1)))
-    (defstruct foo
-      x y)
-    (defstruct (stringwise-foo (:include foo
-                                         (x "x" :type simple-string)
-                                         (y "y" :type simple-string))))
-    (defparameter *stringwise-foo*
-      (make-stringwise-foo))
-    (setf (foo-x *stringwise-foo*) 0)
-    (defun frob-stringwise-foo (sf)
-      (aref (stringwise-foo-x sf) 0))
-    (frob-stringwise-foo *stringwise-foo*)
-  SEGV.
+  d: (fixed in 0.8.1.5)
 
 7:
   The "compiling top-level form:" output ought to be condensed.

diff --git a/NEWS b/NEWS
index d0f4126..240bc66 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1882,6 +1882,9 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0:
 changes in sbcl-0.8.1 relative to sbcl-0.8.0:
   * fixed bug 148: failure to inline-expand a local function left
     garbage, confusing the compiler.
+  * fixed bugs 3cd: structure slot readers perform type check if the
+    slot can have an invalid value (i.e. it is either not initialized
+    or can be written with a less specific slot writer).
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index feec05a..4b0f84d 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -805,9 +805,16 @@
                           (dsd-index included-slot))
                     (dd-inherited-accessor-alist dd)
                     :test #'eq :key #'car))
-         (parse-1-dsd dd
-                      modified
-                      (copy-structure included-slot)))))))
+         (let ((new-slot (parse-1-dsd dd
+                                       modified
+                                       (copy-structure included-slot))))
+            (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
+                       (not (subtypep (dsd-type included-slot)
+                                      (dsd-type new-slot)))
+                       (dsd-safe-p included-slot))
+              (setf (dsd-safe-p new-slot) nil)
+              ;; XXX: notify?
+              )))))))
 \f
 ;;;; various helper functions for setting up DEFSTRUCTs
 

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index bad8d95..4138741 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -321,13 +321,21 @@
             ;; through here.
             (%slotplace-accessor-funs (slotplace instance-type-check-form)
               (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
-              `(values (lambda (instance)
-                         (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
-                         ,instance-type-check-form
-                         (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
-                         ,slotplace)
-                       (let ((typecheckfun (typespec-typecheckfun dsd-type)))
-                         (lambda (new-value instance)
+              `(let ((typecheckfun (typespec-typecheckfun dsd-type)))
+                  (values (if (dsd-safe-p dsd)
+                              (lambda (instance)
+                                (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+                                ,instance-type-check-form
+                                (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                                ,slotplace)
+                              (lambda (instance)
+                                (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+                                ,instance-type-check-form
+                                (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                                (let ((value ,slotplace))
+                                  (funcall typecheckfun value)
+                                  value)))
+                          (lambda (new-value instance)
                            (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
                            ,instance-type-check-form
                            (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
@@ -337,7 +345,7 @@
 
     (let ((dsd-index (dsd-index dsd))
          (dsd-type (dsd-type dsd)))
-           
+
       #+sb-xc (/show0 "got DSD-TYPE=..")
       #+sb-xc (/hexstr dsd-type)
       (ecase (dd-type dd)
@@ -346,7 +354,7 @@
        (structure
         #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
         (%native-slot-accessor-funs %instance-ref))
-                                    
+
        ;; structures with the :TYPE option
 
        ;; FIXME: Worry about these later..

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index e195286..23f9bc7 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -31,7 +31,6 @@
     (c #\# :type (integer 5 6)))
 (let ((s (make-boa-saux)))
   (declare (notinline identity))
-  #+nil ; bug 235a
   (locally (declare (optimize (safety 3))
                     (inline boa-saux-a))
     (assert (raises-error? (identity (boa-saux-a s)) type-error)))
@@ -53,6 +52,17 @@
   (assert (eql (boa-saux-b s) 3))
   (assert (eql (boa-saux-c s) 5)))
 
+(let ((s (make-boa-saux)))
+  (declare (notinline identity))
+  (locally (declare (optimize (safety 3))
+                    (notinline boa-saux-a))
+    (assert (raises-error? (identity (boa-saux-a s)) type-error)))
+  (setf (boa-saux-a s) 1)
+  (setf (boa-saux-c s) 5)
+  (assert (eql (boa-saux-a s) 1))
+  (assert (eql (boa-saux-b s) 3))
+  (assert (eql (boa-saux-c s) 5)))
+
 ;;; basic inheritance
 (defstruct (astronaut (:include person)
                      (:conc-name astro-))
@@ -475,6 +485,34 @@
 (assert (vector-struct-p (make-vector-struct)))
 (assert (not (vector-struct-p nil)))
 (assert (not (vector-struct-p #())))
+\f
+;;; bug 3d: type safety with redefined type constraints on slots
+(macrolet
+    ((test (type)
+       (let* ((base-name (intern (format nil "bug3d-~A" type)))
+              (up-name (intern (format nil "~A-up" base-name)))
+              (accessor (intern (format nil "~A-X" base-name)))
+              (up-accessor (intern (format nil "~A-X" up-name)))
+              (type-options (when type `((:type ,type)))))
+         `(progn
+            (defstruct (,base-name ,@type-options)
+              x y)
+            (defstruct (,up-name (:include ,base-name
+                                           (x "x" :type simple-string)
+                                           (y "y" :type simple-string))
+                                 ,@type-options))
+            (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
+              (setf (,accessor ob) 0)
+              (loop for decl in '(inline notinline)
+                    for fun = `(lambda (s)
+                                 (declare (optimize (safety 3))
+                                          (,decl ,',up-accessor))
+                                 (,',up-accessor s))
+                    do (assert (raises-error? (funcall (compile nil fun) ob)
+                                              type-error))))))))
+  (test nil)
+  (test list)
+  (test vector))
 
 ;;; success
 (format t "~&/returning success~%")

diff --git a/version.lisp-expr b/version.lisp-expr
index 71bf6ec..cee4763 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".)
-"0.8.1.4"
+"0.8.1.5"