(ill-formed-syntax form)))))))
\f
(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 ()
usual==>
with-instance-variables)
(import (runtime syntax)
- classifier-item
+ classifier->runtime
classify-form
compile-expr-item
expr-item))
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))))
\f
;;;; 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))))
(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)))
\f
;;;; Core primitives
(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)
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")
access-assignment-item
assignment-item
body-item
- classifier-item
- classifier-item-impl
- classifier-item?
combination-item
compile-expr-item
constant-item
flatten-items
if-item
item->list
- keyword-item?
lambda-item
let-item
or-item
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))
\f
;;; 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>
- (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)
use-senv))
expr))
-(define-record-type <expander-item>
- (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>
+ (%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)
;;; (failure)
(define (spar->classifier spar)
- (classifier-item
+ (keyword-item
(lambda (form senv hist)
(spar (%new-input form hist)
senv
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
(define (classifier->keyword classifier)
(close-syntax 'keyword
(make-keyword-senv 'keyword
- (classifier-item classifier))))
+ (keyword-item classifier))))
(define (capture-syntactic-environment expander)
`(,(classifier->keyword
projects / mit-scheme.git / commitdiff