This is the first step in eliminating the idea of a "compiler".
(syntax-check '(_ * form) form)
(classify-body-cdr form senv hist))
-(define (compiler:if form senv hist)
+(define (classifier:if form senv hist)
(syntax-check '(_ expression expression ? expression) form)
- (output/conditional
- (compile-expr-item (classify-form-cadr form senv hist))
- (compile-expr-item (classify-form-caddr form senv hist))
- (if (pair? (cdddr form))
- (compile-expr-item (classify-form-cadddr form senv hist))
- (output/unspecific))))
-
-(define (compiler:quote form senv hist)
+ (if-item (classify-form-cadr form senv hist)
+ (classify-form-caddr form senv hist)
+ (if (pair? (cdddr form))
+ (classify-form-cadddr form senv hist)
+ (unspecific-item))))
+
+(define (classifier:quote form senv hist)
(declare (ignore senv hist))
(syntax-check '(_ datum) form)
- (output/constant (strip-syntactic-closures (cadr form))))
+ (constant-item (strip-syntactic-closures (cadr form))))
-(define (compiler:quote-identifier form senv hist)
+(define (classifier:quote-identifier form senv hist)
(declare (ignore hist))
(syntax-check '(_ identifier) form)
(let ((item (lookup-identifier (cadr form) senv)))
(if (not (var-item? item))
(syntax-error "Can't quote a keyword identifier:" form))
- (output/quoted-identifier (var-item-id item))))
+ (quoted-id-item item)))
-(define (compiler:set! form senv hist)
+(define (classifier:set! form senv hist)
(syntax-check '(_ form ? expression) form)
- (let ((lhs (classify-form-cadr form senv hist))
- (rhs
+ (let ((lhs-item (classify-form-cadr form senv hist))
+ (rhs-item
(if (pair? (cddr form))
- (compile-expr-item (classify-form-caddr form senv hist))
- (output/unassigned))))
- (cond ((var-item? lhs)
- (output/assignment (var-item-id lhs) rhs))
- ((access-item? lhs)
- (output/access-assignment (access-item-name lhs)
- (compile-expr-item (access-item-env lhs))
- rhs))
+ (classify-form-caddr form senv hist)
+ (unassigned-item))))
+ (cond ((var-item? lhs-item)
+ (assignment-item (var-item-id lhs-item) rhs-item))
+ ((access-item? lhs-item)
+ (access-assignment-item (access-item-name lhs-item)
+ (access-item-env lhs-item)
+ rhs-item))
(else
(syntax-error "Variable required in this context:" (cadr form))))))
(car binding)
(classify-form-cadr binding senv hist)))
(cadr form)
- (subform-hists (cadr form) (hist-cadr hist))))
- (body-item
- (classify-body-cddr form
- (make-internal-senv binding-senv)
- hist)))
- (expr-item
- (let ((names (map car bindings))
- (values (map cdr bindings)))
- (lambda ()
- (output/let names
- (map compile-expr-item values)
- (compile-body-item body-item)))))))))
+ (subform-hists (cadr form) (hist-cadr hist)))))
+ (let-item (map car bindings)
+ (map cdr bindings)
+ (classify-body-cddr form
+ (make-internal-senv binding-senv)
+ hist))))))
(define (classifier:let-syntax form senv hist)
(syntax-check '(_ (* (identifier expression)) + form) form)
(subform-hists bindings (hist-cadr hist)))))
(classify-body-cddr form (make-internal-senv binding-senv) hist)))
-;; TODO: this is a compiler rather than a macro because it uses the
+;; TODO: this is a classifier rather than a macro because it uses the
;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in
;; the compiler wants this, but it would be nice to eliminate this
;; hack.
-(define (compiler:or form senv hist)
+(define (classifier:or form senv hist)
(syntax-check '(_ * expression) form)
- (reduce-right output/disjunction
- '#f
- (map compile-expr-item
- (classify-forms (cdr form) senv (hist-cdr hist)))))
+ (or-item (classify-forms (cdr form) senv (hist-cdr hist))))
\f
;;;; MIT-specific syntax
(output/access-reference (access-item-name item)
(compile-expr-item (access-item-env item)))))
-(define (compiler:the-environment form senv hist)
+(define (classifier:the-environment form senv hist)
(declare (ignore hist))
(syntax-check '(_) form)
(if (not (senv-top-level? senv))
(syntax-error "This form allowed only at top level:" form))
- (output/the-environment))
+ (the-environment-item))
(define keyword:unspecific
- (compiler->keyword
+ (classifier->keyword
(lambda (form senv hist)
(declare (ignore form senv hist))
- (output/unspecific))))
+ (unspecific-item))))
(define keyword:unassigned
- (compiler->keyword
+ (classifier->keyword
(lambda (form senv hist)
(declare (ignore form senv hist))
- (output/unassigned))))
+ (unassigned-item))))
\f
;;;; Declarations
(files "syntax-items")
(parent (runtime syntax))
(export (runtime syntax)
+ access-assignment-item
+ assignment-item
+ body-item
classifier-item
classifier-item-impl
classifier-item?
compiler-item
compiler-item-impl
compiler-item?
+ combination-item
+ constant-item
decl-item
decl-item-text
decl-item?
defn-item-syntax?
defn-item-value
defn-item?
+ delay-item
expander-item
expander-item-expr
expander-item-impl
expr-item-compiler
expr-item?
flatten-items
+ if-item
item->list
keyword-item?
+ lambda-item
+ let-item
+ or-item
+ quoted-id-item
reserved-name-item
reserved-name-item?
seq-item
seq-item-elements
seq-item?
syntax-defn-item
+ the-environment-item
+ unassigned-item
+ unspecific-item
var-item
var-item-id
var-item?))
classifier:declare
classifier:define-syntax
classifier:er-macro-transformer
+ classifier:if
classifier:let-syntax
classifier:letrec-syntax
+ classifier:or
+ classifier:quote
+ classifier:quote-identifier
classifier:rsc-macro-transformer
classifier:sc-macro-transformer
+ classifier:set!
+ classifier:the-environment
compiler:delay
- compiler:if
compiler:lambda
- compiler:named-lambda
- compiler:or
- compiler:quote
- compiler:quote-identifier
- compiler:set!
- compiler:the-environment)
+ compiler:named-lambda)
(export (runtime mit-macros)
keyword:access
keyword:define
(define (define-classifier name classifier)
(def name (classifier-item classifier)))
- (define-classifier 'BEGIN classifier:begin)
- (define-classifier 'DECLARE classifier:declare)
- (define-classifier 'DEFINE-SYNTAX classifier:define-syntax)
- (define-classifier 'ER-MACRO-TRANSFORMER classifier:er-macro-transformer)
- (define-classifier 'LET-SYNTAX classifier:let-syntax)
- (define-classifier 'LETREC-SYNTAX classifier:letrec-syntax)
- (define-classifier 'RSC-MACRO-TRANSFORMER classifier:rsc-macro-transformer)
- (define-classifier 'SC-MACRO-TRANSFORMER classifier:sc-macro-transformer)
+ (define-classifier 'begin classifier:begin)
+ (define-classifier 'declare classifier:declare)
+ (define-classifier 'define-syntax classifier:define-syntax)
+ (define-classifier 'er-macro-transformer classifier:er-macro-transformer)
+ (define-classifier 'if classifier:if)
+ (define-classifier 'let-syntax classifier:let-syntax)
+ (define-classifier 'letrec-syntax classifier:letrec-syntax)
+ (define-classifier 'or classifier:or)
+ (define-classifier 'quote classifier:quote)
+ (define-classifier 'quote-identifier classifier:quote-identifier)
+ (define-classifier 'rsc-macro-transformer classifier:rsc-macro-transformer)
+ (define-classifier 'sc-macro-transformer classifier:sc-macro-transformer)
+ (define-classifier 'set! classifier:set!)
+ (define-classifier 'the-environment classifier:the-environment)
(define (define-compiler name compiler)
(def name (compiler-item compiler)))
- (define-compiler 'DELAY compiler:delay)
- (define-compiler 'IF compiler:if)
- (define-compiler 'LAMBDA compiler:lambda)
- (define-compiler 'NAMED-LAMBDA compiler:named-lambda)
- (define-compiler 'OR compiler:or)
- (define-compiler 'QUOTE compiler:quote)
- (define-compiler 'quote-identifier compiler:quote-identifier)
- (define-compiler 'SET! compiler:set!)
- (define-compiler 'THE-ENVIRONMENT compiler:the-environment)))
\ No newline at end of file
+ (define-compiler 'delay compiler:delay)
+ (define-compiler 'lambda compiler:lambda)
+ (define-compiler 'named-lambda compiler:named-lambda)))
\ No newline at end of file
(text-getter decl-item-text-getter))
(define (decl-item-text item)
- ((decl-item-text-getter item)))
\ No newline at end of file
+ ((decl-item-text-getter item)))
+\f
+;;;; Specific expression items
+
+(define (combination-item operator operands)
+ (expr-item
+ (lambda ()
+ (output/combination (compile-expr-item operator)
+ (map compile-expr-item operands)))))
+
+(define (constant-item datum)
+ (expr-item
+ (lambda ()
+ (output/constant datum))))
+
+(define (lambda-item name bvl body-item)
+ (expr-item
+ (lambda ()
+ (output/lambda name bvl (compile-expr-item body-item)))))
+
+(define (let-item names value-items body-item)
+ (expr-item
+ (lambda ()
+ (output/let names
+ (map compile-expr-item value-items)
+ (compile-expr-item body-item)))))
+
+(define (body-item items)
+ (expr-item
+ (lambda ()
+ (output/body (compile-body-items items)))))
+
+(define (if-item predicate consequent alternative)
+ (expr-item
+ (lambda ()
+ (output/conditional (compile-expr-item predicate)
+ (compile-expr-item consequent)
+ (compile-expr-item alternative)))))
+
+(define (quoted-id-item var-item)
+ (expr-item
+ (lambda ()
+ (output/quoted-identifier (var-item-id var-item)))))
+
+(define (assignment-item id rhs-item)
+ (expr-item
+ (lambda ()
+ (output/assignment id (compile-expr-item rhs-item)))))
+
+(define (access-assignment-item name env-item rhs-item)
+ (expr-item
+ (lambda ()
+ (output/access-assignment name
+ (compile-expr-item env-item)
+ (compile-expr-item rhs-item)))))
+
+(define (delay-item item)
+ (expr-item
+ (lambda ()
+ (output/delay (compile-expr-item item)))))
+
+(define (or-item items)
+ (expr-item
+ (lambda ()
+ (output/disjunction (map compile-expr-item items)))))
+
+(define (the-environment-item)
+ (expr-item output/the-environment))
+
+(define (unspecific-item)
+ (expr-item output/unspecific))
+
+(define (unassigned-item)
+ (expr-item output/unassigned))
\ No newline at end of file
(define (output/conditional predicate consequent alternative)
(make-scode-conditional predicate consequent alternative))
-(define (output/disjunction predicate alternative)
- (make-scode-disjunction predicate alternative))
+(define (output/disjunction exprs)
+ (reduce-right make-scode-disjunction '#f exprs))
(define (output/sequence expressions)
(make-scode-sequence expressions))
projects / mit-scheme.git / commitdiff