From: Chris Hanson 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