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.
 
      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.
 
 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.
 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
 
 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))
                           (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
 
 \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)
             ;; 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")
                            (/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)))
 
     (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)
       #+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))
        (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..
        ;; 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))
     (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)))
   (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)))
 
   (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-))
 ;;; 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 #())))
 (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~%")
 
 ;;; 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".)
 ;;; 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"