From: Chris Hanson Date: Sat, 24 Mar 2018 05:00:08 +0000 (-0700) Subject: Simplify spars pattern language. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~185 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=028b41b462d778bb7e4334565767ee8b8b2060ef;p=mit-scheme.git Simplify spars pattern language. Also change some of the terms to be clearer: I'm anticipating how the documentation will read. --- diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index b72c3428d..a3bfb6731 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -147,7 +147,7 @@ USA. (define :receive (spar-transformer->runtime (delay - (scons-rule '(r4rs-bvl expr (list (+ form))) + (scons-rule `(,r4rs-lambda-list? any (list (+ any))) (lambda (bvl expr body-forms) (scons-call 'call-with-values (scons-lambda '() expr) @@ -158,12 +158,12 @@ USA. (spar-transformer->runtime (delay (scons-rule - '((or (seq id (values #f)) - (elt id expr)) - (or (seq #f (values #f)) - (seq id (values #f)) + `((or (and id (values #f)) + (elt id any)) + (or (and id (values #f)) + (and ,not (values #f)) (elt id (list (* symbol)))) - (or #f id) + (or id ,not) (list (* (list (elt symbol id (or id (values #f))))))) (lambda (type-name parent maker-name maker-args pred-name field-specs) (apply scons-begin @@ -205,10 +205,7 @@ USA. (spar-transformer->runtime (delay (spar-or - (scons-rule - `(id - (or expr - (value-of ,unassigned-expression))) + (scons-rule `(id ,(optional-value-pattern)) (lambda (name value) (scons-call keyword:define name value))) (scons-rule @@ -216,7 +213,7 @@ USA. ,(spar-elt (spar-push-elt-if identifier? spar-arg:form) (spar-push-if mit-lambda-list? spar-arg:form))) - (list (+ form))) + (list (+ any))) (lambda (name bvl body-forms) (scons-define name (apply scons-named-lambda (cons name bvl) body-forms)))) @@ -225,11 +222,14 @@ USA. ,(spar-elt (spar-push-elt spar-arg:form) (spar-push-if mit-lambda-list? spar-arg:form))) - (list (+ form))) + (list (+ any))) (lambda (nested bvl body-forms) (scons-define nested (apply scons-lambda bvl body-forms)))))) system-global-environment)) + +(define (optional-value-pattern) + `(or any (value-of ,unassigned-expression))) (define :let (spar-transformer->runtime @@ -237,7 +237,7 @@ USA. (scons-rule `((or id (values #f)) ,(let-bindings-pattern) - (list (+ form))) + (list (+ any))) (lambda (name bindings body-forms) (let ((ids (map car bindings)) (vals (map cadr bindings))) @@ -251,10 +251,7 @@ USA. system-global-environment)) (define (let-bindings-pattern) - `(elt (list - (* (elt (list id - (or expr - (value-of ,unassigned-expression)))))))) + `(elt (list (* (elt (list id ,(optional-value-pattern))))))) (define named-let-strategy 'internal-definition) @@ -296,7 +293,7 @@ USA. (delay (scons-rule `(,(let-bindings-pattern) - (list (+ form))) + (list (+ any))) (lambda (bindings body-forms) (expand-let* scons-let bindings body-forms)))) system-global-environment)) @@ -305,8 +302,8 @@ USA. (spar-transformer->runtime (delay (scons-rule - '((elt (list (* (elt (list id expr))))) - (list (+ form))) + '((elt (list (* (elt (list id any))))) + (list (+ any))) (lambda (bindings body-forms) (expand-let* scons-let-syntax bindings body-forms)))) system-global-environment)) @@ -324,7 +321,7 @@ USA. (delay (scons-rule `(,(let-bindings-pattern) - (list (+ form))) + (list (+ any))) (lambda (bindings body-forms) (let* ((ids (map car bindings)) (vals (map cadr bindings)) @@ -343,7 +340,7 @@ USA. (delay (scons-rule `(,(let-bindings-pattern) - (list (+ form))) + (list (+ any))) (lambda (bindings body-forms) (let ((ids (map car bindings)) (vals (map cadr bindings))) @@ -357,7 +354,7 @@ USA. (define :and (spar-transformer->runtime (delay - (scons-rule '((list (* expr))) + (scons-rule '((list (* any))) (lambda (exprs) (if (pair? exprs) (let loop ((exprs exprs)) diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index 868f44fa9..40a264e0b 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -453,8 +453,8 @@ USA. (define (make-pattern-compiler expr? caller) (call-with-constructors expr? (lambda (:* :+ :call :close :compare :cons :elt :eqv? :form :hist :id? :list - :match-elt :match-null :mit-bvl? :not :opt :or :push :push-elt - :push-elt-if :push-value :r4rs-bvl? :senv :seq :symbol? :value) + :match-elt :match-null :opt :or :push :push-elt :push-elt-if + :push-value :senv :seq :symbol? :value) (define (loop pattern) (let-syntax @@ -467,20 +467,17 @@ USA. ,@(cdr rule))) (cdr form)) (else (bad-pattern pattern))))))) - (rules (''symbol (:push-elt-if (:symbol?) (:form))) - ('(or 'identifier 'id) (:push-elt-if (:id?) (:form))) - ('(or 'form 'expr) (:push-elt (:form))) - (''r4rs-bvl (:push-elt-if (:r4rs-bvl?) (:form))) - (''mit-bvl (:push-elt-if (:mit-bvl?) (:form))) - (''ignore (:elt)) - (not (:push-elt-if (:not) (:form))) + (rules (''ignore (:elt)) + (''any (:push-elt (:form))) + (''id (:push-elt-if (:id?) (:form))) + (''symbol (:push-elt-if (:symbol?) (:form))) (procedure? (:push-elt-if pattern (:form))) ('('spar form) (cadr pattern)) ('('* * form) (apply :* (map loop (cdr pattern)))) ('('+ * form) (apply :+ (map loop (cdr pattern)))) ('('? * form) (apply :opt (map loop (cdr pattern)))) ('('or * form) (apply :or (map loop (cdr pattern)))) - ('('seq * form) (apply :seq (map loop (cdr pattern)))) + ('('and * form) (apply :seq (map loop (cdr pattern)))) ('('quote form) (:match-elt (:eqv?) (cadr pattern) (:form))) ('('keyword identifier) (:match-elt (:compare) (cadr pattern) (:form))) @@ -556,15 +553,12 @@ USA. (const 'list list) (proc 'spar-match-elt spar-match-elt) (proc 'spar-match-null spar-match-null) - (const 'mit-lambda-list? mit-lambda-list?) - (const 'not not) (flat-proc 'spar-opt spar-opt) (proc 'spar-or spar-or) (proc 'spar-push spar-push) (proc 'spar-push-elt spar-push-elt) (proc 'spar-push-elt-if spar-push-elt-if) (proc 'spar-push-value spar-push-value) - (const 'r4rs-lambda-list? r4rs-lambda-list?) (const 'spar-arg:senv spar-arg:senv) (flat-proc 'spar-seq spar-seq) (const 'symbol? symbol?)