(classify/body body environment))))))
(define (compile-body-item item)
- (receive (decl-items items) (extract-declarations-from-body item)
- (output/body (map decl-item-text decl-items)
- (compile-body-items items))))
+ (output/body (compile-body-items (item->list item))))
(define (classifier:begin form environment)
(syntax-check '(KEYWORD * FORM) form)
(define keyword:unspecific
(compiler->keyword
(lambda (form environment)
- form environment ;ignore
+ (declare (ignore form environment))
(output/unspecific))))
(define keyword:unassigned
(compiler->keyword
(lambda (form environment)
- form environment ;ignore
+ (declare (ignore form environment))
(output/unassigned))))
\f
;;;; Declarations
(define (classifier:declare form environment)
- (syntax-check '(KEYWORD * (IDENTIFIER * DATUM)) form)
+ (syntax-check '(keyword * (identifier * datum)) form)
(decl-item
(lambda ()
(classify/declarations (cdr form) environment))))
expr-item
expr-item-compiler
expr-item?
- extract-declarations-from-body
flatten-items
item->list
keyword-item?
output/combination
output/conditional
output/constant
+ output/declaration
output/definition
output/delay
output/disjunction
(compile-item/expression value))))
(compile-item/expression item)))
-(define (compile-body-item/top-level seq-item)
- (receive (decl-items body-items)
- (extract-declarations-from-body seq-item)
- (output/top-level-sequence (map decl-item-text decl-items)
- (map compile-item/top-level body-items))))
+(define (compile-body-item/top-level item)
+ (output/top-level-sequence (map compile-item/top-level (item->list item))))
(define (compile-body-items items)
(let ((items (flatten-items items)))
(lambda (item)
(compile-body-items (seq-item-elements item))))
-(define (illegal-expression-compiler description)
+(define-item-compiler decl-item?
(lambda (item)
- (syntax-error (string description " may not be used as an expression:")
- item)))
+ (output/declaration (decl-item-text item))))
+
+(define (illegal-expression-compiler description)
+ (let ((message (string description " may not be used as an expression:")))
+ (lambda (item)
+ (syntax-error message item))))
(define-item-compiler reserved-name-item?
(illegal-expression-compiler "Reserved name"))
(define-item-compiler keyword-item?
(illegal-expression-compiler "Syntactic keyword"))
-(define-item-compiler decl-item?
- (illegal-expression-compiler "Declaration"))
-
(define-item-compiler defn-item?
(illegal-expression-compiler "Definition"))
\ No newline at end of file
;;; Sequence items.
(define (seq-item elements)
- (%seq-item (flatten-items elements)))
+ (let ((elements (flatten-items elements)))
+ (if (and (pair? elements)
+ (null? (cdr elements)))
+ (car elements)
+ (%seq-item elements))))
(define-record-type <seq-item>
(%seq-item elements)
seq-item?
(elements seq-item-elements))
-(define (extract-declarations-from-body seq-item)
- (partition decl-item? (seq-item-elements seq-item)))
-
(define (flatten-items items)
(append-map item->list items))
(output/let '() '() body)
body))))))))
-(define (output/body declarations body)
- (scan-defines (let ((declarations (apply append declarations)))
- (if (pair? declarations)
- (make-scode-sequence
- (list (make-scode-block-declaration declarations)
- body))
- body))
- make-scode-open-block))
+(define (output/body body)
+ (scan-defines body make-scode-open-block))
+
+(define (output/declaration text)
+ (make-scode-block-declaration text))
(define (output/definition name value)
(make-scode-definition name value))
-(define (output/top-level-sequence declarations expressions)
- (let ((declarations (apply append declarations))
- (make-scode-open-block
- (lambda (expressions)
- (scan-defines (make-scode-sequence expressions)
- make-scode-open-block))))
- (if (pair? declarations)
- (make-scode-open-block
- (cons (make-scode-block-declaration declarations)
- (if (pair? expressions)
- expressions
- (list (output/unspecific)))))
- (if (pair? expressions)
- (if (pair? (cdr expressions))
- (make-scode-open-block expressions)
- (car expressions))
- (output/unspecific)))))
+(define (output/top-level-sequence expressions)
+ (if (pair? expressions)
+ (if (pair? (cdr expressions))
+ (scan-defines (make-scode-sequence expressions)
+ make-scode-open-block)
+ (car expressions))
+ (output/unspecific)))
(define (output/the-environment)
(make-scode-the-environment))
(define (output/access-assignment name environment value)
(make-scode-combination (ucode-primitive lexical-assignment)
- (list environment name value)))
+ (list environment name value)))
(define (output/runtime-reference name)
(output/access-reference name system-global-environment))
(let ((item-1 (lookup-identifier identifier-1 environment-1))
(item-2 (lookup-identifier identifier-2 environment-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 items are not cached. Therefore
- ;; two references to the same variable result in two
- ;; different variable items.
+ ;; This is necessary because an identifier that is not explicitly bound
+ ;; by an environment is mapped to a variable item, and the variable
+ ;; items are not hash-consed. Therefore two references to the same
+ ;; variable result in two different variable items.
(and (var-item? item-1)
(var-item? item-2)
(eq? (var-item-id item-1)
projects / mit-scheme.git / commitdiff