From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Jan 2018 07:14:31 +0000 (-0800)
Subject: Change compile-item/expression to be a predicate dispatcher.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~299
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=460486c818cefc514725679f3c5e0a20aba483d1;p=mit-scheme.git
Change compile-item/expression to be a predicate dispatcher.
Also, a bunch of small changes, mostly cleanups and simplification.
---
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 16fc336ba..00b04a266 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -530,6 +530,7 @@ USA.
(RUNTIME UNSYNTAXER)
(RUNTIME PRETTY-PRINTER)
(RUNTIME EXTENDED-SCODE-EVAL)
+ (runtime syntax compile)
(RUNTIME SYNTAX DEFINITIONS)
(runtime syntax rename)
;; REP Loops
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index ba8b33b2e..519a2b2a5 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -86,8 +86,7 @@ USA.
(classify/body body environment))))))
(define (compile-body-item item)
- (receive (declaration-items items)
- (extract-declarations-from-body (body-item/components item))
+ (receive (declaration-items items) (extract-declarations-from-body item)
(output/body (map declaration-item/text declaration-items)
(compile-body-items items))))
@@ -256,7 +255,7 @@ USA.
(make-access-item (cadr form)
(classify/expression (caddr form) environment)))))
-(define-item-compiler <access-item>
+(define-item-compiler access-item?
(lambda (item)
(output/access-reference
(access-item/name item)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 96a2a3ded..0faf0a036 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4384,7 +4384,6 @@ USA.
(files "syntax")
(parent (runtime syntax))
(export ()
- <syntactic-closure>
capture-syntactic-environment
close-syntax
identifier->symbol
@@ -4412,20 +4411,11 @@ USA.
(files "syntax-items")
(parent (runtime syntax))
(export (runtime syntax)
- <binding-item>
- <body-item>
- <classifier-item>
- <compiler-item>
- <declaration-item>
- <expander-item>
- <expression-item>
- <keyword-value-item>
- <reserved-name-item>
- <variable-item>
binding-item/name
binding-item/value
binding-item?
body-item/components
+ body-item?
classifier-item/classifier
classifier-item?
compiler-item/compiler
@@ -4435,6 +4425,8 @@ USA.
expander-item/expander
expander-item?
expression-item/compiler
+ expression-item?
+ extract-declarations-from-body
flatten-body-items
item->list
keyword-item?
@@ -4490,8 +4482,7 @@ USA.
(export (runtime syntax)
classify/body
classify/expression
- classify/form
- extract-declarations-from-body))
+ classify/form))
(define-package (runtime syntax compile)
(files "syntax-compile")
@@ -4500,7 +4491,6 @@ USA.
compile-body-item/top-level
compile-body-items
compile-item/expression
- compile-item/expression
define-item-compiler))
(define-package (runtime syntax rename)
diff --git a/src/runtime/syntax-classify.scm b/src/runtime/syntax-classify.scm
index 2705307b4..47204699e 100644
--- a/src/runtime/syntax-classify.scm
+++ b/src/runtime/syntax-classify.scm
@@ -38,18 +38,16 @@ USA.
(let ((name (identifier->symbol form)))
(lambda ()
(output/combination
- (output/runtime-reference 'SYNTACTIC-KEYWORD->ITEM)
+ (output/runtime-reference 'syntactic-keyword->item)
(list (output/constant name)
(output/the-environment)))))))
item)))
((syntactic-closure? form)
- (let ((form (syntactic-closure-form form))
- (free-names (syntactic-closure-free form))
- (closing-env (syntactic-closure-senv form)))
- (classify/form form
- (make-partial-syntactic-environment free-names
- environment
- closing-env))))
+ (classify/form
+ (syntactic-closure-form form)
+ (make-partial-syntactic-environment (syntactic-closure-free form)
+ environment
+ (syntactic-closure-senv form))))
((pair? form)
(let ((item
(strip-keyword-value-item
@@ -81,7 +79,7 @@ USA.
(if (keyword-value-item? item)
(keyword-value-item/item item)
item))
-
+
(define (classify/expression expression environment)
(classify/form expression environment))
@@ -99,16 +97,4 @@ USA.
(loop (cdr forms)
(reverse* (item->list (classify/form (car forms) environment))
body-items))
- (reverse! body-items)))))
-
-(define (extract-declarations-from-body items)
- (let loop ((items items) (declarations '()) (items* '()))
- (if (pair? items)
- (if (declaration-item? (car items))
- (loop (cdr items)
- (cons (car items) declarations)
- items*)
- (loop (cdr items)
- declarations
- (cons (car items) items*)))
- (values (reverse! declarations) (reverse! items*)))))
\ No newline at end of file
+ (reverse! body-items)))))
\ No newline at end of file
diff --git a/src/runtime/syntax-compile.scm b/src/runtime/syntax-compile.scm
index e76cc72b2..4b3cf4908 100644
--- a/src/runtime/syntax-compile.scm
+++ b/src/runtime/syntax-compile.scm
@@ -43,7 +43,7 @@ USA.
(define (compile-body-item/top-level body-item)
(receive (declaration-items body-items)
- (extract-declarations-from-body (body-item/components body-item))
+ (extract-declarations-from-body body-item)
(output/top-level-sequence (map declaration-item/text declaration-items)
(map compile-item/top-level body-items))))
@@ -63,55 +63,45 @@ USA.
(list (compile-item/expression item))))
items))))
-(define (compile-item/expression item)
- (let ((compiler (get-item-compiler item)))
- (if (not compiler)
- (error:bad-range-argument item 'COMPILE-ITEM/EXPRESSION))
- (compiler item)))
-
-(define (get-item-compiler item)
- (let ((entry (assq (record-type-descriptor item) item-compilers)))
- (and entry
- (cdr entry))))
-
-(define (define-item-compiler rtd compiler)
- (let ((entry (assq rtd item-compilers)))
- (if entry
- (set-cdr! entry compiler)
- (begin
- (set! item-compilers (cons (cons rtd compiler) item-compilers))
- unspecific))))
-
-(define item-compilers '())
-
-(define (illegal-expression-compiler description)
- (lambda (item)
- (syntax-error (string description " may not be used as an expression:")
- item)))
-
-(define-item-compiler <reserved-name-item>
- (illegal-expression-compiler "Reserved name"))
-
-(let ((compiler (illegal-expression-compiler "Syntactic keyword")))
- (define-item-compiler <classifier-item> compiler)
- (define-item-compiler <compiler-item> compiler)
- (define-item-compiler <expander-item> compiler)
- (define-item-compiler <keyword-value-item> compiler))
-
-(define-item-compiler <variable-item>
+(define compile-item/expression)
+(add-boot-init!
+ (lambda ()
+ (set! compile-item/expression
+ (standard-predicate-dispatcher 'compile-item/expression 1))
+ (run-deferred-boot-actions 'define-item-compiler)))
+
+(define (define-item-compiler predicate compiler)
+ (defer-boot-action 'define-item-compiler
+ (lambda ()
+ (define-predicate-dispatch-handler compile-item/expression
+ (list predicate)
+ compiler))))
+
+(define-item-compiler variable-item?
(lambda (item)
(output/variable (variable-item/name item))))
-(define-item-compiler <expression-item>
+(define-item-compiler expression-item?
(lambda (item)
((expression-item/compiler item))))
-(define-item-compiler <body-item>
+(define-item-compiler body-item?
(lambda (item)
(compile-body-items (body-item/components item))))
-(define-item-compiler <declaration-item>
+(define (illegal-expression-compiler description)
+ (lambda (item)
+ (syntax-error (string description " may not be used as an expression:")
+ 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 declaration-item?
(illegal-expression-compiler "Declaration"))
-(define-item-compiler <binding-item>
+(define-item-compiler binding-item?
(illegal-expression-compiler "Definition"))
\ No newline at end of file
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 89b63ef0b..a34eaa53a 100644
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -71,6 +71,30 @@ USA.
(cond ((syntactic-environment? object) object)
((environment? object) (%make-runtime-syntactic-environment object))
(else (error "Unable to convert to a syntactic environment:" object))))
+
+;;; Runtime syntactic environments are wrappers around runtime environments.
+;;; They maintain their own bindings, but can defer lookups of syntactic
+;;; keywords to the given runtime environment.
+
+(define (%make-runtime-syntactic-environment env)
+
+ (define (get-type)
+ (if (interpreter-environment? env) 'runtime-top-level 'runtime))
+
+ (define (get-runtime)
+ env)
+
+ (define (lookup identifier)
+ (and (symbol? identifier)
+ (environment-lookup-macro env identifier)))
+
+ (define (store identifier item)
+ (environment-define-macro env identifier item))
+
+ (define (rename identifier)
+ (rename-top-level-identifier identifier))
+
+ (make-senv get-type get-runtime lookup store rename))
;;; Null environments are used only for synthetic identifiers.
@@ -93,7 +117,7 @@ USA.
(error "Can't rename in null environment:" identifier))
(make-senv get-type get-runtime lookup store rename)))
-
+
;;; Keyword environments are used to make keywords that represent items.
(define (make-keyword-syntactic-environment name item)
@@ -114,30 +138,8 @@ USA.
(define (rename identifier)
(error "Can't rename in keyword environment:" identifier))
- (make-senv get-type get-runtime lookup store rename))
-
-;;; Runtime syntactic environments are wrappers around runtime environments.
-;;; They maintain their own bindings, but can defer lookups of syntactic
-;;; keywords to the given runtime environment.
-
-(define (%make-runtime-syntactic-environment env)
-
- (define (get-type)
- (if (interpreter-environment? env) 'runtime-top-level 'runtime))
-
- (define (get-runtime)
- env)
-
- (define (lookup identifier)
- (and (symbol? identifier)
- (environment-lookup-macro env identifier)))
-
- (define (store identifier item)
- (environment-define-macro env identifier item))
-
- (define (rename identifier)
- (rename-top-level-identifier identifier))
-
+ (guarantee identifier? name 'make-keyword-environment)
+ (guarantee keyword-item? item 'make-keyword-environment)
(make-senv get-type get-runtime lookup store rename))
;;; Top-level syntactic environments represent top-level environments.
diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 83b9ff7b5..20648205f 100644
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -28,16 +28,7 @@ USA.
(declare (usual-integrations))
-;;; Reserved name items do not represent any form, but instead are
-;;; used to reserve a particular name in a syntactic environment. If
-;;; the classifier refers to a reserved name, a syntax error is
-;;; signalled. This is used in the implementation of LETREC-SYNTAX
-;;; to signal a meaningful error when one of the <init>s refers to
-;;; one of the names being bound.
-
-(define-record-type <reserved-name-item>
- (make-reserved-name-item)
- reserved-name-item?)
+;;; These items can be stored in a syntactic environment.
;;; Keyword items represent macro keywords. There are several flavors
;;; of keyword item.
@@ -63,31 +54,71 @@ USA.
(item keyword-value-item/item)
(expression keyword-value-item/expression))
-(define (keyword-item? item)
- (or (classifier-item? item)
- (compiler-item? item)
- (expander-item? item)
- (keyword-value-item? item)))
+(define (keyword-item? object)
+ (or (classifier-item? object)
+ (compiler-item? object)
+ (expander-item? object)
+ (keyword-value-item? object)))
+
+(register-predicate! keyword-item? 'keyword-item)
+(set-predicate<=! classifier-item? keyword-item?)
+(set-predicate<=! compiler-item? keyword-item?)
+(set-predicate<=! expander-item? keyword-item?)
+(set-predicate<=! keyword-value-item? keyword-item?)
;;; Variable items represent run-time variables.
+(define (make-variable-item name)
+ (guarantee identifier? name 'make-variable-item)
+ (%make-variable-item name))
+
(define-record-type <variable-item>
- (make-variable-item name)
+ (%make-variable-item name)
variable-item?
(name variable-item/name))
(define-unparser-method variable-item?
- (simple-unparser-method 'variable-item?
+ (simple-unparser-method 'variable-item
(lambda (item)
(list (variable-item/name item)))))
+
+;;; Reserved name items do not represent any form, but instead are
+;;; used to reserve a particular name in a syntactic environment. If
+;;; the classifier refers to a reserved name, a syntax error is
+;;; signalled. This is used in the implementation of LETREC-SYNTAX
+;;; to signal a meaningful error when one of the <init>s refers to
+;;; one of the names being bound.
+
+(define-record-type <reserved-name-item>
+ (make-reserved-name-item)
+ reserved-name-item?)
-;;; Expression items represent any kind of expression other than a
-;;; run-time variable or a sequence.
+;;; These items can't be stored in a syntactic environment.
-(define-record-type <expression-item>
- (make-expression-item compiler)
- expression-item?
- (compiler expression-item/compiler))
+;;; Binding items represent definitions, whether top-level or internal, keyword
+;;; or variable.
+
+(define (make-binding-item name value)
+ (guarantee identifier? name 'make-binding-item)
+ (guarantee binding-item-value? value 'make-binding-item)
+ (%make-binding-item name value))
+
+(define (binding-item-value? object)
+ (not (or (reserved-name-item? object)
+ (declaration-item? object))))
+(register-predicate! binding-item-value? 'binding-item-value)
+
+(define-record-type <binding-item>
+ (%make-binding-item name value)
+ binding-item?
+ (name binding-item/name)
+ (value binding-item/value))
+
+(define-unparser-method binding-item?
+ (simple-unparser-method 'binding-item
+ (lambda (item)
+ (list (binding-item/name item)
+ (binding-item/value item)))))
;;; Body items represent sequences (e.g. BEGIN).
@@ -96,6 +127,9 @@ USA.
body-item?
(components body-item/components))
+(define (extract-declarations-from-body body-item)
+ (partition declaration-item? (body-item/components body-item)))
+
(define (flatten-body-items items)
(append-map item->list items))
@@ -104,6 +138,14 @@ USA.
(flatten-body-items (body-item/components item))
(list item)))
+;;; Expression items represent any kind of expression other than a
+;;; run-time variable or a sequence.
+
+(define-record-type <expression-item>
+ (make-expression-item compiler)
+ expression-item?
+ (compiler expression-item/compiler))
+
;;; Declaration items represent block-scoped declarations that are to
;;; be passed through to the compiler.
@@ -113,13 +155,4 @@ USA.
(get-text declaration-item/get-text))
(define (declaration-item/text item)
- ((declaration-item/get-text item)))
-
-;;; Binding items represent definitions, whether top-level or internal, keyword
-;;; or variable.
-
-(define-record-type <binding-item>
- (make-binding-item name value)
- binding-item?
- (name binding-item/name)
- (value binding-item/value))
\ No newline at end of file
+ ((declaration-item/get-text item)))
\ No newline at end of file
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index 0cf48c549..261bf8053 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -24,7 +24,7 @@ USA.
|#
-;;;; Syntaxer Output Interface
+;;;; Syntaxer output interface
;;; package: (runtime syntax output)
(declare (usual-integrations))
@@ -90,10 +90,12 @@ USA.
(output/combination (output/named-lambda lambda-tag:let names body) values))
(define (output/letrec names values body)
- (let ((temps (map (lambda (name)
- (string->uninterned-symbol
- (string-append (symbol->string (identifier->symbol name))
- "-value"))) names)))
+ (let ((temps
+ (map (lambda (name)
+ (string->uninterned-symbol
+ (string-append (symbol->string (identifier->symbol name))
+ "-value")))
+ names)))
(output/let
names (map (lambda (name) name (output/unassigned)) names)
(make-scode-sequence
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index dbe842c29..41228ab45 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -66,6 +66,25 @@ USA.
;;;; Syntactic closures
+(define (close-syntax form senv)
+ (make-syntactic-closure senv '() form))
+
+(define (make-syntactic-closure senv free form)
+ (let ((senv (->syntactic-environment senv 'make-syntactic-closure)))
+ (guarantee-list-of identifier? free 'make-syntactic-closure)
+ (if (or (memq form free) ;LOOKUP-IDENTIFIER assumes this.
+ (constant-form? form)
+ (and (syntactic-closure? form)
+ (null? (syntactic-closure-free form))
+ (not (identifier? (syntactic-closure-form form)))))
+ form
+ (%make-syntactic-closure senv free form))))
+
+(define (constant-form? form)
+ (not (or (syntactic-closure? form)
+ (pair? form)
+ (identifier? form))))
+
(define-record-type <syntactic-closure>
(%make-syntactic-closure senv free form)
syntactic-closure?
@@ -73,20 +92,6 @@ USA.
(free syntactic-closure-free)
(form syntactic-closure-form))
-(define (make-syntactic-closure environment free-names form)
- (let ((senv (->syntactic-environment environment 'MAKE-SYNTACTIC-CLOSURE)))
- (guarantee-list-of-type free-names identifier?
- "list of identifiers" 'MAKE-SYNTACTIC-CLOSURE)
- (if (or (memq form free-names) ;LOOKUP-IDENTIFIER assumes this.
- (and (syntactic-closure? form)
- (null? (syntactic-closure-free form))
- (not (identifier? (syntactic-closure-form form))))
- (not (or (syntactic-closure? form)
- (pair? form)
- (symbol? form))))
- form
- (%make-syntactic-closure senv free-names form))))
-
(define (strip-syntactic-closures object)
(if (let loop ((object object))
(if (pair? object)
@@ -101,9 +106,6 @@ USA.
(loop (syntactic-closure-form object))
object)))
object))
-
-(define (close-syntax form environment)
- (make-syntactic-closure environment '() form))
;;;; Identifiers
@@ -112,6 +114,7 @@ USA.
;; This makes `:keyword' objects be self-evaluating.
(not (keyword? object)))
(synthetic-identifier? object)))
+(register-predicate! identifier? 'identifier)
(define (synthetic-identifier? object)
(and (syntactic-closure? object)
@@ -126,7 +129,7 @@ USA.
(loop (syntactic-closure-form identifier))
(and (symbol? identifier)
identifier)))
- (error:not-a identifier? identifier 'IDENTIFIER->SYMBOL)))
+ (error:not-a identifier? identifier 'identifier->symbol)))
(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
(let ((item-1 (lookup-identifier identifier-1 environment-1))
@@ -154,7 +157,7 @@ USA.
(lookup-identifier (syntactic-closure-form identifier)
(syntactic-closure-senv identifier)))
(else
- (error:not-a identifier? identifier 'LOOKUP-IDENTIFIER)))))
+ (error:not-a identifier? identifier 'lookup-identifier)))))
;;;; Utilities