1.0.29.1: fix FILL

[sbcl.git] / tests / dynamic-extent.impure.lisp

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 99d925a..0d1992d 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -147,15 +147,51 @@
 
 ;;; MAKE-ARRAY
 
-(defun-with-dx make-array-on-stack ()
+(defun force-make-array-on-stack (n)
+  (declare (optimize safety))
+  (let ((v (make-array (min n 1))))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true v)
+    nil))
+
+(defun-with-dx make-array-on-stack-1 ()
   (let ((v (make-array '(42) :element-type 'single-float)))
     (declare (dynamic-extent v))
     (true v)
     nil))
 
-(defun force-make-array-on-stack (n)
-  (declare (optimize safety))
-  (let ((v (make-array (min n 1))))
+(defun-with-dx make-array-on-stack-2 (n x)
+  (declare (integer n))
+  (let ((v (make-array n :initial-contents x)))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true v)
+    nil))
+
+(defun-with-dx make-array-on-stack-3 (x y z)
+  (let ((v (make-array 3
+                       :element-type 'fixnum :initial-contents (list x y z)
+                       :element-type t :initial-contents x)))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true v)
+    nil))
+
+(defun-with-dx make-array-on-stack-4 ()
+  (let ((v (make-array 3 :initial-contents '(1 2 3))))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true v)
+    nil))
+
+;;; Unfortunately VECTOR-FILL* conses right now, so this one
+;;; doesn't pass yet.
+#+nil
+(defun-with-dx make-array-on-stack-5 ()
+  (let ((v (make-array 3 :initial-element 12 :element-type t)))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true v)
+    nil))
+
+(defun-with-dx vector-on-stack (x y)
+  (let ((v (vector 1 x 2 y 3)))
     (declare (sb-int:truly-dynamic-extent v))
     (true v)
     nil))
@@ -482,24 +518,36 @@
   (assert-no-consing (test-let-var-subst2 17))
   (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 (force-make-array-on-stack 128))
-  (assert-no-consing (make-foo1-on-stack 123))
-  (assert-no-consing (nested-good 42))
+  ;; Only for platforms with DX FIXED-ALLOC
+  #+(or hppa mips x86 x86-64)
+  (progn
+    (assert-no-consing (cons-on-stack 42))
+    (assert-no-consing (make-foo1-on-stack 123))
+    (assert-no-consing (nested-good 42))
+    (assert-no-consing (nested-dx-conses))
+    (assert-no-consing (dx-handler-bind 2))
+    (assert-no-consing (dx-handler-case 2)))
+  ;; Only for platforms with DX ALLOCATE-VECTOR
+  #+(or hppa mips x86 x86-64)
+  (progn
+    (assert-no-consing (force-make-array-on-stack 128))
+    (assert-no-consing (make-array-on-stack-1))
+    (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
+    (assert-no-consing (make-array-on-stack-3 9 8 7))
+    (assert-no-consing (make-array-on-stack-4))
+    #+nil
+    (assert-no-consing (make-array-on-stack-5))
+    (assert-no-consing (vector-on-stack :x :y)))
   (#+raw-instance-init-vops assert-no-consing
    #-raw-instance-init-vops progn
    (make-foo2-on-stack 1.24 1.23d0))
   (#+raw-instance-init-vops assert-no-consing
    #-raw-instance-init-vops progn
    (make-foo3-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))
-  (assert-no-consing (dx-handler-bind 2))
-  (assert-no-consing (dx-handler-case 2))
   ;; Not strictly DX..
   (assert-no-consing (test-hash-table))
   #+sb-thread
@@ -546,7 +594,10 @@
   (let ((a (make-array 11 :initial-element 0)))
     (declare (dynamic-extent a))
     (assert (every (lambda (x) (eql x 0)) a))))
-(assert-no-consing (bdowning-2005-iv-16))
+(with-test (:name :bdowning-2005-iv-16)
+  #+(or hppa mips x86 x86-64)
+  (assert-no-consing (bdowning-2005-iv-16))
+  (bdowning-2005-iv-16))
 
 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
   (let* ((a (list x y z))
@@ -584,7 +635,9 @@
       (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
         (assert (equalp f2 y))
         (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
-  (assert-no-consing (assert (eql n (funcall fun nil)))))
+  #+(or hppa mips x86 x86-64)
+  (assert-no-consing (assert (eql n (funcall fun nil))))
+  (assert (eql n (funcall fun nil))))
 (macrolet ((def (n f1 f2 f3)
              (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
                `(progn