Rework test infrastructure to keep track of tests which are disabled

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

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 912b44e..76d2cf8 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -499,12 +499,10 @@
 
 (defvar *a-cons* (cons nil nil))
 
-#+stack-allocatable-closures
-(with-test (:name (:no-consing :dx-closures))
+(with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures))
   (assert-no-consing (dxclosure 42)))
 
-#+stack-allocatable-lists
-(with-test (:name (:no-consing :dx-lists))
+(with-test (:name (:no-consing :dx-lists) :skipped-on '(not :stack-allocatable-lists))
   (assert-no-consing (dxlength 1 2 3))
   (assert-no-consing (dxlength t t t t t t))
   (assert-no-consing (dxlength))
@@ -520,8 +518,7 @@
 (with-test (:name (:no-consing :dx-value-cell))
   (assert-no-consing (dx-value-cell 13)))
 
-#+stack-allocatable-fixed-objects
-(with-test (:name (:no-consing :dx-fixed-objects))
+(with-test (:name (:no-consing :dx-fixed-objects) :skipped-on '(not :stack-allocatable-fixed-objects))
   (assert-no-consing (cons-on-stack 42))
   (assert-no-consing (make-foo1-on-stack 123))
   (assert-no-consing (nested-good 42))
@@ -529,8 +526,7 @@
   (assert-no-consing (dx-handler-bind 2))
   (assert-no-consing (dx-handler-case 2)))
 
-#+stack-allocatable-vectors
-(with-test (:name (:no-consing :dx-vectors))
+(with-test (:name (:no-consing :dx-vectors) :skipped-on '(not :stack-allocatable-vectors))
   (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)))
@@ -539,8 +535,7 @@
   (assert-no-consing (make-array-on-stack-5))
   (assert-no-consing (vector-on-stack :x :y)))
 
-#+raw-instance-init-vops
-(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc)
+(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc :skipped-on '(not :raw-instance-init-vops))
   (let (a b)
     (setf a 1.24 b 1.23d0)
     (assert-no-consing (make-foo2-on-stack a b)))
@@ -574,12 +569,10 @@
   (sb-thread:with-mutex (*mutex*)
     (true *mutex*)))
 
-#+sb-thread
-(with-test (:name (:no-consing :mutex) :fails-on :ppc)
+(with-test (:name (:no-consing :mutex) :fails-on :ppc :skipped-on '(not :sb-thread))
   (assert-no-consing (test-mutex)))
 
-#+sb-thread
-(with-test (:name (:no-consing :spinlock) :fails-on :ppc)
+(with-test (:name (:no-consing :spinlock) :fails-on :ppc :skipped-on '(not :sb-thread))
   (assert-no-consing (test-spinlock)))
 
 \f
@@ -928,3 +921,75 @@
 (with-test (:name :rest-stops-dynamic-extent)
   (assert (rest-stops-dx-ok)))
 
+;;;; These tests aren't strictly speaking DX, but rather &REST -> &MORE
+;;;; conversion.
+(with-test (:name :rest-to-more-conversion)
+  (let ((f1 (compile nil `(lambda (f &rest args)
+                            (apply f args)))))
+    (assert-no-consing (assert (eql f1 (funcall f1 #'identity f1)))))
+  (let ((f2 (compile nil `(lambda (f1 f2 &rest args)
+                            (values (apply f1 args) (apply f2 args))))))
+    (assert-no-consing (multiple-value-bind (a b)
+                           (funcall f2 (lambda (x y z) (+ x y z)) (lambda (x y z) (- x y z))
+                                    1 2 3)
+                         (assert (and (eql 6 a) (eql -4 b))))))
+  (let ((f3 (compile nil `(lambda (f &optional x &rest args)
+                            (when x
+                              (apply f x args))))))
+    (assert-no-consing (assert (eql 42 (funcall f3
+                                                (lambda (a b c) (+ a b c))
+                                                11
+                                                10
+                                                21)))))
+  (let ((f4 (compile nil `(lambda (f &optional x &rest args &key y &allow-other-keys)
+                            (apply f y x args)))))
+    (assert-no-consing (funcall f4 (lambda (y x yk y2 b c)
+                                     (assert (eq y 'y))
+                                     (assert (= x 2))
+                                     (assert (eq :y yk))
+                                     (assert (eq y2 'y))
+                                     (assert (eq b 'b))
+                                     (assert (eq c 'c)))
+                                2 :y 'y 'b 'c)))
+  (let ((f5 (compile nil `(lambda (a b c &rest args)
+                            (apply #'list* a b c args)))))
+    (assert (equal '(1 2 3 4 5 6 7) (funcall f5 1 2 3 4 5 6 '(7)))))
+  (let ((f6 (compile nil `(lambda (x y)
+                            (declare (optimize speed))
+                            (concatenate 'string x y)))))
+    (assert (equal "foobar" (funcall f6 "foo" "bar"))))
+  (let ((f7 (compile nil `(lambda (&rest args)
+                            (lambda (f)
+                              (apply f args))))))
+    (assert (equal '(a b c d e f) (funcall (funcall f7 'a 'b 'c 'd 'e 'f) 'list))))
+  (let ((f8 (compile nil `(lambda (&rest args)
+                            (flet ((foo (f)
+                                     (apply f args)))
+                              #'foo)))))
+    (assert (equal '(a b c d e f) (funcall (funcall f8 'a 'b 'c 'd 'e 'f) 'list))))
+  (let ((f9 (compile nil `(lambda (f &rest args)
+                            (flet ((foo (g)
+                                     (apply g args)))
+                              (declare (dynamic-extent #'foo))
+                              (funcall f #'foo))))))
+    (assert (equal '(a b c d e f)
+                   (funcall f9 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f))))
+  (let ((f10 (compile nil `(lambda (f &rest args)
+                            (flet ((foo (g)
+                                     (apply g args)))
+                              (funcall f #'foo))))))
+    (assert (equal '(a b c d e f)
+                   (funcall f10 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f))))
+  (let ((f11 (compile nil `(lambda (x y z)
+                             (block out
+                               (labels ((foo (x &rest rest)
+                                          (apply (lambda (&rest rest2)
+                                                   (return-from out (values-list rest2)))
+                                                 x rest)))
+                                (if x
+                                    (foo x y z)
+                                    (foo y z x))))))))
+    (multiple-value-bind (a b c) (funcall f11 1 2 3)
+      (assert (eql a 1))
+      (assert (eql b 2))
+      (assert (eql c 3)))))