From: Chris Hanson Date: Tue, 30 Jan 2018 06:32:09 +0000 (-0800) Subject: Change declaration processing to decouple it from open blocks. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~285 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=94e75985835388cb5c102a56e966e21f3643b0c6;p=mit-scheme.git Change declaration processing to decouple it from open blocks. --- diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index a27ec554c..38ad6e38e 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -86,9 +86,7 @@ USA. (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) @@ -279,19 +277,19 @@ USA. (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)))) ;;;; 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)))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e117f38cc..bb0033b74 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4434,7 +4434,6 @@ USA. expr-item expr-item-compiler expr-item? - extract-declarations-from-body flatten-items item->list keyword-item? @@ -4518,6 +4517,7 @@ USA. output/combination output/conditional output/constant + output/declaration output/definition output/delay output/disjunction diff --git a/src/runtime/syntax-compile.scm b/src/runtime/syntax-compile.scm index b437d3c4b..216c4a313 100644 --- a/src/runtime/syntax-compile.scm +++ b/src/runtime/syntax-compile.scm @@ -41,11 +41,8 @@ USA. (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))) @@ -89,10 +86,14 @@ USA. (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")) @@ -100,8 +101,5 @@ USA. (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 diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm index d6d46e59b..2f0e2e90f 100644 --- a/src/runtime/syntax-items.scm +++ b/src/runtime/syntax-items.scm @@ -122,16 +122,17 @@ USA. ;;; 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 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)) diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index 680a7772f..58446894c 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -117,35 +117,22 @@ USA. (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)) @@ -155,7 +142,7 @@ USA. (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)) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 55b260628..2305828aa 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -154,11 +154,10 @@ USA. (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)