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 865b6060d206eb5bfe8adb8fbacf302e8768a383..5eae5a92b4952de8a5f0b69c99831e1175cc90c2 100644 (file)
--- 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 92e3895255313a7ece7055305e4344707da2e994..6573abe8cc0f7079e9de666991a0e6d21b5683d4 100644 (file)
--- 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))
 \f
 (define-*matcher-expander '+
   (lambda (expression)

diff --git a/v7/src/star-parser/parser.pkg b/v7/src/star-parser/parser.pkg
index f79d03bfcc7f714dad8445d0062074d9cb7b9618..db746eb110407f50ebd4665574757463f2ac4e96 100644 (file)
--- 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 6bfcf14f42a54482df36368b61d44f64210768d6..76bc0aa5f590c24e71d3fd11df8c68341e2c4beb 100644 (file)
--- 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))
 \f
 (define-*parser-expander '+
   (lambda (expression)

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index 8a17a95c283c41fcbd75e4796f3a4380fdd89478..4e475b5d5ee4f4418bbbfe227d8a878455fbcd46 100644 (file)
--- 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)))))))
 \f
+(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*)
+\f
 ;;;; Buffer pointers
 
 (define (call-with-unknown-pointer procedure)