- (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
- (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
- (make-lambda-vars (cadr form))
- (multiple-value-bind (forms decls) (parse-body (cddr form))
- (let* ((result-cont (make-continuation))
- (*lexenv* (process-decls decls
- (append aux-vars vars)
- nil result-cont))
- (forms (if (and *allow-debug-catch-tag*
- (policy *lexenv* (= insert-debug-catch 3)))
- `((catch (make-symbol "SB-DEBUG-CATCH-TAG")
- ,@forms))
- forms))
- (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
- (ir1-convert-hairy-lambda forms vars keyp
- allow-other-keys
- aux-vars aux-vals result-cont
- :source-name source-name
- :debug-name debug-name)
- (ir1-convert-lambda-body forms vars
- :aux-vars aux-vars
- :aux-vals aux-vals
- :result result-cont
- :source-name source-name
- :debug-name debug-name))))
- (setf (functional-inline-expansion res) form)
- (setf (functional-arg-documentation res) (cadr form))
- res)))))
+ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+ (make-lambda-vars (cadr form))
+ (multiple-value-bind (forms decls) (parse-body (cddr form))
+ (binding* (((*lexenv* result-type post-binding-lexenv)
+ (process-decls decls (append aux-vars vars) nil
+ :binding-form-p t))
+ (forms (if (and *allow-instrumenting*
+ (policy *lexenv* (>= insert-debug-catch 2)))
+ `((catch (locally
+ (declare (optimize (insert-step-conditions 0)))
+ (make-symbol "SB-DEBUG-CATCH-TAG"))
+ ,@forms))
+ forms))
+ (forms (if (eq result-type *wild-type*)
+ forms
+ `((the ,result-type (progn ,@forms)))))
+ (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+ (ir1-convert-hairy-lambda forms vars keyp
+ allow-other-keys
+ aux-vars aux-vals
+ :post-binding-lexenv post-binding-lexenv
+ :source-name source-name
+ :debug-name debug-name)
+ (ir1-convert-lambda-body forms vars
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :post-binding-lexenv post-binding-lexenv
+ :source-name source-name
+ :debug-name debug-name))))
+ (setf (functional-inline-expansion res) form)
+ (setf (functional-arg-documentation res) (cadr form))
+ res))))