From: Chris Hanson Date: Thu, 29 Mar 2018 03:48:26 +0000 (-0700) Subject: Rename spar*elt* to spar*subform*. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~164 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9a13206319381508543a2ec9e2ab21edd2c5a7e1;p=mit-scheme.git Rename spar*elt* to spar*subform*. --- diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index fa76f96c5..66da99d40 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -39,17 +39,17 @@ USA. (define clause-pattern (let ((clause-pattern* (lambda args (apply clause-pattern args)))) (spar-or - (spar-push-elt-if identifier? spar-arg:form) - (spar-elt + (spar-push-subform-if identifier? spar-arg:form) + (spar-subform (spar-call-with-values list (spar-or - (spar-and (spar-push-elt-if spar-arg:compare 'or spar-arg:form) + (spar-and (spar-push-subform-if spar-arg:compare 'or spar-arg:form) (spar* clause-pattern*) (spar-match-null)) - (spar-and (spar-push-elt-if spar-arg:compare 'and spar-arg:form) + (spar-and (spar-push-subform-if spar-arg:compare 'and spar-arg:form) (spar* clause-pattern*) (spar-match-null)) - (spar-and (spar-push-elt-if spar-arg:compare 'not spar-arg:form) + (spar-and (spar-push-subform-if spar-arg:compare 'not spar-arg:form) clause-pattern* (spar-match-null)))))))) `((values compare) @@ -236,8 +236,8 @@ USA. (scons-call keyword:define name value))) (scons-rule `((spar - ,(spar-elt - (spar-push-elt-if identifier? spar-arg:form) + ,(spar-subform + (spar-push-subform-if identifier? spar-arg:form) (spar-push-form-if mit-lambda-list? spar-arg:form))) (+ any)) (lambda (name bvl body-forms) @@ -245,8 +245,8 @@ USA. (apply scons-named-lambda (cons name bvl) body-forms)))) (scons-rule `((spar - ,(spar-elt - (spar-push-elt) + ,(spar-subform + (spar-push-subform) (spar-push-form-if mit-lambda-list? spar-arg:form))) (+ any)) (lambda (nested bvl body-forms) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index f9273a826..678b5479e 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -81,20 +81,20 @@ USA. (seq-item ctx (map-in-order (lambda (p) (p)) deferred-items))) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar* (spar-elt spar-push-deferred-classified)) + (spar* (spar-subform spar-push-deferred-classified)) (spar-match-null))))) (define :if (spar-classifier->runtime (delay (spar-call-with-values if-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt spar-push-classified) - (spar-elt spar-push-classified) - (spar-or (spar-elt spar-push-classified) + (spar-subform spar-push-classified) + (spar-subform spar-push-classified) + (spar-or (spar-subform spar-push-classified) (spar-push-value unspecific-item spar-arg:ctx)) (spar-match-null))))) @@ -102,18 +102,18 @@ USA. (spar-classifier->runtime (delay (spar-call-with-values constant-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt (spar-push-value strip-syntactic-closures spar-arg:form)) + (spar-subform (spar-push-value strip-syntactic-closures spar-arg:form)) (spar-match-null))))) (define :quote-identifier (spar-classifier->runtime (delay (spar-call-with-values quoted-id-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt + (spar-subform (spar-match identifier? spar-arg:form) (spar-push-value lookup-identifier spar-arg:form spar-arg:senv) (spar-or (spar-match var-item? spar-arg:value) @@ -132,9 +132,9 @@ USA. (access-item-name lhs-item) (access-item-env lhs-item) rhs-item))) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt + (spar-subform spar-push-classified (spar-or (spar-match (lambda (lhs-item) (or (var-item? lhs-item) @@ -142,7 +142,7 @@ USA. spar-arg:value) (spar-error "Variable required in this context:" spar-arg:form))) - (spar-or (spar-elt spar-push-classified) + (spar-or (spar-subform spar-push-classified) (spar-push-value unassigned-item spar-arg:ctx)) (spar-match-null))))) @@ -154,18 +154,18 @@ USA. (spar-classifier->runtime (delay (spar-call-with-values or-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar* (spar-elt spar-push-classified)) + (spar* (spar-subform spar-push-classified)) (spar-match-null))))) (define :delay (spar-classifier->runtime (delay (spar-call-with-values delay-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt spar-push-deferred-classified) + (spar-subform spar-push-deferred-classified) (spar-match-null))))) ;;;; Definitions @@ -174,12 +174,12 @@ USA. (spar-classifier->keyword (delay (spar-call-with-values defn-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt + (spar-subform (spar-match identifier? spar-arg:form) (spar-push-value bind-variable spar-arg:form spar-arg:senv)) - (spar-elt spar-push-classified) + (spar-subform spar-push-classified) (spar-match-null))))) (define :define-syntax @@ -198,10 +198,10 @@ USA. (senv-top-level? senv)) (syntax-defn-item ctx id (keyword-item-expr item)) (seq-item ctx '())))) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-push-elt-if identifier? spar-arg:form) - (spar-elt + (spar-push-subform-if identifier? spar-arg:form) + (spar-subform spar-push-classified (spar-or (spar-match keyword-item? spar-arg:value) (spar-error "Keyword binding value must be a keyword:" @@ -217,9 +217,9 @@ USA. (lambda (ctx bvl body-ctx body) (assemble-lambda-item ctx scode-lambda-name:unnamed bvl body-ctx body)) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-push-elt-if mit-lambda-list? spar-arg:form) + (spar-push-subform-if mit-lambda-list? spar-arg:form) (spar-push-body))))) (define :named-lambda @@ -229,10 +229,10 @@ USA. (lambda (ctx name bvl body-ctx body) (assemble-lambda-item ctx (identifier->symbol name) bvl body-ctx body)) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt - (spar-push-elt-if identifier? spar-arg:form) + (spar-subform + (spar-push-subform-if identifier? spar-arg:form) (spar-push-form-if mit-lambda-list? spar-arg:form)) (spar-push-body))))) @@ -245,7 +245,7 @@ USA. (let ((body-senv (make-internal-senv frame-senv))) (map-in-order (lambda (elt) (elt body-senv)) elts)))) - (spar+ (spar-elt spar-push-open-classified)) + (spar+ (spar-subform spar-push-open-classified)) (spar-match-null)))) (define (assemble-lambda-item ctx name bvl body-ctx body) @@ -269,15 +269,15 @@ USA. (bind-keyword (car binding) frame-senv (cdr binding))) bindings) (seq-item body-ctx (body frame-senv)))) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt + (spar-subform (spar-call-with-values list (spar* (spar-call-with-values cons - (spar-elt (spar-push-elt-if identifier? spar-arg:form) - (spar-elt spar-push-classified) - (spar-match-null))))) + (spar-subform (spar-push-subform-if identifier? spar-arg:form) + (spar-subform spar-push-classified) + (spar-match-null))))) (spar-match-null)) (spar-push-body)))) @@ -304,15 +304,15 @@ USA. ((cdr binding) frame-senv)) bindings)) (seq-item body-ctx (body frame-senv)))) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-elt + (spar-subform (spar-call-with-values list (spar* (spar-call-with-values cons - (spar-elt (spar-push-elt-if identifier? spar-arg:form) - (spar-elt spar-push-open-classified) - (spar-match-null))))) + (spar-subform (spar-push-subform-if identifier? spar-arg:form) + (spar-subform spar-push-open-classified) + (spar-match-null))))) (spar-match-null)) (spar-push-body))))) @@ -329,10 +329,10 @@ USA. (spar-classifier->keyword (delay (spar-call-with-values access-item - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) - (spar-push-elt-if identifier? spar-arg:form) - (spar-elt spar-push-classified) + (spar-push-subform-if identifier? spar-arg:form) + (spar-subform spar-push-classified) (spar-match-null))))) (define-expr-item-compiler access-item? @@ -347,7 +347,7 @@ USA. (spar-or (spar-match senv-top-level? spar-arg:senv) (spar-error "This form allowed only at top level:" spar-arg:form spar-arg:senv)) - (spar-elt) + (spar-subform) (spar-match-null) (spar-push-value the-environment-item spar-arg:ctx))))) @@ -355,7 +355,7 @@ USA. (spar-classifier->keyword (delay (spar-and - (spar-elt) + (spar-subform) (spar-match-null) (spar-push-value unspecific-item spar-arg:ctx))))) @@ -363,7 +363,7 @@ USA. (spar-classifier->keyword (delay (spar-and - (spar-elt) + (spar-subform) (spar-match-null) (spar-push-value unassigned-item spar-arg:ctx))))) @@ -387,15 +387,15 @@ USA. decl)) decls (hist-cadr hist)))))) - (spar-elt) + (spar-subform) (spar-push spar-arg:ctx) (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-push-subform-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 25a1723a6..322738e95 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4559,7 +4559,6 @@ USA. spar-arg:values spar-call-with-values spar-discard-form - spar-elt spar-encapsulate-values spar-error spar-fail @@ -4567,18 +4566,19 @@ USA. spar-if spar-map-values spar-match - spar-match-elt spar-match-null + spar-match-subform spar-not spar-opt spar-or spar-push - spar-push-elt - spar-push-elt-if spar-push-form-if + spar-push-subform + spar-push-subform-if spar-push-value spar-repeat spar-and + spar-subform spar-succeed spar-transform-values spar-with-mapped-senv) diff --git a/src/runtime/syntax-constructor.scm b/src/runtime/syntax-constructor.scm index 76d82c796..c118e1571 100644 --- a/src/runtime/syntax-constructor.scm +++ b/src/runtime/syntax-constructor.scm @@ -33,7 +33,7 @@ USA. (spar-call-with-values (lambda (close . args) (close-part close (apply procedure args))) - (spar-elt) + (spar-subform) (spar-push spar-arg:close) (pattern->spar pattern))) diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index 84bebe1d8..c123d0fd2 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -352,7 +352,7 @@ USA. ;;;; Element combinators -(define (spar-elt . spars) +(define (spar-subform . spars) (let ((spar (%and spars))) (lambda (input senv output success failure) (if (%input-pair? input) @@ -365,14 +365,14 @@ USA. failure) (failure))))) -(define (spar-match-elt predicate . args) - (spar-elt (apply spar-match predicate args))) +(define (spar-match-subform predicate . args) + (spar-subform (apply spar-match predicate args))) -(define (spar-push-elt) - (spar-elt (spar-push spar-arg:form))) +(define (spar-push-subform) + (spar-subform (spar-push spar-arg:form))) -(define (spar-push-elt-if predicate . args) - (spar-elt (apply spar-push-form-if predicate args))) +(define (spar-push-subform-if predicate . args) + (spar-subform (apply spar-push-form-if predicate args))) (define (spar-match-null) (spar-match null? spar-arg:form)) @@ -468,8 +468,8 @@ USA. (define (make-pattern-compiler expr? caller) (call-with-constructors expr? - (lambda ($* $+ $and $call $elt $if $match-elt $match-null $not $opt $or - $push $push-elt $push-elt-if $push-value) + (lambda ($* $+ $and $call $if $match-null $match-subform $not $opt $or $push + $push-subform $push-subform-if $push-value $subform) (define (loop pattern) (let-syntax @@ -482,11 +482,11 @@ USA. ,@(cdr rule))) (cdr form)) (else (bad-pattern pattern))))))) - (rules (''ignore ($elt)) - (''any ($push-elt)) - (''id ($push-elt-if identifier? spar-arg:form)) - (''symbol ($push-elt-if symbol? spar-arg:form)) - (procedure? ($push-elt-if pattern spar-arg:form)) + (rules (''ignore ($subform)) + (''any ($push-subform)) + (''id ($push-subform-if identifier? spar-arg:form)) + (''symbol ($push-subform-if symbol? spar-arg:form)) + (procedure? ($push-subform-if pattern spar-arg:form)) ('('spar form) (cadr pattern)) ('('* * form) ($call list (apply $* (map loop (cdr pattern))))) ('('+ * form) ($call list (apply $+ (map loop (cdr pattern))))) @@ -496,13 +496,15 @@ USA. ('('and * form) (apply $and (map loop (cdr pattern)))) ('('not form) ($not (loop (cadr pattern)))) ('('noise form) - ($match-elt eqv? (cadr pattern) spar-arg:form)) + ($match-subform eqv? (cadr pattern) spar-arg:form)) ('('noise-keyword identifier) - ($match-elt spar-arg:compare (cadr pattern) spar-arg:form)) + ($match-subform spar-arg:compare + (cadr pattern) + spar-arg:form)) ('('keyword identifier) - ($and ($match-elt spar-arg:compare - (cadr pattern) - spar-arg:form) + ($and ($match-subform spar-arg:compare + (cadr pattern) + spar-arg:form) ($push (cadr pattern)))) ('('values * form) (apply $push (map convert-spar-arg (cdr pattern)))) @@ -515,8 +517,8 @@ USA. ('('call + form) (apply $call (cadr pattern) (map loop (cddr pattern)))) ('('elt * form) - ($elt (apply $and (map loop (cdr pattern))) - ($match-null)))))) + ($subform (apply $and (map loop (cdr pattern))) + ($match-null)))))) (define (convert-spar-arg arg) (case arg @@ -561,17 +563,17 @@ USA. (flat-proc 'spar+ spar+) (flat-proc 'spar-and spar-and) (flat-proc 'spar-call-with-values spar-call-with-values) - (flat-proc 'spar-elt spar-elt) (proc 'spar-if spar-if) - (proc 'spar-match-elt spar-match-elt) (proc 'spar-match-null spar-match-null) + (proc 'spar-match-subform spar-match-subform) (proc 'spar-not spar-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))) + (proc 'spar-push-subform spar-push-subform) + (proc 'spar-push-subform-if spar-push-subform-if) + (proc 'spar-push-value spar-push-value) + (flat-proc 'spar-subform spar-subform))) (define-deferred pattern->spar (make-pattern-compiler #f 'pattern->spar))