;;;; 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))
-(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
;;; 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)))
\f
;;;; miscellaneous old bugs
;;; 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)
+(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)
\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")))))
(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)))))