From cc0a2b715ac16099573271c6935a8831a3c46ba7 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 18 Feb 2018 22:32:39 -0800
Subject: [PATCH] Implement spar-macro-transformer.
---
src/runtime/mit-syntax.scm | 6 ++++
src/runtime/runtime.pkg | 5 ++-
src/runtime/syntax-low.scm | 59 ++++++++++++++++++++++-------------
src/runtime/syntax-parser.scm | 23 +++++++-------
4 files changed, 58 insertions(+), 35 deletions(-)
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
--
2.25.1