Implement first two macros using syntax-parser.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index b964ad87ae7952b76c619d0943ece1448d6c0b75..9b8f6a474f7ff005bdc404fdb65f265d6a0d882b 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -143,16 +143,25 @@ USA.
                     (car p)))
              supported-features))
 \f
-(define-syntax :receive
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare                           ;ignore
-     (if (syntax-match? '(r4rs-bvl form + form) (cdr form))
-        (let ((r-lambda (rename 'LAMBDA)))
-          `(,(rename 'CALL-WITH-VALUES)
-            (,r-lambda () ,(caddr form))
-            (,r-lambda ,(cadr form) ,@(cdddr form))))
-        (ill-formed-syntax form)))))
+(define (get-closing-env)
+  (runtime-environment->syntactic system-global-environment))
+
+(define :receive
+  (spar-transformer->runtime
+   (delay
+     (spar-call-with-values
+        (lambda (close identifiers expr . body-forms)
+          (let ((r-cwv (close 'call-with-values))
+                (r-lambda (close 'lambda)))
+            `(,r-cwv (,r-lambda () ,expr)
+                     (,r-lambda (,@identifiers) ,@body-forms))))
+       (spar-elt)
+       (spar-push spar-arg:close)
+       (spar-push-elt-if r4rs-lambda-list? spar-arg:form)
+       (spar-push-elt spar-arg:form)
+       (spar+ (spar-push-elt spar-arg:form))
+       spar-match-null))
+   get-closing-env))
 
 (define-syntax :define-record-type
   (er-macro-transformer
@@ -208,76 +217,70 @@ USA.
        (else
         (ill-formed-syntax form))))
 \f
-(define named-let-strategy 'internal-definition)
+(define :let
+  (spar-transformer->runtime
+   (delay
+     (spar-call-with-values
+        (lambda (close name bindings . body-forms)
+          (let ((ids (map car bindings))
+                (vals (map cdr bindings)))
+            (if name
+                (generate-named-let close name ids vals body-forms)
+                `((,(close 'named-lambda)
+                   (,scode-lambda-name:let ,@ids)
+                   ,@body-forms)
+                  ,@vals))))
+       (spar-elt)
+       (spar-push spar-arg:close)
+       (spar-or (spar-elt spar-push-id)
+               (spar-push '#f))
+       (spar-elt
+        (spar-push-values
+         (spar* (spar-elt
+                  (spar-call-with-values cons
+                    (spar-elt spar-push-id)
+                    (spar-or (spar-push-elt spar-arg:form)
+                             (spar-push-value unassigned-expression)))
+                  spar-match-null))
+         spar-match-null))
+       (spar+ (spar-push-elt spar-arg:form))
+       spar-match-null))
+   get-closing-env))
 
-(define-syntax :let
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare                           ;ignore
-     (cond ((syntax-match? '(identifier (* (identifier ? expression)) + form)
-                          (cdr form))
-           (let ((name (cadr form))
-                 (bindings (caddr form))
-                 (body (cdddr form)))
-             (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
-           (ill-formed-syntax form))))))
-
-(define (normalize-let-bindings form)
-  `(,(car form) ,(map (lambda (binding)
-                       (if (pair? (cdr binding))
-                           binding
-                           (list (car binding) (unassigned-expression))))
-                     (cadr form))
-               ,@(cddr form)))
+(define named-let-strategy 'internal-definition)
 
+(define (generate-named-let close name ids vals body-forms)
+  (let ((proc `(,(close 'named-lambda) (,name ,@ids) ,@body-forms)))
+    (case named-let-strategy
+      ((internal-definition)
+       `((,(close 'let) ()
+         (,(close 'define) ,name ,proc)
+         ,name)
+        ,@vals))
+      ((letrec)
+       `((,(close 'letrec) ((,name ,proc)) ,name)
+        ,@vals))
+      ((letrec*)
+       `((,(close 'letrec*) ((,name ,proc)) ,name)
+        ,@vals))
+      ((fixed-point)
+       (let ((iter (new-identifier 'iter))
+            (kernel (new-identifier 'kernel))
+            (temps (map new-identifier ids))
+            (r-lambda (close 'lambda))
+            (r-declare (close 'declare)))
+        `((,r-lambda (,kernel)
+                     (,kernel ,kernel ,@vals))
+          (,r-lambda (,iter ,@ids)
+                     ((,r-lambda (,name)
+                                 (,r-declare (integrate-operator ,name))
+                                 ,@body-forms)
+                      (,r-lambda ,temps
+                                 (,r-declare (integrate ,@temps))
+                                 (,iter ,iter ,@temps)))))))
+      (else
+       (error "Unrecognized strategy:" named-let-strategy)))))
+\f
 (define-syntax :let*
   (er-macro-transformer
    (lambda (form rename compare)

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 2715064804ddaea0c3f39da2c6f691a82443b108..7d6ee8000887dd3b2dc4b194c6f4b3fe6cb30d59 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -237,30 +237,6 @@ USA.
 \f
 ;;;; LET-like
 
-(define keyword:let
-  (spar-classifier->keyword
-   (delay
-     (spar-call-with-values
-        (lambda (bindings body senv)
-          (let* ((frame-senv (make-internal-senv senv))
-                 (ids
-                  (map (lambda (b)
-                         (bind-variable (car b) frame-senv))
-                       bindings)))
-            (let-item ids
-                      (map cdr bindings)
-                      (body-item (body frame-senv)))))
-       (spar-elt)
-       (spar-elt
-        (spar-push-values
-          (spar*
-            (spar-call-with-values cons
-              (spar-elt (spar-elt spar-push-id)
-                        (spar-elt spar-push-classified)
-                        spar-match-null))))
-        spar-match-null)
-       spar-push-body))))
-
 (define spar-promise:let-syntax
   (delay
     (spar-call-with-values

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b371eb8a942f2090ef28e1278b8e5783035e0c19..13e8a662ff2d832bbf3fb7ff886a0886a423ad09 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4647,7 +4647,6 @@ USA.
   (export (runtime mit-macros)
          keyword:access
          keyword:define
-         keyword:let
          keyword:let-syntax
          keyword:unassigned
          keyword:unspecific))