- (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
- (dolist (name names)
- (cond
- ((symbolp name)
- (let* ((bound-var (find-in-bindings vars name))
- (var (or bound-var
- (lexenv-find name vars)
- (find-free-var name))))
- (etypecase var
- (leaf
- (if bound-var
- (setf (leaf-dynamic-extent var) t)
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- name)))
- (cons
- (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
- (heap-alien-info
- (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
- name)))))
- ((and (consp name)
- (eq (car name) 'function)
- (null (cddr name))
- (valid-function-name-p (cadr name)))
- (let* ((fname (cadr name))
- (bound-fun (find fname fvars
- :key #'leaf-source-name
- :test #'equal)))
- (etypecase bound-fun
- (leaf
- #!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) t)
- #!-stack-allocatable-closures
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
+ (let ((dx (cond ((eq 'truly-dynamic-extent kind)
+ :truly)
+ ((and (eq 'dynamic-extent kind)
+ *stack-allocate-dynamic-extent*)
+ t))))
+ (if dx
+ (dolist (name names)
+ (cond
+ ((symbolp name)
+ (let* ((bound-var (find-in-bindings vars name))
+ (var (or bound-var
+ (lexenv-find name vars)
+ (find-free-var name))))
+ (etypecase var
+ (leaf
+ (if bound-var
+ (setf (leaf-dynamic-extent var) dx)
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration for free ~S"
+ name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (heap-alien-info
+ (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
+ name)))))
+ ((and (consp name)
+ (eq (car name) 'function)
+ (null (cddr name))
+ (valid-function-name-p (cadr name)))
+ (let* ((fname (cadr name))
+ (bound-fun (find fname fvars
+ :key #'leaf-source-name
+ :test #'equal)))
+ (etypecase bound-fun
+ (leaf
+ #!+stack-allocatable-closures
+ (setf (leaf-dynamic-extent bound-fun) dx)
+ #!-stack-allocatable-closures
+ (maybe-notify
+ "ignoring DYNAMIC-EXTENT declaration on a function ~S ~