;;; debugger is having a bad day
(defvar *instance*)
-(defmacro test-variant (defstructname &key colontype)
+(defmacro test-variant (defstructname &key colontype boa-constructor-p)
`(progn
(format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
(defstruct (,defstructname
- ,@(when colontype `((:type ,colontype))))
+ ,@(when colontype `((:type ,colontype)))
+ ,@(when boa-constructor-p
+ `((:constructor ,(symbol+ "CREATE-" defstructname)
+ (id
+ &optional
+ (optional-test 2 optional-test-p)
+ &key
+ (home nil home-p)
+ (no-home-comment "Home package CL not provided.")
+ (comment (if home-p "" no-home-comment))
+ (refcount (if optional-test-p optional-test nil))
+ hash
+ weight)))))
+
;; some ordinary tagged slots
id
(home nil :type package :read-only t)
(format t "~&/done with DEFSTRUCT~%")
(let* ((cn (string+ ',defstructname "-")) ; conc-name
- (ctor (symbol-function (symbol+ "MAKE-" ',defstructname)))
+ (ctor (symbol-function ',(symbol+ (if boa-constructor-p
+ "CREATE-"
+ "MAKE-")
+ defstructname)))
(*instance* (funcall ctor
- :id "some id"
+ ,@(unless boa-constructor-p
+ `(:id)) "some id"
+ ,@(when boa-constructor-p
+ '(1))
:home (find-package :cl)
:hash (+ 14 most-positive-fixnum)
- :refcount 1)))
+ ,@(unless boa-constructor-p
+ `(:refcount 1)))))
;; Check that ctor set up slot values correctly.
(format t "~&/checking constructed structure~%")
(test-variant vanilla-struct)
(test-variant vector-struct :colontype vector)
(test-variant list-struct :colontype list)
+(test-variant vanilla-struct :boa-constructor-p t)
+(test-variant vector-struct :colontype vector :boa-constructor-p t)
+(test-variant list-struct :colontype list :boa-constructor-p t)
+
\f
;;;; testing raw slots harder
;;;;
(manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
(let ((copy (copy-manyraw *manyraw*)))
+ (assert (eql (manyraw-a copy) (expt 2 30)))
+ (assert (eql (manyraw-b copy) 0.1))
+ (assert (eql (manyraw-c copy) 0.2d0))
+ (assert (eql (manyraw-d copy) #c(0.3 0.3)))
+ (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
(assert (eql (manyraw-aa copy) (expt 2 31)))
(assert (eql (manyraw-bb copy) 0.11))
(assert (eql (manyraw-cc copy) 0.22d0))
(assert (eql (manyraw-dd copy) #c(0.33 0.33)))
(assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
\f
+;;;; miscellaneous old bugs
+
+(defstruct ya-struct)
+(when (ignore-errors (or (ya-struct-p) 12))
+ (error "YA-STRUCT-P of no arguments should signal an error."))
+(when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
+ (error "YA-STRUCT-P of three arguments should signal an error."))
+
+;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
+;;; declared inside on the theory that slot types were already
+;;; checked, which bogusly suppressed unbound-variable and other
+;;; checks within the evaluation of initforms.
+(defvar *bug210*)
+(defstruct (bug210a (:constructor bug210a ()))
+ (slot *bug210*))
+(defstruct bug210b
+ (slot *bug210*))
+;;; Because of bug 210, this assertion used to fail.
+(assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
+;;; Even with bug 210, these assertions succeeded.
+(assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
+(assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
+\f
;;; success
(format t "~&/returning success~%")
(quit :unix-status 104)