From 41eb62a9fb4f9b71a17a6eeb8becf429b267ca7d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 6 Feb 2018 22:31:46 -0800 Subject: [PATCH] A bunch of renames to eliminate weird "/" phase of mine. --- src/edwin/clsmac.scm | 4 +- src/edwin/edwin.pkg | 2 +- src/runtime/host-adapter.scm | 3 +- src/runtime/mit-syntax.scm | 48 ++++++++-------- src/runtime/runtime.pkg | 10 ++-- src/runtime/syntax.scm | 108 ++++++++++++++++------------------- 6 files changed, 82 insertions(+), 93 deletions(-) diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm index 0dc8a1a77..6ee1257ce 100644 --- a/src/edwin/clsmac.scm +++ b/src/edwin/clsmac.scm @@ -97,9 +97,9 @@ USA. (transform-instance-variables (class-instance-transforms (name->class (identifier->symbol class-name))) - (compile/expression self environment) + (compile-expr self environment) free-names - (compile/expression + (compile-expr `(,(close-syntax 'begin (runtime-environment->syntactic system-global-environment)) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 3b8b02509..10a0fd13b 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -285,7 +285,7 @@ USA. usual==> with-instance-variables) (import (runtime syntax) - compile/expression + compile-expr compiler-item)) (define-package (edwin class-macros transform-instance-variables) diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 5b3666e08..52c449c1a 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -186,7 +186,8 @@ USA. env 'microcode-type)))) (let ((env (->environment '(runtime syntax)))) - (provide-rename env 'make-compiler-item 'compiler-item)) + (provide-rename env 'make-compiler-item 'compiler-item) + (provide-rename env 'compile/expression 'compile-expr)) (let ((env (->environment '(package)))) (if (eval '(not (link-description? '#(name1 (package name) name2 #f))) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index cac848ecb..ef3c9beaf 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -34,9 +34,7 @@ USA. (define (transformer-keyword procedure-name transformer->expander) (lambda (form senv) (syntax-check '(KEYWORD EXPRESSION) form) - (let ((transformer - (compile-item/expression - (classify/expression (cadr form) senv)))) + (let ((transformer (compile-expr (cadr form) senv))) (let ((item (transformer->expander (transformer-eval transformer senv) senv))) @@ -86,22 +84,22 @@ USA. bvl))) (values bvl (compile-body-item - (classify/body body environment)))))) + (classify-body body environment)))))) (define (compile-body-item item) (output/body (compile-body-items (item->list item)))) (define (classifier:begin form environment) (syntax-check '(KEYWORD * FORM) form) - (classify/body (cdr form) environment)) + (classify-body (cdr form) environment)) (define (compiler:if form environment) (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form) (output/conditional - (compile/expression (cadr form) environment) - (compile/expression (caddr form) environment) + (compile-expr (cadr form) environment) + (compile-expr (caddr form) environment) (if (pair? (cdddr form)) - (compile/expression (cadddr form) environment) + (compile-expr (cadddr form) environment) (output/unspecific)))) (define (compiler:quote form environment) @@ -122,17 +120,17 @@ USA. (classify/location (cadr form) environment) (let ((value (if (pair? (cddr form)) - (compile/expression (caddr form) environment) + (compile-expr (caddr form) environment) (output/unassigned)))) (if environment-item (output/access-assignment name - (compile-item/expression environment-item) + (compile-expr-item environment-item) value) (output/assignment name value))))) (define (classify/location form environment) - (let ((item (classify/expression form environment))) + (let ((item (classify-form form environment))) (cond ((var-item? item) (values (var-item-id item) #f)) ((access-item? item) @@ -142,7 +140,7 @@ USA. (define (compiler:delay form environment) (syntax-check '(KEYWORD EXPRESSION) form) - (output/delay (compile/expression (cadr form) environment))) + (output/delay (compile-expr (cadr form) environment))) ;;;; Definitions @@ -154,12 +152,12 @@ USA. (variable-binder defn-item environment name - (classify/expression (caddr form) environment)))))) + (classify-form (caddr form) environment)))))) (define (classifier:define-syntax form environment) (syntax-check '(keyword identifier expression) form) (let ((name (cadr form)) - (item (classify/expression (caddr form) environment))) + (item (classify-form (caddr form) environment))) (keyword-binder environment name item) ;; User-defined macros at top level are preserved in the output. (if (and (keyword-value-item? item) @@ -190,18 +188,18 @@ USA. (variable-binder cons binding-env (car binding) - (classify/expression (cadr binding) env))) + (classify-form (cadr binding) env))) bindings))) (expr-item (let ((names (map car bindings)) (values (map cdr bindings)) (seq-item - (classify/body + (classify-body body (make-internal-syntactic-environment binding-env)))) (lambda () (output/let names - (map compile-item/expression values) + (map compile-expr-item values) (compile-body-item seq-item)))))))))) (define (classifier:let-syntax form env) @@ -212,9 +210,9 @@ USA. (for-each (lambda (binding) (keyword-binder binding-env (car binding) - (classify/expression (cadr binding) env))) + (classify-form (cadr binding) env))) bindings) - (classify/body body (make-internal-syntactic-environment binding-env)))) + (classify-body body (make-internal-syntactic-environment binding-env)))) (define keyword:let-syntax (classifier->keyword classifier:let-syntax)) @@ -233,9 +231,9 @@ USA. (keyword-binder binding-env (car binding) item)) bindings (map (lambda (binding) - (classify/expression (cadr binding) binding-env)) + (classify-form (cadr binding) binding-env)) bindings)) - (classify/body body (make-internal-syntactic-environment binding-env)))) + (classify-body body (make-internal-syntactic-environment binding-env)))) ;; TODO: this is a compiler rather than a macro because it uses the ;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in @@ -245,7 +243,7 @@ USA. (syntax-check '(KEYWORD * EXPRESSION) form) (if (pair? (cdr form)) (let loop ((expressions (cdr form))) - (let ((compiled (compile/expression (car expressions) environment))) + (let ((compiled (compile-expr (car expressions) environment))) (if (pair? (cdr expressions)) (output/disjunction compiled (loop (cdr expressions))) compiled))) @@ -263,13 +261,13 @@ USA. (classifier->keyword (lambda (form environment) (make-access-item (cadr form) - (classify/expression (caddr form) environment))))) + (classify-form (caddr form) environment))))) (define-item-compiler access-item? (lambda (item) (output/access-reference (access-item/name item) - (compile-item/expression (access-item/environment item))))) + (compile-expr-item (access-item/environment item))))) (define (compiler:the-environment form environment) (syntax-check '(KEYWORD) form) @@ -310,7 +308,7 @@ USA. declaration)) (define (classify/variable-reference identifier environment) - (let ((item (classify/expression identifier environment))) + (let ((item (classify-form identifier environment))) (if (not (var-item? item)) (syntax-error "Variable required in this context:" identifier)) item)) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index fded8384a..6ac545178 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4404,13 +4404,11 @@ USA. syntax-error) (export (runtime syntax) classifier->keyword - classify/body - classify/expression - classify/form - compile-body-item/top-level + classify-body + classify-form compile-body-items - compile-item/expression - compile/expression + compile-expr-item + compile-expr compiler->keyword define-item-compiler raw-identifier?)) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index c8c1d4f7a..7410399d6 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -55,20 +55,18 @@ USA. (with-identifier-renaming (lambda () (if (top-level-syntactic-environment? senv) - (compile-body-item/top-level (classify/body forms senv)) - (output/sequence (compile/expressions forms senv))))))) - -(define (compile/expression expression environment) - (compile-item/expression (classify/expression expression environment))) - -(define (compile/expressions expressions environment) - (map (lambda (expression) - (compile/expression expression environment)) - expressions)) + (compile-top-level-body (classify-body forms senv)) + (output/sequence + (map (lambda (expr) + (compile-expr expr senv)) + forms))))))) + +(define (compile-expr expression environment) + (compile-expr-item (classify-form expression environment))) ;;;; Classifier -(define (classify/form form environment) +(define (classify-form form environment) (cond ((identifier? form) (let ((item (lookup-identifier form environment))) (if (keyword-item? item) @@ -83,7 +81,7 @@ USA. (output/the-environment))))))) item))) ((syntactic-closure? form) - (classify/form + (classify-form (syntactic-closure-form form) (make-partial-syntactic-environment (syntactic-closure-free form) environment @@ -91,7 +89,7 @@ USA. ((pair? form) (let ((item (strip-keyword-value-item - (classify/expression (car form) environment)))) + (classify-form (car form) environment)))) (cond ((classifier-item? item) ((classifier-item-impl item) form environment)) ((compiler-item? item) @@ -100,17 +98,20 @@ USA. (lambda () (compiler form environment))))) ((expander-item? item) - (classify/form ((expander-item-impl item) form environment) + (classify-form ((expander-item-impl item) form environment) environment)) (else (if (not (list? (cdr form))) (syntax-error "Combination must be a proper list:" form)) (expr-item - (let ((items (classify/expressions (cdr form) environment))) + (let ((items + (map (lambda (expr) + (classify-form expr environment)) + (cdr form)))) (lambda () (output/combination - (compile-item/expression item) - (map compile-item/expression items))))))))) + (compile-expr-item item) + (map compile-expr-item items))))))))) (else (expr-item (lambda () (output/constant form)))))) @@ -119,42 +120,34 @@ USA. (keyword-value-item-keyword item) item)) -(define (classify/expression expression environment) - (classify/form expression environment)) - -(define (classify/expressions expressions environment) - (map (lambda (expression) - (classify/expression expression environment)) - expressions)) - -(define (classify/body forms environment) +(define (classify-body forms environment) ;; Syntactic definitions affect all forms that appear after them, so classify ;; FORMS in order. (seq-item (let loop ((forms forms) (items '())) (if (pair? forms) (loop (cdr forms) - (reverse* (item->list (classify/form (car forms) environment)) + (reverse* (item->list (classify-form (car forms) environment)) items)) (reverse! items))))) ;;;; Compiler -(define (compile-item/top-level item) - (if (defn-item? item) - (let ((name (identifier->symbol (defn-item-id item))) - (value (defn-item-value item))) - (if (keyword-value-item? value) - (output/top-level-syntax-definition - name - (compile-item/expression (keyword-value-item-expr value))) - (output/top-level-definition - name - (compile-item/expression value)))) - (compile-item/expression item))) - -(define (compile-body-item/top-level item) - (output/top-level-sequence (map compile-item/top-level (item->list item)))) +(define (compile-top-level-body item) + (output/top-level-sequence + (map (lambda (item) + (if (defn-item? item) + (let ((name (defn-item-id item)) + (value (defn-item-value item))) + (if (keyword-value-item? value) + (output/top-level-syntax-definition + name + (compile-expr-item (keyword-value-item-expr value))) + (output/top-level-definition + name + (compile-expr-item value)))) + (compile-expr-item item))) + (item->list item)))) (define (compile-body-items items) (let ((items (flatten-items items))) @@ -168,21 +161,21 @@ USA. (if (keyword-value-item? value) '() (list (output/definition (defn-item-id item) - (compile-item/expression value))))) - (list (compile-item/expression item)))) + (compile-expr-item value))))) + (list (compile-expr-item item)))) items)))) -(define compile-item/expression) +(define compile-expr-item) (add-boot-init! (lambda () - (set! compile-item/expression - (standard-predicate-dispatcher 'compile-item/expression 1)) + (set! compile-expr-item + (standard-predicate-dispatcher 'compile-expr-item 1)) (run-deferred-boot-actions 'define-item-compiler))) (define (define-item-compiler predicate compiler) (defer-boot-action 'define-item-compiler (lambda () - (define-predicate-dispatch-handler compile-item/expression + (define-predicate-dispatch-handler compile-expr-item (list predicate) compiler)))) @@ -286,9 +279,9 @@ USA. ((closed-identifier? identifier) (syntactic-closure-form identifier)) (else (error:not-a identifier? identifier 'identifier->symbol)))) -(define (identifier=? environment-1 identifier-1 environment-2 identifier-2) - (let ((item-1 (lookup-identifier identifier-1 environment-1)) - (item-2 (lookup-identifier identifier-2 environment-2))) +(define (identifier=? senv-1 identifier-1 senv-2 identifier-2) + (let ((item-1 (lookup-identifier identifier-1 senv-1)) + (item-2 (lookup-identifier identifier-2 senv-2))) (or (eq? item-1 item-2) ;; This is necessary because an identifier that is not explicitly bound ;; by an environment is mapped to a variable item, and the variable @@ -317,12 +310,11 @@ USA. (define (capture-syntactic-environment expander) `(,(classifier->keyword - (lambda (form environment) - form ;ignore - (classify/form (expander environment) - environment))))) + (lambda (form senv) + (declare (ignore form)) + (classify-form (expander senv) senv))))) -(define (reverse-syntactic-environments environment procedure) +(define (reverse-syntactic-environments senv procedure) (capture-syntactic-environment - (lambda (closing-environment) - (close-syntax (procedure closing-environment) environment)))) \ No newline at end of file + (lambda (closing-senv) + (close-syntax (procedure closing-senv) senv)))) \ No newline at end of file -- 2.25.1