From: Joe Marshall <eval.apply@gmail.com>
Date: Mon, 13 Jun 2011 23:08:33 +0000 (-0700)
Subject: Add ability to expand named-let as pure function.
X-Git-Tag: release-9.1.0~22^2~2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d69b30dab2f73789953f677f1281621376834b2e;p=mit-scheme.git

Add ability to expand named-let as pure function.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 470b8f72c..d68030012 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -163,6 +163,8 @@ USA.
 	(else
 	 (ill-formed-syntax form))))
 
+(define named-let-strategy 'letrec)
+
 (define-syntax :let
   (er-macro-transformer
    (lambda (form rename compare)
@@ -172,15 +174,37 @@ USA.
 	    (let ((name (cadr form))
 		  (bindings (caddr form))
 		  (body (cdddr form)))
-	      `((,(rename 'LETREC)
-		 ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
-						  ,@body)))
-		 ,name)
-		,@(map (lambda (binding)
-			 (if (pair? (cdr binding))
-			     (cadr binding)
-			     (unassigned-expression)))
-		       bindings))))
+	      (case named-let-strategy
+		((letrec)
+		 `((,(rename 'LETREC)
+		    ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
+			     ,@body)))
+		    ,name)
+		   ,@(map (lambda (binding)
+			    (if (pair? (cdr binding))
+				(cadr binding)
+				(unassigned-expression)))
+			  bindings)))
+		((fixed-point)
+		 (let ((iter (make-synthetic-identifier 'ITER))
+		       (kernel (make-synthetic-identifier 'KERNEL))
+		       (temps (map (lambda (b)
+				     (declare (ignore b))
+				     (make-synthetic-identifier 'TEMP)) bindings)))
+		   `((,(rename 'LAMBDA) (,kernel)
+		      (,kernel ,kernel ,@(map (lambda (binding)
+						(if (pair? (cdr binding))
+						    (cadr binding)
+						    (unassigned-expression)))
+					      bindings)))
+		     (,(rename 'LAMBDA) (,iter ,@(map car bindings))
+		      ((,(rename 'LAMBDA) (,name)
+			(,(rename 'DECLARE) (INTEGRATE-OPERATOR ,name))
+			,@body)
+		       (,(rename 'LAMBDA) ,temps
+			(,(rename 'DECLARE) (INTEGRATE ,@temps))
+			(,iter ,iter ,@temps)))))))
+		(else (error "Unrecognized named-let-strategy: " named-let-strategy)))))
 	   ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
 	    `(,keyword:let ,@(cdr (normalize-let-bindings form))))
 	   (else
@@ -519,7 +543,7 @@ USA.
 	      `(,r-begin
 		(,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
 		(,r-define ,(cadr form)
-			   (,r-declare (INTEGRATE ,@(cdadr form)))
+			    (,r-declare (INTEGRATE ,@(cdadr form)))
 			   ,@(cddr form))))
 	     (else
 	      (ill-formed-syntax form)))))))