(define (transformer-keyword procedure-name transformer->expander)
(lambda (form senv)
(syntax-check '(KEYWORD EXPRESSION) form)
- (let ((transformer
- (compile-item/expression
- (classify/expression (cadr form) senv))))
+ (let ((transformer (compile-expr (cadr form) senv)))
(let ((item
(transformer->expander (transformer-eval transformer senv)
senv)))
bvl)))
(values bvl
(compile-body-item
- (classify/body body environment))))))
+ (classify-body body environment))))))
(define (compile-body-item item)
(output/body (compile-body-items (item->list item))))
(define (classifier:begin form environment)
(syntax-check '(KEYWORD * FORM) form)
- (classify/body (cdr form) environment))
+ (classify-body (cdr form) environment))
(define (compiler:if form environment)
(syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form)
(output/conditional
- (compile/expression (cadr form) environment)
- (compile/expression (caddr form) environment)
+ (compile-expr (cadr form) environment)
+ (compile-expr (caddr form) environment)
(if (pair? (cdddr form))
- (compile/expression (cadddr form) environment)
+ (compile-expr (cadddr form) environment)
(output/unspecific))))
(define (compiler:quote form environment)
(classify/location (cadr form) environment)
(let ((value
(if (pair? (cddr form))
- (compile/expression (caddr form) environment)
+ (compile-expr (caddr form) environment)
(output/unassigned))))
(if environment-item
(output/access-assignment
name
- (compile-item/expression environment-item)
+ (compile-expr-item environment-item)
value)
(output/assignment name value)))))
(define (classify/location form environment)
- (let ((item (classify/expression form environment)))
+ (let ((item (classify-form form environment)))
(cond ((var-item? item)
(values (var-item-id item) #f))
((access-item? item)
(define (compiler:delay form environment)
(syntax-check '(KEYWORD EXPRESSION) form)
- (output/delay (compile/expression (cadr form) environment)))
+ (output/delay (compile-expr (cadr form) environment)))
\f
;;;; Definitions
(variable-binder defn-item
environment
name
- (classify/expression (caddr form) environment))))))
+ (classify-form (caddr form) environment))))))
(define (classifier:define-syntax form environment)
(syntax-check '(keyword identifier expression) form)
(let ((name (cadr form))
- (item (classify/expression (caddr form) environment)))
+ (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)
(variable-binder cons
binding-env
(car binding)
- (classify/expression (cadr binding) env)))
+ (classify-form (cadr binding) env)))
bindings)))
(expr-item
(let ((names (map car bindings))
(values (map cdr bindings))
(seq-item
- (classify/body
+ (classify-body
body
(make-internal-syntactic-environment binding-env))))
(lambda ()
(output/let names
- (map compile-item/expression values)
+ (map compile-expr-item values)
(compile-body-item seq-item))))))))))
(define (classifier:let-syntax form env)
(for-each (lambda (binding)
(keyword-binder binding-env
(car binding)
- (classify/expression (cadr binding) env)))
+ (classify-form (cadr binding) env)))
bindings)
- (classify/body body (make-internal-syntactic-environment binding-env))))
+ (classify-body body (make-internal-syntactic-environment binding-env))))
(define keyword:let-syntax
(classifier->keyword classifier:let-syntax))
(keyword-binder binding-env (car binding) item))
bindings
(map (lambda (binding)
- (classify/expression (cadr binding) binding-env))
+ (classify-form (cadr binding) binding-env))
bindings))
- (classify/body body (make-internal-syntactic-environment binding-env))))
+ (classify-body body (make-internal-syntactic-environment binding-env))))
;; TODO: this is a compiler rather than a macro because it uses the
;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in
(syntax-check '(KEYWORD * EXPRESSION) form)
(if (pair? (cdr form))
(let loop ((expressions (cdr form)))
- (let ((compiled (compile/expression (car expressions) environment)))
+ (let ((compiled (compile-expr (car expressions) environment)))
(if (pair? (cdr expressions))
(output/disjunction compiled (loop (cdr expressions)))
compiled)))
(classifier->keyword
(lambda (form environment)
(make-access-item (cadr form)
- (classify/expression (caddr form) environment)))))
+ (classify-form (caddr form) environment)))))
(define-item-compiler access-item?
(lambda (item)
(output/access-reference
(access-item/name item)
- (compile-item/expression (access-item/environment item)))))
+ (compile-expr-item (access-item/environment item)))))
(define (compiler:the-environment form environment)
(syntax-check '(KEYWORD) form)
declaration))
(define (classify/variable-reference identifier environment)
- (let ((item (classify/expression identifier environment)))
+ (let ((item (classify-form identifier environment)))
(if (not (var-item? item))
(syntax-error "Variable required in this context:" identifier))
item))
\ No newline at end of file
(with-identifier-renaming
(lambda ()
(if (top-level-syntactic-environment? senv)
- (compile-body-item/top-level (classify/body forms senv))
- (output/sequence (compile/expressions forms senv)))))))
-
-(define (compile/expression expression environment)
- (compile-item/expression (classify/expression expression environment)))
-
-(define (compile/expressions expressions environment)
- (map (lambda (expression)
- (compile/expression expression environment))
- expressions))
+ (compile-top-level-body (classify-body forms senv))
+ (output/sequence
+ (map (lambda (expr)
+ (compile-expr expr senv))
+ forms)))))))
+
+(define (compile-expr expression environment)
+ (compile-expr-item (classify-form expression environment)))
\f
;;;; Classifier
-(define (classify/form form environment)
+(define (classify-form form environment)
(cond ((identifier? form)
(let ((item (lookup-identifier form environment)))
(if (keyword-item? item)
(output/the-environment)))))))
item)))
((syntactic-closure? form)
- (classify/form
+ (classify-form
(syntactic-closure-form form)
(make-partial-syntactic-environment (syntactic-closure-free form)
environment
((pair? form)
(let ((item
(strip-keyword-value-item
- (classify/expression (car form) environment))))
+ (classify-form (car form) environment))))
(cond ((classifier-item? item)
((classifier-item-impl item) form environment))
((compiler-item? item)
(lambda ()
(compiler form environment)))))
((expander-item? item)
- (classify/form ((expander-item-impl item) form environment)
+ (classify-form ((expander-item-impl item) form environment)
environment))
(else
(if (not (list? (cdr form)))
(syntax-error "Combination must be a proper list:" form))
(expr-item
- (let ((items (classify/expressions (cdr form) environment)))
+ (let ((items
+ (map (lambda (expr)
+ (classify-form expr environment))
+ (cdr form))))
(lambda ()
(output/combination
- (compile-item/expression item)
- (map compile-item/expression items)))))))))
+ (compile-expr-item item)
+ (map compile-expr-item items)))))))))
(else
(expr-item (lambda () (output/constant form))))))
(keyword-value-item-keyword item)
item))
-(define (classify/expression expression environment)
- (classify/form expression environment))
-
-(define (classify/expressions expressions environment)
- (map (lambda (expression)
- (classify/expression expression environment))
- expressions))
-
-(define (classify/body forms environment)
+(define (classify-body forms environment)
;; Syntactic definitions affect all forms that appear after them, so classify
;; FORMS in order.
(seq-item
(let loop ((forms forms) (items '()))
(if (pair? forms)
(loop (cdr forms)
- (reverse* (item->list (classify/form (car forms) environment))
+ (reverse* (item->list (classify-form (car forms) environment))
items))
(reverse! items)))))
\f
;;;; Compiler
-(define (compile-item/top-level item)
- (if (defn-item? item)
- (let ((name (identifier->symbol (defn-item-id item)))
- (value (defn-item-value item)))
- (if (keyword-value-item? value)
- (output/top-level-syntax-definition
- name
- (compile-item/expression (keyword-value-item-expr value)))
- (output/top-level-definition
- name
- (compile-item/expression value))))
- (compile-item/expression item)))
-
-(define (compile-body-item/top-level item)
- (output/top-level-sequence (map compile-item/top-level (item->list item))))
+(define (compile-top-level-body item)
+ (output/top-level-sequence
+ (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))))
+ (compile-expr-item item)))
+ (item->list item))))
(define (compile-body-items items)
(let ((items (flatten-items items)))
(if (keyword-value-item? value)
'()
(list (output/definition (defn-item-id item)
- (compile-item/expression value)))))
- (list (compile-item/expression item))))
+ (compile-expr-item value)))))
+ (list (compile-expr-item item))))
items))))
-(define compile-item/expression)
+(define compile-expr-item)
(add-boot-init!
(lambda ()
- (set! compile-item/expression
- (standard-predicate-dispatcher 'compile-item/expression 1))
+ (set! compile-expr-item
+ (standard-predicate-dispatcher 'compile-expr-item 1))
(run-deferred-boot-actions 'define-item-compiler)))
(define (define-item-compiler predicate compiler)
(defer-boot-action 'define-item-compiler
(lambda ()
- (define-predicate-dispatch-handler compile-item/expression
+ (define-predicate-dispatch-handler compile-expr-item
(list predicate)
compiler))))
((closed-identifier? identifier) (syntactic-closure-form identifier))
(else (error:not-a identifier? identifier 'identifier->symbol))))
-(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
- (let ((item-1 (lookup-identifier identifier-1 environment-1))
- (item-2 (lookup-identifier identifier-2 environment-2)))
+(define (identifier=? senv-1 identifier-1 senv-2 identifier-2)
+ (let ((item-1 (lookup-identifier identifier-1 senv-1))
+ (item-2 (lookup-identifier identifier-2 senv-2)))
(or (eq? item-1 item-2)
;; This is necessary because an identifier that is not explicitly bound
;; by an environment is mapped to a variable item, and the variable
(define (capture-syntactic-environment expander)
`(,(classifier->keyword
- (lambda (form environment)
- form ;ignore
- (classify/form (expander environment)
- environment)))))
+ (lambda (form senv)
+ (declare (ignore form))
+ (classify-form (expander senv) senv)))))
-(define (reverse-syntactic-environments environment procedure)
+(define (reverse-syntactic-environments senv procedure)
(capture-syntactic-environment
- (lambda (closing-environment)
- (close-syntax (procedure closing-environment) environment))))
\ No newline at end of file
+ (lambda (closing-senv)
+ (close-syntax (procedure closing-senv) senv))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff