From: Alexey D. <ade...@us...> - 2003-06-26 07:50:30
|
Update of /cvsroot/sbcl/sbcl/tests In directory sc8-pr-cvs1:/tmp/cvs-serv31648/tests Modified Files: defstruct.impure.lisp Log Message: 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. Index: defstruct.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/defstruct.impure.lisp,v retrieving revision 1.16 retrieving revision 1.17 diff -u -d -r1.16 -r1.17 --- defstruct.impure.lisp 28 Jan 2003 17:21:15 -0000 1.16 +++ defstruct.impure.lisp 26 Jun 2003 07:50:27 -0000 1.17 @@ -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~%") |