(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
type-error))
+;;; An &AUX variable in a boa-constructor without a default value
+;;; means "do not initialize slot" and does not cause type error
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+
+(defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
+ (a #\! :type (integer 1 2))
+ (b #\? :type (integer 3 4))
+ (c #\# :type (integer 5 6)))
+(let ((s (make-boa-saux)))
+ (locally (declare (optimize (safety 3))
+ (inline boa-saux-a))
+ (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
+ (setf (boa-saux-a s) 1)
+ (setf (boa-saux-c s) 5)
+ (assert (eql (boa-saux-a s) 1))
+ (assert (eql (boa-saux-b s) 3))
+ (assert (eql (boa-saux-c s) 5)))
+ ; these two checks should be
+ ; kept separated
+(let ((s (make-boa-saux)))
+ (locally (declare (optimize (safety 0))
+ (inline boa-saux-a))
+ (assert (eql (opaque-identity (boa-saux-a s)) 0)))
+ (setf (boa-saux-a s) 1)
+ (setf (boa-saux-c s) 5)
+ (assert (eql (boa-saux-a s) 1))
+ (assert (eql (boa-saux-b s) 3))
+ (assert (eql (boa-saux-c s) 5)))
+
+(let ((s (make-boa-saux)))
+ (locally (declare (optimize (safety 3))
+ (notinline boa-saux-a))
+ (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
+ (setf (boa-saux-a s) 1)
+ (setf (boa-saux-c s) 5)
+ (assert (eql (boa-saux-a s) 1))
+ (assert (eql (boa-saux-b s) 3))
+ (assert (eql (boa-saux-c s) 5)))
+
;;; basic inheritance
(defstruct (astronaut (:include person)
(:conc-name astro-))
;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
(defstruct (binop (:type list) :named (:initial-offset 2))
- (operator '? :type symbol)
+ (operator '? :type symbol)
operand-1
operand-2)
(defstruct (annotated-binop (:type list)
(assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
undefined-function))
\f
+;;; The named/typed predicates were a little fragile, in that they
+;;; could throw errors on innocuous input:
+(defstruct (list-struct (:type list) :named) a-slot)
+(assert (list-struct-p (make-list-struct)))
+(assert (not (list-struct-p nil)))
+(assert (not (list-struct-p 1)))
+(defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot)
+(assert (offset-list-struct-p (make-offset-list-struct)))
+(assert (not (offset-list-struct-p nil)))
+(assert (not (offset-list-struct-p 1)))
+(assert (not (offset-list-struct-p '(offset-list-struct))))
+(assert (not (offset-list-struct-p '(offset-list-struct . 3))))
+(defstruct (vector-struct (:type vector) :named) a-slot)
+(assert (vector-struct-p (make-vector-struct)))
+(assert (not (vector-struct-p nil)))
+(assert (not (vector-struct-p #())))
+\f
+;;; bug 3d: type safety with redefined type constraints on slots
+(macrolet
+ ((test (type)
+ (let* ((base-name (intern (format nil "bug3d-~A" type)))
+ (up-name (intern (format nil "~A-up" base-name)))
+ (accessor (intern (format nil "~A-X" base-name)))
+ (up-accessor (intern (format nil "~A-X" up-name)))
+ (type-options (when type `((:type ,type)))))
+ `(progn
+ (defstruct (,base-name ,@type-options)
+ x y)
+ (defstruct (,up-name (:include ,base-name
+ (x "x" :type simple-string)
+ (y "y" :type simple-string))
+ ,@type-options))
+ (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
+ (setf (,accessor ob) 0)
+ (loop for decl in '(inline notinline)
+ for fun = `(lambda (s)
+ (declare (optimize (safety 3))
+ (,decl ,',up-accessor))
+ (,',up-accessor s))
+ do (assert (raises-error? (funcall (compile nil fun) ob)
+ type-error))))))))
+ (test nil)
+ (test list)
+ (test vector))
+
+(let* ((name (gensym))
+ (form `(defstruct ,name
+ (x nil :type (or null (function (integer)
+ (values number &optional foo)))))))
+ (eval (copy-tree form))
+ (eval (copy-tree form)))
+
+;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
+;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
+;;; test suite.
+(defstruct (bug-332a (:type list) (:initial-offset 5) :named))
+(defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a)))
+(assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail))))
+(assert (not (bug-332b-p 873257)))
+(assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a))))
+(assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
+
+;;; Similar test for vectors, just for good measure.
+(defstruct (bug-332a-aux (:type vector)
+ (:initial-offset 5) :named))
+(defstruct (bug-332b-aux (:type vector)
+ (:initial-offset 2) :named
+ (:include bug-332a-aux)))
+(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
+(assert (not (bug-332b-aux-p 873257)))
+(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
+(assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux)))
+
+;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
+;;; slot accessors signalled a condition at macroexpansion time, not
+;;; when the code was actually compiled or loaded.
+(let ((defstruct-form '(defstruct bug-in-0-8-11-8 x)))
+ (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
+ (handler-case (macroexpand defstruct-form)
+ (warning (c)
+ (error "shouldn't warn just from macroexpansion here"))))
+
+;;; bug 318 symptom no 1. (rest not fixed yet)
+(catch :ok
+ (handler-bind ((error (lambda (c)
+ ;; Used to cause stack-exhaustion
+ (unless (typep c 'storege-condition)
+ (throw :ok)))))
+ (eval '(progn
+ (defstruct foo a)
+ (setf (find-class 'foo) nil)
+ (defstruct foo slot-1)))))
+
+;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
+;;; Melis.
+(defstruct bug-348 x)
+
+(assert (eql -1 (let ((i (eval '-2))
+ (x (make-bug-348)))
+ (funcall #'(setf bug-348-x)
+ (incf i)
+ (aref (vector x) (incf i)))
+ (bug-348-x x))))
+
;;; success
(format t "~&/returning success~%")
(quit :unix-status 104)
projects / sbcl.git / blobdiff