;;; somewhat bogus, but the requirement is clear.)
(defstruct person age (name 007 :type string)) ; not an error until 007 used
(make-person :name "James") ; not an error, 007 not used
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(assert (raises-error? (make-person) type-error))
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
type-error))
(assert (eql (boa-saux-c s) 5)))
; these two checks should be
; kept separated
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(let ((s (make-boa-saux)))
(locally (declare (optimize (safety 0))
(inline boa-saux-a))
;;; debugger is having a bad day
(defvar *instance*)
+(declaim (optimize (debug 2)))
+
(defmacro test-variant (defstructname &key colontype boa-constructor-p)
`(progn
(assert (not (vector-struct-p nil)))
(assert (not (vector-struct-p #())))
\f
+
;;; bug 3d: type safety with redefined type constraints on slots
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
(macrolet
((test (type)
(let* ((base-name (intern (format nil "bug3d-~A" type)))
(catch :ok
(handler-bind ((error (lambda (c)
;; Used to cause stack-exhaustion
- (unless (typep c 'storege-condition)
- (throw :ok)))))
+ (unless (typep c 'storage-condition)
+ (throw :ok t)))))
(eval '(progn
(defstruct foo a)
(setf (find-class 'foo) nil)
(aref (vector x) (incf i)))
(bug-348-x x))))
-;;; success
-(format t "~&/returning success~%")
-(quit :unix-status 104)
+;;; obsolete instance trapping
+;;;
+;;; FIXME: Both error conditions below should possibly be instances
+;;; 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)
+ (eval '(defstruct born-to-change))
+ (let ((x (make-born-to-change)))
+ (handler-bind ((error 'continue))
+ (eval '(defstruct born-to-change slot)))
+ (assert (eq :error
+ (handler-case
+ (princ-to-string x)
+ (sb-pcl::obsolete-structure ()
+ :error))))))
+
+(with-test (:name obsolete-defstruct/typep)
+ (eval '(defstruct born-to-change-2))
+ (let ((x (make-born-to-change-2)))
+ (handler-bind ((error 'continue))
+ (eval '(defstruct born-to-change-2 slot)))
+ (assert (eq :error2
+ (handler-case
+ (typep x (find-class 'standard-class))
+ (sb-kernel:layout-invalid ()
+ :error2))))))
+
+;; EQUALP didn't work for structures with float slots (reported by
+;; Vjacheslav Fyodorov).
+(defstruct raw-slot-equalp-bug
+ (b 0s0 :type single-float)
+ c
+ (a 0d0 :type double-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)
+ (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)))))
+
+;;; Check that all slot types (non-raw and raw) can be initialized with
+;;; constant arguments.
+(defstruct constant-arg-inits
+ (a 42 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float)
+ (f #c(5.0 5.0) :type (complex single-float))
+ (g #c(6.0d0 6.0d0) :type (complex double-float)))
+(defun test-constant-arg-inits ()
+ (let ((foo (make-constant-arg-inits)))
+ (declare (dynamic-extent foo))
+ (assert (eql 42 (constant-arg-inits-a foo)))
+ (assert (eql 1 (constant-arg-inits-b foo)))
+ (assert (eql 2 (constant-arg-inits-c foo)))
+ (assert (eql 3.0 (constant-arg-inits-d foo)))
+ (assert (eql 4.0d0 (constant-arg-inits-e foo)))
+ (assert (eql #c(5.0 5.0) (constant-arg-inits-f foo)))
+ (assert (eql #c(6.0d0 6.0d0) (constant-arg-inits-g foo)))))
+(make-constant-arg-inits)