From: Chris Hanson 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)))