From: Joe Marshall <eval.apply@gmail.com>
Date: Wed, 25 Jan 2012 08:38:12 +0000 (-0800)
Subject: Correctly handle lambda bodies with declarations.
X-Git-Tag: release-9.2.0~332^2~8
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4a3b6be3762e368888ba2467cc7e014195d92b46;p=mit-scheme.git

Correctly handle lambda bodies with declarations.
---

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