0.8.11.19:

[sbcl.git] / tests / defstruct.impure.lisp

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 029babd..a23302f 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -25,15 +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))
   (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))
@@ -42,10 +44,9 @@
                                         ; 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))
@@ -53,10 +54,9 @@
   (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)))
+    (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))
@@ -521,6 +521,36 @@
   (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"))))
+
 ;;; success
 (format t "~&/returning success~%")
 (quit :unix-status 104)