+;;; Tests begin.
+;; Base case: recklessly-continue.
+(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)
+ (path2 defstruct*))
+ recklessly-continue-from-incompatible-defstruct-error
+ (load path1)
+ (let ((instance (funcall ctor)))
+ (load path2)
+ (assert-is pred instance)))
+
+;; Base case: continue (i.e., invalidate instances).
+(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)
+ (path2 defstruct*))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (let ((instance (funcall ctor)))
+ (load path2)
+ (assert-invalid pred instance)))
+
+;; 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
+ (((defstruct) :class-name redef-test-3 :slots (a))
+ ((defstruct*) :class-name redef-test-3 :slots (a b)))
+ ((path1 defstruct)
+ (path2 defstruct*))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (load (compile-file-assert path2)))
+
+;; 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
+ (((defstruct ctor pred) :class-name redef-test-4 :slots (a))
+ ((defstruct*) :class-name redef-test-4 :slots (a b)))
+ ((path1 defstruct)
+ (path2 defstruct*))
+ recklessly-continue-from-incompatible-defstruct-error
+ (load path1)
+ (let ((instance (funcall ctor)))
+ (load (compile-file-assert path2))
+ (assert-is pred instance)))
+
+;; 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
+ (((defstruct ctor pred) :class-name redef-test-5 :slots (a))
+ ((defstruct*) :class-name redef-test-5 :slots (a b)))
+ ((path1 defstruct)
+ (path2 defstruct*))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (let ((instance (funcall ctor)))
+ (load (compile-file-assert path2))
+ (assert-invalid pred instance)))
+\f
+;;; Subclasses.
+;; 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
+ (((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))
+ ((defstruct*) :class-name redef-test-6 :slots (a b)))
+ ((path1 defstruct substruct)
+ (path2 defstruct* substruct))
+ recklessly-continue-from-incompatible-defstruct-error
+ (load path1)
+ (let ((instance (funcall ctor)))
+ (load (compile-file-assert path2))
+ (assert-is pred1 instance)
+ (assert-is pred2 instance)))
+
+;; Ensure that continuing invalidates instances of subclasses.
+(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))
+ ((defstruct*) :class-name redef-test-7 :slots (a b)))
+ ((path1 defstruct substruct)
+ (path2 defstruct* substruct))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (let ((instance (funcall ctor)))
+ (load (compile-file-assert path2))
+ (assert-invalid pred instance)))
+
+;; Reclkessly continuing doesn't invalidate instances of subclasses.
+(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))
+ ((defstruct*) :class-name redef-test-8 :slots (a b)))
+ ((path1 defstruct)
+ (path2 substruct)
+ (path3 defstruct*))
+ recklessly-continue-from-incompatible-defstruct-error
+ (load path1)
+ (load path2)
+ (let ((instance (funcall ctor)))
+ (load (compile-file-assert path3))
+ (assert-is pred1 instance)
+ (assert-is pred2 instance)))
+
+;; This is an icky case: when a subclass is defined in a separate
+;; 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
+ (((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))
+ ((defstruct*) :class-name redef-test-9 :slots (a b)))
+ ((path1 defstruct)
+ (path2 substruct)
+ (path3 defstruct*))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (load path2)
+ (let ((instance (funcall ctor)))
+ (load (compile-file-assert path3))
+ ;; At this point, the instance of the subclass will not count as
+ ;; an instance of the superclass or of the subclass, but PRED2's
+ ;; predicate will error with "an obsolete structure accessor
+ ;; function was called".
+ (assert-invalid pred1 instance)
+ (format t "~&~A~%" (nth-value 1 (ignore-errors (funcall pred2 instance))))
+ ;; After loading PATH2, we'll get the desired LAYOUT-INVALID error.
+ (load path2)
+ (assert-invalid pred2 instance)))
+
+;; 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 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))
+ ((defstruct*) :class-name redef-test-10 :slots (a b)))
+ ((path1 defstruct)
+ (path2 substruct)
+ (path3 defstruct*))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (load path2)
+ (let ((instance (funcall ctor)))
+ ;; First we clobber the compiler's layout for the superclass.
+ (compile-file-assert path3)
+ ;; Then we recompile the subclass definition (which generates a
+ ;; warning about the compiled layout for the superclass being
+ ;; incompatible with the loaded layout, because we haven't loaded
+ ;; path3 since recompiling).
+ (compile-file path2)
+ ;; Ugh. I don't want to think about loading these in the wrong
+ ;; order.
+ (load (compile-file-pathname path3))
+ (load (compile-file-pathname path2))
+ (assert-invalid pred1 instance)
+ (assert-invalid pred2 instance)))
+
+(with-defstruct-redefinition-test
+ 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))
+ ((defstruct*) :class-name redef-test-11 :slots (a b)))
+ ((path1 defstruct)
+ (path2 substruct)
+ (path3 defstruct*))
+ continue-from-incompatible-defstruct-error
+ (load path1)
+ (load path2)
+ (let ((instance (funcall ctor)))
+ ;; This clobbers the compiler's layout for REDEF-TEST-11.
+ (compile-file-assert path3)
+ ;; This recompiles REDEF-TEST-11-SUB, using the new REDEF-TEST-11
+ ;; compiler-layout.
+ (load (compile-file-pathname path2))
+ ;; Note that because we haven't loaded PATH3, we haven't clobbered
+ ;; the class's layout REDEF-TEST-11, so REDEF-11's predicate will
+ ;; still work. That's probably bad.
+ (assert-is pred1 instance)
+ (assert-is pred2 instance)))
+
+(with-test (:name :raw-slot/circle-subst)
+ ;; CIRCLE-SUBSTS used %INSTANCE-REF on raw slots
+ (multiple-value-bind (list n)
+ (eval '(progn
+ (defstruct raw-slot/circle-subst
+ (x 0.0 :type single-float))
+ (read-from-string "((#1=#S(raw-slot/circle-subst :x 2.7158911)))")))
+ (destructuring-bind ((struct)) list
+ (assert (raw-slot/circle-subst-p struct))
+ (assert (eql 2.7158911 (raw-slot/circle-subst-x struct)))
+ (assert (eql 45 n)))))
+
+(defstruct (bug-3b (:constructor make-bug-3b (&aux slot)))
+ (slot nil :type string))
+
+(with-test (:name :bug-3b)
+ (handler-case
+ (progn
+ (bug-3b-slot (make-bug-3b))
+ (error "fail"))
+ (type-error (e)
+ (assert (eq 'string (type-error-expected-type e)))
+ (assert (zerop (type-error-datum e))))))
+
+(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")))))
+
+(with-test (:name :bug-528807)
+ (let ((*evaluator-mode* :compile))
+ (handler-bind ((style-warning #'error))
+ (eval `(defstruct (bug-528807 (:constructor make-528807 (&aux x)))
+ (x nil :type fixnum))))))
+
+(with-test (:name :bug-520607)
+ (assert
+ (raises-error?
+ (eval '(defstruct (typed-struct (:type list) (:predicate typed-struct-p))
+ (a 42 :type fixnum)))))
+ ;; NIL is ok, though.
+ (eval '(defstruct (typed-struct (:type list) (:predicate nil))
+ (a 42 :type fixnum)))
+ ;; 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)))))