X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=029babdc875ef26a2c7b564616d5f14947740cd8;hb=17794352c2ef078a1fc3cdd306f17f7328edf40b;hp=b895b22e8e2c541f3484c36161f787cb86ee26b4;hpb=0957d59ccfaf3db9aaf79a7f4909a40ea0ca0dcd;p=sbcl.git

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index b895b22..029babd 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -23,6 +23,46 @@
 (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
+(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)))
+  (declare (notinline identity))
+  (locally (declare (optimize (safety 3))
+                    (inline boa-saux-a))
+    (assert (raises-error? (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)))
+  (declare (notinline identity))
+  (locally (declare (optimize (safety 0))
+                    (inline boa-saux-a))
+    (assert (eql (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)))
+  (declare (notinline identity))
+  (locally (declare (optimize (safety 3))
+                    (notinline boa-saux-a))
+    (assert (raises-error? (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-))
@@ -40,7 +80,7 @@
 
 ;;; 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)
@@ -420,6 +460,66 @@
 (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))
+
+;;; 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 #())))
+
+;;; 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)))
 
 ;;; success
 (format t "~&/returning success~%")