From 460486c818cefc514725679f3c5e0a20aba483d1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 25 Jan 2018 23:14:31 -0800
Subject: [PATCH] Change compile-item/expression to be a predicate dispatcher.

Also, a bunch of small changes, mostly cleanups and simplification.
---
 src/runtime/make.scm               |  1 +
 src/runtime/mit-syntax.scm         |  5 +-
 src/runtime/runtime.pkg            | 18 ++----
 src/runtime/syntax-classify.scm    | 30 +++------
 src/runtime/syntax-compile.scm     | 72 ++++++++++------------
 src/runtime/syntax-environment.scm | 52 ++++++++--------
 src/runtime/syntax-items.scm       | 99 ++++++++++++++++++++----------
 src/runtime/syntax-output.scm      | 12 ++--
 src/runtime/syntax.scm             | 41 +++++++------
 9 files changed, 168 insertions(+), 162 deletions(-)

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
 
-- 
2.25.1