X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=9bfc78c11f0b8b3997a84006744313d2d478dbd1;hb=cc67baa3070a13bd84bb37680761011e689fb917;hp=1947bbd2c408caee16b9f2fa156de5376328c2d3;hpb=ba12c5c0420f28250ef4931b47af92c6d7963195;p=sbcl.git diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 1947bbd..9bfc78c 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,12 +462,12 @@ *manyraw*))) (room) (sb-ext:gc)) -(with-test (:name defstruct-raw-slot-gc) +(with-test (:name :defstruct-raw-slot-gc) (check-manyraws *manyraw*)) ;;; try a full GC, too (sb-ext:gc :full t) -(with-test (:name (defstruct-raw-slot-gc :full)) +(with-test (:name (:defstruct-raw-slot-gc :full)) (check-manyraws *manyraw*)) ;;; fasl dumper and loader also have special handling of raw slots, so @@ -487,7 +488,7 @@ ;;; re-read the dumped structures and check them (load "tmp-defstruct.manyraw.fasl") -(with-test (:name (defstruct-raw-slot load)) +(with-test (:name (:defstruct-raw-slot load)) (check-manyraws (dumped-manyraws))) @@ -680,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)) @@ -691,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)) @@ -709,7 +710,13 @@ c (a 0d0 :type double-float)) -(with-test (:name raw-slot-equalp) +(defstruct raw-slot-equalp-bug-2 + (b (complex 1d0) :type (complex double-float)) + (x (complex 1d0) :type (complex double-float)) + c + (a 1s0 :type single-float)) + +(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) @@ -717,7 +724,15 @@ (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) (make-raw-slot-equalp-bug :a 1d0 :b 3s0)))) (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) - (make-raw-slot-equalp-bug :a 2d0 :b 2s0))))) + (make-raw-slot-equalp-bug :a 2d0 :b 2s0)))) + (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0) + (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0))) + (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 0s0) + (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a -0s0))) + (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0) + (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 3s0)))) + (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0) + (make-raw-slot-equalp-bug-2 :b (complex 2d0) :a 2s0))))) ;;; Check that all slot types (non-raw and raw) can be initialized with ;;; constant arguments. @@ -852,7 +867,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) @@ -864,7 +879,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) @@ -877,7 +892,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) @@ -888,7 +903,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) @@ -901,7 +916,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) @@ -916,7 +931,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)) @@ -931,7 +946,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)) @@ -945,7 +960,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)) @@ -965,7 +980,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)) @@ -991,7 +1006,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)) @@ -1018,7 +1033,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)) @@ -1065,7 +1080,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"))))) @@ -1112,3 +1127,29 @@ redefinition." (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)))))