From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 22 Mar 2018 07:10:25 +0000 (-0700)
Subject: More macros converted to new model, plus a lot of fixes and tweaks.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~189
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6d958ebd33a6dc257bb4a448703a1c470583c128;p=mit-scheme.git

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 bc211ab9a..cee09bff8 100644
--- 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))
 
-(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)))))
 
-(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))
 
-(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))
 
 (define-syntax :case
   (er-macro-transformer
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7e4550e9a..b6091d458 100644
--- 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 5859ad150..3727f9bdd 100644
--- a/src/runtime/syntax-constructor.scm
+++ b/src/runtime/syntax-constructor.scm
@@ -29,7 +29,7 @@ USA.
 
 (declare (usual-integrations))
 
-(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)))))
 
 (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 2b4c38d5c..7d90801f5 100644
--- 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)