From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 12 Feb 2018 06:48:57 +0000 (-0800)
Subject: Eliminate compile-body-item and simplify.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~249
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=edaaa5b1d14cd2156693cc9273774548cf63bc7d;p=mit-scheme.git
Eliminate compile-body-item and simplify.
---
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 96870ccc2..6a6c8c80f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4424,7 +4424,6 @@ USA.
classify-forms-cdr
classify-forms-in-order-cddr
classify-forms-in-order-cdr
- compile-body-items
compile-expr-item
define-item-compiler
hist-caddr
@@ -4541,10 +4540,8 @@ USA.
output/quoted-identifier
output/runtime-reference
output/sequence
+ output/syntax-definition
output/the-environment
- output/top-level-definition
- output/top-level-sequence
- output/top-level-syntax-definition
output/top-level-syntax-expander
output/unassigned
output/unassigned-test
diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 698f721d6..e48bc50e6 100644
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -180,7 +180,7 @@ USA.
(define (body-item items)
(expr-item
(lambda ()
- (output/body (compile-body-items items)))))
+ (output/body (map compile-expr-item items)))))
(define (if-item predicate consequent alternative)
(expr-item
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index 989fd9c5a..f3e4316b9 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -46,7 +46,7 @@ USA.
(define (output/assignment name value)
(make-scode-assignment name value))
-(define (output/top-level-definition name value)
+(define (output/definition name value)
(make-scode-definition name
(if (scode-lambda? value)
(lambda-components* value
@@ -56,7 +56,7 @@ USA.
value)))
value)))
-(define (output/top-level-syntax-definition name value)
+(define (output/syntax-definition name value)
(make-scode-definition name (make-macro-reference-trap-expression value)))
(define (output/top-level-syntax-expander procedure-name transformer)
@@ -70,16 +70,17 @@ USA.
(define (output/disjunction exprs)
(reduce-right make-scode-disjunction '#f exprs))
-(define (output/sequence expressions)
- (make-scode-sequence expressions))
+(define (output/sequence exprs)
+ (if (pair? exprs)
+ (make-scode-sequence exprs)
+ (output/unspecific)))
(define (output/combination operator operands)
(make-scode-combination operator operands))
(define (output/lambda name lambda-list body)
- (call-with-values (lambda () (parse-mit-lambda-list lambda-list))
- (lambda (required optional rest)
- (make-lambda* name required optional rest body))))
+ (receive (required optional rest) (parse-mit-lambda-list lambda-list)
+ (make-lambda* name required optional rest body)))
(define (output/delay expression)
(make-scode-delay expression))
@@ -120,23 +121,12 @@ USA.
(output/let '() '() body)
body))))))))
-(define (output/body body)
- (scan-defines body make-scode-open-block))
+(define (output/body exprs)
+ (scan-defines (output/sequence exprs) 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 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))
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 85d048824..3bfa73b75 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -54,34 +54,11 @@ USA.
(runtime-environment->syntactic environment))))
(with-identifier-renaming
(lambda ()
- (if (senv-top-level? senv)
- (%compile-top-level-body (%classify-body-top-level forms senv))
- (output/sequence
- (map (lambda (form)
- (compile-expr-item
- (%classify-form-top-level form senv)))
- forms)))))))
-
-(define (%classify-form-top-level form senv)
- (classify-form form senv (initial-hist form)))
-
-(define (%classify-body-top-level forms senv)
- (seq-item
- (map-in-order (lambda (form)
- (%classify-form-top-level form senv))
- forms)))
-
-(define (%compile-top-level-body item)
- (output/top-level-sequence
- (map (lambda (item)
- (if (defn-item? item)
- (let ((name (defn-item-id item))
- (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))))
+ (compile-expr-item
+ (body-item
+ (map-in-order (lambda (form)
+ (classify-form form senv (initial-hist form)))
+ forms)))))))
;;;; Classifier
@@ -148,22 +125,6 @@ USA.
;;;; Compiler
-(define (compile-body-items items)
- (let ((items (flatten-items items)))
- (if (not (pair? items))
- (syntax-error "Empty body"))
- (output/sequence
- (append-map
- (lambda (item)
- (if (defn-item? item)
- (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))))
-
(define compile-expr-item)
(add-boot-init!
(lambda ()
@@ -188,12 +149,22 @@ USA.
(define-item-compiler seq-item?
(lambda (item)
- (compile-body-items (seq-item-elements item))))
+ (output/sequence (map compile-expr-item (seq-item-elements item)))))
(define-item-compiler decl-item?
(lambda (item)
(output/declaration (decl-item-text item))))
+(define-item-compiler defn-item?
+ (lambda (item)
+ (if (defn-item? item)
+ (let ((name (defn-item-id item))
+ (value (compile-expr-item (defn-item-value item))))
+ (if (defn-item-syntax? item)
+ (output/syntax-definition name value)
+ (output/definition name value)))
+ (compile-expr-item item))))
+
(define (illegal-expression-compiler description)
(let ((message (string description " may not be used as an expression:")))
(lambda (item)
@@ -204,9 +175,6 @@ USA.
(define-item-compiler keyword-item?
(illegal-expression-compiler "Syntactic keyword"))
-
-(define-item-compiler defn-item?
- (illegal-expression-compiler "Definition"))
;;;; Syntactic closures