X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=7867bae61a559b3a7097ea23d0757602adb2b59a;hb=2ff0ff83dacac9fb25a31f5783b6ea8c0442bc2c;hp=685ff6d5b926fe814b928ab78adff92f46b0028b;hpb=6822034325136cde4e14773c83c3769b42721306;p=sbcl.git

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 685ff6d..7867bae 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -129,7 +129,7 @@
 
 (defun-with-dx dx-value-cell (x)
   ;; Not implemented everywhere, yet.
-  #+(or x86 x86-64 mips)
+  #+(or x86 x86-64 mips hppa)
   (let ((cell x))
     (declare (sb-int:truly-dynamic-extent cell))
     (flet ((f ()
@@ -370,6 +370,29 @@
       (setf (car x) nil))
     nil))
 
+(defparameter *bar* nil)
+(declaim (inline make-nested-bad make-nested-good))
+(defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
+                   (:constructor make-nested-good (&key bar)))
+  bar)
+
+(defun-with-dx nested-good (y)
+  (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
+    (declare (dynamic-extent x))
+    (true x)))
+
+(defun-with-dx nested-bad (y)
+  (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
+    (declare (dynamic-extent x))
+    (unless (equalp (caar x) (make-nested-good :bar *bar*))
+      (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
+    (caar x)))
+
+(with-test (:name :conservative-nested-dx)
+  ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
+  (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
+  (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
+
 ;;; multiple uses for dx lvar
 
 (defun-with-dx multiple-dx-uses ()
@@ -440,7 +463,7 @@
 
 (defvar *a-cons* (cons nil nil))
 
-#+(or x86 x86-64 alpha ppc sparc mips)
+#+(or x86 x86-64 alpha ppc sparc mips hppa)
 (progn
   (assert-no-consing (dxclosure 42))
   (assert-no-consing (dxlength 1 2 3))
@@ -455,6 +478,7 @@
   (assert-no-consing (cons-on-stack 42))
   (assert-no-consing (make-array-on-stack))
   (assert-no-consing (make-foo1-on-stack 123))
+  (assert-no-consing (nested-good 42))
   (#+raw-instance-init-vops assert-no-consing
    #-raw-instance-init-vops progn
    (make-foo2-on-stack 1.24 1.23d0))
@@ -516,16 +540,17 @@
     (assert (every (lambda (x) (eql x 0)) a))))
 (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)))))
+
+(with-test (:name :let-converted-vars-dx-allocated-bug)
+  (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.
@@ -587,4 +612,26 @@
                14)
          ))))
 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
+
+(with-test (:name :regression-1.0.23.38)
+  (compile nil '(lambda ()
+                 (flet ((make (x y)
+                          (let ((res (cons x x)))
+                            (setf (cdr res) y)
+                            res)))
+                   (declaim (inline make))
+                   (let ((z (make 1 2)))
+                     (declare (dynamic-extent z))
+                     (print z)
+                     t))))
+  (compile nil '(lambda ()
+                 (flet ((make (x y)
+                          (let ((res (cons x x)))
+                            (setf (cdr res) y)
+                            (if x res y))))
+                   (declaim (inline make))
+                   (let ((z (make 1 2)))
+                     (declare (dynamic-extent z))
+                     (print z)
+                     t)))))