X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=e27f5aeb2f6b5a340fa9c6d2b3867bc9835df8a4;hb=ed891a4fd882d1b9fe066ab14bcf2107aea95baa;hp=78923f3717f33f669d983a2e6c291ca6769fac2f;hpb=975f1932acc3a8e90fb31d2b055bfbdde78ea927;p=sbcl.git

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 78923f3..e27f5ae 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -129,6 +129,7 @@
 ;;; value-cells
 
 (defun-with-dx dx-value-cell (x)
+  (declare (optimize sb-c::stack-allocate-value-cells))
   ;; Not implemented everywhere, yet.
   #+(or x86 x86-64 mips)
   (let ((cell x))
@@ -146,6 +147,14 @@
     (true cons)
     nil))
 
+;;; MAKE-ARRAY
+
+(defun-with-dx make-array-on-stack ()
+  (let ((v (make-array '(42) :element-type 'single-float)))
+    (declare (dynamic-extent v))
+    (true v)
+    nil))
+
 ;;; Nested DX
 
 (defun-with-dx nested-dx-lists ()
@@ -160,6 +169,25 @@
     (true dx)
     nil))
 
+(defun-with-dx nested-dx-not-used (x)
+  (declare (list x))
+  (let ((l (setf (car x) (list x x x))))
+    (declare (dynamic-extent l))
+    (true l)
+    (true (length l))
+    nil))
+
+(defun-with-dx nested-evil-dx-used (x)
+  (declare (list x))
+  (let ((l (list x x x)))
+    (declare (dynamic-extent l))
+    (unwind-protect
+         (progn
+           (setf (car x) l)
+           (true l))
+      (setf (car x) nil))
+    nil))
+
 ;;; multiple uses for dx lvar
 
 (defun-with-dx multiple-dx-uses ()
@@ -196,6 +224,18 @@
       (funcall thunk))
     (assert (< (- (get-bytes-consed) before) times))))
 
+(defmacro assert-consing (form &optional times)
+  `(%assert-consing (lambda () ,form) ,times))
+(defun %assert-consing (thunk &optional times)
+  (let ((before (get-bytes-consed))
+        (times (or times 10000)))
+    (declare (type (integer 1 *) times))
+    (dotimes (i times)
+      (funcall thunk))
+    (assert (not (< (- (get-bytes-consed) before) times)))))
+
+(defvar *a-cons* (cons nil nil))
+
 #+(or x86 x86-64 alpha ppc sparc mips)
 (progn
   (assert-no-consing (dxclosure 42))
@@ -209,8 +249,11 @@
   (assert-no-consing (test-lvar-subst 11))
   (assert-no-consing (dx-value-cell 13))
   (assert-no-consing (cons-on-stack 42))
+  (assert-no-consing (make-array-on-stack))
   (assert-no-consing (nested-dx-conses))
   (assert-no-consing (nested-dx-lists))
+  (assert-consing (nested-dx-not-used *a-cons*))
+  (assert-no-consing (nested-evil-dx-used *a-cons*))
   (assert-no-consing (multiple-dx-uses))
   ;; Not strictly DX..
   (assert-no-consing (test-hash-table))
@@ -256,6 +299,31 @@
   (let ((a (make-array 11 :initial-element 0)))
     (declare (dynamic-extent a))
     (assert (every (lambda (x) (eql x 0)) a))))
-(bdowning-2005-iv-16)
-
+(assert-no-consing (bdowning-2005-iv-16))
+
+
+(defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
+  (let* ((a (list x y z))
+         (b (list x y z))
+         (c (list a b)))
+    (declare (dynamic-extent c))
+    (values (first c) (second c))))
+(multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
+  (assert (and (equal i j)
+               (equal i (list 1 2 3)))))
+
+;;; workaround for bug 419 -- real issue remains, but check that the
+;;; bandaid holds.
+(defun-with-dx bug419 (x)
+  (multiple-value-call #'list
+    (eval '(values 1 2 3))
+    (let ((x x))
+      (declare (dynamic-extent x))
+      (flet ((mget (y)
+               (+ x y))
+             (mset (z)
+               (incf x z)))
+        (declare (dynamic-extent #'mget #'mset))
+        ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
+(assert (equal (bug419 42) '(1 2 3 4 5 6)))