X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=6841e4d6b05c3dc734c7a6646e48feb5fe3a15fc;hb=6b8604ad86a30578a776d706d01b2f3ab3fac8f2;hp=291a80b7f9c8621dc2fb8cadac4e5bf288a10cf9;hpb=bd0c2b854688663c40a50a4453d668a7abfc96db;p=sbcl.git

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 291a80b..6841e4d 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -12,7 +12,7 @@
 ;;;; more information.
 
 (when (eq sb-ext:*evaluator-mode* :interpret)
-  (sb-ext:quit :unix-status 104))
+  (sb-ext:exit :code 104))
 
 (load "compiler-test-util.lisp")
 (use-package :ctu)
@@ -21,8 +21,17 @@
       sb-ext:*stack-allocate-dynamic-extent* t)
 
 (defmacro defun-with-dx (name arglist &body body)
-  `(defun ,name ,arglist
-     ,@body))
+  (let ((debug-name (sb-int:symbolicate name "-HIGH-DEBUG"))
+        (default-name (sb-int:symbolicate name "-DEFAULT")))
+    `(progn
+       (defun ,debug-name ,arglist
+         (declare (optimize debug))
+         ,@body)
+       (defun ,default-name ,arglist
+        ,@body)
+       (defun ,name (&rest args)
+         (apply #',debug-name args)
+         (apply #',default-name args)))))
 
 (declaim (notinline opaque-identity))
 (defun opaque-identity (x)
@@ -252,6 +261,13 @@
     (true v)
     nil))
 
+(defun-with-dx make-array-on-stack-11 ()
+  (let ((v (make-array (the integer (opaque-identity 3)) :initial-element 12.0d0 :element-type 'double-float)))
+    (declare (sb-int:truly-dynamic-extent v))
+    (true 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))
@@ -577,15 +593,18 @@
   (assert-no-consing (vector-on-stack :x :y)))
 
 (with-test (:name (:no-consing :specialized-dx-vectors)
+            :fails-on :x86
             :skipped-on `(not (and :stack-allocatable-vectors
                                    :c-stack-is-control-stack)))
   (assert-no-consing (make-array-on-stack-6))
   (assert-no-consing (make-array-on-stack-7))
   (assert-no-consing (make-array-on-stack-8))
   (assert-no-consing (make-array-on-stack-9))
-  (assert-no-consing (make-array-on-stack-10)))
+  (assert-no-consing (make-array-on-stack-10))
+  (assert-no-consing (make-array-on-stack-11)))
 
-(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc :skipped-on '(not :raw-instance-init-vops))
+(with-test (:name (:no-consing :dx-raw-instances) :skipped-on '(or (not :raw-instance-init-vops)
+                                                                   (not (and :gencgc :c-stack-is-control-stack))))
   (let (a b)
     (setf a 1.24 b 1.23d0)
     (assert-no-consing (make-foo2-on-stack a b)))
@@ -602,6 +621,15 @@
 ;; This fails on threaded PPC because the hash-table implementation
 ;; uses recursive system locks, which cons (see below for test
 ;; (:no-consing :lock), which also fails on threaded PPC).
+;;
+;; -- That may have been the situation in 2010 when the above comment
+;; was written, but AFAICT now, hash tables use WITH-PINNED-OBJECTS,
+;; which conses on PPC and SPARC when GENCGC is enabled.  So neither is
+;; this actually about threading, nor about PPC.  Yet since we are
+;; failing most of this file on SPARC anyway (for some tests even on
+;; cheneygc), I won't bother to mark this particular test as failing.
+;; It would be nice if someone could go through this file and figure it
+;; all out... --DFL
 (with-test (:name (:no-consing :hash-tables) :fails-on '(and :ppc :sb-thread))
   (assert-no-consing (test-hash-table)))
 
@@ -663,7 +691,7 @@
   (bdowning-2005-iv-16))
 
 (declaim (inline my-nconc))
-(defun-with-dx my-nconc (&rest lists)
+(defun my-nconc (&rest lists)
   (declare (dynamic-extent lists))
   (apply #'nconc lists))
 (defun-with-dx my-nconc-caller (a b c)
@@ -866,7 +894,9 @@
                          nil)))
     (assert-notes 0 `(lambda (list)
                        (declare (optimize (space 0)))
-                       (sort list #'<)))
+                       (sort list (lambda (x y) ; shut unrelated notes up
+                                    (< (truly-the fixnum x)
+                                       (truly-the fixnum y))))))
     (assert-notes 0 `(lambda (other)
                        #'(lambda (s c n)
                            (ignore-errors (funcall other s c n)))))))