From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 21 Dec 2001 18:41:22 +0000 (+0000)
Subject: Store macro definitions in environments rather than in syntax tables.
X-Git-Tag: 20090517-FFI~2316
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2793f01a820aac2a21c1100c4b827c791ad7875b;p=mit-scheme.git

Store macro definitions in environments rather than in syntax tables.
---

diff --git a/v7/src/edwin/clsmac.scm b/v7/src/edwin/clsmac.scm
index afab5d6bf..33b839a5d 100644
--- a/v7/src/edwin/clsmac.scm
+++ b/v7/src/edwin/clsmac.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;$Id: clsmac.scm,v 1.5 2001/12/19 01:41:36 cph Exp $
+;;;$Id: clsmac.scm,v 1.6 2001/12/21 18:41:10 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989, 1999, 2001 Massachusetts Institute of Technology
 ;;;
@@ -29,13 +29,7 @@
 ;;; likely will not ever, be supported as a part of the Scheme system.
 ;;; ******************************************************************
 
-(define window-environment
-  (->environment '(EDWIN WINDOW)))
-
-(set-environment-syntax-table! window-environment
-			       (make-syntax-table (->environment '(EDWIN))))
-
-(syntax-table/define window-environment 'DEFINE-CLASS
+(define-syntax define-class
   (lambda (name superclass variables)
     (guarantee-symbol "Class name" name)
     (if (not (null? superclass))
@@ -50,20 +44,20 @@
 		   ,(if (null? superclass) false superclass)
 		   ',variables))))
 
-(syntax-table/define window-environment 'DEFINE-METHOD
+(define-syntax define-method
   (lambda (class bvl . body)
     (syntax-class-definition class bvl body
       (lambda (name expression)
 	(make-syntax-closure
 	 (make-method-definition class name expression))))))
 
-(syntax-table/define window-environment 'WITH-INSTANCE-VARIABLES
+(define-syntax with-instance-variables
   (lambda (class self free-names . body)
     (guarantee-symbol "Self name" self)
     (make-syntax-closure
      (syntax-class-expression class self free-names body))))
 
-(syntax-table/define window-environment '=>
+(define-syntax =>
   (lambda (object operation . arguments)
     (guarantee-symbol "Operation name" operation)
     (let ((obname (string->uninterned-symbol "object")))
@@ -72,7 +66,7 @@
 	  ,obname
 	  ,@arguments)))))
 
-(syntax-table/define window-environment 'USUAL=>
+(define-syntax usual=>
   (lambda (object operation . arguments)
     (guarantee-symbol "Operation name" operation)
     (if (not *class-name*)
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 253c36744..c575c14b9 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.278 2001/12/19 01:43:59 cph Exp $
+$Id: edwin.pkg,v 1.279 2001/12/21 18:41:18 cph Exp $
 
 Copyright (c) 1989-2001 Massachusetts Institute of Technology
 
@@ -107,6 +107,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  output-buffer/write-substring-block)
   (import (runtime char-syntax)
 	  char-syntax-table/entries)
+  (import (runtime)
+	  define-primitives
+	  ucode-primitive
+	  ucode-type)
   (export (edwin class-macros)
 	  class-instance-transforms)
   (export ()
@@ -122,6 +126,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define-package (edwin class-macros)
   (files "clsmac")
   (parent (edwin))
+  (export (edwin window)
+	  =>
+	  define-class
+	  define-method
+	  usual=>
+	  with-instance-variables)
   (import ()
 	  (make-scode-variable make-variable)
 	  (scode-variable-name variable-name)))
@@ -148,9 +158,22 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (parent (edwin))
   (export (edwin)
 	  canonicalize-name
+	  command-defined?
 	  command-name->scheme-name
+	  define-command
+	  define-major-mode
+	  define-minor-mode
+	  define-variable
+	  define-variable-per-buffer
 	  edwin-syntax-table
+	  local-set-variable!
 	  mode-name->scheme-name
+	  ref-command
+	  ref-command-object
+	  ref-mode-object
+	  ref-variable
+	  ref-variable-object
+	  set-variable!
 	  variable-name->scheme-name))
 
 (define-package (edwin group-operations)
diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm
index e89ecc6b5..f8d418438 100644
--- a/v7/src/edwin/macros.scm
+++ b/v7/src/edwin/macros.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: macros.scm,v 1.67 2001/12/19 01:46:08 cph Exp $
+;;; $Id: macros.scm,v 1.68 2001/12/21 18:41:22 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -22,20 +22,9 @@
 
 (declare (usual-integrations))
 
-(define edwin-environment (->environment '(EDWIN)))
-(define edwin-syntax-table edwin-environment) ;upwards compatibility
+(define edwin-syntax-table (->environment '(EDWIN))) ;upwards compatibility
 
-(set-environment-syntax-table! edwin-environment
-			       (make-syntax-table (->environment '())))
-
-(let ((runtime-environment (->environment '(RUNTIME))))
-  (for-each
-   (lambda (name)
-     (syntax-table/define edwin-environment name
-			  (syntax-table/ref runtime-environment name)))
-   (syntax-table/defined-names runtime-environment)))
-
-(syntax-table/define edwin-environment 'DEFINE-COMMAND
+(define-syntax define-command
   (lambda (name description interactive procedure)
     (let ((name (canonicalize-name name)))
       (let ((scheme-name (command-name->scheme-name name)))
@@ -53,16 +42,16 @@
 				 ,@(cddr procedure))
 			      procedure)))))))
 
-(syntax-table/define edwin-environment 'REF-COMMAND-OBJECT
+(define-syntax ref-command-object
   (lambda (name)
     (command-name->scheme-name (canonicalize-name name))))
 
-(syntax-table/define edwin-environment 'REF-COMMAND
+(define-syntax ref-command
   (lambda (name)
     `(COMMAND-PROCEDURE
       ,(command-name->scheme-name (canonicalize-name name)))))
 
-(syntax-table/define edwin-environment 'COMMAND-DEFINED?
+(define-syntax command-defined?
   (lambda (name)
     (let ((variable-name (command-name->scheme-name (canonicalize-name name))))
       `(LET ((_ENV (->ENVIRONMENT '(EDWIN))))
@@ -72,43 +61,46 @@
 (define (command-name->scheme-name name)
   (symbol-append 'EDWIN-COMMAND$ name))
 
-(let ((variable-definition
-       (lambda (buffer-local?)
-	 (lambda (name description #!optional value test normalization)
-	   (let ((name (canonicalize-name name)))
-	     (let ((scheme-name (variable-name->scheme-name name)))
-	       `(BEGIN
-		  (DEFINE ,scheme-name
-		    (MAKE-VARIABLE ',name
-				   ,description
-				   ,(if (default-object? value) '#F value)
-				   ',buffer-local?))
-		  ,@(if (default-object? test)
-			'()
-			`((SET-VARIABLE-VALUE-VALIDITY-TEST! ,scheme-name
-							     ,test)))
-		  ,@(if (default-object? normalization)
-			'()
-			`((SET-VARIABLE-VALUE-NORMALIZATION!
-			   ,scheme-name
-			   ,normalization))))))))))
-  (syntax-table/define edwin-environment 'DEFINE-VARIABLE
-    (variable-definition false))
-  (syntax-table/define edwin-environment 'DEFINE-VARIABLE-PER-BUFFER
-    (variable-definition true)))
-
-(syntax-table/define edwin-environment 'REF-VARIABLE-OBJECT
+(define-syntax define-variable
+  (lambda args
+    (apply (variable-definition #f) args)))
+
+(define-syntax define-variable-per-buffer
+  (lambda args
+    (apply (variable-definition #t) args)))
+
+(define (variable-definition buffer-local?)
+  (lambda (name description #!optional value test normalization)
+    (let ((name (canonicalize-name name)))
+      (let ((scheme-name (variable-name->scheme-name name)))
+	`(BEGIN
+	   (DEFINE ,scheme-name
+	     (MAKE-VARIABLE ',name
+			    ,description
+			    ,(if (default-object? value) '#F value)
+			    ',buffer-local?))
+	   ,@(if (default-object? test)
+		 '()
+		 `((SET-VARIABLE-VALUE-VALIDITY-TEST! ,scheme-name
+						      ,test)))
+	   ,@(if (default-object? normalization)
+		 '()
+		 `((SET-VARIABLE-VALUE-NORMALIZATION!
+		    ,scheme-name
+		    ,normalization))))))))
+
+(define-syntax ref-variable-object
   (lambda (name)
     (variable-name->scheme-name (canonicalize-name name))))
 
-(syntax-table/define edwin-environment 'REF-VARIABLE
+(define-syntax ref-variable
   (lambda (name #!optional buffer)
     (let ((name (variable-name->scheme-name (canonicalize-name name))))
       (if (default-object? buffer)
 	  `(VARIABLE-VALUE ,name)
 	  `(VARIABLE-LOCAL-VALUE ,buffer ,name)))))
 
-(syntax-table/define edwin-environment 'SET-VARIABLE!
+(define-syntax set-variable!
   (lambda (name #!optional value buffer)
     (let ((name (variable-name->scheme-name (canonicalize-name name)))
 	  (value (if (default-object? value) '#F value)))
@@ -116,7 +108,7 @@
 	  `(SET-VARIABLE-VALUE! ,name ,value)
 	  `(SET-VARIABLE-LOCAL-VALUE! ,buffer ,name ,value)))))
 
-(syntax-table/define edwin-environment 'LOCAL-SET-VARIABLE!
+(define-syntax local-set-variable!
   (lambda (name #!optional value buffer)
     `(DEFINE-VARIABLE-LOCAL-VALUE!
       ,(if (default-object? buffer) '(CURRENT-BUFFER) buffer)
@@ -126,7 +118,7 @@
 (define (variable-name->scheme-name name)
   (symbol-append 'EDWIN-VARIABLE$ name))
 
-(syntax-table/define edwin-environment 'DEFINE-MAJOR-MODE
+(define-syntax define-major-mode
   (lambda (name super-mode-name display-name description
 		#!optional initialization)
     (let ((name (canonicalize-name name))
@@ -156,7 +148,7 @@
 			     (initialization)
 			     (else `(LAMBDA (BUFFER) BUFFER UNSPECIFIC)))))))))
 
-(syntax-table/define edwin-environment 'DEFINE-MINOR-MODE
+(define-syntax define-minor-mode
   (lambda (name display-name description #!optional initialization)
     (let ((name (canonicalize-name name)))
       `(DEFINE ,(mode-name->scheme-name name)
@@ -170,7 +162,7 @@
 			 initialization
 			 `(LAMBDA (BUFFER) BUFFER UNSPECIFIC)))))))
 
-(syntax-table/define edwin-environment 'REF-MODE-OBJECT
+(define-syntax ref-mode-object
   (lambda (name)
     (mode-name->scheme-name (canonicalize-name name))))
 
diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 9252033fa..6fa928a66 100644
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.34 2001/12/20 06:34:28 cph Exp $
+$Id: defstr.scm,v 14.35 2001/12/21 18:37:18 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -70,12 +70,7 @@ differences:
 
 |#
 
-(define (initialize-define-structure-macro!)
-  (syntax-table/define system-global-environment
-		       'DEFINE-STRUCTURE
-		       transform/define-structure))
-
-(define transform/define-structure
+(define-syntax define-structure
   (lambda (name-and-options . slot-descriptions)
     (let ((structure
 	   (with-values
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index f6e697316..f3b8bb89b 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.80 2001/12/21 18:22:20 cph Exp $
+$Id: make.scm,v 14.81 2001/12/21 18:37:23 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -475,7 +475,6 @@ USA.
    (RUNTIME SYNTAXER)
    (RUNTIME ILLEGAL-DEFINITIONS)
    (RUNTIME MACROS)
-   ((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t)
    (RUNTIME UNSYNTAXER)
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 1bae82768..79566fd25 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.400 2001/12/21 18:22:33 cph Exp $
+$Id: runtime.pkg,v 14.401 2001/12/21 18:37:35 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -1241,6 +1241,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (files "defstr")
   (parent (runtime))
   (export ()
+	  define-structure
 	  define-structure/keyword-parser
 	  define-structure/list-accessor
 	  define-structure/list-modifier
@@ -1250,8 +1251,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  named-structure/description
 	  named-structure?)
   (export (runtime unparser)
-	  structure-tag/unparser-method)
-  (initialization (initialize-package!)))
+	  structure-tag/unparser-method))
 
 (define-package (runtime directory)
   (parent (runtime))
@@ -3755,14 +3755,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (files "syntab")
   (parent (runtime))
   (export ()
-	  guarantee-syntax-table
-	  make-syntax-table
-	  syntax-table/define
-	  syntax-table/ref
-	  syntax-table?)
+	  syntax-table/define)
   (export (runtime syntaxer)
+	  guarantee-syntax-table
 	  syntax-table/environment
-	  syntax-table/extend))
+	  syntax-table/extend
+	  syntax-table/ref))
 
 (define-package (runtime syntaxer)
   (files "syntax")
diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm
index 03a67ac19..45885b7ba 100644
--- a/v7/src/sf/pardec.scm
+++ b/v7/src/sf/pardec.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pardec.scm,v 4.13 2001/12/20 06:35:49 cph Exp $
+$Id: pardec.scm,v 4.14 2001/12/21 18:39:20 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -272,9 +272,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	    externs))))
      (append-map (lambda (specification)
 		   (let ((value
-			  (scode-eval
-			   (syntax specification system-global-environment)
-			   syntaxer/default-environment)))
+			  (eval specification system-global-environment)))
 		     (if (pair? value)
 			 (map ->pathname value)
 			 (list (->pathname value)))))
diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg
index e453e3b13..8786d426f 100644
--- a/v7/src/sf/sf.pkg
+++ b/v7/src/sf/sf.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sf.pkg,v 4.14 2001/12/19 05:26:35 cph Exp $
+$Id: sf.pkg,v 4.15 2001/12/21 18:39:24 cph Exp $
 
 Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology
 
@@ -116,9 +116,7 @@ USA.
 	  declarations/map
 	  declarations/original
 	  declarations/parse
-	  operations->external)
-  (import (runtime syntaxer)
-	  syntaxer/default-environment))
+	  operations->external))
 
 (define-package (scode-optimizer copy)
   (files "copy")