X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=76d2cf859177c97c97224dc04ceaf71e35c94542;hb=a27839c3a9c59b2ca1b4080de5a3a9dd682ac5b9;hp=7f963aaa00539706edc369ade140aba71cb10502;hpb=2e511bb9091cfbb1a683fd1b6b31a7b2ca28c013;p=sbcl.git diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 7f963aa..76d2cf8 100644 --- 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))) @@ -903,3 +896,100 @@ (assert (eql x (car (aref vec 0))))))) (assert-no-consing (test 42)))) +(defun bug-681092 () + (declare (optimize speed)) + (let ((c 0)) + (flet ((bar () c)) + (declare (dynamic-extent #'bar)) + (do () ((list) (bar)) + (setf c 10) + (return (bar)))))) +(with-test (:name :bug-681092) + (assert (= 10 (bug-681092)))) + +;;;; &REST lists should stop DX propagation -- not required by ANSI, +;;;; but required by sanity. + +(declaim (inline rest-stops-dx)) +(defun-with-dx rest-stops-dx (&rest args) + (declare (dynamic-extent args)) + (apply #'opaque-identity args)) + +(defun-with-dx rest-stops-dx-ok () + (equal '(:foo) (rest-stops-dx (list :foo)))) + +(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)))))