(check-manyraws *manyraw*))
;;; fasl dumper and loader also have special handling of raw slots, so
(check-manyraws *manyraw*))
;;; fasl dumper and loader also have special handling of raw slots, so
;;; of the same class. (Putting this FIXME here, since this is the only
;;; place where they appear together.)
;;; of the same class. (Putting this FIXME here, since this is the only
;;; place where they appear together.)
(eval '(defstruct born-to-change))
(let ((x (make-born-to-change)))
(handler-bind ((error 'continue))
(eval '(defstruct born-to-change))
(let ((x (make-born-to-change)))
(handler-bind ((error 'continue))
(eval '(defstruct born-to-change-2))
(let ((x (make-born-to-change-2)))
(handler-bind ((error 'continue))
(eval '(defstruct born-to-change-2))
(let ((x (make-born-to-change-2)))
(handler-bind ((error 'continue))
(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)
(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)
(((defstruct ctor pred) :class-name redef-test-1 :slots (a))
((defstruct*) :class-name redef-test-1 :slots (a b)))
((path1 defstruct)
(((defstruct ctor pred) :class-name redef-test-1 :slots (a))
((defstruct*) :class-name redef-test-1 :slots (a b)))
((path1 defstruct)
(assert-is pred instance)))
;; Base case: continue (i.e., invalidate instances).
(assert-is pred instance)))
;; Base case: continue (i.e., invalidate instances).
(((defstruct ctor pred) :class-name redef-test-2 :slots (a))
((defstruct*) :class-name redef-test-2 :slots (a b)))
((path1 defstruct)
(((defstruct ctor pred) :class-name redef-test-2 :slots (a))
((defstruct*) :class-name redef-test-2 :slots (a b)))
((path1 defstruct)
;; Compiling a file with an incompatible defstruct should emit a
;; warning and an error, but the fasl should be loadable.
;; Compiling a file with an incompatible defstruct should emit a
;; warning and an error, but the fasl should be loadable.
(((defstruct) :class-name redef-test-3 :slots (a))
((defstruct*) :class-name redef-test-3 :slots (a b)))
((path1 defstruct)
(((defstruct) :class-name redef-test-3 :slots (a))
((defstruct*) :class-name redef-test-3 :slots (a b)))
((path1 defstruct)
;; After compiling a file with an incompatible DEFSTRUCT, load the
;; fasl and ensure that an old instance remains valid.
;; After compiling a file with an incompatible DEFSTRUCT, load the
;; fasl and ensure that an old instance remains valid.
(((defstruct ctor pred) :class-name redef-test-4 :slots (a))
((defstruct*) :class-name redef-test-4 :slots (a b)))
((path1 defstruct)
(((defstruct ctor pred) :class-name redef-test-4 :slots (a))
((defstruct*) :class-name redef-test-4 :slots (a b)))
((path1 defstruct)
;; After compiling a file with an incompatible DEFSTRUCT, load the
;; fasl and ensure that an old instance has become invalid.
;; After compiling a file with an incompatible DEFSTRUCT, load the
;; fasl and ensure that an old instance has become invalid.
(((defstruct ctor pred) :class-name redef-test-5 :slots (a))
((defstruct*) :class-name redef-test-5 :slots (a b)))
((path1 defstruct)
(((defstruct ctor pred) :class-name redef-test-5 :slots (a))
((defstruct*) :class-name redef-test-5 :slots (a b)))
((path1 defstruct)
;; 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.)
;; 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.)
(((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 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-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))
((substruct ctor pred) :class-name redef-test-7-sub
:super-name redef-test-7 :slots (z))
(assert-invalid pred instance)))
;; Reclkessly continuing doesn't invalidate instances of subclasses.
(assert-invalid pred instance)))
;; Reclkessly continuing doesn't invalidate instances of subclasses.
(((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 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))
;; 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.
;; 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.
(((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 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))
;; 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
;; 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 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 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 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 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))
(assert (not (raises-error? (copy-person (make-astronaut :name "Neil")))))
(assert (raises-error? (copy-astronaut (make-person :name "Fred")))))
(assert (not (raises-error? (copy-person (make-astronaut :name "Neil")))))
(assert (raises-error? (copy-astronaut (make-person :name "Fred")))))