More macros converted to new model, plus a lot of fixes and tweaks.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index bc211ab9adc315ce5ab6601b591623b1563e15d9..cee09bff858db11d09d73d689657da4d9daf5ba6 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -147,7 +147,7 @@ USA.
 (define :receive
   (spar-transformer->runtime
    (delay
-     (spar-top-level '(r4rs-bvl expr (list (+ form)))
+     (scons-rule '(r4rs-bvl expr (list (+ form)))
        (lambda (bvl expr body-forms)
         (scons-call 'call-with-values
                     (scons-lambda '() expr)
@@ -157,15 +157,14 @@ USA.
 (define :define-record-type
   (spar-transformer->runtime
    (delay
-     (spar-top-level
-        '((or (seq id (push #f))
+     (scons-rule
+        '((or (seq id (values #f))
               (elt id expr))
-          (or (seq '#f (push #f #f))
-              (seq id (push #f))
+          (or (seq #f (values #f))
+              (seq id (values #f))
               (elt id (list (* symbol))))
-          (or (seq '#f (push #f))
-              id)
-          (list (* (list (elt symbol id (or id (push #f)))))))
+          (or #f id)
+          (list (* (list (elt symbol id (or id (values #f)))))))
        (lambda (type-name parent maker-name maker-args pred-name field-specs)
         (apply scons-begin
                (scons-define type-name
@@ -202,12 +201,35 @@ USA.
                            field-specs)))))
    system-global-environment))
 \f
-(define-syntax :define
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare                           ;ignore
-     (receive (name value) (parse-define-form form rename)
-       `(,keyword:define ,name ,value)))))
+(define :define
+  (spar-transformer->runtime
+   (delay
+     (spar-or
+       (scons-rule
+          `(id
+            (or expr
+                (value-of ,unassigned-expression)))
+        (lambda (name value)
+          (scons-call keyword:define name value)))
+       (scons-rule
+          `((spar
+             ,(spar-elt
+                (spar-push-elt-if identifier? spar-arg:form)
+                (spar-push-if mit-lambda-list? spar-arg:form)))
+            (list (+ form)))
+        (lambda (name bvl body-forms)
+          (scons-define name
+            (apply scons-named-lambda (cons name bvl) body-forms))))
+       (scons-rule
+          `((spar
+             ,(spar-elt
+                (spar-push-elt spar-arg:form)
+                (spar-push-if mit-lambda-list? spar-arg:form)))
+            (list (+ form)))
+        (lambda (nested bvl body-forms)
+          (scons-define nested
+            (apply scons-lambda bvl body-forms))))))
+   system-global-environment))
 
 (define (parse-define-form form rename)
   (cond ((syntax-match? '((datum . mit-bvl) + form) (cdr form))
@@ -228,19 +250,13 @@ USA.
 (define :let
   (spar-transformer->runtime
    (delay
-     (spar-top-level
-        `((or id (push #f))
-          (elt
-           (list
-            (*
-             (elt
-              (cons id
-                    (or expr
-                        (push-value ,unassigned-expression)))))))
+     (scons-rule
+        `((or id (values #f))
+          ,(let-bindings-pattern)
           (list (+ form)))
        (lambda (name bindings body-forms)
         (let ((ids (map car bindings))
-              (vals (map cdr bindings)))
+              (vals (map cadr bindings)))
           (if name
               (generate-named-let name ids vals body-forms)
               (apply scons-call
@@ -250,6 +266,12 @@ USA.
                      vals))))))
    system-global-environment))
 
+(define (let-bindings-pattern)
+  `(elt (list
+        (* (elt (list id
+                      (or expr
+                          (value-of ,unassigned-expression))))))))
+
 (define named-let-strategy 'internal-definition)
 
 (define (generate-named-let name ids vals body-forms)
@@ -285,88 +307,83 @@ USA.
       (else
        (error "Unrecognized strategy:" named-let-strategy)))))
 \f
-(define-syntax :let*
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare                   ;ignore
-     (expand/let* form (rename 'LET)))))
+(define :let*
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+        `(,(let-bindings-pattern)
+          (list (+ form)))
+       (lambda (bindings body-forms)
+        (expand-let* scons-let bindings body-forms))))
+   system-global-environment))
 
-(define-syntax :let*-syntax
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare                   ;ignore
-     (expand/let* form (rename 'LET-SYNTAX)))))
-
-(define (expand/let* form let-keyword)
-  (syntax-check '(_ (* datum) + form) form)
-  (let ((bindings (cadr form))
-       (body (cddr form)))
-    (if (pair? bindings)
-       (let loop ((bindings bindings))
-         (if (pair? (cdr bindings))
-             `(,let-keyword (,(car bindings)) ,(loop (cdr bindings)))
-             `(,let-keyword ,bindings ,@body)))
-       `(,let-keyword ,bindings ,@body))))
-
-(define-syntax :letrec
-  (er-macro-transformer
-   (lambda (form rename compare)
-     (declare (ignore compare))
-     (syntax-check '(_ (* (identifier ? expression)) + form) form)
-     (let ((bindings (cadr form))
-          (r-lambda (rename 'LAMBDA))
-          (r-named-lambda (rename 'NAMED-LAMBDA))
-          (r-set!   (rename 'SET!)))
-       (let ((temps
-             (map (lambda (binding)
-                    (make-synthetic-identifier
-                     (identifier->symbol (car binding))))
-                  bindings)))
-        `((,r-named-lambda (,scode-lambda-name:unnamed ,@(map car bindings))
-                           ((,r-lambda ,temps
-                                       ,@(map (lambda (binding temp)
-                                                `(,r-set! ,(car binding)
-                                                          ,temp))
-                                              bindings
-                                              temps))
-                            ,@(map cadr bindings))
-                           ((,r-lambda () ,@(cddr form))))
-          ,@(map (lambda (binding)
-                   (declare (ignore binding))
-                   (unassigned-expression)) bindings)))))))
-
-(define-syntax :letrec*
-  (er-macro-transformer
-   (lambda (form rename compare)
-     (declare (ignore compare))
-     (syntax-check '(_ (* (identifier ? expression)) + form) form)
-     (let ((bindings (cadr form))
-          (r-lambda (rename 'LAMBDA))
-          (r-named-lambda (rename 'NAMED-LAMBDA))
-          (r-set!   (rename 'SET!)))
-       `((,r-named-lambda (,scode-lambda-name:unnamed ,@(map car bindings))
-                         ,@(map (lambda (binding)
-                                  `(,r-set! ,@binding)) bindings)
-                         ((,r-lambda () ,@(cddr form))))
-        ,@(map (lambda (binding)
-                 (declare (ignore binding))
-                 (unassigned-expression)) bindings))))))
+(define :let*-syntax
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+        '((elt (list (* (elt (list id expr)))))
+          (list (+ form)))
+       (lambda (bindings body-forms)
+        (expand-let* scons-let-syntax bindings body-forms))))
+   system-global-environment))
+
+(define (expand-let* scons-let bindings body-forms)
+  (if (pair? bindings)
+      (let loop ((bindings bindings))
+       (if (pair? (cdr bindings))
+           (scons-let (list (car bindings)) (loop (cdr bindings)))
+           (apply scons-let (list (car bindings)) body-forms)))
+      (apply scons-let '() body-forms)))
+
+(define :letrec
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+        `(,(let-bindings-pattern)
+          (list (+ form)))
+       (lambda (bindings body-forms)
+        (let* ((ids (map car bindings))
+               (vals (map cadr bindings))
+               (temps (map new-identifier ids)))
+          (scons-let (map (lambda (id)
+                            (list id (unassigned-expression)))
+                          ids)
+            (apply scons-let
+                   (map list temps vals)
+                   (map scons-set! ids temps))
+            (scons-call (apply scons-lambda '() body-forms)))))))
+   system-global-environment))
+
+(define :letrec*
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+        `(,(let-bindings-pattern)
+          (list (+ form)))
+       (lambda (bindings body-forms)
+        (let ((ids (map car bindings))
+              (vals (map cadr bindings)))
+          (scons-let (map (lambda (id)
+                            (list id (unassigned-expression)))
+                          ids)
+            (apply scons-begin (map scons-set! ids vals))
+            (scons-call (apply scons-lambda '() body-forms)))))))
+   system-global-environment))
 \f
-(define-syntax :and
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare                           ;ignore
-     (syntax-check '(_ * expression) form)
-     (let ((operands (cdr form)))
-       (if (pair? operands)
-          (let ((if-keyword (rename 'IF)))
-            (let loop ((operands operands))
-              (if (pair? (cdr operands))
-                  `(,if-keyword ,(car operands)
-                                ,(loop (cdr operands))
-                                #F)
-                  (car operands))))
-          `#T)))))
+(define :and
+  (spar-transformer->runtime
+   (delay
+     (scons-rule '((list (* expr)))
+       (lambda (exprs)
+        (if (pair? exprs)
+            (let loop ((exprs exprs))
+              (if (pair? (cdr exprs))
+                  (scons-if (car exprs)
+                            (loop (cdr exprs))
+                            #f)
+                  (car exprs)))
+            #t))))
+   system-global-environment))
 \f
 (define-syntax :case
   (er-macro-transformer

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7e4550e9a8bbf8a1be711df0c7a64e79bd327df8..b6091d458471a342197a701b86a0f9bbec9b28de 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4604,6 +4604,7 @@ USA.
          scons-if
          scons-lambda
          scons-let
+         scons-let-syntax
          scons-letrec
          scons-letrec*
          scons-named-lambda
@@ -4611,8 +4612,8 @@ USA.
          scons-or
          scons-quote
          scons-quote-identifier
-         scons-set!
-         spar-top-level))
+         scons-rule
+         scons-set!))
 
 (define-package (runtime syntax rename)
   (files "syntax-rename")

diff --git a/src/runtime/syntax-constructor.scm b/src/runtime/syntax-constructor.scm
index 5859ad150ece1016cd29f3e54de21eff96e55749..3727f9bdd0e9e2488f28a93c74fc908e7884d5ce 100644 (file)
--- a/src/runtime/syntax-constructor.scm
+++ b/src/runtime/syntax-constructor.scm
@@ -29,7 +29,7 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (spar-top-level pattern procedure)
+(define (scons-rule pattern procedure)
   (spar-call-with-values
       (lambda (close . args)
        (close-part close (apply procedure args)))
@@ -37,9 +37,14 @@ USA.
     (spar-push spar-arg:close)
     (pattern->spar pattern)))
 
+(define-record-type <open-expr>
+    (make-open-expr procedure)
+    open-expr?
+  (procedure open-expr-procedure))
+
 (define (close-part close part)
-  (if (procedure? part)
-      (part close)
+  (if (open-expr? part)
+      ((open-expr-procedure part) close)
       part))
 
 (define (close-parts close parts)
@@ -47,82 +52,96 @@ USA.
        parts))
 
 (define (scons-and . exprs)
-  (lambda (close)
-    (cons (close 'and)
-         (close-parts close exprs))))
+  (make-open-expr
+   (lambda (close)
+     (cons (close 'and)
+          (close-parts close exprs)))))
 
 (define (scons-begin . exprs)
-  (lambda (close)
-    (cons (close 'begin)
-         (close-parts close (remove default-object? exprs)))))
+  (make-open-expr
+   (lambda (close)
+     (cons (close 'begin)
+          (close-parts close (remove default-object? exprs))))))
 
 (define (scons-call operator . operands)
-  (lambda (close)
-    (cons (if (identifier? operator)
-             (close operator)
-             (close-part close operator))
-         (close-parts close operands))))
+  (make-open-expr
+   (lambda (close)
+     (cons (if (identifier? operator)
+              (close operator)
+              (close-part close operator))
+          (close-parts close operands)))))
 
 (define (scons-declare . decls)
-  (lambda (close)
-    (cons (close 'declare)
-         decls)))
+  (make-open-expr
+   (lambda (close)
+     (cons (close 'declare)
+          decls))))
 
 (define (scons-define name value)
-  (lambda (close)
-    (list (close 'define)
-         name
-         (close-part close value))))
+  (make-open-expr
+   (lambda (close)
+     (list (close 'define)
+          name
+          (close-part close value)))))
 
 (define (scons-delay expr)
-  (lambda (close)
-    (list (close 'delay)
-         (close-part close expr))))
+  (make-open-expr
+   (lambda (close)
+     (list (close 'delay)
+          (close-part close expr)))))
 
 (define (scons-if predicate consequent alternative)
-  (lambda (close)
-    (list (close 'if)
-         (close-part close predicate)
-         (close-part close consequent)
-         (close-part close alternative))))
+  (make-open-expr
+   (lambda (close)
+     (list (close 'if)
+          (close-part close predicate)
+          (close-part close consequent)
+          (close-part close alternative)))))
 \f
 (define (scons-lambda bvl . body-forms)
-  (lambda (close)
-    (cons* (close 'lambda)
-          bvl
-          (close-parts close body-forms))))
+  (make-open-expr
+   (lambda (close)
+     (cons* (close 'lambda)
+           bvl
+           (close-parts close body-forms)))))
 
 (define (scons-named-lambda bvl . body-forms)
-  (lambda (close)
-    (cons* (close 'named-lambda)
-          bvl
-          (close-parts close body-forms))))
+  (make-open-expr
+   (lambda (close)
+     (cons* (close 'named-lambda)
+           bvl
+           (close-parts close body-forms)))))
 
 (define (scons-or . exprs)
-  (lambda (close)
-    (cons (close 'or)
-         (close-parts close exprs))))
+  (make-open-expr
+   (lambda (close)
+     (cons (close 'or)
+          (close-parts close exprs)))))
 
 (define (scons-quote datum)
-  (lambda (close)
-    (list (close 'quote) datum)))
+  (make-open-expr
+   (lambda (close)
+     (list (close 'quote) datum))))
 
 (define (scons-quote-identifier id)
-  (lambda (close)
-    (list (close 'quote-identifier) id)))
+  (make-open-expr
+   (lambda (close)
+     (list (close 'quote-identifier) id))))
 
 (define (scons-set! name value)
-  (lambda (close)
-    (list (close 'set!)
-         name
-         (close-part close value))))
+  (make-open-expr
+   (lambda (close)
+     (list (close 'set!)
+          name
+          (close-part close value)))))
 
 (define (let-like keyword)
   (lambda (bindings . body-forms)
-    (lambda (close)
-      (cons* (close keyword)
-            (close-bindings close bindings)
-            (close-parts close body-forms)))))
+    (make-open-expr
+     (lambda (close)
+       (cons* (close keyword)
+             (close-bindings close bindings)
+             (close-parts close body-forms))))))
 
 (define (close-bindings close bindings)
   (map (lambda (b)
@@ -130,12 +149,14 @@ USA.
        bindings))
 
 (define scons-let (let-like 'let))
+(define scons-let-syntax (let-like 'let-syntax))
 (define scons-letrec (let-like 'letrec))
 (define scons-letrec* (let-like 'letrec*))
 
 (define (scons-named-let name bindings . body-forms)
-  (lambda (close)
-    (cons* (close 'let)
-          name
-          (close-bindings close bindings)
-          (close-parts close body-forms))))
\ No newline at end of file
+  (make-open-expr
+   (lambda (close)
+     (cons* (close 'let)
+           name
+           (close-bindings close bindings)
+           (close-parts close body-forms)))))
\ No newline at end of file

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 2b4c38d5c05f72785f872c3d6644b20204bcb306..7d90801f5590cc1049b68a6b159be0d6540611ed 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -444,11 +444,13 @@ USA.
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
     (lambda (:* :+ :call :close :cons :elt :eqv? :form :hist :identifier? :list
-               :match-elt :match-null :mit-bvl? :opt :or :push :push-elt
+               :match-elt :match-null :mit-bvl? :not :opt :or :push :push-elt
                :push-elt-if :push-value :r4rs-bvl? :senv :seq :symbol? :value)
 
       (define (loop pattern)
-       (cond ((symbol? pattern)
+       (cond ((not pattern)
+              (:push-elt-if (:not) (:form)))
+             ((symbol? pattern)
               (case pattern
                 ((symbol) (:push-elt-if (:symbol?) (:form)))
                 ((identifier id) (:push-elt-if (:identifier?) (:form)))
@@ -472,15 +474,19 @@ USA.
                                (null? (cddr pattern))))
                      (bad-pattern pattern))
                  (:match-elt (:eqv?) (cadr pattern) (:form)))
-                ((push) (apply :push (map convert-spar-arg (cdr pattern))))
-                ((push-value)
+                ((values) (apply :push (map convert-spar-arg (cdr pattern))))
+                ((value-of)
                  (apply :push-value
                         (cadr pattern)
                         (map convert-spar-arg (cddr pattern))))
                 ((list) (apply :call (:list) (map loop (cdr pattern))))
                 ((cons) (apply :call (:cons) (map loop (cdr pattern))))
                 ((call) (apply :call (cadr pattern) (map loop (cddr pattern))))
-                ((spar) (apply :seq (cdr pattern)))
+                ((spar)
+                 (if (not (and (pair? (cdr pattern))
+                               (null? (cddr pattern))))
+                     (bad-pattern pattern))
+                 (cadr pattern))
                 ((elt)
                  (:elt (apply :seq (map loop (cdr pattern)))
                        (:match-null)))
@@ -546,6 +552,7 @@ USA.
             (proc 'spar-match-elt spar-match-elt)
             (proc 'spar-match-null spar-match-null)
             (const 'mit-lambda-list? mit-lambda-list?)
+            (const 'not not)
             (flat-proc 'spar-opt spar-opt)
             (proc 'spar-or spar-or)
             (proc 'spar-push spar-push)