Add LETREC*. Convert LETREC to R6RS semantics. Use internal definition for expansio...

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 94d9e92d415c9fdaa5fa72c28a3e6dd60ad52c69..4888170f1ab7e6cca9a6241b3bd775a84153c132 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -164,7 +164,7 @@ USA.
        (else
         (ill-formed-syntax form))))
 \f
-(define named-let-strategy 'letrec)
+(define named-let-strategy 'internal-definition)
 
 (define-syntax :let
   (er-macro-transformer
@@ -175,39 +175,48 @@ USA.
            (let ((name (cadr form))
                  (bindings (caddr form))
                  (body (cdddr form)))
-             (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))
-                      (r-lambda (rename 'LAMBDA))
-                      (r-declare (rename 'DECLARE)))
-                  `((,r-lambda (,kernel)
-                     (,kernel ,kernel ,@(map (lambda (binding)
-                                               (if (pair? (cdr binding))
-                                                   (cadr binding)
-                                                   (unassigned-expression)))
-                                             bindings)))
-                    (,r-lambda (,iter ,@(map car bindings))
-                     ((,r-lambda (,name)
-                       (,r-declare (INTEGRATE-OPERATOR ,name))
-                       ,@body)
-                      (,r-lambda ,temps
-                       (,r-declare (INTEGRATE ,@temps))
-                       (,iter ,iter ,@temps)))))))
-               (else (error "Unrecognized named-let-strategy: " named-let-strategy)))))
+             (let ((vars (map car bindings))
+                   (vals (map (lambda (binding)
+                                (if (pair? (cdr binding))
+                                    (cadr binding)
+                                    (unassigned-expression)))
+                              bindings)))
+               (case named-let-strategy
+                 ((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))
+                        (r-lambda (rename 'LAMBDA))
+                        (r-declare (rename 'DECLARE)))
+                    `((,r-lambda (,kernel)
+                         (,kernel ,kernel ,@vals))
+                      (,r-lambda (,iter ,@vars)
+                         ((,r-lambda (,name)
+                             (,r-declare (INTEGRATE-OPERATOR ,name))
+                             ,@body)
+                          (,r-lambda ,temps
+                             (,r-declare (INTEGRATE ,@temps))
+                             (,iter ,iter ,@temps)))))))
+                 ((internal-definition)
+                  `((,(rename 'LET) ()
+                     (,(rename 'DEFINE) (,name ,@vars) ,@body)
+                     ,name)
+                    ,@vals))
+                 ((letrec)
+                  `((,(rename 'LETREC)
+                     ((,name (,(rename 'NAMED-LAMBDA) (,name ,@vars)
+                              ,@body)))
+                     ,name)
+                    ,@vals))
+                 ((letrec*)
+                  `((,(rename 'LETREC*)
+                     ((,name (,(rename 'NAMED-LAMBDA) (,name ,@vars)
+                              ,@body)))
+                     ,name)
+                    ,@vals))
+                 (else (error "Unrecognized named-let-strategy: " named-let-strategy))))))
           ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
            `(,keyword:let ,@(cdr (normalize-let-bindings form))))
           (else

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index e0ea9a417dc132d4a13f2e52eaffd82d1d4c8dfb..a2d3a91837eb8d2e4b8c205998d50345d57ca413 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -2,8 +2,8 @@
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
-    Technology
+    2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
+    of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -25,6 +25,7 @@ USA.
 |#
 
 ;;;; MIT/GNU Scheme Syntax
+;;; package: (runtime syntax mit)
 
 (declare (usual-integrations))
 \f
@@ -197,6 +198,8 @@ USA.
   (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form)
   (let* ((binding-environment
          (make-internal-syntactic-environment environment))
+        (value-environment
+         (make-internal-syntactic-environment binding-environment))
         (body-environment
          (make-internal-syntactic-environment binding-environment)))
     (for-each (let ((item (make-reserved-name-item)))
@@ -206,11 +209,31 @@ USA.
                                                item)))
              (cadr form))
     (classify/let-like form
-                      binding-environment
+                      value-environment
                       binding-environment
                       body-environment
                       variable-binding-theory
                       output/letrec)))
+
+(define (classifier:letrec* form environment definition-environment)
+  definition-environment
+  (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form)
+  (let* ((binding-environment
+         (make-internal-syntactic-environment environment))
+        (body-environment
+         (make-internal-syntactic-environment binding-environment)))
+    (for-each (let ((item (make-reserved-name-item)))
+               (lambda (binding)
+                 (syntactic-environment/define binding-environment
+                                               (car binding)
+                                               item)))
+             (cadr form))
+    (classify/let-like form
+                      binding-environment
+                      binding-environment
+                      body-environment
+                      variable-binding-theory
+                      output/letrec*)))
 \f
 (define (classifier:let-syntax form environment definition-environment)
   definition-environment

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 93039f6577b62a45649e4a1dc3deb718dddc0fb7..7159dab8619558ab73d1eb497d7a1939c3bd1593 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4694,6 +4694,7 @@ USA.
          output/lambda
          output/let
          output/letrec
+         output/letrec*
          output/local-declare
          output/named-lambda
          output/post-process-expression
@@ -4737,6 +4738,7 @@ USA.
          classifier:er-macro-transformer
          classifier:let-syntax
          classifier:letrec
+         classifier:letrec*
          classifier:letrec-syntax
          classifier:local-declare
          classifier:non-hygienic-macro-transformer

diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm
index 10df021ce9d5f50155d5aeb3549b128a03662a97..8a2d96502fc187f14580912c3923f5ba3de3edeb 100644 (file)
--- a/src/runtime/syntax-definitions.scm
+++ b/src/runtime/syntax-definitions.scm
@@ -25,6 +25,7 @@ USA.
 |#
 
 ;;;; Code to install syntax keywords in global environment
+;;; package: (runtime syntax definitions)
 
 (declare (usual-integrations))
 \f
@@ -45,6 +46,7 @@ USA.
   (define-classifier 'ER-MACRO-TRANSFORMER classifier:er-macro-transformer)
   (define-classifier 'LET-SYNTAX classifier:let-syntax)
   (define-classifier 'LETREC classifier:letrec)
+  (define-classifier 'LETREC* classifier:letrec*)
   (define-classifier 'LETREC-SYNTAX classifier:letrec-syntax)
   (define-classifier 'LOCAL-DECLARE classifier:local-declare)
   (define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER

diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index a8ee5d5b91011f1d83bf04ca45a167e582587f83..7cfd678d8453d91ff4793531c61bace545a0e384 100644 (file)
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -2,8 +2,8 @@
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
-    Technology
+    2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
+    of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -25,6 +25,7 @@ USA.
 |#
 
 ;;;; Syntaxer Output Interface
+;;; package: (runtime syntax output)
 
 (declare (usual-integrations))
 \f
@@ -89,14 +90,34 @@ USA.
   (output/combination (output/named-lambda lambda-tag:let names body) values))
 
 (define (output/letrec names values body)
-  (output/let '() '()
-             (make-sequence
-              (append! (map make-definition names values)
-                       (list
-                        (let ((body (scan-defines body make-open-block)))
-                          (if (open-block? body)
-                              (output/let '() '() body)
-                              body)))))))
+  (let ((temps (map (lambda (name)
+                     (utf8-string->uninterned-symbol
+                      (string-append (symbol-name (identifier->symbol name))
+                                     "-value"))) names)))
+    (output/let
+     names (map (lambda (name) name (output/unassigned)) names)
+     (make-sequence
+      (cons (output/let
+            temps values
+            (make-sequence (map (lambda (name temp)
+                                  (make-assignment name (make-variable temp)))
+                                names temps)))
+           (list
+            (let ((body (scan-defines body make-open-block)))
+              (if (open-block? body)
+                  (output/let '() '() body)
+                  body))))))))
+
+(define (output/letrec* names values body)
+  (output/let
+   names (map (lambda (name) name (output/unassigned)) names)
+   (make-sequence
+    (append! (map make-assignment names values)
+            (list
+             (let ((body (scan-defines body make-open-block)))
+               (if (open-block? body)
+                   (output/let '() '() body)
+                   body)))))))
 
 (define (output/body declarations body)
   (scan-defines (let ((declarations (apply append declarations)))