From 3e377595fb3ae5f140de448cf30589cbd2f2ea3b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 18 Feb 2018 21:44:09 -0800 Subject: [PATCH] Merge classifier and keyword items. --- src/edwin/clsmac.scm | 49 +++++++++++++++++------------------ src/edwin/edwin.pkg | 2 +- src/runtime/host-adapter.scm | 6 ++++- src/runtime/mit-syntax.scm | 22 +++++++--------- src/runtime/runtime.pkg | 39 ++++++++++++++-------------- src/runtime/syntax-items.scm | 16 ------------ src/runtime/syntax-low.scm | 30 +++++++++++++++++---- src/runtime/syntax-parser.scm | 2 +- src/runtime/syntax.scm | 17 +++++------- 9 files changed, 92 insertions(+), 91 deletions(-) diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm index c8dd91ef0..f5a68022d 100644 --- a/src/edwin/clsmac.scm +++ b/src/edwin/clsmac.scm @@ -85,31 +85,30 @@ USA. (ill-formed-syntax form))))))) (define with-instance-variables - (make-unmapped-macro-reference-trap - (classifier-item - ;; Rest arg facilitates cross-compiling from 9.2. - ;; It should be removed after 9.3 release. - (lambda (form senv . rest) - (syntax-check '(_ identifier expression (* identifier) + expression) form) - (let ((class-name (cadr form)) - (self-item (apply classify-form (caddr form) senv rest)) - (free-names (cadddr form)) - (body-item - (apply classify-form - `(,(close-syntax 'begin - (runtime-environment->syntactic - system-global-environment)) - ,@(cddddr form)) - senv - rest))) - (expr-item - (lambda () - (transform-instance-variables - (class-instance-transforms - (name->class (identifier->symbol class-name))) - (compile-expr-item self-item) - free-names - (compile-expr-item body-item))))))))) + (classifier->runtime + ;; Rest arg facilitates cross-compiling from 9.2. + ;; It should be removed after 9.3 release. + (lambda (form senv . rest) + (syntax-check '(_ identifier expression (* identifier) + expression) form) + (let ((class-name (cadr form)) + (self-item (apply classify-form (caddr form) senv rest)) + (free-names (cadddr form)) + (body-item + (apply classify-form + `(,(close-syntax 'begin + (runtime-environment->syntactic + system-global-environment)) + ,@(cddddr form)) + senv + rest))) + (expr-item + (lambda () + (transform-instance-variables + (class-instance-transforms + (name->class (identifier->symbol class-name))) + (compile-expr-item self-item) + free-names + (compile-expr-item body-item)))))))) (define-syntax ==> (syntax-rules () diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 6dc4d9c7d..327503594 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -285,7 +285,7 @@ USA. usual==> with-instance-variables) (import (runtime syntax) - classifier-item + classifier->runtime classify-form compile-expr-item expr-item)) diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 95fa1b960..e9fbf36f8 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -189,12 +189,16 @@ USA. env 'microcode-type)))) (let ((env (->environment '(runtime syntax)))) - (provide-rename env 'make-classifier-item 'classifier-item) (provide-rename env 'make-expression-item 'expr-item) (provide-rename env 'compile-item/expression 'compile-expr-item) (if (unbound? env 'classify-form) (eval '(define (classify-form form senv #!optional hist) (classify/form form senv senv)) + env)) + (if (unbound? env 'classifier->runtime) + (eval '(define (classifier->runtime classifier) + (make-unmapped-macro-reference-trap + (make-classifier-item classifier))) env))) (let ((env (->environment '(package)))) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 7c6f3fb8f..14d13f3d8 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -31,7 +31,7 @@ USA. ;;;; Macro transformers -(define (transformer-keyword procedure-name transformer->expander) +(define (transformer-classifier procedure-name transformer->expander) (lambda (form senv hist) (scheck '(_ expression) form senv hist) (let ((transformer (compile-expr-item (classify-form-cadr form senv hist)))) @@ -42,26 +42,23 @@ USA. (output/top-level-syntax-expander procedure-name transformer))))))) -(define (classifier->runtime classifier) - (make-unmapped-macro-reference-trap (classifier-item classifier))) - (define :sc-macro-transformer ;; "Syntactic Closures" transformer (classifier->runtime - (transformer-keyword 'sc-macro-transformer->expander - sc-macro-transformer->expander))) + (transformer-classifier 'sc-macro-transformer->expander + sc-macro-transformer->expander))) (define :rsc-macro-transformer ;; "Reversed Syntactic Closures" transformer (classifier->runtime - (transformer-keyword 'rsc-macro-transformer->expander - rsc-macro-transformer->expander))) + (transformer-classifier 'rsc-macro-transformer->expander + rsc-macro-transformer->expander))) (define :er-macro-transformer ;; "Explicit Renaming" transformer (classifier->runtime - (transformer-keyword 'er-macro-transformer->expander - er-macro-transformer->expander))) + (transformer-classifier 'er-macro-transformer->expander + er-macro-transformer->expander))) ;;;; Core primitives @@ -177,8 +174,9 @@ USA. (bind-keyword name senv item) ;; User-defined macros at top level are preserved in the output. (if (and (senv-top-level? senv) - (expander-item? item)) - (syntax-defn-item name (expander-item-expr item)) + (keyword-item? item) + (keyword-item-has-expr? item)) + (syntax-defn-item name (keyword-item-expr item)) (seq-item '())))))) (define (classify-keyword-value form senv hist) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 7265a77df..bdeff62bf 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4440,7 +4440,26 @@ USA. serror sfor-each smap - subform-select)) + subform-select) + (export (runtime syntax low) + reclassify + with-error-context)) + +(define-package (runtime syntax low) + (files "syntax-low") + (parent (runtime syntax)) + (export () + er-macro-transformer->expander + rsc-macro-transformer->expander + sc-macro-transformer->expander + syntactic-keyword->item) + (export (runtime syntax) + classifier->runtime + keyword-item + keyword-item-expr + keyword-item-has-expr? + keyword-item-impl + keyword-item?)) (define-package (runtime syntax items) (files "syntax-items") @@ -4449,9 +4468,6 @@ USA. access-assignment-item assignment-item body-item - classifier-item - classifier-item-impl - classifier-item? combination-item compile-expr-item constant-item @@ -4469,7 +4485,6 @@ USA. flatten-items if-item item->list - keyword-item? lambda-item let-item or-item @@ -4487,20 +4502,6 @@ USA. var-item-id var-item?)) -(define-package (runtime syntax low) - (files "syntax-low") - (parent (runtime syntax)) - (export () - er-macro-transformer->expander - rsc-macro-transformer->expander - sc-macro-transformer->expander - syntactic-keyword->item) - (export (runtime syntax) - expander-item - expander-item-expr - expander-item-impl - expander-item?)) - (define-package (runtime syntax environment) (files "syntax-environment") (parent (runtime syntax)) diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm index 6be040b91..f092dbcb4 100644 --- a/src/runtime/syntax-items.scm +++ b/src/runtime/syntax-items.scm @@ -30,22 +30,6 @@ USA. ;;; These items can be stored in a syntactic environment. -;;; Keyword items represent macro keywords. There are several flavors -;;; of keyword item. - -(define-record-type - (classifier-item impl) - classifier-item? - (impl classifier-item-impl)) - -(define (keyword-item? object) - (or (classifier-item? object) - (expander-item? object))) - -(register-predicate! keyword-item? 'keyword-item) -(set-predicate<=! classifier-item? keyword-item?) -(set-predicate<=! expander-item? keyword-item?) - ;;; Variable items represent run-time variables. (define (var-item id) diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm index 7e72af09f..3a2de40ea 100644 --- a/src/runtime/syntax-low.scm +++ b/src/runtime/syntax-low.scm @@ -56,11 +56,31 @@ USA. use-senv)) expr)) -(define-record-type - (expander-item impl expr) - expander-item? - (impl expander-item-impl) - (expr expander-item-expr)) +;;; Keyword items represent syntactic keywords. + +(define (keyword-item impl #!optional expr) + (%keyword-item impl expr)) + +(define (keyword-item-has-expr? item) + (not (default-object? (keyword-item-expr item)))) + +(define-record-type + (%keyword-item impl expr) + keyword-item? + (impl keyword-item-impl) + (expr keyword-item-expr)) + +(define (expander-item impl expr) + (keyword-item (lambda (form senv hist) + (reclassify (with-error-context form senv hist + (lambda () + (impl form senv))) + senv + hist)) + expr)) + +(define (classifier->runtime classifier) + (make-unmapped-macro-reference-trap (keyword-item classifier))) (define (->senv env) (if (syntactic-environment? env) diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index 2631907e1..a8d98d037 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -65,7 +65,7 @@ USA. ;;; (failure) (define (spar->classifier spar) - (classifier-item + (keyword-item (lambda (form senv hist) (spar (%new-input form hist) senv diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 9d6f506dd..2ec9317ce 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -73,17 +73,12 @@ USA. hist)) ((pair? form) (let ((item (classify-form-car form senv hist))) - (cond ((classifier-item? item) - ((classifier-item-impl item) form senv hist)) - ((expander-item? item) - (reclassify (with-error-context form senv hist - (lambda () - ((expander-item-impl item) form senv))) - senv - hist)) - (else + (if (keyword-item? item) + ((keyword-item-impl item) form senv hist) + (begin (if (not (list? (cdr form))) - (serror form senv hist "Combination must be a proper list:" form)) + (serror form senv hist + "Combination must be a proper list:" form)) (combination-item item (classify-forms-cdr form senv hist)))))) (else @@ -350,7 +345,7 @@ USA. (define (classifier->keyword classifier) (close-syntax 'keyword (make-keyword-senv 'keyword - (classifier-item classifier)))) + (keyword-item classifier)))) (define (capture-syntactic-environment expander) `(,(classifier->keyword -- 2.25.1