;;;; more information.
(load "assertoid.lisp")
+(load "compiler-test-util.lisp")
(use-package "ASSERTOID")
\f
;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
*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
;;; 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)))
\f
;;; 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))
(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))
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)
(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.
\f
;;; 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)
(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)
;; 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)
;; 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)
;; 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)
;; 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))
(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))
(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))
;; 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))
;; 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))
(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))
(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")))))
(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)))))
projects / sbcl.git / blobdiff