From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 29 Mar 2018 04:20:34 +0000 (-0700)
Subject: Refactor how keywords are matched.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~162
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=663eb2fde70480dc0d5db01d628dec16f4d753b0;p=mit-scheme.git
Refactor how keywords are matched.
* spar-arg:compare renamed to spar-arg:id=? and second argument is optional,
defaulting to spar-arg:form.
* patterns (noise ...), (noise-keyword ...), and (keyword ...) are eliminated.
* New pattern (ignore-if predicate arg...) ignores a subform if calling the
predicate is satisfied.
* Renamed (value-if ...) to (keep-if ...) with same semantics: keeps a subform
if calling the predicate is satisfied.
* New pattern (value arg) is like (values arg...) but a little clearer.
---
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index a91ff3bf6..ecbae2cc2 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -43,25 +43,25 @@ USA.
(spar-subform
(spar-call-with-values list
(spar-or
- (spar-and (spar-push-subform-if spar-arg:compare 'or spar-arg:form)
+ (spar-and (spar-push-subform-if spar-arg:id=? 'or)
(spar* clause-pattern*)
(spar-match-null))
- (spar-and (spar-push-subform-if spar-arg:compare 'and spar-arg:form)
+ (spar-and (spar-push-subform-if spar-arg:id=? 'and)
(spar* clause-pattern*)
(spar-match-null))
- (spar-and (spar-push-subform-if spar-arg:compare 'not spar-arg:form)
+ (spar-and (spar-push-subform-if spar-arg:id=? 'not)
clause-pattern*
(spar-match-null))))))))
- `((values compare)
+ `((value id=?)
(+ (subform (cons (spar ,clause-pattern)
(* any))))))
-(define (generate-cond-expand compare clauses)
+(define (generate-cond-expand id=? clauses)
(define (process-clauses clauses)
(cond ((not (pair? clauses))
(generate '()))
- ((compare 'else (caar clauses))
+ ((id=? 'else (caar clauses))
(if (pair? (cdr clauses))
(syntax-error "ELSE clause must be last:" clauses))
(generate (cdar clauses)))
@@ -76,15 +76,15 @@ USA.
(define (eval-req req success failure)
(cond ((identifier? req) (if (supported-feature? req) (success) (failure)))
- ((compare 'or (car req)) (eval-or (cdr req) success failure))
- ((compare 'and (car req)) (eval-and (cdr req) success failure))
- ((compare 'not (car req)) (eval-req (cadr req) failure success))
+ ((id=? 'or (car req)) (eval-or (cdr req) success failure))
+ ((id=? 'and (car req)) (eval-and (cdr req) success failure))
+ ((id=? 'not (car req)) (eval-req (cadr req) failure success))
(else (error "Unknown requirement:" req))))
(define (supported-feature? req)
(let ((p
(find (lambda (p)
- (compare (car p) req))
+ (id=? (car p) req))
supported-features)))
(and p
((cdr p)))))
@@ -182,13 +182,13 @@ USA.
(spar-transformer->runtime
(delay
(scons-rule
- `((or (and id (values #f))
+ `((or (and id (value #f))
(subform id any))
- (or (and id (values #f))
- (and ,not (values #f))
+ (or (and id (value #f))
+ (and ,not (value #f))
(subform id (* symbol)))
(or id ,not)
- (* (subform (list symbol id (or id (values #f))))))
+ (* (subform (list symbol id (or id (value #f))))))
(lambda (type-name parent maker-name maker-args pred-name field-specs)
(apply scons-begin
(scons-define type-name
@@ -261,7 +261,7 @@ USA.
(spar-transformer->runtime
(delay
(scons-rule
- `((or id (values #f))
+ `((or id (value #f))
,(let-bindings-pattern)
(+ any))
(lambda (name bindings body-forms)
@@ -391,17 +391,17 @@ USA.
(delay
(scons-rule
(let ((action-pattern
- '(if (noise-keyword =>)
- (list (values =>)
+ '(if (ignore-if id=? =>)
+ (list (value =>)
any)
- (cons (values begin)
+ (cons (value begin)
(+ any)))))
`(any
(* (subform (cons (subform (* any))
,action-pattern)))
- (or (subform (noise-keyword else)
+ (or (subform (ignore-if id=? else)
,action-pattern)
- (values #f))))
+ (value #f))))
(lambda (expr clauses else-clause)
(let ((temp (new-identifier 'key)))
@@ -446,9 +446,9 @@ USA.
(delay
(scons-rule
`((* ,cond-clause-pattern)
- (or (subform (noise-keyword else)
+ (or (subform (ignore-if id=? else)
(+ any))
- (values #f)))
+ (value #f)))
(lambda (clauses else-actions)
(fold-right expand-cond-clause
(if else-actions
@@ -458,12 +458,12 @@ USA.
system-global-environment))
(define cond-clause-pattern
- '(subform (cons (and (not (noise-keyword else))
+ '(subform (cons (and (not (ignore-if id=? else))
any)
- (if (noise-keyword =>)
- (list (values =>)
+ (if (ignore-if id=? =>)
+ (list (value =>)
any)
- (cons (values begin)
+ (cons (value begin)
(* any))))))
(define (expand-cond-clause clause rest)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 322738e95..bcbe35e44 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4551,9 +4551,9 @@ USA.
spar+
spar-append-map-values
spar-arg:close
- spar-arg:compare
spar-arg:form
spar-arg:hist
+ spar-arg:id=?
spar-arg:senv
spar-arg:value
spar-arg:values
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 21eb56463..e2a662311 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -155,10 +155,10 @@ USA.
(cond ((eq? arg spar-arg:form) (%input-form input))
((eq? arg spar-arg:hist) (%input-hist input))
((eq? arg spar-arg:close) (make-closer (%input-closing-senv input)))
- ((eq? arg spar-arg:compare)
- (make-comparer (%input-closing-senv input) senv))
((eq? arg spar-arg:ctx)
(serror-ctx (%input-form input) senv (%input-hist input)))
+ ((eq? arg spar-arg:id=?)
+ (make-comparer (%input-closing-senv input) senv (%input-form input)))
((eq? arg spar-arg:senv) senv)
((eq? arg spar-arg:value) (%output-top output))
((eq? arg spar-arg:values) (%output-all output))
@@ -168,16 +168,17 @@ USA.
(lambda (expr)
(close-syntax expr closing-senv)))
-(define (make-comparer closing-senv use-senv)
- (lambda (reference form)
- (and (identifier? form)
- (identifier=? closing-senv reference use-senv form))))
+(define (make-comparer closing-senv use-senv form)
+ (lambda (reference #!optional comparand)
+ (let ((comparand (if (default-object? comparand) form comparand)))
+ (and (identifier? comparand)
+ (identifier=? closing-senv reference use-senv comparand)))))
(define-deferred spar-arg:form (string->uninterned-symbol ".form."))
(define-deferred spar-arg:hist (string->uninterned-symbol ".hist."))
(define-deferred spar-arg:close (string->uninterned-symbol ".close."))
-(define-deferred spar-arg:compare (string->uninterned-symbol ".compare."))
(define-deferred spar-arg:ctx (string->uninterned-symbol ".ctx."))
+(define-deferred spar-arg:id=? (string->uninterned-symbol ".id=?."))
(define-deferred spar-arg:senv (string->uninterned-symbol ".senv."))
(define-deferred spar-arg:value (string->uninterned-symbol ".value."))
(define-deferred spar-arg:values (string->uninterned-symbol ".values."))
@@ -495,17 +496,12 @@ USA.
('('or * form) (apply $or (map loop (cdr pattern))))
('('and * form) (apply $and (map loop (cdr pattern))))
('('not form) ($not (loop (cadr pattern))))
- ('('noise form)
- ($match-subform eqv? (cadr pattern) spar-arg:form))
- ('('noise-keyword identifier)
- ($match-subform spar-arg:compare
- (cadr pattern)
- spar-arg:form))
- ('('keyword identifier)
- ($and ($match-subform spar-arg:compare
- (cadr pattern)
- spar-arg:form)
- ($push (cadr pattern))))
+ ('('ignore-if + form)
+ (apply $match-subform (map convert-spar-arg (cdr pattern))))
+ ('('keep-if + form)
+ (apply $push-subform-if (map convert-spar-arg (cdr pattern))))
+ ('('value * form)
+ ($push (convert-spar-arg (cadr pattern))))
('('values * form)
(apply $push (map convert-spar-arg (cdr pattern))))
('('value-of + form)
@@ -525,7 +521,7 @@ USA.
((form) spar-arg:form)
((hist) spar-arg:hist)
((close) spar-arg:close)
- ((compare) spar-arg:compare)
+ ((id=?) spar-arg:id=?)
((senv) spar-arg:senv)
((value) spar-arg:value)
(else arg)))