From 4a3b6be3762e368888ba2467cc7e014195d92b46 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Wed, 25 Jan 2012 00:38:12 -0800 Subject: [PATCH] Correctly handle lambda bodies with declarations. --- src/runtime/unsyn.scm | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index ec3d4e6e0..a489427b2 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -172,7 +172,7 @@ USA. (if (eq? lambda-name name) `(DEFINE (,name . ,(lambda-list required optional rest '())) ,@(with-bindings required optional rest - unsyntax-sequence body)) + unsyntax-lambda-body body)) `(DEFINE ,name ,@(unexpand-binding-value value)))))) (else `(DEFINE ,name ,@(unexpand-binding-value value))))) @@ -322,7 +322,7 @@ USA. (collect-lambda name (lambda-list required optional rest '()) (with-bindings required optional rest - unsyntax-sequence body)))) + unsyntax-lambda-body body)))) (lambda-components expression (lambda (name required optional rest auxiliary declarations body) (collect-lambda name @@ -374,6 +374,25 @@ USA. (bind-auxilliaries internal-defines body))) (bind-auxilliaries auxiliary (unscan-defines auxiliary declarations body)))))) + +(define (unsyntax-lambda-body body) + (cond ((open-block? body) + (open-block-components body + (lambda (names declarations open-block-body) + (let ((unscanned (unscan-defines names declarations open-block-body))) + (if (sequence? unscanned) + (unsyntax-lambda-body-sequence unscanned) + (list (unsyntax-object unscanned))))))) + ((sequence? body) (unsyntax-lambda-body-sequence sequence)) + (else (list (unsyntax-object body))))) + +(define (unsyntax-lambda-body-sequence sequence) + (guarantee-sequence sequence 'unsyntax-lambda-body-sequence) + (let ((first-action (sequence-first sequence))) + (if (block-declaration? first-action) + `((DECLARE ,@(block-declaration-text first-action)) + ,@(unsyntax-sequence (sequence-second sequence))) + (unsyntax-sequence sequence)))) ;;;; Combinations @@ -405,7 +424,7 @@ USA. (eq? name lambda-tag:let)) `(LET ,(unsyntax-let-bindings required operands) ,@(with-bindings required '() #F - unsyntax-sequence body)) + unsyntax-lambda-body body)) (ordinary-combination)) (ordinary-combination))))) (else -- 2.25.1