X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=f1b06b56ab9ae5617037c2a2b3c4912e6e3d5ee7;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=e1952867fd02118dd86b37529ea290084304f18d;hpb=8922e16df316133288d46695ff2d7596c397a6a0;p=sbcl.git

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index e195286..f1b06b5 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -25,16 +25,17 @@
 
 ;;; An &AUX variable in a boa-constructor without a default value
 ;;; means "do not initialize slot" and does not cause type error
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+
 (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))
-  #+nil ; bug 235a
   (locally (declare (optimize (safety 3))
                     (inline boa-saux-a))
-    (assert (raises-error? (identity (boa-saux-a s)) type-error)))
+    (assert (raises-error? (opaque-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))
@@ -43,10 +44,19 @@
                                         ; 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)))
+    (assert (eql (opaque-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)))
+  (locally (declare (optimize (safety 3))
+                    (notinline boa-saux-a))
+    (assert (raises-error? (opaque-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))
@@ -475,6 +485,93 @@
 (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)))
+
+;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
+;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
+;;; test suite.
+(defstruct (bug-332a (:type list) (:initial-offset 5) :named))
+(defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a)))
+(assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail))))
+(assert (not (bug-332b-p 873257)))
+(assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a))))
+(assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
+
+;;; Similar test for vectors, just for good measure.
+(defstruct (bug-332a-aux (:type vector) 
+			 (:initial-offset 5) :named))
+(defstruct (bug-332b-aux (:type vector) 
+			 (:initial-offset 2) :named 
+			 (:include bug-332a-aux)))
+(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
+(assert (not (bug-332b-aux-p 873257)))
+(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
+(assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux)))
+
+;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
+;;; slot accessors signalled a condition at macroexpansion time, not
+;;; when the code was actually compiled or loaded.
+(let ((defstruct-form '(defstruct bug-in-0-8-11-8 x)))
+  (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
+  (handler-case (macroexpand defstruct-form)
+    (warning (c)
+      (error "shouldn't warn just from macroexpansion here"))))
+
+;;; bug 318 symptom no 1. (rest not fixed yet)
+(catch :ok
+  (handler-bind ((error (lambda (c)
+                          ;; Used to cause stack-exhaustion
+                          (unless (typep c 'storege-condition)
+                            (throw :ok)))))
+    (eval '(progn
+            (defstruct foo a)
+            (setf (find-class 'foo) nil)
+            (defstruct foo slot-1)))))
+
+;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
+;;; Melis.
+(defstruct bug-348 x)
+
+(assert (eql -1 (let ((i (eval '-2))
+                      (x (make-bug-348)))
+                  (funcall #'(setf bug-348-x)
+                           (incf i)
+                           (aref (vector x) (incf i)))
+                  (bug-348-x x))))
 
 ;;; success
 (format t "~&/returning success~%")