From: Chris Hanson <org/chris-hanson/cph>
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>
(%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)