(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
(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)
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
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?))
(impl compiler-item-impl))
(define-record-type <expander-item>
- (expander-item impl)
+ (expander-item impl expr)
expander-item?
- (impl expander-item-impl))
-
-(define-record-type <keyword-value-item>
- (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.
;;; 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)
(register-predicate! defn-item-value? 'defn-item-value)
(define-record-type <defn-item>
- (%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
(declare (usual-integrations))
\f
-(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)
(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)
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)
(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.
(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))))
(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))))
(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
projects / mit-scheme.git / commitdiff