X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=00aa376d7b26128a9a7c9b6c525b4fbfbfeaba5b;hb=9c9d6dbdc28a8bfe70be09f35263e9ec02411d0e;hp=1354ab60174d828c90f7b9250d2f70e5374178bb;hpb=3120740c3569735b00123b94b61679f56e253ea6;p=sbcl.git diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 1354ab6..00aa376 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -10,6 +10,7 @@ ;;;; more information. (load "assertoid.lisp") +(load "compiler-test-util.lisp") (use-package "ASSERTOID") ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec @@ -461,11 +462,13 @@ *manyraw*))) (room) (sb-ext:gc)) -(check-manyraws *manyraw*) +(with-test (:name :defstruct-raw-slot-gc) + (check-manyraws *manyraw*)) ;;; try a full GC, too (sb-ext:gc :full t) -(check-manyraws *manyraw*) +(with-test (:name (:defstruct-raw-slot-gc :full)) + (check-manyraws *manyraw*)) ;;; fasl dumper and loader also have special handling of raw slots, so ;;; dump all of them into a fasl @@ -485,7 +488,8 @@ ;;; re-read the dumped structures and check them (load "tmp-defstruct.manyraw.fasl") -(check-manyraws (dumped-manyraws)) +(with-test (:name (:defstruct-raw-slot load)) + (check-manyraws (dumped-manyraws))) ;;;; miscellaneous old bugs @@ -677,7 +681,7 @@ ;;; of the same class. (Putting this FIXME here, since this is the only ;;; place where they appear together.) -(with-test (:name obsolete-defstruct/print-object) +(with-test (:name :obsolete-defstruct/print-object) (eval '(defstruct born-to-change)) (let ((x (make-born-to-change))) (handler-bind ((error 'continue)) @@ -688,7 +692,7 @@ (sb-pcl::obsolete-structure () :error)))))) -(with-test (:name obsolete-defstruct/typep) +(with-test (:name :obsolete-defstruct/typep) (eval '(defstruct born-to-change-2)) (let ((x (make-born-to-change-2))) (handler-bind ((error 'continue)) @@ -706,7 +710,7 @@ c (a 0d0 :type double-float)) -(with-test (:name raw-slot-equalp) +(with-test (:name :raw-slot-equalp) (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) (make-raw-slot-equalp-bug :a 1d0 :b 2s0))) (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0) @@ -849,7 +853,7 @@ redefinition." ;;; Tests begin. ;; Base case: recklessly-continue. -(with-defstruct-redefinition-test defstruct/recklessly +(with-defstruct-redefinition-test :defstruct/recklessly (((defstruct ctor pred) :class-name redef-test-1 :slots (a)) ((defstruct*) :class-name redef-test-1 :slots (a b))) ((path1 defstruct) @@ -861,7 +865,7 @@ redefinition." (assert-is pred instance))) ;; Base case: continue (i.e., invalidate instances). -(with-defstruct-redefinition-test defstruct/continue +(with-defstruct-redefinition-test :defstruct/continue (((defstruct ctor pred) :class-name redef-test-2 :slots (a)) ((defstruct*) :class-name redef-test-2 :slots (a b))) ((path1 defstruct) @@ -874,7 +878,7 @@ redefinition." ;; Compiling a file with an incompatible defstruct should emit a ;; warning and an error, but the fasl should be loadable. -(with-defstruct-redefinition-test defstruct/compile-file-should-warn +(with-defstruct-redefinition-test :defstruct/compile-file-should-warn (((defstruct) :class-name redef-test-3 :slots (a)) ((defstruct*) :class-name redef-test-3 :slots (a b))) ((path1 defstruct) @@ -885,7 +889,7 @@ redefinition." ;; After compiling a file with an incompatible DEFSTRUCT, load the ;; fasl and ensure that an old instance remains valid. -(with-defstruct-redefinition-test defstruct/compile-file-reckless +(with-defstruct-redefinition-test :defstruct/compile-file-reckless (((defstruct ctor pred) :class-name redef-test-4 :slots (a)) ((defstruct*) :class-name redef-test-4 :slots (a b))) ((path1 defstruct) @@ -898,7 +902,7 @@ redefinition." ;; After compiling a file with an incompatible DEFSTRUCT, load the ;; fasl and ensure that an old instance has become invalid. -(with-defstruct-redefinition-test defstruct/compile-file-continue +(with-defstruct-redefinition-test :defstruct/compile-file-continue (((defstruct ctor pred) :class-name redef-test-5 :slots (a)) ((defstruct*) :class-name redef-test-5 :slots (a b))) ((path1 defstruct) @@ -913,7 +917,7 @@ redefinition." ;; Ensure that recklessly continuing DT(expected)T to instances of ;; subclasses. (This is a case where recklessly continuing is ;; actually dangerous, but we don't care.) -(with-defstruct-redefinition-test defstruct/subclass-reckless +(with-defstruct-redefinition-test :defstruct/subclass-reckless (((defstruct ignore pred1) :class-name redef-test-6 :slots (a)) ((substruct ctor pred2) :class-name redef-test-6-sub :super-name redef-test-6 :slots (z)) @@ -928,7 +932,7 @@ redefinition." (assert-is pred2 instance))) ;; Ensure that continuing invalidates instances of subclasses. -(with-defstruct-redefinition-test defstruct/subclass-continue +(with-defstruct-redefinition-test :defstruct/subclass-continue (((defstruct) :class-name redef-test-7 :slots (a)) ((substruct ctor pred) :class-name redef-test-7-sub :super-name redef-test-7 :slots (z)) @@ -942,7 +946,7 @@ redefinition." (assert-invalid pred instance))) ;; Reclkessly continuing doesn't invalidate instances of subclasses. -(with-defstruct-redefinition-test defstruct/subclass-in-other-file-reckless +(with-defstruct-redefinition-test :defstruct/subclass-in-other-file-reckless (((defstruct ignore pred1) :class-name redef-test-8 :slots (a)) ((substruct ctor pred2) :class-name redef-test-8-sub :super-name redef-test-8 :slots (z)) @@ -962,7 +966,7 @@ redefinition." ;; file, CONTINUE'ing from LOAD of a file containing an incompatible ;; superclass definition leaves the predicates and accessors into the ;; subclass in a bad way until the subclass form is evaluated. -(with-defstruct-redefinition-test defstruct/subclass-in-other-file-continue +(with-defstruct-redefinition-test :defstruct/subclass-in-other-file-continue (((defstruct ignore pred1) :class-name redef-test-9 :slots (a)) ((substruct ctor pred2) :class-name redef-test-9-sub :super-name redef-test-9 :slots (z)) @@ -988,7 +992,7 @@ redefinition." ;; Some other subclass wrinkles have to do with splitting definitions ;; accross files and compiling and loading things in a funny order. (with-defstruct-redefinition-test - defstruct/subclass-in-other-file-funny-operation-order-continue + :defstruct/subclass-in-other-file-funny-operation-order-continue (((defstruct ignore pred1) :class-name redef-test-10 :slots (a)) ((substruct ctor pred2) :class-name redef-test-10-sub :super-name redef-test-10 :slots (z)) @@ -1015,7 +1019,7 @@ redefinition." (assert-invalid pred2 instance))) (with-defstruct-redefinition-test - defstruct/subclass-in-other-file-funny-operation-order-continue + :defstruct/subclass-in-other-file-funny-operation-order-continue (((defstruct ignore pred1) :class-name redef-test-11 :slots (a)) ((substruct ctor pred2) :class-name redef-test-11-sub :super-name redef-test-11 :slots (z)) @@ -1062,7 +1066,7 @@ redefinition." (assert (eq 'string (type-error-expected-type e))) (assert (zerop (type-error-datum e)))))) -(with-test (:name defstruct-copier-typechecks-argument) +(with-test (:name :defstruct-copier-typechecks-argument) (assert (not (raises-error? (copy-person (make-astronaut :name "Neil"))))) (assert (raises-error? (copy-astronaut (make-person :name "Fred"))))) @@ -1083,3 +1087,55 @@ redefinition." ;; So's empty. (eval '(defstruct (typed-struct2 (:type list) (:predicate)) (a 42 :type fixnum)))) + +(with-test (:name (:boa-supplied-p &optional)) + (handler-bind ((warning #'error)) + (eval `(defstruct (boa-supplied-p.1 (:constructor make-boa-supplied-p.1 + (&optional (bar t barp)))) + bar + barp))) + (let ((b1 (make-boa-supplied-p.1)) + (b2 (make-boa-supplied-p.1 t))) + (assert (eq t (boa-supplied-p.1-bar b1))) + (assert (eq t (boa-supplied-p.1-bar b2))) + (assert (eq nil (boa-supplied-p.1-barp b1))) + (assert (eq t (boa-supplied-p.1-barp b2))))) + +(with-test (:name (:boa-supplied-p &key)) + (handler-bind ((warning #'error)) + (eval `(defstruct (boa-supplied-p.2 (:constructor make-boa-supplied-p.2 + (&key (bar t barp)))) + bar + barp))) + (let ((b1 (make-boa-supplied-p.2)) + (b2 (make-boa-supplied-p.2 :bar t))) + (assert (eq t (boa-supplied-p.2-bar b1))) + (assert (eq t (boa-supplied-p.2-bar b2))) + (assert (eq nil (boa-supplied-p.2-barp b1))) + (assert (eq t (boa-supplied-p.2-barp b2))))) + +(defstruct structure-with-predicate) +(defclass class-to-be-redefined () ()) +(let ((x (make-instance 'class-to-be-redefined))) + (defun function-trampoline (fun) (funcall fun x))) + +(with-test (:name (:struct-predicate :obsolete-instance)) + (defclass class-to-be-redefined () ((a :initarg :a :initform 1))) + (function-trampoline #'structure-with-predicate-p)) + +(with-test (:name (:defstruct :not-toplevel-silent)) + (let ((sb-ext:*evaluator-mode* :compile)) + (handler-bind ((warning #'error)) + (eval `(let () + (defstruct destruct-no-warning-not-at-toplevel bar)))))) + +(with-test (:name :bug-941102) + (let ((test `((defstruct bug-941102) + (setf (find-class 'bug-941102-alias) (find-class 'bug-941102)) + (setf (find-class 'bug-941102-alias) nil)))) + (multiple-value-bind (warn fail) (ctu:file-compile test :load t) + (assert (not warn)) + (assert (not fail))) + (multiple-value-bind (warn2 fail2) (ctu:file-compile test) + (assert (not warn2)) + (assert (not fail2)))))