From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 14 Jul 2001 11:42:49 +0000 (+0000)
Subject: Add environment mechanism so that parser/matcher macros from one
X-Git-Tag: 20090517-FFI~2654
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c0f3239d2218031f419b108210b5eb7ab44c82a3;p=mit-scheme.git

Add environment mechanism so that parser/matcher macros from one
program don't interfere with those from another.
---

diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm
index 865b6060d..5eae5a92b 100644
--- a/v7/src/star-parser/load.scm
+++ b/v7/src/star-parser/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.6 2001/07/11 21:22:57 cph Exp $
+;;; $Id: load.scm,v 1.7 2001/07/14 11:42:49 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -24,4 +24,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (package/system-loader "parser" '() 'QUERY))))
-(add-subsystem-identification! "*Parser" '(0 6))
\ No newline at end of file
+(add-subsystem-identification! "*Parser" '(0 7))
\ No newline at end of file
diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index 92e389525..6573abe8c 100644
--- a/v7/src/star-parser/matcher.scm
+++ b/v7/src/star-parser/matcher.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: matcher.scm,v 1.13 2001/07/11 21:23:00 cph Exp $
+;;; $Id: matcher.scm,v 1.14 2001/07/14 11:42:26 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -66,12 +66,6 @@
       (hash-table/put! matcher-preprocessors name procedure))
   name)
 
-(define (matcher-preprocessor name)
-  (hash-table/get matcher-preprocessors name #f))
-
-(define matcher-preprocessors
-  (make-eq-hash-table))
-
 (syntax-table/define system-global-syntax-table 'DEFINE-*MATCHER-MACRO
   (lambda (bvl expression)
     (cond ((symbol? bvl)
@@ -86,13 +80,20 @@
 	   (error "Malformed bound-variable list:" bvl)))))
 
 (define (define-*matcher-expander name procedure)
-  (define-matcher-preprocessor name
+  (define-matcher-macro name
     (lambda (expression external-bindings internal-bindings)
       (preprocess-matcher-expression (if (pair? expression)
 					 (apply procedure (cdr expression))
 					 (procedure))
 				     external-bindings
 				     internal-bindings))))
+
+(define (matcher-preprocessor name)
+  (or (lookup-matcher-macro name)
+      (hash-table/get matcher-preprocessors name #f)))
+
+(define matcher-preprocessors
+  (make-eq-hash-table))
 
 (define-*matcher-expander '+
   (lambda (expression)
diff --git a/v7/src/star-parser/parser.pkg b/v7/src/star-parser/parser.pkg
index f79d03bfc..db746eb11 100644
--- a/v7/src/star-parser/parser.pkg
+++ b/v7/src/star-parser/parser.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: parser.pkg,v 1.8 2001/07/12 03:08:30 cph Exp $
+;;; $Id: parser.pkg,v 1.9 2001/07/14 11:42:29 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -67,8 +67,14 @@
   (files "synchk" "shared" "matcher" "parser")
   (parent ())
   (export ()
+	  current-parser-macros
 	  define-*matcher-expander
-	  define-*parser-expander))
+	  define-*parser-expander
+	  global-parser-macros
+	  make-parser-macros
+	  parser-macros?
+	  set-current-parser-macros!
+	  with-current-parser-macros))
 
 (define-package (runtime unicode)
   (files "unicode")
diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 6bfcf14f4..76bc0aa5f 100644
--- a/v7/src/star-parser/parser.scm
+++ b/v7/src/star-parser/parser.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: parser.scm,v 1.16 2001/07/09 04:08:19 cph Exp $
+;;; $Id: parser.scm,v 1.17 2001/07/14 11:42:31 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -66,12 +66,6 @@
       (hash-table/put! parser-preprocessors name procedure))
   name)
 
-(define (parser-preprocessor name)
-  (hash-table/get parser-preprocessors name #f))
-
-(define parser-preprocessors
-  (make-eq-hash-table))
-
 (syntax-table/define system-global-syntax-table 'DEFINE-*PARSER-MACRO
   (lambda (bvl expression)
     (cond ((symbol? bvl)
@@ -86,13 +80,20 @@
 	   (error "Malformed bound-variable list:" bvl)))))
 
 (define (define-*parser-expander name procedure)
-  (define-parser-preprocessor name
+  (define-parser-macro name
     (lambda (expression external-bindings internal-bindings)
       (preprocess-parser-expression (if (pair? expression)
 					(apply procedure (cdr expression))
 					(procedure))
 				    external-bindings
 				    internal-bindings))))
+
+(define (parser-preprocessor name)
+  (or (lookup-parser-macro name)
+      (hash-table/get parser-preprocessors name #f)))
+
+(define parser-preprocessors
+  (make-eq-hash-table))
 
 (define-*parser-expander '+
   (lambda (expression)
diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index 8a17a95c2..4e475b5d5 100644
--- a/v7/src/star-parser/shared.scm
+++ b/v7/src/star-parser/shared.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: shared.scm,v 1.8 2001/07/02 18:18:38 cph Exp $
+;;; $Id: shared.scm,v 1.9 2001/07/14 11:42:35 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -88,6 +88,76 @@
 		  (symbol? (car object))
 		  (loop (cdr object)))))))
 
+(define parser-macros-rtd
+  (make-record-type "parser-macros" '(PARENT MATCHER-TABLE PARSER-TABLE)))
+
+(define make-parser-macros
+  (let ((constructor (record-constructor parser-macros-rtd)))
+    (lambda (parent)
+      (if parent (guarantee-parser-macros parent 'MAKE-PARSER-MACROS))
+      (constructor (or parent *global-parser-macros*)
+		   (make-eq-hash-table)
+		   (make-eq-hash-table)))))
+
+(define *global-parser-macros*
+  ((record-constructor parser-macros-rtd)
+   #f
+   (make-eq-hash-table)
+   (make-eq-hash-table)))
+
+(define (guarantee-parser-macros object procedure)
+  (if (not (parser-macros? object))
+      (error:wrong-type-argument object "parser macros" procedure)))
+
+(define parser-macros?
+  (record-predicate parser-macros-rtd))
+
+(define parent-macros
+  (record-accessor parser-macros-rtd 'PARENT))
+
+(define matcher-macros-table
+  (record-accessor parser-macros-rtd 'MATCHER-TABLE))
+
+(define parser-macros-table
+  (record-accessor parser-macros-rtd 'PARSER-TABLE))
+
+(define (define-matcher-macro name expander)
+  (hash-table/put! (matcher-macros-table *parser-macros*) name expander))
+
+(define (lookup-matcher-macro name)
+  (let loop ((environment *parser-macros*))
+    (and environment
+	 (or (hash-table/get (matcher-macros-table environment) name #f)
+	     (loop (parent-macros environment))))))
+
+(define (define-parser-macro name expander)
+  (hash-table/put! (parser-macros-table *parser-macros*) name expander))
+
+(define (lookup-parser-macro name)
+  (let loop ((environment *parser-macros*))
+    (and environment
+	 (or (hash-table/get (parser-macros-table environment) name #f)
+	     (loop (parent-macros environment))))))
+
+(define (with-current-parser-macros macros thunk)
+  (guarantee-parser-macros macros 'WITH-CURRENT-PARSER-MACROS)
+  (fluid-let ((*parser-macros* macros))
+    (thunk)))
+
+(define (current-parser-macros)
+  *parser-macros*)
+
+(define (set-current-parser-macros! macros)
+  (guarantee-parser-macros macros 'SET-CURRENT-PARSER-MACROS!)
+  (set! *parser-macros* macros)
+  unspecific)
+
+(define (global-parser-macros)
+  *global-parser-macros*)
+
+(define *parser-macros*
+  *global-parser-macros*)
+
 ;;;; Buffer pointers
 
 (define (call-with-unknown-pointer procedure)