X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=45ba8a1f1e9ee41f371786047e4d254c43336cf3;hb=b41f8c974ccfba8a59ec2a6af843e8869e14be5f;hp=c86fb9e7fc1111217d3736ccbe46187a4167ad32;hpb=f8e44b3103b284f98b18c177b5904b064ad44f93;p=sbcl.git diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index c86fb9e..45ba8a1 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -9,9 +9,8 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(cl:in-package :cl-user) - (load "assertoid.lisp") +(use-package "ASSERTOID") ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec @@ -21,8 +20,48 @@ (defstruct person age (name 007 :type string)) ; not an error until 007 used (make-person :name "James") ; not an error, 007 not used (assert (raises-error? (make-person) type-error)) -;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62 -#+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error)) +(assert (raises-error? (setf (person-name (make-person :name "Q")) 1) + type-error)) + +;;; An &AUX variable in a boa-constructor without a default value +;;; means "do not initialize slot" and does not cause type error +(declaim (notinline opaque-identity)) +(defun opaque-identity (x) x) + +(defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c)))) + (a #\! :type (integer 1 2)) + (b #\? :type (integer 3 4)) + (c #\# :type (integer 5 6))) +(let ((s (make-boa-saux))) + (locally (declare (optimize (safety 3)) + (inline boa-saux-a)) + (assert (raises-error? (opaque-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))) + ; these two checks should be + ; kept separated +(let ((s (make-boa-saux))) + (locally (declare (optimize (safety 0)) + (inline boa-saux-a)) + (assert (eql (opaque-identity (boa-saux-a s)) 0))) + (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))) + +(let ((s (make-boa-saux))) + (locally (declare (optimize (safety 3)) + (notinline boa-saux-a)) + (assert (raises-error? (opaque-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) @@ -41,7 +80,7 @@ ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET (defstruct (binop (:type list) :named (:initial-offset 2)) - (operator '? :type symbol) + (operator '? :type symbol) operand-1 operand-2) (defstruct (annotated-binop (:type list) @@ -310,13 +349,13 @@ ;;;; some other raw slot). (defstruct manyraw - (a (expt 2 30) :type (unsigned-byte 32)) + (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits)) (b 0.1 :type single-float) (c 0.2d0 :type double-float) (d #c(0.3 0.3) :type (complex single-float)) unraw-slot-just-for-variety (e #c(0.4d0 0.4d0) :type (complex double-float)) - (aa (expt 2 30) :type (unsigned-byte 32)) + (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits)) (bb 0.1 :type single-float) (cc 0.2d0 :type double-float) (dd #c(0.3 0.3) :type (complex single-float)) @@ -352,6 +391,95 @@ (assert (eql (manyraw-cc copy) 0.22d0)) (assert (eql (manyraw-dd copy) #c(0.33 0.33))) (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0)))) + + +;;;; Since GC treats raw slots specially now, let's try this with more objects +;;;; and random values as a stress test. + +(setf *manyraw* nil) + +(defconstant +n-manyraw+ 10) +(defconstant +m-manyraw+ 1000) + +(defun check-manyraws (manyraws) + (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+))) + (loop + for m in (reverse manyraws) + for i from 0 + do + ;; Compare the tagged reference values with raw reffer results. + (destructuring-bind (j a b c d e) + (manyraw-unraw-slot-just-for-variety m) + (assert (eql i j)) + (assert (= (manyraw-a m) a)) + (assert (= (manyraw-b m) b)) + (assert (= (manyraw-c m) c)) + (assert (= (manyraw-d m) d)) + (assert (= (manyraw-e m) e))) + ;; Test the funny out-of-line OAOOM-style closures, too. + (mapcar (lambda (fn value) + (assert (= (funcall fn m) value))) + (list #'manyraw-a + #'manyraw-b + #'manyraw-c + #'manyraw-d + #'manyraw-e) + (cdr (manyraw-unraw-slot-just-for-variety m))))) + +(defstruct (manyraw-subclass (:include manyraw)) + (stolperstein 0 :type (unsigned-byte 32))) + +;;; create lots of manyraw objects, triggering GC every now and then +(dotimes (y +n-manyraw+) + (dotimes (x +m-manyraw+) + (let ((a (random (expt 2 32))) + (b (random most-positive-single-float)) + (c (random most-positive-double-float)) + (d (complex + (random most-positive-single-float) + (random most-positive-single-float))) + (e (complex + (random most-positive-double-float) + (random most-positive-double-float)))) + (push (funcall (if (zerop (mod x 3)) + #'make-manyraw-subclass + #'make-manyraw) + :unraw-slot-just-for-variety + (list (+ x (* y +m-manyraw+)) a b c d e) + :a a + :b b + :c c + :d d + :e e) + *manyraw*))) + (room) + (sb-ext:gc)) +(check-manyraws *manyraw*) + +;;; try a full GC, too +(sb-ext:gc :full t) +(check-manyraws *manyraw*) + +;;; fasl dumper and loader also have special handling of raw slots, so +;;; dump all of them into a fasl +(defmethod make-load-form ((self manyraw) &optional env) + self env + :sb-just-dump-it-normally) +(with-open-file (s "tmp-defstruct.manyraw.lisp" + :direction :output + :if-exists :supersede) + (write-string "(defun dumped-manyraws () '#.*manyraw*)" s)) +(compile-file "tmp-defstruct.manyraw.lisp") +(delete-file "tmp-defstruct.manyraw.lisp") + +;;; nuke the objects and try another GC just to be extra careful +(setf *manyraw* nil) +(sb-ext:gc :full t) + +;;; re-read the dumped structures and check them +(load "tmp-defstruct.manyraw.fasl") +(check-manyraws (dumped-manyraws)) + ;;;; miscellaneous old bugs @@ -389,6 +517,151 @@ (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s)) (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not))) +;;; tests of behaviour of colliding accessors. +(defstruct (bug127-foo (:conc-name bug127-baz-)) a) +(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1)) +(defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b) +(assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1)) +(assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2)) +(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1)) + +(defun bug127-flurble (x) + x) +(defstruct bug127 flurble) +(assert (= (bug127-flurble (make-bug127 :flurble 7)) 7)) + +(defstruct bug127-a b-c) +(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9)) +(defstruct (bug127-a-b (:include bug127-a)) c) +(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9)) +(assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11)) + +(defstruct (bug127-e (:conc-name bug127--)) foo) +(assert (= (bug127--foo (make-bug127-e :foo 3)) 3)) +(defstruct (bug127-f (:conc-name bug127--)) foo) +(assert (= (bug127--foo (make-bug127-f :foo 3)) 3)) +(assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error)) + +;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE + +;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little +;;; too fragile: +(defstruct (conc-name-syntax :conc-name) a-conc-name-slot) +(assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y)) + 'y)) +;;; and further :CONC-NAME NIL was being wrongly treated: +(defpackage "DEFSTRUCT-TEST-SCRATCH") +(defstruct (conc-name-nil :conc-name) + defstruct-test-scratch::conc-name-nil-slot) +(assert (= (defstruct-test-scratch::conc-name-nil-slot + (make-conc-name-nil :conc-name-nil-slot 1)) 1)) +(assert (raises-error? (conc-name-nil-slot (make-conc-name-nil)) + undefined-function)) + +;;; The named/typed predicates were a little fragile, in that they +;;; could throw errors on innocuous input: +(defstruct (list-struct (:type list) :named) a-slot) +(assert (list-struct-p (make-list-struct))) +(assert (not (list-struct-p nil))) +(assert (not (list-struct-p 1))) +(defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot) +(assert (offset-list-struct-p (make-offset-list-struct))) +(assert (not (offset-list-struct-p nil))) +(assert (not (offset-list-struct-p 1))) +(assert (not (offset-list-struct-p '(offset-list-struct)))) +(assert (not (offset-list-struct-p '(offset-list-struct . 3)))) +(defstruct (vector-struct (:type vector) :named) a-slot) +(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)) + +(let* ((name (gensym)) + (form `(defstruct ,name + (x nil :type (or null (function (integer) + (values number &optional foo))))))) + (eval (copy-tree form)) + (eval (copy-tree form))) + +;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists" +;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP +;;; test suite. +(defstruct (bug-332a (:type list) (:initial-offset 5) :named)) +(defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a))) +(assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail)))) +(assert (not (bug-332b-p 873257))) +(assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a)))) +(assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b))) + +;;; Similar test for vectors, just for good measure. +(defstruct (bug-332a-aux (:type vector) + (:initial-offset 5) :named)) +(defstruct (bug-332b-aux (:type vector) + (:initial-offset 2) :named + (:include bug-332a-aux))) +(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end)))) +(assert (not (bug-332b-aux-p 873257))) +(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux)))) +(assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux))) + +;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure +;;; slot accessors signalled a condition at macroexpansion time, not +;;; when the code was actually compiled or loaded. +(let ((defstruct-form '(defstruct bug-in-0-8-11-8 x))) + (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing")) + (handler-case (macroexpand defstruct-form) + (warning (c) + (error "shouldn't warn just from macroexpansion here")))) + +;;; bug 318 symptom no 1. (rest not fixed yet) +(catch :ok + (handler-bind ((error (lambda (c) + ;; Used to cause stack-exhaustion + (unless (typep c 'storege-condition) + (throw :ok))))) + (eval '(progn + (defstruct foo a) + (setf (find-class 'foo) nil) + (defstruct foo slot-1))))) + +;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor +;;; Melis. +(defstruct bug-348 x) + +(assert (eql -1 (let ((i (eval '-2)) + (x (make-bug-348))) + (funcall #'(setf bug-348-x) + (incf i) + (aref (vector x) (incf i))) + (bug-348-x x)))) + ;;; success (format t "~&/returning success~%") (quit :unix-status 104)