1 ;;;; tests that dynamic-extent functionality works.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (when (eq sb-ext:*evaluator-mode* :interpret)
15 (sb-ext:quit :unix-status 104))
17 (setq sb-c::*check-consistency* t
18 sb-ext:*stack-allocate-dynamic-extent* t)
20 (defmacro defun-with-dx (name arglist &body body)
21 `(defun ,name ,arglist
24 (declaim (notinline opaque-identity))
25 (defun opaque-identity (x)
29 (defun-with-dx dxlength (&rest rest)
30 (declare (dynamic-extent rest))
33 (assert (= (dxlength 1 2 3) 3))
34 (assert (= (dxlength t t t t t t) 6))
35 (assert (= (dxlength) 0))
38 (destructuring-bind (a b c d e f &rest g) list
39 (+ a b c d e f (length g))))
41 (defun-with-dx dxcaller (&rest rest)
42 (declare (dynamic-extent rest))
44 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
46 (defun-with-dx dxcaller-align-1 (x &rest rest)
47 (declare (dynamic-extent rest))
49 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
50 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
53 (defun-with-dx test-nip-values ()
54 (flet ((bar (x &rest y)
55 (declare (dynamic-extent y))
59 (multiple-value-call #'values
63 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
65 ;;; LET-variable substitution
66 (defun-with-dx test-let-var-subst1 (x)
67 (let ((y (list x (1- x))))
68 (opaque-identity :foo)
69 (let ((z (the list y)))
70 (declare (dynamic-extent z))
72 (assert (eql (test-let-var-subst1 17) 2))
74 (defun-with-dx test-let-var-subst2 (x)
75 (let ((y (list x (1- x))))
76 (declare (dynamic-extent y))
77 (opaque-identity :foo)
78 (let ((z (the list y)))
80 (assert (eql (test-let-var-subst2 17) 2))
82 ;;; DX propagation through LET-return.
83 (defun-with-dx test-lvar-subst (x)
84 (let ((y (list x (1- x))))
85 (declare (dynamic-extent y))
86 (second (let ((z (the list y)))
87 (opaque-identity :foo)
89 (assert (eql (test-lvar-subst 11) 10))
91 ;;; this code is incorrect, but the compiler should not fail
92 (defun-with-dx test-let-var-subst-incorrect (x)
93 (let ((y (list x (1- x))))
94 (opaque-identity :foo)
95 (let ((z (the list y)))
96 (declare (dynamic-extent z))
97 (opaque-identity :bar)
102 (defun-with-dx test-alignment-dx-list (form)
103 (multiple-value-prog1 (eval form)
104 (let ((l (list 1 2 3 4)))
105 (declare (dynamic-extent l))
106 (setq *x* (copy-list l)))))
108 (let* ((res (loop for i below n collect i))
109 (form `(values ,@res)))
110 (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
111 (assert (equal *x* '(1 2 3 4)))))
115 (declaim (notinline true))
120 (defun-with-dx dxclosure (x)
123 (declare (dynamic-extent #'f))
126 (assert (eq t (dxclosure 13)))
130 (defun-with-dx dx-value-cell (x)
131 ;; Not implemented everywhere, yet.
132 #+(or x86 x86-64 mips hppa)
134 (declare (sb-int:truly-dynamic-extent cell))
137 (declare (dynamic-extent #'f))
142 (defun-with-dx cons-on-stack (x)
143 (let ((cons (cons x x)))
144 (declare (dynamic-extent cons))
150 (defun force-make-array-on-stack (n)
151 (declare (optimize safety))
152 (let ((v (make-array (min n 1))))
153 (declare (sb-int:truly-dynamic-extent v))
157 (defun-with-dx make-array-on-stack-1 ()
158 (let ((v (make-array '(42) :element-type 'single-float)))
159 (declare (dynamic-extent v))
163 (defun-with-dx make-array-on-stack-2 (n x)
164 (declare (integer n))
165 (let ((v (make-array n :initial-contents x)))
166 (declare (sb-int:truly-dynamic-extent v))
170 (defun-with-dx make-array-on-stack-3 (x y z)
171 (let ((v (make-array 3
172 :element-type 'fixnum :initial-contents (list x y z)
173 :element-type t :initial-contents x)))
174 (declare (sb-int:truly-dynamic-extent v))
178 (defun-with-dx make-array-on-stack-4 ()
179 (let ((v (make-array 3 :initial-contents '(1 2 3))))
180 (declare (sb-int:truly-dynamic-extent v))
184 ;;; Unfortunately VECTOR-FILL* conses right now, so this one
185 ;;; doesn't pass yet.
187 (defun-with-dx make-array-on-stack-5 ()
188 (let ((v (make-array 3 :initial-element 12 :element-type t)))
189 (declare (sb-int:truly-dynamic-extent v))
193 (defun-with-dx vector-on-stack (x y)
194 (let ((v (vector 1 x 2 y 3)))
195 (declare (sb-int:truly-dynamic-extent v))
201 (declaim (inline make-fp-struct-1))
202 (defstruct fp-struct-1
203 (s 0.0 :type single-float)
204 (d 0.0d0 :type double-float))
206 (defun-with-dx test-fp-struct-1.1 (s d)
207 (let ((fp (make-fp-struct-1 :s s)))
208 (declare (dynamic-extent fp))
209 (assert (eql s (fp-struct-1-s fp)))
210 (assert (eql 0.0d0 (fp-struct-1-d fp)))))
212 (defun-with-dx test-fp-struct-1.2 (s d)
213 (let ((fp (make-fp-struct-1 :d d)))
214 (declare (dynamic-extent fp))
215 (assert (eql 0.0 (fp-struct-1-s fp)))
216 (assert (eql d (fp-struct-1-d fp)))))
218 (defun-with-dx test-fp-struct-1.3 (s d)
219 (let ((fp (make-fp-struct-1 :d d :s s)))
220 (declare (dynamic-extent fp))
221 (assert (eql s (fp-struct-1-s fp)))
222 (assert (eql d (fp-struct-1-d fp)))))
224 (defun-with-dx test-fp-struct-1.4 (s d)
225 (let ((fp (make-fp-struct-1 :s s :d d)))
226 (declare (dynamic-extent fp))
227 (assert (eql s (fp-struct-1-s fp)))
228 (assert (eql d (fp-struct-1-d fp)))))
230 (test-fp-struct-1.1 123.456 876.243d0)
231 (test-fp-struct-1.2 123.456 876.243d0)
232 (test-fp-struct-1.3 123.456 876.243d0)
233 (test-fp-struct-1.4 123.456 876.243d0)
235 (declaim (inline make-fp-struct-2))
236 (defstruct fp-struct-2
237 (d 0.0d0 :type double-float)
238 (s 0.0 :type single-float))
240 (defun-with-dx test-fp-struct-2.1 (s d)
241 (let ((fp (make-fp-struct-2 :s s)))
242 (declare (dynamic-extent fp))
243 (assert (eql s (fp-struct-2-s fp)))
244 (assert (eql 0.0d0 (fp-struct-2-d fp)))))
246 (defun-with-dx test-fp-struct-2.2 (s d)
247 (let ((fp (make-fp-struct-2 :d d)))
248 (declare (dynamic-extent fp))
249 (assert (eql 0.0 (fp-struct-2-s fp)))
250 (assert (eql d (fp-struct-2-d fp)))))
252 (defun-with-dx test-fp-struct-2.3 (s d)
253 (let ((fp (make-fp-struct-2 :d d :s s)))
254 (declare (dynamic-extent fp))
255 (assert (eql s (fp-struct-2-s fp)))
256 (assert (eql d (fp-struct-2-d fp)))))
258 (defun-with-dx test-fp-struct-2.4 (s d)
259 (let ((fp (make-fp-struct-2 :s s :d d)))
260 (declare (dynamic-extent fp))
261 (assert (eql s (fp-struct-2-s fp)))
262 (assert (eql d (fp-struct-2-d fp)))))
264 (test-fp-struct-2.1 123.456 876.243d0)
265 (test-fp-struct-2.2 123.456 876.243d0)
266 (test-fp-struct-2.3 123.456 876.243d0)
267 (test-fp-struct-2.4 123.456 876.243d0)
269 (declaim (inline make-cfp-struct-1))
270 (defstruct cfp-struct-1
271 (s (complex 0.0) :type (complex single-float))
272 (d (complex 0.0d0) :type (complex double-float)))
274 (defun-with-dx test-cfp-struct-1.1 (s d)
275 (let ((cfp (make-cfp-struct-1 :s s)))
276 (declare (dynamic-extent cfp))
277 (assert (eql s (cfp-struct-1-s cfp)))
278 (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
280 (defun-with-dx test-cfp-struct-1.2 (s d)
281 (let ((cfp (make-cfp-struct-1 :d d)))
282 (declare (dynamic-extent cfp))
283 (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
284 (assert (eql d (cfp-struct-1-d cfp)))))
286 (defun-with-dx test-cfp-struct-1.3 (s d)
287 (let ((cfp (make-cfp-struct-1 :d d :s s)))
288 (declare (dynamic-extent cfp))
289 (assert (eql s (cfp-struct-1-s cfp)))
290 (assert (eql d (cfp-struct-1-d cfp)))))
292 (defun-with-dx test-cfp-struct-1.4 (s d)
293 (let ((cfp (make-cfp-struct-1 :s s :d d)))
294 (declare (dynamic-extent cfp))
295 (assert (eql s (cfp-struct-1-s cfp)))
296 (assert (eql d (cfp-struct-1-d cfp)))))
298 (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
299 (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
300 (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
301 (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
303 (declaim (inline make-cfp-struct-2))
304 (defstruct cfp-struct-2
305 (d (complex 0.0d0) :type (complex double-float))
306 (s (complex 0.0) :type (complex single-float)))
308 (defun-with-dx test-cfp-struct-2.1 (s d)
309 (let ((cfp (make-cfp-struct-2 :s s)))
310 (declare (dynamic-extent cfp))
311 (assert (eql s (cfp-struct-2-s cfp)))
312 (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
314 (defun-with-dx test-cfp-struct-2.2 (s d)
315 (let ((cfp (make-cfp-struct-2 :d d)))
316 (declare (dynamic-extent cfp))
317 (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
318 (assert (eql d (cfp-struct-2-d cfp)))))
320 (defun-with-dx test-cfp-struct-2.3 (s d)
321 (let ((cfp (make-cfp-struct-2 :d d :s s)))
322 (declare (dynamic-extent cfp))
323 (assert (eql s (cfp-struct-2-s cfp)))
324 (assert (eql d (cfp-struct-2-d cfp)))))
326 (defun-with-dx test-cfp-struct-2.4 (s d)
327 (let ((cfp (make-cfp-struct-2 :s s :d d)))
328 (declare (dynamic-extent cfp))
329 (assert (eql s (cfp-struct-2-s cfp)))
330 (assert (eql d (cfp-struct-2-d cfp)))))
332 (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
333 (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
334 (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
335 (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
337 (declaim (inline make-foo1 make-foo2 make-foo3))
340 (defun-with-dx make-foo1-on-stack (x)
341 (let ((foo (make-foo1 :x x)))
342 (declare (dynamic-extent foo))
343 (assert (eql x (foo1-x foo)))))
346 (x 0.0 :type single-float)
347 (y 0.0d0 :type double-float)
352 (defmacro assert-eql (expected got)
353 `(let ((exp ,expected)
355 (unless (eql exp got)
356 (error "Expected ~S, got ~S!" exp got))))
358 (defun-with-dx make-foo2-on-stack (x y)
359 (let ((foo (make-foo2 :y y :c 'c)))
360 (declare (dynamic-extent foo))
361 (assert-eql 0.0 (foo2-x foo))
362 (assert-eql y (foo2-y foo))
363 (assert-eql 'c (foo2-c foo))
364 (assert-eql nil (foo2-b foo))))
366 ;;; Check that constants work out as argument for all relevant
371 (c 2 :type sb-vm:word)
372 (d 3.0 :type single-float)
373 (e 4.0d0 :type double-float))
374 (defun-with-dx make-foo3-on-stack ()
375 (let ((foo (make-foo3)))
376 (declare (dynamic-extent foo))
377 (assert (eql 0 (foo3-a foo)))
378 (assert (eql 1 (foo3-b foo)))
379 (assert (eql 2 (foo3-c foo)))
380 (assert (eql 3.0 (foo3-d foo)))
381 (assert (eql 4.0d0 (foo3-e foo)))))
385 (defun-with-dx nested-dx-lists ()
386 (let ((dx (list (list 1 2) (list 3 4))))
387 (declare (dynamic-extent dx))
391 (defun-with-dx nested-dx-conses ()
392 (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
393 (declare (dynamic-extent dx))
397 (defun-with-dx nested-dx-not-used (x)
399 (let ((l (setf (car x) (list x x x))))
400 (declare (dynamic-extent l))
405 (defun-with-dx nested-evil-dx-used (x)
407 (let ((l (list x x x)))
408 (declare (dynamic-extent l))
416 (defparameter *bar* nil)
417 (declaim (inline make-nested-bad make-nested-good))
418 (defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
419 (:constructor make-nested-good (&key bar)))
422 (defun-with-dx nested-good (y)
423 (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
424 (declare (dynamic-extent x))
427 (defun-with-dx nested-bad (y)
428 (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
429 (declare (dynamic-extent x))
430 (unless (equalp (caar x) (make-nested-good :bar *bar*))
431 (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
434 (with-test (:name :conservative-nested-dx)
435 ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
436 (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
437 (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
439 ;;; multiple uses for dx lvar
441 (defun-with-dx multiple-dx-uses ()
442 (let ((dx (if (true t)
445 (declare (dynamic-extent dx))
449 ;;; handler-case and handler-bind should use DX internally
451 (defun dx-handler-bind (x)
452 (handler-bind ((error
453 (lambda (c) (break "OOPS: ~S caused ~S" x c)))
454 ((and serious-condition (not error))
455 #'(lambda (c) (break "OOPS2: ~S did ~S" x c))))
458 (defun dx-handler-case (x)
459 (assert (zerop (handler-case (/ 2 x)
461 (break "OOPS: ~S caused ~S" x c))
465 ;;; with-spinlock and with-mutex should use DX and not cons
467 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
469 (defun test-spinlock ()
470 (sb-thread::with-spinlock (*slock*)
473 (defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
476 (sb-thread:with-mutex (*mutex*)
479 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
481 (defvar *table* (make-hash-table))
483 (defun test-hash-table ()
484 (setf (gethash 5 *table*) 13)
487 (defmacro assert-no-consing (form &optional times)
488 `(%assert-no-consing (lambda () ,form) ,times))
489 (defun %assert-no-consing (thunk &optional times)
490 (let ((before (get-bytes-consed))
491 (times (or times 10000)))
492 (declare (type (integer 1 *) times))
495 (assert (< (- (get-bytes-consed) before) times))))
497 (defmacro assert-consing (form &optional times)
498 `(%assert-consing (lambda () ,form) ,times))
499 (defun %assert-consing (thunk &optional times)
500 (let ((before (get-bytes-consed))
501 (times (or times 10000)))
502 (declare (type (integer 1 *) times))
505 (assert (not (< (- (get-bytes-consed) before) times)))))
507 (defvar *a-cons* (cons nil nil))
509 #+(or x86 x86-64 alpha ppc sparc mips hppa)
511 (assert-no-consing (dxclosure 42))
512 (assert-no-consing (dxlength 1 2 3))
513 (assert-no-consing (dxlength t t t t t t))
514 (assert-no-consing (dxlength))
515 (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
516 (assert-no-consing (test-nip-values))
517 (assert-no-consing (test-let-var-subst1 17))
518 (assert-no-consing (test-let-var-subst2 17))
519 (assert-no-consing (test-lvar-subst 11))
520 (assert-no-consing (dx-value-cell 13))
521 (assert-no-consing (cons-on-stack 42))
522 (assert-no-consing (force-make-array-on-stack 128))
523 (assert-no-consing (make-array-on-stack-1))
524 (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
525 (assert-no-consing (make-array-on-stack-3 9 8 7))
526 (assert-no-consing (make-array-on-stack-4))
528 (assert-no-consing (make-array-on-stack-5))
529 (assert-no-consing (vector-on-stack :x :y))
530 (assert-no-consing (make-foo1-on-stack 123))
531 (assert-no-consing (nested-good 42))
532 (#+raw-instance-init-vops assert-no-consing
533 #-raw-instance-init-vops progn
534 (make-foo2-on-stack 1.24 1.23d0))
535 (#+raw-instance-init-vops assert-no-consing
536 #-raw-instance-init-vops progn
537 (make-foo3-on-stack))
538 (assert-no-consing (nested-dx-conses))
539 (assert-no-consing (nested-dx-lists))
540 (assert-consing (nested-dx-not-used *a-cons*))
541 (assert-no-consing (nested-evil-dx-used *a-cons*))
542 (assert-no-consing (multiple-dx-uses))
543 (assert-no-consing (dx-handler-bind 2))
544 (assert-no-consing (dx-handler-case 2))
546 (assert-no-consing (test-hash-table))
549 (assert-no-consing (test-spinlock))
550 (assert-no-consing (test-mutex))))
553 ;;; Bugs found by Paul F. Dietz
560 (declare (optimize (speed 2) (space 0) (safety 0)
561 (debug 1) (compilation-speed 3)))
562 (let* ((v5 (cons b b)))
563 (declare (dynamic-extent v5))
571 ;;; bug reported by Svein Ove Aas
572 (defun svein-2005-ii-07 (x y)
573 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
574 (let ((args (list* y 1 2 x)))
575 (declare (dynamic-extent args))
576 (apply #'aref args)))
580 #3A(((1 1 1) (1 1 1) (1 1 1))
581 ((1 1 1) (1 1 1) (4 1 1))
582 ((1 1 1) (1 1 1) (1 1 1))))
585 ;;; bug reported by Brian Downing: stack-allocated arrays were not
586 ;;; filled with zeroes.
587 (defun-with-dx bdowning-2005-iv-16 ()
588 (let ((a (make-array 11 :initial-element 0)))
589 (declare (dynamic-extent a))
590 (assert (every (lambda (x) (eql x 0)) a))))
591 (assert-no-consing (bdowning-2005-iv-16))
593 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
594 (let* ((a (list x y z))
597 (declare (dynamic-extent c))
598 (values (first c) (second c))))
600 (with-test (:name :let-converted-vars-dx-allocated-bug)
601 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
602 (assert (and (equal i j)
603 (equal i (list 1 2 3))))))
605 ;;; workaround for bug 419 -- real issue remains, but check that the
607 (defun-with-dx bug419 (x)
608 (multiple-value-call #'list
609 (eval '(values 1 2 3))
611 (declare (dynamic-extent x))
616 (declare (dynamic-extent #'mget #'mset))
617 ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
618 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
620 ;;; Multiple DX arguments in a local function call
621 (defun test-dx-flet-test (fun n f1 f2 f3)
622 (let ((res (with-output-to-string (s)
623 (assert (eql n (ignore-errors (funcall fun s)))))))
624 (multiple-value-bind (x pos) (read-from-string res nil)
625 (assert (equalp f1 x))
626 (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
627 (assert (equalp f2 y))
628 (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
629 (assert-no-consing (assert (eql n (funcall fun nil)))))
630 (macrolet ((def (n f1 f2 f3)
631 (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
633 (defun-with-dx ,name (s)
635 (declare (dynamic-extent x))
644 (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
645 (def 0 (list :one) (list :two) (list :three))
646 (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
647 (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
649 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
650 (defun test-update-uvl-live-sets (x y z)
651 (declare (optimize speed (safety 0)))
653 (declare (dynamic-extent a))
654 (eval `(list (length ',a) ',b))))
656 (bar (list x y z) ; dx push
658 (multiple-value-call 'list
659 (eval '(values 1 2 3)) ; uv push
664 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
666 (with-test (:name :regression-1.0.23.38)
667 (compile nil '(lambda ()
669 (let ((res (cons x x)))
672 (declaim (inline make))
673 (let ((z (make 1 2)))
674 (declare (dynamic-extent z))
677 (compile nil '(lambda ()
679 (let ((res (cons x x)))
682 (declaim (inline make))
683 (let ((z (make 1 2)))
684 (declare (dynamic-extent z))
688 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
689 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
690 ;;; location, leading to all manner of badness. ...reproducing this
691 ;;; reliably is hard, but this it at least used to break on x86-64.
692 (defun length-and-words-packed-in-same-tn (m)
693 (declare (optimize speed (safety 0) (debug 0) (space 0)))
694 (let ((array (make-array (max 1 m) :element-type 'fixnum)))
695 (declare (dynamic-extent array))
696 (array-total-size array)))
697 (with-test (:name :length-and-words-packed-in-same-tn)
698 (assert (= 1 (length-and-words-packed-in-same-tn -3))))
700 (with-test (:name :handler-case-bogus-compiler-note)
701 (handler-bind ((compiler-note #'error))
702 ;; Taken from SWANK, used to signal a bogus stack allocation
705 `(lambda (files fasl-dir load)
706 (let ((needs-recompile nil))
708 (let ((dest (binary-pathname src fasl-dir)))
711 (when (or needs-recompile
712 (not (probe-file dest))
713 (file-newer-p src dest))
714 (setq needs-recompile t)
715 (ensure-directories-exist dest)
716 (compile-file src :output-file dest :print nil :verbose t))
718 (load dest :verbose t)))
719 (serious-condition (c)
720 (handle-loadtime-error c dest))))))))))
722 (with-test (:name :dx-compiler-notes)
724 (handler-bind ((compiler-note (lambda (c)
725 (declare (ignore cc))
727 (compile nil `(lambda (x)
728 (let ((v (make-array x)))
729 (declare (dynamic-extent v))
732 (compile nil `(lambda (x)
733 (let ((y (if (plusp x)
736 (declare (dynamic-extent y))