X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=c86fb9e7fc1111217d3736ccbe46187a4167ad32;hb=c3d4cd43d7cd8e0495dbb9c11fd9c121ea069a45;hp=e0995f30051157ba28608033bc3217d46aa34858;hpb=986ce2596822cc0871b609346aaf592348aca596;p=sbcl.git

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index e0995f3..c86fb9e 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -177,13 +177,26 @@
 ;;; 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)
@@ -197,12 +210,19 @@
      (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~%")
@@ -273,6 +293,10 @@
 (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)
+
 
 ;;;; testing raw slots harder
 ;;;;
@@ -318,12 +342,53 @@
       (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))))
 
+;;;; 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)))
+
 ;;; success
 (format t "~&/returning success~%")
 (quit :unix-status 104)