From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 13 Feb 2018 04:50:20 +0000 (-0800)
Subject: Bind classifiers directly into global environment.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~248
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b8df35753623937a007b4626da512a7833a0c750;p=mit-scheme.git

Bind classifiers directly into global environment.

Eliminates kludge of syntax-definitions.
---

diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm
index 0006b5660..e18c6ab48 100644
--- a/src/runtime/ed-ffi.scm
+++ b/src/runtime/ed-ffi.scm
@@ -161,7 +161,6 @@ USA.
     ("syntax"	(runtime syntax top-level))
     ("syntax-check" (runtime syntax check))
     ("syntax-declaration" (runtime syntax declaration))
-    ("syntax-definitions" (runtime syntax definitions))
     ("syntax-environment" (runtime syntax environment))
     ("syntax-items" (runtime syntax items))
     ("syntax-output" (runtime syntax output))
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index ab1cb70d0..e04c35a50 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -531,7 +531,6 @@ USA.
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)
    (runtime syntax top-level)
-   (RUNTIME SYNTAX DEFINITIONS)
    (runtime syntax rename)
    ;; REP Loops
    (RUNTIME INTERRUPT-HANDLER)
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index aed5ff544..14757f77d 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -42,34 +42,44 @@ USA.
 				(output/top-level-syntax-expander
 				 procedure-name transformer)))))))
 
-(define classifier:sc-macro-transformer
+(define (classifier->runtime classifier)
+  (make-unmapped-macro-reference-trap (classifier-item classifier)))
+
+(define :sc-macro-transformer
   ;; "Syntactic Closures" transformer
-  (transformer-keyword 'sc-macro-transformer->expander
-		       sc-macro-transformer->expander))
+  (classifier->runtime
+   (transformer-keyword 'sc-macro-transformer->expander
+			sc-macro-transformer->expander)))
 
-(define classifier:rsc-macro-transformer
+(define :rsc-macro-transformer
   ;; "Reversed Syntactic Closures" transformer
-  (transformer-keyword 'rsc-macro-transformer->expander
-		       rsc-macro-transformer->expander))
+  (classifier->runtime
+   (transformer-keyword 'rsc-macro-transformer->expander
+			rsc-macro-transformer->expander)))
 
-(define classifier:er-macro-transformer
+(define :er-macro-transformer
   ;; "Explicit Renaming" transformer
-  (transformer-keyword 'er-macro-transformer->expander
-		       er-macro-transformer->expander))
+  (classifier->runtime
+   (transformer-keyword 'er-macro-transformer->expander
+			er-macro-transformer->expander)))
 
 ;;;; Core primitives
 
-(define (classifier:lambda form senv hist)
-  (syntax-check '(_ mit-bvl + form) form)
-  (classify-lambda scode-lambda-name:unnamed
-		   (cadr form)
-		   form senv hist))
+(define :lambda
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ mit-bvl + form) form)
+     (classify-lambda scode-lambda-name:unnamed
+		      (cadr form)
+		      form senv hist))))
 
-(define (classifier:named-lambda form senv hist)
-  (syntax-check '(_ (identifier . mit-bvl) + form) form)
-  (classify-lambda (identifier->symbol (caadr form))
-		   (cdadr form)
-		   form senv hist))
+(define :named-lambda
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ (identifier . mit-bvl) + form) form)
+     (classify-lambda (identifier->symbol (caadr form))
+		      (cdadr form)
+		      form senv hist))))
 
 (define (classify-lambda name bvl form senv hist)
   (let ((senv (make-internal-senv senv)))
@@ -84,51 +94,74 @@ USA.
 		     (body-item
 		      (classify-forms-in-order-cddr form senv hist)))))))
 
-(define (classifier:begin form senv hist)
-  (syntax-check '(_ * form) form)
-  (seq-item (classify-forms-in-order-cdr form senv hist)))
-
-(define (classifier:if form senv hist)
-  (syntax-check '(_ expression expression ? expression) form)
-  (if-item (classify-form-cadr form senv hist)
-	   (classify-form-caddr form senv hist)
-	   (if (pair? (cdddr form))
-	       (classify-form-cadddr form senv hist)
-	       (unspecific-item))))
-
-(define (classifier:quote form senv hist)
-  (declare (ignore senv hist))
-  (syntax-check '(_ datum) form)
-  (constant-item (strip-syntactic-closures (cadr form))))
-
-(define (classifier:quote-identifier form senv hist)
-  (declare (ignore hist))
-  (syntax-check '(_ identifier) form)
-  (let ((item (lookup-identifier (cadr form) senv)))
-    (if (not (var-item? item))
-	(syntax-error "Can't quote a keyword identifier:" form))
-    (quoted-id-item item)))
-
-(define (classifier:set! form senv hist)
-  (syntax-check '(_ form ? expression) form)
-  (let ((lhs-item (classify-form-cadr form senv hist))
-	(rhs-item
-	 (if (pair? (cddr form))
-	     (classify-form-caddr form senv hist)
-	     (unassigned-item))))
-    (cond ((var-item? lhs-item)
-	   (assignment-item (var-item-id lhs-item) rhs-item))
-	  ((access-item? lhs-item)
-	   (access-assignment-item (access-item-name lhs-item)
-				   (access-item-env lhs-item)
-				   rhs-item))
-	  (else
-	   (syntax-error "Variable required in this context:" (cadr form))))))
-
-(define (classifier:delay form senv hist)
-  (syntax-check '(_ expression) form)
-  (delay-item (lambda () (classify-form-cadr form senv hist))))
+(define :delay
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ expression) form)
+     (delay-item (lambda () (classify-form-cadr form senv hist))))))
+
+(define :begin
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ * form) form)
+     (seq-item (classify-forms-in-order-cdr form senv hist)))))
+
+(define :if
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ expression expression ? expression) form)
+     (if-item (classify-form-cadr form senv hist)
+	      (classify-form-caddr form senv hist)
+	      (if (pair? (cdddr form))
+		  (classify-form-cadddr form senv hist)
+		  (unspecific-item))))))
+
+(define :quote
+  (classifier->runtime
+   (lambda (form senv hist)
+     (declare (ignore senv hist))
+     (syntax-check '(_ datum) form)
+     (constant-item (strip-syntactic-closures (cadr form))))))
+
+(define :quote-identifier
+  (classifier->runtime
+   (lambda (form senv hist)
+     (declare (ignore hist))
+     (syntax-check '(_ identifier) form)
+     (let ((item (lookup-identifier (cadr form) senv)))
+       (if (not (var-item? item))
+	   (syntax-error "Can't quote a keyword identifier:" form))
+       (quoted-id-item item)))))
 
+(define :set!
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ form ? expression) form)
+     (let ((lhs-item (classify-form-cadr form senv hist))
+	   (rhs-item
+	    (if (pair? (cddr form))
+		(classify-form-caddr form senv hist)
+		(unassigned-item))))
+       (cond ((var-item? lhs-item)
+	      (assignment-item (var-item-id lhs-item) rhs-item))
+	     ((access-item? lhs-item)
+	      (access-assignment-item (access-item-name lhs-item)
+				      (access-item-env lhs-item)
+				      rhs-item))
+	     (else
+	      (syntax-error "Variable required in this context:"
+			    (cadr form))))))))
+
+;; TODO: this is a classifier rather than a macro because it uses the
+;; special OUTPUT/DISJUNCTION.  Unfortunately something downstream in
+;; the compiler wants this, but it would be nice to eliminate this
+;; hack.
+(define :or
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ * expression) form)
+     (or-item (classify-forms-cdr form senv hist)))))
+
 ;;;; Definitions
 
 (define keyword:define
@@ -137,16 +170,18 @@ USA.
      (let ((id (bind-variable (cadr form) senv)))
        (defn-item id (classify-form-caddr form senv hist))))))
 
-(define (classifier:define-syntax form senv hist)
-  (syntax-check '(_ identifier expression) form)
-  (let ((name (cadr form))
-	(item (classify-form-caddr form senv hist)))
-    (keyword-binder senv name item)
-    ;; User-defined macros at top level are preserved in the output.
-    (if (and (senv-top-level? senv)
-	     (expander-item? item))
-	(syntax-defn-item name (expander-item-expr item))
-	(seq-item '()))))
+(define :define-syntax
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ identifier expression) form)
+     (let ((name (cadr form))
+	   (item (classify-form-caddr form senv hist)))
+       (keyword-binder senv name item)
+       ;; User-defined macros at top level are preserved in the output.
+       (if (and (senv-top-level? senv)
+		(expander-item? item))
+	   (syntax-defn-item name (expander-item-expr item))
+	   (seq-item '()))))))
 
 (define (keyword-binder senv name item)
   (if (not (keyword-item? item))
@@ -184,37 +219,34 @@ USA.
     (seq-item
      (classify-forms-in-order-cddr form body-senv hist))))
 
+(define :let-syntax
+  (classifier->runtime classifier:let-syntax))
+
 (define keyword:let-syntax
   (classifier->keyword classifier:let-syntax))
 
-(define (classifier:letrec-syntax form senv hist)
-  (syntax-check '(_ (* (identifier expression)) + form) form)
-  (let ((binding-senv (make-internal-senv senv)))
-    (let ((bindings (cadr form)))
-      (for-each (lambda (binding)
-		  (reserve-identifier (car binding) binding-senv))
-		bindings)
-      ;; Classify right-hand sides first, in order to catch references to
-      ;; reserved names.  Then bind names prior to classifying body.
-      (for-each (lambda (binding item)
-		  (keyword-binder binding-senv (car binding) item))
-		bindings
-		(map (lambda (binding hist)
-		       (classify-form-cadr binding binding-senv hist))
-		     bindings
-		     (subform-hists bindings (hist-cadr hist)))))
-    (seq-item
-     (classify-forms-in-order-cddr form
-				   (make-internal-senv binding-senv)
-				   hist))))
-
-;; TODO: this is a classifier rather than a macro because it uses the
-;; special OUTPUT/DISJUNCTION.  Unfortunately something downstream in
-;; the compiler wants this, but it would be nice to eliminate this
-;; hack.
-(define (classifier:or form senv hist)
-  (syntax-check '(_ * expression) form)
-  (or-item (classify-forms-cdr form senv hist)))
+(define :letrec-syntax
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ (* (identifier expression)) + form) form)
+     (let ((binding-senv (make-internal-senv senv)))
+       (let ((bindings (cadr form)))
+	 (for-each (lambda (binding)
+		     (reserve-identifier (car binding) binding-senv))
+		   bindings)
+	 ;; Classify right-hand sides first, in order to catch references to
+	 ;; reserved names.  Then bind names prior to classifying body.
+	 (for-each (lambda (binding item)
+		     (keyword-binder binding-senv (car binding) item))
+		   bindings
+		   (map (lambda (binding hist)
+			  (classify-form-cadr binding binding-senv hist))
+			bindings
+			(subform-hists bindings (hist-cadr hist)))))
+       (seq-item
+	(classify-forms-in-order-cddr form
+				      (make-internal-senv binding-senv)
+				      hist))))))
 
 ;;;; MIT-specific syntax
 
@@ -235,12 +267,14 @@ USA.
     (output/access-reference (access-item-name item)
 			     (compile-expr-item (access-item-env item)))))
 
-(define (classifier:the-environment form senv hist)
-  (declare (ignore hist))
-  (syntax-check '(_) form)
-  (if (not (senv-top-level? senv))
-      (syntax-error "This form allowed only at top level:" form))
-  (the-environment-item))
+(define :the-environment
+  (classifier->runtime
+   (lambda (form senv hist)
+     (declare (ignore hist))
+     (syntax-check '(_) form)
+     (if (not (senv-top-level? senv))
+	 (syntax-error "This form allowed only at top level:" form))
+     (the-environment-item))))
 
 (define keyword:unspecific
   (classifier->keyword
@@ -253,14 +287,16 @@ USA.
    (lambda (form senv hist)
      (declare (ignore form senv hist))
      (unassigned-item))))
-
+
 ;;;; Declarations
 
-(define (classifier:declare form senv hist)
-  (syntax-check '(_ * (identifier * datum)) form)
-  (decl-item
-   (lambda ()
-     (classify-decls (cdr form) senv (hist-cdr hist)))))
+(define :declare
+  (classifier->runtime
+   (lambda (form senv hist)
+     (syntax-check '(_ * (identifier * datum)) form)
+     (decl-item
+      (lambda ()
+	(classify-decls (cdr form) senv (hist-cdr hist)))))))
 
 (define (classify-decls decls senv hist)
   (map (lambda (decl hist)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6a6c8c80f..3be7548c5 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4569,24 +4569,24 @@ USA.
 (define-package (runtime syntax mit)
   (files "mit-syntax")
   (parent (runtime syntax))
-  (export (runtime syntax definitions)
-	  classifier:begin
-	  classifier:declare
-	  classifier:define-syntax
-	  classifier:delay
-	  classifier:er-macro-transformer
-	  classifier:if
-	  classifier:lambda
-	  classifier:let-syntax
-	  classifier:letrec-syntax
-	  classifier:named-lambda
-	  classifier:or
-	  classifier:quote
-	  classifier:quote-identifier
-	  classifier:rsc-macro-transformer
-	  classifier:sc-macro-transformer
-	  classifier:set!
-	  classifier:the-environment)
+  (export ()
+	  (begin :begin)
+	  (declare :declare)
+	  (define-syntax :define-syntax)
+	  (delay :delay)
+	  (er-macro-transformer :er-macro-transformer)
+	  (if :if)
+	  (lambda :lambda)
+	  (let-syntax :let-syntax)
+	  (letrec-syntax :letrec-syntax)
+	  (named-lambda :named-lambda)
+	  (or :or)
+	  (quote :quote)
+	  (quote-identifier :quote-identifier)
+	  (rsc-macro-transformer :rsc-macro-transformer)
+	  (sc-macro-transformer :sc-macro-transformer)
+	  (set! :set!)
+	  (the-environment :the-environment))
   (export (runtime mit-macros)
 	  keyword:access
 	  keyword:define
@@ -4643,11 +4643,6 @@ USA.
   (export ()
 	  define-structure))
 
-(define-package (runtime syntax definitions)
-  (files "syntax-definitions")
-  (parent (runtime syntax))
-  (initialization (initialize-package!)))
-
 (define-package (runtime system-macros)
   (files "sysmac")
   (parent (runtime))
diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm
deleted file mode 100644
index 55053e8e1..000000000
--- a/src/runtime/syntax-definitions.scm
+++ /dev/null
@@ -1,56 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
-    2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Code to install syntax keywords in global environment
-;;; package: (runtime syntax definitions)
-
-(declare (usual-integrations))
-
-(add-boot-init!
- (lambda ()
-
-   (define (define-classifier name classifier)
-     (environment-define-macro system-global-environment
-			       name
-			       (classifier-item classifier)))
-
-   (define-classifier 'begin classifier:begin)
-   (define-classifier 'declare classifier:declare)
-   (define-classifier 'define-syntax classifier:define-syntax)
-   (define-classifier 'delay classifier:delay)
-   (define-classifier 'er-macro-transformer classifier:er-macro-transformer)
-   (define-classifier 'if classifier:if)
-   (define-classifier 'lambda classifier:lambda)
-   (define-classifier 'let-syntax classifier:let-syntax)
-   (define-classifier 'letrec-syntax classifier:letrec-syntax)
-   (define-classifier 'named-lambda classifier:named-lambda)
-   (define-classifier 'or classifier:or)
-   (define-classifier 'quote classifier:quote)
-   (define-classifier 'quote-identifier classifier:quote-identifier)
-   (define-classifier 'rsc-macro-transformer classifier:rsc-macro-transformer)
-   (define-classifier 'sc-macro-transformer classifier:sc-macro-transformer)
-   (define-classifier 'set! classifier:set!)
-   (define-classifier 'the-environment classifier:the-environment)))
\ No newline at end of file