From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Feb 2018 06:32:39 +0000 (-0800)
Subject: Implement spar-macro-transformer.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~236
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cc0a2b715ac16099573271c6935a8831a3c46ba7;p=mit-scheme.git

Implement spar-macro-transformer.
---

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 19fc2ef03..b4e69ab0b 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -61,6 +61,12 @@ USA.
   (classifier->runtime
    (transformer-classifier er-macro-transformer->keyword-item
 			   'er-macro-transformer->expander)))
+
+(define :spar-macro-transformer
+  ;; "Syntax PARser" transformer
+  (classifier->runtime
+   (transformer-classifier spar-macro-transformer->keyword-item
+			   'spar-macro-transformer->expander)))
 
 ;;;; Core primitives
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e9f1b80c5..edfa5e368 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4452,6 +4452,7 @@ USA.
 	  er-macro-transformer->expander
 	  rsc-macro-transformer->expander
 	  sc-macro-transformer->expander
+	  spar-macro-transformer->expander
 	  syntactic-keyword->item)
   (export (runtime syntax)
 	  classifier->runtime
@@ -4462,7 +4463,8 @@ USA.
 	  keyword-item-impl
 	  keyword-item?
 	  rsc-macro-transformer->keyword-item
-	  sc-macro-transformer->keyword-item))
+	  sc-macro-transformer->keyword-item
+	  spar-macro-transformer->keyword-item))
 
 (define-package (runtime syntax items)
   (files "syntax-items")
@@ -4639,6 +4641,7 @@ USA.
 	  (rsc-macro-transformer :rsc-macro-transformer)
 	  (sc-macro-transformer :sc-macro-transformer)
 	  (set! :set!)
+	  (spar-macro-transformer :spar-macro-transformer)
 	  (the-environment :the-environment))
   (export (runtime mit-macros)
 	  keyword:access
diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm
index 17d12348c..c05c9d809 100644
--- a/src/runtime/syntax-low.scm
+++ b/src/runtime/syntax-low.scm
@@ -38,44 +38,40 @@ USA.
   (expander-item (sc-wrapper transformer (runtime-getter env))
 		 expr))
 
-(define (rsc-macro-transformer->expander transformer env #!optional expr)
-  (expander-item (rsc-wrapper transformer (runtime-getter env))
-		 expr))
-
-(define (er-macro-transformer->expander transformer env #!optional expr)
-  (expander-item (er-wrapper transformer (runtime-getter env))
-		 expr))
-
 (define (sc-macro-transformer->keyword-item transformer closing-senv expr)
   (expander-item (sc-wrapper transformer (lambda () closing-senv))
 		 expr))
 
-(define (rsc-macro-transformer->keyword-item transformer closing-senv expr)
-  (expander-item (rsc-wrapper transformer (lambda () closing-senv))
-		 expr))
-
-(define (er-macro-transformer->keyword-item transformer closing-senv expr)
-  (expander-item (er-wrapper transformer (lambda () closing-senv))
-		 expr))
-
-(define (runtime-getter env)
-  (lambda ()
-    (runtime-environment->syntactic env)))
-
 (define (sc-wrapper transformer get-closing-senv)
   (lambda (form use-senv)
     (close-syntax (transformer form use-senv)
 		  (get-closing-senv))))
 
+(define (rsc-macro-transformer->expander transformer env #!optional expr)
+  (expander-item (rsc-wrapper transformer (runtime-getter env))
+		 expr))
+
+(define (rsc-macro-transformer->keyword-item transformer closing-senv expr)
+  (expander-item (rsc-wrapper transformer (lambda () closing-senv))
+		 expr))
+
 (define (rsc-wrapper transformer get-closing-senv)
   (lambda (form use-senv)
     (close-syntax (transformer form (get-closing-senv))
 		  use-senv)))
 
-(define (er-wrapper transformer get-closing-env)
+(define (er-macro-transformer->expander transformer env #!optional expr)
+  (expander-item (er-wrapper transformer (runtime-getter env))
+		 expr))
+
+(define (er-macro-transformer->keyword-item transformer closing-senv expr)
+  (expander-item (er-wrapper transformer (lambda () closing-senv))
+		 expr))
+
+(define (er-wrapper transformer get-closing-senv)
   (lambda (form use-senv)
     (close-syntax (transformer form
-			       (make-er-rename (get-closing-env))
+			       (make-er-rename (get-closing-senv))
 			       (make-er-compare use-senv))
 		  use-senv)))
 
@@ -86,6 +82,25 @@ USA.
 (define (make-er-compare use-senv)
   (lambda (x y)
     (identifier=? use-senv x use-senv y)))
+
+(define (spar-macro-transformer->expander spar env expr)
+  (keyword-item (spar-wrapper spar (runtime-getter env))
+		expr))
+
+(define (spar-macro-transformer->keyword-item spar closing-senv expr)
+  (keyword-item (spar-wrapper spar (lambda () closing-senv))
+		expr))
+
+(define (spar-wrapper spar get-closing-senv)
+  (lambda (form senv hist)
+    (reclassify (close-syntax ((spar->classifier spar) form senv hist)
+			      (get-closing-senv))
+		senv
+		hist)))
+
+(define (runtime-getter env)
+  (lambda ()
+    (runtime-environment->syntactic env)))
 
 ;;; Keyword items represent syntactic keywords.
 
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index a8d98d037..4da6494eb 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -65,18 +65,17 @@ USA.
 ;;;     (failure)
 
 (define (spar->classifier spar)
-  (keyword-item
-   (lambda (form senv hist)
-     (spar (%new-input form hist)
-	   senv
-	   (%new-output)
-	   (lambda (input senv output failure)
-	     (declare (ignore senv failure))
-	     (if (%input-null? input)
-		 (error "Rule failed to match entire form."))
-	     (output 'get-only))
-	   (lambda ()
-	     (serror form senv hist "Ill-formed syntax:" form))))))
+  (lambda (form senv hist)
+    (spar (%new-input form hist)
+	  senv
+	  (%new-output)
+	  (lambda (input senv output failure)
+	    (declare (ignore senv failure))
+	    (if (%input-null? input)
+		(error "Rule failed to match entire form."))
+	    (output 'get-only))
+	  (lambda ()
+	    (serror form senv hist "Ill-formed syntax:" form)))))
 
 ;;;; Inputs and outputs