X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=6102a1494ab06788e8aa719820cc222a0e27ab24;hb=2253ebaef8a0a1527d2282a1c10f48c62e0d4a83;hp=23f9bc7553cc33440a32effff305f5ef82a7281e;hpb=f409f90c5e8c4c87ed9fa6efdc0e5c1952d94602;p=sbcl.git

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 23f9bc7..6102a14 100644
--- 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))
@@ -349,13 +349,13 @@
 ;;;; some other raw slot).
 
 (defstruct manyraw
-  (a (expt 2 30) :type (unsigned-byte 32))
+  (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
   (b 0.1 :type single-float)
   (c 0.2d0 :type double-float)
   (d #c(0.3 0.3) :type (complex single-float))
   unraw-slot-just-for-variety
   (e #c(0.4d0 0.4d0) :type (complex double-float))
-  (aa (expt 2 30) :type (unsigned-byte 32))
+  (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
   (bb 0.1 :type single-float)
   (cc 0.2d0 :type double-float)
   (dd #c(0.3 0.3) :type (complex single-float))
@@ -391,6 +391,94 @@
   (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))))
+
+
+;;;; Since GC treats raw slots specially now, let's try this with more objects
+;;;; and random values as a stress test.
+
+(setf *manyraw* nil)
+
+(defconstant +n-manyraw+ 10)
+(defconstant +m-manyraw+ 1000)
+
+(defun check-manyraws (manyraws)
+  (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
+  (loop
+      for m in (reverse manyraws)
+      for i from 0
+      do
+	;; Compare the tagged reference values with raw reffer results.
+	(destructuring-bind (j a b c d e)
+	    (manyraw-unraw-slot-just-for-variety m)
+	  (assert (eql i j))
+	  (assert (= (manyraw-a m) a))
+	  (assert (= (manyraw-b m) b))
+	  (assert (= (manyraw-c m) c))
+	  (assert (= (manyraw-d m) d))
+	  (assert (= (manyraw-e m) e)))
+	;; Test the funny out-of-line OAOOM-style closures, too.
+	(mapcar (lambda (fn value)
+		  (assert (= (funcall fn m) value)))
+		(list #'manyraw-a
+		      #'manyraw-b
+		      #'manyraw-c
+		      #'manyraw-d
+		      #'manyraw-e)
+		(cdr (manyraw-unraw-slot-just-for-variety m)))))
+
+(defstruct (manyraw-subclass (:include manyraw))
+  (stolperstein 0 :type (unsigned-byte 32)))
+
+;;; create lots of manyraw objects, triggering GC every now and then
+(dotimes (y +n-manyraw+)
+  (dotimes (x +m-manyraw+)
+    (let ((a (random (expt 2 32)))
+	  (b (random most-positive-single-float))
+	  (c (random most-positive-double-float))
+	  (d (complex
+	      (random most-positive-single-float)
+	      (random most-positive-single-float)))
+	  (e (complex
+	      (random most-positive-double-float)
+	      (random most-positive-double-float))))
+      (push (funcall (if (zerop (mod x 3))
+			 #'make-manyraw-subclass
+			 #'make-manyraw)
+		     :unraw-slot-just-for-variety
+		     (list (+ x (* y +m-manyraw+)) a b c d e)
+		     :a a
+		     :b b
+		     :c c
+		     :d d
+		     :e e)
+	    *manyraw*)))
+  (room)
+  (sb-ext:gc))
+(check-manyraws *manyraw*)
+
+;;; try a full GC, too
+(sb-ext:gc :full t)
+(check-manyraws *manyraw*)
+
+;;; fasl dumper and loader also have special handling of raw slots, so
+;;; dump all of them into a fasl
+(defmethod make-load-form ((self manyraw) &optional env)
+  self env
+  :sb-just-dump-it-normally)
+(with-open-file (s "tmp-defstruct.manyraw.lisp"
+		 :direction :output
+		 :if-exists :supersede)
+  (write-string "(defun dumped-manyraws () '#.*manyraw*)" s))
+(compile-file "tmp-defstruct.manyraw.lisp")
+
+;;; nuke the objects and try another GC just to be extra careful
+(setf *manyraw* nil)
+(sb-ext:gc :full t)
+
+;;; re-read the dumped structures and check them
+(load "tmp-defstruct.manyraw.fasl")
+(check-manyraws (dumped-manyraws))
+
 
 ;;;; miscellaneous old bugs
 
@@ -514,6 +602,65 @@
   (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~%")
 (quit :unix-status 104)