X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=0582be52043c7725074a3869176be0948097c000;hb=e76ddf242a31a2acaae3a9cb818fa31500ebbf92;hp=bca97caf466a543bf6294096543763c56328a857;hpb=063e696d6151fd6329677216646e872731e6a85d;p=sbcl.git

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index bca97ca..0582be5 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -9,9 +9,8 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-(cl:in-package :cl-user)
-
 (load "assertoid.lisp")
+(use-package "ASSERTOID")
 
 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
 
@@ -21,8 +20,8 @@
 (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)
@@ -360,6 +359,75 @@
   (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)))
+
+;;; 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
+
+;;; 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))
 
 ;;; success
 (format t "~&/returning success~%")