From: Chris Hanson Date: Mon, 12 Feb 2018 04:51:48 +0000 (-0800) Subject: Change most of the "compilers" to "classifiers". X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~256 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a1375edb236d4dea1c174a046b46b979e15c83c6;p=mit-scheme.git Change most of the "compilers" to "classifiers". This is the first step in eliminating the idea of a "compiler". --- diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 17aea0004..b2c46eb96 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -89,41 +89,40 @@ USA. (syntax-check '(_ * form) form) (classify-body-cdr form senv hist)) -(define (compiler:if form senv hist) +(define (classifier:if form senv hist) (syntax-check '(_ expression expression ? expression) form) - (output/conditional - (compile-expr-item (classify-form-cadr form senv hist)) - (compile-expr-item (classify-form-caddr form senv hist)) - (if (pair? (cdddr form)) - (compile-expr-item (classify-form-cadddr form senv hist)) - (output/unspecific)))) - -(define (compiler:quote form senv hist) + (if-item (classify-form-cadr form senv hist) + (classify-form-caddr form senv hist) + (if (pair? (cdddr form)) + (classify-form-cadddr form senv hist) + (unspecific-item)))) + +(define (classifier:quote form senv hist) (declare (ignore senv hist)) (syntax-check '(_ datum) form) - (output/constant (strip-syntactic-closures (cadr form)))) + (constant-item (strip-syntactic-closures (cadr form)))) -(define (compiler:quote-identifier form senv hist) +(define (classifier:quote-identifier form senv hist) (declare (ignore hist)) (syntax-check '(_ identifier) form) (let ((item (lookup-identifier (cadr form) senv))) (if (not (var-item? item)) (syntax-error "Can't quote a keyword identifier:" form)) - (output/quoted-identifier (var-item-id item)))) + (quoted-id-item item))) -(define (compiler:set! form senv hist) +(define (classifier:set! form senv hist) (syntax-check '(_ form ? expression) form) - (let ((lhs (classify-form-cadr form senv hist)) - (rhs + (let ((lhs-item (classify-form-cadr form senv hist)) + (rhs-item (if (pair? (cddr form)) - (compile-expr-item (classify-form-caddr form senv hist)) - (output/unassigned)))) - (cond ((var-item? lhs) - (output/assignment (var-item-id lhs) rhs)) - ((access-item? lhs) - (output/access-assignment (access-item-name lhs) - (compile-expr-item (access-item-env lhs)) - rhs)) + (classify-form-caddr form senv hist) + (unassigned-item)))) + (cond ((var-item? lhs-item) + (assignment-item (var-item-id lhs-item) rhs-item)) + ((access-item? lhs-item) + (access-assignment-item (access-item-name lhs-item) + (access-item-env lhs-item) + rhs-item)) (else (syntax-error "Variable required in this context:" (cadr form)))))) @@ -177,18 +176,12 @@ USA. (car binding) (classify-form-cadr binding senv hist))) (cadr form) - (subform-hists (cadr form) (hist-cadr hist)))) - (body-item - (classify-body-cddr form - (make-internal-senv binding-senv) - hist))) - (expr-item - (let ((names (map car bindings)) - (values (map cdr bindings))) - (lambda () - (output/let names - (map compile-expr-item values) - (compile-body-item body-item))))))))) + (subform-hists (cadr form) (hist-cadr hist))))) + (let-item (map car bindings) + (map cdr bindings) + (classify-body-cddr form + (make-internal-senv binding-senv) + hist)))))) (define (classifier:let-syntax form senv hist) (syntax-check '(_ (* (identifier expression)) + form) form) @@ -224,16 +217,13 @@ USA. (subform-hists bindings (hist-cadr hist))))) (classify-body-cddr form (make-internal-senv binding-senv) hist))) -;; TODO: this is a compiler rather than a macro because it uses the +;; TODO: this is a classifier rather than a macro because it uses the ;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in ;; the compiler wants this, but it would be nice to eliminate this ;; hack. -(define (compiler:or form senv hist) +(define (classifier:or form senv hist) (syntax-check '(_ * expression) form) - (reduce-right output/disjunction - '#f - (map compile-expr-item - (classify-forms (cdr form) senv (hist-cdr hist))))) + (or-item (classify-forms (cdr form) senv (hist-cdr hist)))) ;;;; MIT-specific syntax @@ -254,24 +244,24 @@ USA. (output/access-reference (access-item-name item) (compile-expr-item (access-item-env item))))) -(define (compiler:the-environment form senv hist) +(define (classifier:the-environment form senv hist) (declare (ignore hist)) (syntax-check '(_) form) (if (not (senv-top-level? senv)) (syntax-error "This form allowed only at top level:" form)) - (output/the-environment)) + (the-environment-item)) (define keyword:unspecific - (compiler->keyword + (classifier->keyword (lambda (form senv hist) (declare (ignore form senv hist)) - (output/unspecific)))) + (unspecific-item)))) (define keyword:unassigned - (compiler->keyword + (classifier->keyword (lambda (form senv hist) (declare (ignore form senv hist)) - (output/unassigned)))) + (unassigned-item)))) ;;;; Declarations diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b5ae0da99..3273ca89a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4444,12 +4444,17 @@ USA. (files "syntax-items") (parent (runtime syntax)) (export (runtime syntax) + access-assignment-item + assignment-item + body-item classifier-item classifier-item-impl classifier-item? compiler-item compiler-item-impl compiler-item? + combination-item + constant-item decl-item decl-item-text decl-item? @@ -4458,6 +4463,7 @@ USA. defn-item-syntax? defn-item-value defn-item? + delay-item expander-item expander-item-expr expander-item-impl @@ -4466,14 +4472,22 @@ USA. expr-item-compiler expr-item? flatten-items + if-item item->list keyword-item? + lambda-item + let-item + or-item + quoted-id-item reserved-name-item reserved-name-item? seq-item seq-item-elements seq-item? syntax-defn-item + the-environment-item + unassigned-item + unspecific-item var-item var-item-id var-item?)) @@ -4568,19 +4582,19 @@ USA. classifier:declare classifier:define-syntax classifier:er-macro-transformer + classifier:if classifier:let-syntax classifier:letrec-syntax + classifier:or + classifier:quote + classifier:quote-identifier classifier:rsc-macro-transformer classifier:sc-macro-transformer + classifier:set! + classifier:the-environment compiler:delay - compiler:if compiler:lambda - compiler:named-lambda - compiler:or - compiler:quote - compiler:quote-identifier - compiler:set! - compiler:the-environment) + compiler:named-lambda) (export (runtime mit-macros) keyword:access keyword:define diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm index 5a3120afd..9b9147b93 100644 --- a/src/runtime/syntax-definitions.scm +++ b/src/runtime/syntax-definitions.scm @@ -38,24 +38,24 @@ USA. (define (define-classifier name classifier) (def name (classifier-item classifier))) - (define-classifier 'BEGIN classifier:begin) - (define-classifier 'DECLARE classifier:declare) - (define-classifier 'DEFINE-SYNTAX classifier:define-syntax) - (define-classifier 'ER-MACRO-TRANSFORMER classifier:er-macro-transformer) - (define-classifier 'LET-SYNTAX classifier:let-syntax) - (define-classifier 'LETREC-SYNTAX classifier:letrec-syntax) - (define-classifier 'RSC-MACRO-TRANSFORMER classifier:rsc-macro-transformer) - (define-classifier 'SC-MACRO-TRANSFORMER classifier:sc-macro-transformer) + (define-classifier 'begin classifier:begin) + (define-classifier 'declare classifier:declare) + (define-classifier 'define-syntax classifier:define-syntax) + (define-classifier 'er-macro-transformer classifier:er-macro-transformer) + (define-classifier 'if classifier:if) + (define-classifier 'let-syntax classifier:let-syntax) + (define-classifier 'letrec-syntax classifier:letrec-syntax) + (define-classifier 'or classifier:or) + (define-classifier 'quote classifier:quote) + (define-classifier 'quote-identifier classifier:quote-identifier) + (define-classifier 'rsc-macro-transformer classifier:rsc-macro-transformer) + (define-classifier 'sc-macro-transformer classifier:sc-macro-transformer) + (define-classifier 'set! classifier:set!) + (define-classifier 'the-environment classifier:the-environment) (define (define-compiler name compiler) (def name (compiler-item compiler))) - (define-compiler 'DELAY compiler:delay) - (define-compiler 'IF compiler:if) - (define-compiler 'LAMBDA compiler:lambda) - (define-compiler 'NAMED-LAMBDA compiler:named-lambda) - (define-compiler 'OR compiler:or) - (define-compiler 'QUOTE compiler:quote) - (define-compiler 'quote-identifier compiler:quote-identifier) - (define-compiler 'SET! compiler:set!) - (define-compiler 'THE-ENVIRONMENT compiler:the-environment))) \ No newline at end of file + (define-compiler 'delay compiler:delay) + (define-compiler 'lambda compiler:lambda) + (define-compiler 'named-lambda compiler:named-lambda))) \ No newline at end of file diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm index f6c1c3893..b2bb81db8 100644 --- a/src/runtime/syntax-items.scm +++ b/src/runtime/syntax-items.scm @@ -157,4 +157,77 @@ USA. (text-getter decl-item-text-getter)) (define (decl-item-text item) - ((decl-item-text-getter item))) \ No newline at end of file + ((decl-item-text-getter item))) + +;;;; Specific expression items + +(define (combination-item operator operands) + (expr-item + (lambda () + (output/combination (compile-expr-item operator) + (map compile-expr-item operands))))) + +(define (constant-item datum) + (expr-item + (lambda () + (output/constant datum)))) + +(define (lambda-item name bvl body-item) + (expr-item + (lambda () + (output/lambda name bvl (compile-expr-item body-item))))) + +(define (let-item names value-items body-item) + (expr-item + (lambda () + (output/let names + (map compile-expr-item value-items) + (compile-expr-item body-item))))) + +(define (body-item items) + (expr-item + (lambda () + (output/body (compile-body-items items))))) + +(define (if-item predicate consequent alternative) + (expr-item + (lambda () + (output/conditional (compile-expr-item predicate) + (compile-expr-item consequent) + (compile-expr-item alternative))))) + +(define (quoted-id-item var-item) + (expr-item + (lambda () + (output/quoted-identifier (var-item-id var-item))))) + +(define (assignment-item id rhs-item) + (expr-item + (lambda () + (output/assignment id (compile-expr-item rhs-item))))) + +(define (access-assignment-item name env-item rhs-item) + (expr-item + (lambda () + (output/access-assignment name + (compile-expr-item env-item) + (compile-expr-item rhs-item))))) + +(define (delay-item item) + (expr-item + (lambda () + (output/delay (compile-expr-item item))))) + +(define (or-item items) + (expr-item + (lambda () + (output/disjunction (map compile-expr-item items))))) + +(define (the-environment-item) + (expr-item output/the-environment)) + +(define (unspecific-item) + (expr-item output/unspecific)) + +(define (unassigned-item) + (expr-item output/unassigned)) \ No newline at end of file diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index e14d35911..989fd9c5a 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -67,8 +67,8 @@ USA. (define (output/conditional predicate consequent alternative) (make-scode-conditional predicate consequent alternative)) -(define (output/disjunction predicate alternative) - (make-scode-disjunction predicate alternative)) +(define (output/disjunction exprs) + (reduce-right make-scode-disjunction '#f exprs)) (define (output/sequence expressions) (make-scode-sequence expressions))