;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(cl:in-package :cl-user)
-
(load "assertoid.lisp")
+(use-package "ASSERTOID")
\f
;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
(defstruct person age (name 007 :type string)) ; not an error until 007 used
(make-person :name "James") ; not an error, 007 not used
(assert (raises-error? (make-person) type-error))
-;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62
-#+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error))
+(assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
+ type-error))
;;; basic inheritance
(defstruct (astronaut (:include person)
;;; 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
+;;;;
+;;;; The offsets of raw slots need to be rescaled during the punning
+;;;; process which is used to access them. That seems like a good
+;;;; place for errors to lurk, so we'll try hunting for them by
+;;;; verifying that all the raw slot data gets written successfully
+;;;; into the object, can be copied with the object, and can then be
+;;;; read back out (with none of it ending up bogusly outside the
+;;;; object, so that it couldn't be copied, or bogusly overwriting
+;;;; some other raw slot).
+
+(defstruct manyraw
+ (a (expt 2 30) :type (unsigned-byte 32))
+ (b 0.1 :type single-float)
+ (c 0.2d0 :type double-float)
+ (d #c(0.3 0.3) :type (complex single-float))
+ unraw-slot-just-for-variety
+ (e #c(0.4d0 0.4d0) :type (complex double-float))
+ (aa (expt 2 30) :type (unsigned-byte 32))
+ (bb 0.1 :type single-float)
+ (cc 0.2d0 :type double-float)
+ (dd #c(0.3 0.3) :type (complex single-float))
+ (ee #c(0.4d0 0.4d0) :type (complex double-float)))
+
+(defvar *manyraw* (make-manyraw))
+
+(assert (eql (manyraw-a *manyraw*) (expt 2 30)))
+(assert (eql (manyraw-b *manyraw*) 0.1))
+(assert (eql (manyraw-c *manyraw*) 0.2d0))
+(assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
+(assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
+(assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
+(assert (eql (manyraw-bb *manyraw*) 0.1))
+(assert (eql (manyraw-cc *manyraw*) 0.2d0))
+(assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
+(assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
+
+(setf (manyraw-aa *manyraw*) (expt 2 31)
+ (manyraw-bb *manyraw*) 0.11
+ (manyraw-cc *manyraw*) 0.22d0
+ (manyraw-dd *manyraw*) #c(0.33 0.33)
+ (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))
+
+;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
+;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
+;;; setting up compiler-layout information would run before the
+;;; constructor function installing the layout was compiled. Make sure
+;;; that doesn't happen again.
+(defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
+(assert (not (find-class 'foo-0-7-8-53 nil)))
+(foo-0-7-8-53)
+(assert (find-class 'foo-0-7-8-53 nil))
+(let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
+ (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
+ (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
+\f
+;;; tests of behaviour of colliding accessors.
+(defstruct (bug127-foo (:conc-name bug127-baz-)) a)
+(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
+(defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
+(assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
+(assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
+(assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
+
+(defun bug127-flurble (x)
+ x)
+(defstruct bug127 flurble)
+(assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
+
+(defstruct bug127-a b-c)
+(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
+(defstruct (bug127-a-b (:include bug127-a)) c)
+(assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
+(assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
+
+(defstruct (bug127-e (:conc-name bug127--)) foo)
+(assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
+(defstruct (bug127-f (:conc-name bug127--)) foo)
+(assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
+(assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
+
+;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
+\f
+;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
+;;; too fragile:
+(defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
+(assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
+ 'y))
+;;; and further :CONC-NAME NIL was being wrongly treated:
+(defpackage "DEFSTRUCT-TEST-SCRATCH")
+(defstruct (conc-name-nil :conc-name)
+ defstruct-test-scratch::conc-name-nil-slot)
+(assert (= (defstruct-test-scratch::conc-name-nil-slot
+ (make-conc-name-nil :conc-name-nil-slot 1)) 1))
+(assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
+ undefined-function))
\f
;;; success
(format t "~&/returning success~%")
projects / sbcl.git / blobdiff