(reference-constant start next result thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
+(defun name-lambdalike (thing)
+ (ecase (car thing)
+ ((named-lambda)
+ (second thing))
+ ((lambda instance-lambda)
+ `(lambda ,(second thing)))
+ ((lambda-with-lexenv)'
+ `(lambda ,(fifth thing)))))
+
(defun fun-name-leaf (thing)
(if (consp thing)
(cond
'(lambda named-lambda instance-lambda lambda-with-lexenv))
(values (ir1-convert-lambdalike
thing
- :debug-name (debug-namify "#'" thing))
+ :debug-name (name-lambdalike thing))
t))
((legal-fun-name-p thing)
(values (find-lexically-apparent-fun
(binding* ((ctran (make-ctran))
(fun-lvar (make-lvar))
((next result)
- (processing-decls (decls vars nil next result)
+ (processing-decls (decls vars nil next result
+ post-binding-lexenv)
(let ((fun (ir1-convert-lambda-body
forms
vars
- :debug-name (debug-namify "LET S"
- bindings))))
+ :post-binding-lexenv post-binding-lexenv
+ :debug-name (debug-name 'let bindings))))
(reference-leaf start ctran fun-lvar fun))
(values next result))))
(ir1-convert-combination-args fun-lvar ctran next result values)))))
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
- (processing-decls (decls vars nil start next)
+ (processing-decls (decls vars nil start next post-binding-lexenv)
(ir1-convert-aux-bindings start
next
result
forms
vars
- values))))
+ values
+ post-binding-lexenv))))
(compiler-error "Malformed LET* bindings: ~S." bindings)))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
(let ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
- :debug-name (debug-namify
- "FLET " n)))
+ :debug-name (debug-name 'flet n)))
names defs)))
(processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
(placeholder-funs (mapcar (lambda (name)
(make-functional
:%source-name name
- :%debug-name (debug-namify
- "LABELS placeholder "
+ :%debug-name (debug-name
+ 'labels-placeholder
name)))
names))
;; (like PAIRLIS but guaranteed to preserve ordering:)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
- :debug-name (debug-namify
- "LABELS " name)))
+ :debug-name (debug-name 'labels name)))
names defs))))
;; Modify all the references to the dummy function leaves so
(ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for " tag))))
+ :debug-name (debug-name 'escape-fun tag))))
(ctran (make-ctran)))
(setf (functional-kind fun) :escape)
(ir1-convert start ctran nil `(%%allocate-closures ,fun))