From: Alexey Dejneka Date: Thu, 26 Jun 2003 07:50:27 +0000 (+0000) Subject: 0.8.1.5: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f409f90c5e8c4c87ed9fa6efdc0e5c1952d94602;p=sbcl.git 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 --- 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 --- 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 --- 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? + ))))))) ;;;; 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 --- 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 --- 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 #()))) + +;;; 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 --- 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"