+;;; value-cells
+
+(defun-with-dx dx-value-cell (x)
+ ;; Not implemented everywhere, yet.
+ #+(or x86 x86-64 mips hppa)
+ (let ((cell x))
+ (declare (sb-int:truly-dynamic-extent cell))
+ (flet ((f ()
+ (incf cell)))
+ (declare (dynamic-extent #'f))
+ (true #'f))))
+
+;;; CONS
+
+(defun-with-dx cons-on-stack (x)
+ (let ((cons (cons x x)))
+ (declare (dynamic-extent cons))
+ (true cons)
+ nil))
+
+;;; MAKE-ARRAY
+
+(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)
+ (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)
+ (true v)
+ nil))
+
+(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)
+ (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)
+ (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)
+ (true v)
+ 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)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-6 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type '(unsigned-byte 8))))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-7 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type '(signed-byte 8))))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-8 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type 'word)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-9 ()
+ (let ((v (make-array 3 :initial-element 12.0 :element-type 'single-float)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-10 ()
+ (let ((v (make-array 3 :initial-element 12.0d0 :element-type 'double-float)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (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))
+ (true v)
+ nil))
+
+;;; MAKE-STRUCTURE
+
+(declaim (inline make-fp-struct-1))
+(defstruct fp-struct-1
+ (s 0.0 :type single-float)
+ (d 0.0d0 :type double-float))
+
+(defun-with-dx test-fp-struct-1.1 (s d)
+ (let ((fp (make-fp-struct-1 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql 0.0d0 (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.2 (s d)
+ (let ((fp (make-fp-struct-1 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.3 (s d)
+ (let ((fp (make-fp-struct-1 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.4 (s d)
+ (let ((fp (make-fp-struct-1 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(with-test (:name (:test-fp-struct-1.1))
+ (test-fp-struct-1.1 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-1.2))
+ (test-fp-struct-1.2 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-1.3))
+ (test-fp-struct-1.3 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-1.4))
+ (test-fp-struct-1.4 123.456 876.243d0))
+
+(declaim (inline make-fp-struct-2))
+(defstruct fp-struct-2
+ (d 0.0d0 :type double-float)
+ (s 0.0 :type single-float))
+
+(defun-with-dx test-fp-struct-2.1 (s d)
+ (let ((fp (make-fp-struct-2 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql 0.0d0 (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.2 (s d)
+ (let ((fp (make-fp-struct-2 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.3 (s d)
+ (let ((fp (make-fp-struct-2 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.4 (s d)
+ (let ((fp (make-fp-struct-2 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(with-test (:name (:test-fp-struct-2.1))
+ (test-fp-struct-2.1 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-2.2))
+ (test-fp-struct-2.2 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-2.3))
+ (test-fp-struct-2.3 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-2.4))
+ (test-fp-struct-2.4 123.456 876.243d0))
+
+(declaim (inline make-cfp-struct-1))
+(defstruct cfp-struct-1
+ (s (complex 0.0) :type (complex single-float))
+ (d (complex 0.0d0) :type (complex double-float)))
+
+(defun-with-dx test-cfp-struct-1.1 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.2 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.3 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.4 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(with-test (:name (:test-cfp-struct-1.1))
+ (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-1.2))
+ (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-1.3))
+ (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-1.4))
+ (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+
+(declaim (inline make-cfp-struct-2))
+(defstruct cfp-struct-2
+ (d (complex 0.0d0) :type (complex double-float))
+ (s (complex 0.0) :type (complex single-float)))
+
+(defun-with-dx test-cfp-struct-2.1 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.2 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.3 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.4 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(with-test (:name (:test-cfp-struct-2.1))
+ (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-2.2))
+ (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-2.3))
+ (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-2.4))
+ (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+
+(declaim (inline make-foo1 make-foo2 make-foo3))
+(defstruct foo1 x)
+
+(defun-with-dx make-foo1-on-stack (x)
+ (let ((foo (make-foo1 :x x)))
+ (declare (dynamic-extent foo))
+ (assert (eql x (foo1-x foo)))))
+
+(defstruct foo2
+ (x 0.0 :type single-float)
+ (y 0.0d0 :type double-float)
+ a
+ b
+ c)
+
+(defun-with-dx make-foo2-on-stack (x y)
+ (let ((foo (make-foo2 :y y :c 'c)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0.0 (foo2-x foo)))
+ (assert (eql y (foo2-y foo)))
+ (assert (eql 'c (foo2-c foo)))
+ (assert (eql nil (foo2-b foo)))))
+
+;;; Check that constants work out as argument for all relevant
+;;; slot types.
+(defstruct foo3
+ (a 0 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float))
+
+(defun-with-dx make-foo3-on-stack ()
+ (let ((foo (make-foo3)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0 (foo3-a foo)))
+ (assert (eql 1 (foo3-b foo)))
+ (assert (eql 2 (foo3-c foo)))
+ (assert (eql 3.0 (foo3-d foo)))
+ (assert (eql 4.0d0 (foo3-e foo)))))
+
+;;; Nested DX
+
+(defun-with-dx nested-dx-lists ()
+ (let ((dx (list (list 1 2) (list 3 4))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+(defun-with-dx nested-dx-conses ()
+ (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+(defun-with-dx nested-dx-not-used (x)
+ (declare (list x))
+ (let ((l (setf (car x) (list x x x))))
+ (declare (dynamic-extent l))
+ (true l)
+ (true (length l))
+ nil))
+
+(defun-with-dx nested-evil-dx-used (x)
+ (declare (list x))
+ (let ((l (list x x x)))
+ (declare (dynamic-extent l))
+ (unwind-protect
+ (progn
+ (setf (car x) l)
+ (true l))
+ (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 ()
+ (let ((dx (if (true t)
+ (list 1 2 3)
+ (list 2 3 4))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+;;; handler-case and handler-bind should use DX internally
+
+(defun dx-handler-bind (x)
+ (handler-bind ((error
+ #'(lambda (c)
+ (break "OOPS: ~S caused ~S" x c)))
+ ((and serious-condition (not error))
+ #'(lambda (c)
+ (break "OOPS2: ~S did ~S" x c))))
+ (/ 2 x)))
+
+(defun dx-handler-case (x)
+ (assert (zerop (handler-case (/ 2 x)
+ (error (c)
+ (break "OOPS: ~S caused ~S" x c)
+ -1)
+ (:no-error (res)
+ (1- res))))))
+
+(defvar *a-cons* (cons nil nil))
+
+(with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures))
+ (assert-no-consing (dxclosure 42)))
+
+(with-test (:name (:no-consing :dx-lists) :skipped-on '(not :stack-allocatable-lists))