From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Mar 2018 03:38:53 +0000 (-0700)
Subject: Simplify spar interface a bit more.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~200
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d3036ed946d60d5fee5d85784ab7985862c2c159;p=mit-scheme.git
Simplify spar interface a bit more.
---
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 9ae619f4c..ade5c1e71 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -238,13 +238,13 @@ USA.
,@vals))))
(spar-elt)
(spar-push spar-arg:close)
- (spar-or (spar-elt spar-push-id)
+ (spar-or (spar-push-elt-if identifier? spar-arg:form)
(spar-push '#f))
(spar-elt
- (spar-push-values
+ (spar-call-with-values list
(spar* (spar-elt
(spar-call-with-values cons
- (spar-elt spar-push-id)
+ (spar-push-elt-if identifier? spar-arg:form)
(spar-or (spar-push-elt spar-arg:form)
(spar-push-value unassigned-expression)))
spar-match-null))
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 7d6ee8000..c9b6a4822 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -190,7 +190,7 @@ USA.
(syntax-defn-item id (keyword-item-expr item))
(seq-item '()))))
(spar-elt)
- (spar-elt spar-push-id)
+ (spar-push-elt-if identifier? spar-arg:form)
(spar-push spar-arg:senv)
(spar-elt
spar-push-classified
@@ -208,9 +208,7 @@ USA.
(lambda (bvl body senv)
(assemble-lambda-item scode-lambda-name:unnamed bvl body senv))
(spar-elt)
- (spar-elt
- (spar-match mit-lambda-list? spar-arg:form)
- (spar-push spar-arg:form))
+ (spar-push-elt-if mit-lambda-list? spar-arg:form)
spar-push-body))))
(define :named-lambda
@@ -221,9 +219,8 @@ USA.
(assemble-lambda-item (identifier->symbol name) bvl body senv))
(spar-elt)
(spar-elt
- (spar-elt spar-push-id)
- (spar-match mit-lambda-list? spar-arg:form)
- (spar-push spar-arg:form))
+ (spar-push-elt-if identifier? spar-arg:form)
+ (spar-push-if mit-lambda-list? spar-arg:form))
spar-push-body))))
(define (assemble-lambda-item name bvl body senv)
@@ -248,10 +245,10 @@ USA.
(seq-item (body frame-senv))))
(spar-elt)
(spar-elt
- (spar-push-values
+ (spar-call-with-values list
(spar*
(spar-call-with-values cons
- (spar-elt (spar-elt spar-push-id)
+ (spar-elt (spar-push-elt-if identifier? spar-arg:form)
(spar-elt spar-push-classified)
spar-match-null))))
spar-match-null)
@@ -282,10 +279,10 @@ USA.
(seq-item (body frame-senv))))
(spar-elt)
(spar-elt
- (spar-push-values
+ (spar-call-with-values list
(spar*
(spar-call-with-values cons
- (spar-elt (spar-elt spar-push-id)
+ (spar-elt (spar-push-elt-if identifier? spar-arg:form)
(spar-elt spar-push-open-classified)
spar-match-null))))
spar-match-null)
@@ -304,7 +301,7 @@ USA.
(delay
(spar-call-with-values access-item
(spar-elt)
- (spar-elt spar-push-id)
+ (spar-push-elt-if identifier? spar-arg:form)
(spar-elt spar-push-classified)
spar-match-null))))
@@ -360,15 +357,13 @@ USA.
(spar-elt)
(spar-push spar-arg:senv)
(spar-push spar-arg:hist)
- (spar-push-values
- (spar*
- (spar-elt
- (spar-match (lambda (form)
- (and (pair? form)
- (identifier? (car form))
- (list? (cdr form))))
- spar-arg:form)
- (spar-push spar-arg:form))))
+ (spar-call-with-values list
+ (spar*
+ (spar-push-elt-if (lambda (form)
+ (and (pair? form)
+ (identifier? (car form))
+ (list? (cdr form))))
+ spar-arg:form)))
spar-match-null))))
(define (classify-id id senv hist)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index ed7142cab..b2d1f5b72 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4572,10 +4572,8 @@ USA.
spar-push-body
spar-push-elt
spar-push-elt-if
- spar-push-id
spar-push-if
spar-push-value
- spar-push-values
spar-repeat
spar-seq
spar-succeed
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 4828c30e6..c5f834746 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -336,11 +336,14 @@ USA.
failure)
(failure)))))
+(define (spar-match-elt predicate . args)
+ (spar-elt (apply spar-match predicate args)))
+
(define (spar-push-elt . args)
(spar-elt (apply spar-push args)))
-(define (spar-push-elt-if . args)
- (spar-elt (apply spar-push-if args)))
+(define (spar-push-elt-if predicate . args)
+ (spar-elt (apply spar-push-if predicate args)))
(define-deferred spar-match-null
(spar-match null? spar-arg:form))
@@ -380,20 +383,9 @@ USA.
spar-arg:form
spar-arg:senv
spar-arg:hist))
-
-(define-deferred spar-push-id
- (spar-seq
- (spar-match identifier? spar-arg:form)
- (spar-push spar-arg:form)
- spar-discard-form))
;;;; Value combinators
-(define (spar-push-values . spars)
- (%with-output (lambda (output output*)
- (%output-push output (%output-all output*)))
- spars))
-
(define (spar-encapsulate-values procedure . spars)
(%encapsulate procedure spars))