From: Chris Hanson Date: Wed, 7 Feb 2018 06:45:14 +0000 (-0800) Subject: Eliminate keyword-value-item. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~271 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=07a3f64ffc535c1dbaa8e3853540dbf813ccfedc;p=mit-scheme.git Eliminate keyword-value-item. --- diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index ef3c9beaf..0c9e83181 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -35,16 +35,12 @@ USA. (lambda (form senv) (syntax-check '(KEYWORD EXPRESSION) form) (let ((transformer (compile-expr (cadr form) senv))) - (let ((item - (transformer->expander (transformer-eval transformer senv) - senv))) - (if (top-level-syntactic-environment? senv) - (keyword-value-item - item - (expr-item - (lambda () - (output/top-level-syntax-expander procedure-name transformer)))) - item))))) + (transformer->expander (transformer-eval transformer senv) + senv + (expr-item + (lambda () + (output/top-level-syntax-expander + procedure-name transformer))))))) (define classifier:sc-macro-transformer ;; "Syntactic Closures" transformer @@ -160,9 +156,9 @@ USA. (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) - (top-level-syntactic-environment? environment)) - (defn-item name item) + (if (and (top-level-syntactic-environment? environment) + (expander-item? item)) + (syntax-defn-item name (expander-item-expr item)) (seq-item '())))) (define (keyword-binder environment name item) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6ac545178..94d6964b3 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4428,9 +4428,11 @@ USA. decl-item? defn-item defn-item-id + defn-item-syntax? defn-item-value defn-item? expander-item + expander-item-expr expander-item-impl expander-item? expr-item @@ -4439,15 +4441,12 @@ USA. flatten-items item->list keyword-item? - keyword-value-item - keyword-value-item-expr - keyword-value-item-keyword - keyword-value-item? reserved-name-item reserved-name-item? seq-item seq-item-elements seq-item? + syntax-defn-item var-item var-item-id var-item?)) diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm index 2f0e2e90f..f6c1c3893 100644 --- a/src/runtime/syntax-items.scm +++ b/src/runtime/syntax-items.scm @@ -44,27 +44,20 @@ USA. (impl compiler-item-impl)) (define-record-type - (expander-item impl) + (expander-item impl expr) expander-item? - (impl expander-item-impl)) - -(define-record-type - (keyword-value-item keyword expr) - keyword-value-item? - (keyword keyword-value-item-keyword) - (expr keyword-value-item-expr)) + (impl expander-item-impl) + (expr expander-item-expr)) (define (keyword-item? object) (or (classifier-item? object) (compiler-item? object) - (expander-item? object) - (keyword-value-item? object))) + (expander-item? object))) (register-predicate! keyword-item? 'keyword-item) (set-predicate<=! classifier-item? keyword-item?) (set-predicate<=! compiler-item? keyword-item?) (set-predicate<=! expander-item? keyword-item?) -(set-predicate<=! keyword-value-item? keyword-item?) ;;; Variable items represent run-time variables. @@ -97,10 +90,15 @@ USA. ;;; Definition items, whether top-level or internal, keyword or variable. +(define (syntax-defn-item id value) + (guarantee identifier? id 'syntax-defn-item) + (guarantee defn-item-value? value 'syntax-defn-item) + (%defn-item id value #t)) + (define (defn-item id value) (guarantee identifier? id 'defn-item) (guarantee defn-item-value? value 'defn-item) - (%defn-item id value)) + (%defn-item id value #f)) (define (defn-item-value? object) (not (or (reserved-name-item? object) @@ -108,10 +106,11 @@ USA. (register-predicate! defn-item-value? 'defn-item-value) (define-record-type - (%defn-item id value) + (%defn-item id value syntax?) defn-item? (id defn-item-id) - (value defn-item-value)) + (value defn-item-value) + (syntax? defn-item-syntax?)) (define-unparser-method defn-item? (simple-unparser-method 'defn-item diff --git a/src/runtime/syntax-transforms.scm b/src/runtime/syntax-transforms.scm index 7f6e77819..d0837ca6d 100644 --- a/src/runtime/syntax-transforms.scm +++ b/src/runtime/syntax-transforms.scm @@ -31,25 +31,30 @@ USA. (declare (usual-integrations)) -(define (sc-macro-transformer->expander transformer closing-env) - (expander-item - (lambda (form use-senv) - (close-syntax (transformer form use-senv) - (->senv closing-env))))) - -(define (rsc-macro-transformer->expander transformer closing-env) - (expander-item - (lambda (form use-senv) - (close-syntax (transformer form (->senv closing-env)) - use-senv)))) - -(define (er-macro-transformer->expander transformer closing-env) - (expander-item - (lambda (form use-senv) - (close-syntax (transformer form - (make-er-rename (->senv closing-env)) - (make-er-compare use-senv)) - use-senv)))) +;;; These optional arguments are needed for cross-compiling 9.2->9.3. +;;; They can become required after 9.3 release. + +(define (sc-macro-transformer->expander transformer closing-env #!optional expr) + (expander-item (lambda (form use-senv) + (close-syntax (transformer form use-senv) + (->senv closing-env))) + expr)) + +(define (rsc-macro-transformer->expander transformer closing-env + #!optional expr) + (expander-item (lambda (form use-senv) + (close-syntax (transformer form (->senv closing-env)) + use-senv)) + expr)) + +(define (er-macro-transformer->expander transformer closing-env #!optional expr) + (expander-item (lambda (form use-senv) + (close-syntax (transformer form + (make-er-rename + (->senv closing-env)) + (make-er-compare use-senv)) + use-senv)) + expr)) (define (->senv env) (if (syntactic-environment? env) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 7410399d6..9673672e2 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -68,18 +68,7 @@ USA. (define (classify-form form environment) (cond ((identifier? form) - (let ((item (lookup-identifier form environment))) - (if (keyword-item? item) - (keyword-value-item - (strip-keyword-value-item item) - (expr-item - (let ((name (identifier->symbol form))) - (lambda () - (output/combination - (output/runtime-reference 'syntactic-keyword->item) - (list (output/constant name) - (output/the-environment))))))) - item))) + (lookup-identifier form environment)) ((syntactic-closure? form) (classify-form (syntactic-closure-form form) @@ -87,9 +76,7 @@ USA. environment (syntactic-closure-senv form)))) ((pair? form) - (let ((item - (strip-keyword-value-item - (classify-form (car form) environment)))) + (let ((item (classify-form (car form) environment))) (cond ((classifier-item? item) ((classifier-item-impl item) form environment)) ((compiler-item? item) @@ -115,11 +102,6 @@ USA. (else (expr-item (lambda () (output/constant form)))))) -(define (strip-keyword-value-item item) - (if (keyword-value-item? item) - (keyword-value-item-keyword item) - item)) - (define (classify-body forms environment) ;; Syntactic definitions affect all forms that appear after them, so classify ;; FORMS in order. @@ -138,14 +120,10 @@ USA. (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)))) + (value (compile-expr-item (defn-item-value item)))) + (if (defn-item-syntax? item) + (output/top-level-syntax-definition name value) + (output/top-level-definition name value))) (compile-expr-item item))) (item->list item)))) @@ -157,11 +135,11 @@ USA. (append-map (lambda (item) (if (defn-item? item) - (let ((value (defn-item-value item))) - (if (keyword-value-item? value) - '() - (list (output/definition (defn-item-id item) - (compile-expr-item value))))) + (if (defn-item-syntax? item) + '() + (list (output/definition + (defn-item-id item) + (compile-expr-item (defn-item-value item))))) (list (compile-expr-item item)))) items)))) diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index 12f3691a8..f35f3071e 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -196,7 +196,10 @@ USA. (and (scode-access? operator) (eq? system-global-environment (scode-access-environment operator)) - (= 2 (length operands)) + ;; Two args for legacy; three for new. + ;; Erase legacy support after 9.3 release. + (or (= 2 (length operands)) + (= 3 (length operands))) (scode-lambda? (car operands)) (scode-the-environment? (cadr operands)) (let ((go