Lots of hair to allow explicit character-set specifications to be

compiled at load time rather than at run time.

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index aae5931709ecd9e095629d82c5d9410811a80997..aa91bb11de21c5f7cf53c0d7b2ed283d479e7e1e 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.2 2001/06/26 19:01:31 cph Exp $
+;;; $Id: matcher.scm,v 1.3 2001/06/26 21:02:04 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -38,24 +38,16 @@
     (optimize-expression (generate-matcher-code expression))))
 
 (define (generate-matcher-code expression)
-  (with-buffer-name
-    (lambda ()
-      (with-canonical-matcher-expression expression
-       (lambda (expression)
+  (with-canonical-matcher-expression expression
+    (lambda (expression)
+      (with-buffer-name
+       (lambda ()
          (compile-matcher-expression
           expression
           (no-pointers)
           (simple-backtracking-continuation `#T)
           (simple-backtracking-continuation `#F)))))))
 
-;; COMPILE-MATCHER is called by the parser compiler, to generate code
-;; to be embedded into a parser.
-
-(define (compile-matcher expression pointers if-succeed if-fail)
-  (with-canonical-matcher-expression expression
-    (lambda (expression)
-      (compile-matcher-expression expression pointers if-succeed if-fail))))
-
 (define (compile-matcher-expression expression pointers if-succeed if-fail)
   (cond ((and (pair? expression)
              (symbol? (car expression))
@@ -82,82 +74,78 @@
 ;;;; Canonicalization
 
 (define (with-canonical-matcher-expression expression receiver)
-  (let ((bindings '()))
-    (define (do-expression expression)
-      (cond ((and (pair? expression)
-                 (symbol? (car expression))
-                 (list? (cdr expression)))
-            (case (car expression)
-              ((ALT SEQ)
-               `(,(car expression)
-                 ,@(flatten-expressions (map do-expression (cdr expression))
-                                        (car expression))))
-              ((*)
-               `(,(car expression)
-                 ,(do-expression (check-1-arg expression))))
-              ((+)
-               (do-expression
-                (let ((expression (check-1-arg expression)))
-                  `(SEQ ,expression (* ,expression)))))
-              ((?)
-               (do-expression
-                `(ALT ,(check-1-arg expression) (SEQ))))
-              ((CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI)
-               `(,(car expression)
-                 ,(handle-complex-expression (check-1-arg expression))))
-              ((STRING)
-               (let ((string (check-1-arg expression)))
-                 (if (and (string? string) (fix:= (string-length string) 1))
-                     `(CHAR ,(string-ref string 0))
-                     `(STRING ,(handle-complex-expression string)))))
-              ((STRING-CI)
-               (let ((string (check-1-arg expression)))
-                 (if (and (string? string) (fix:= (string-length string) 1))
-                     `(CHAR-CI ,(string-ref string 0))
-                     `(STRING-CI ,(handle-complex-expression string)))))
-              ((ALPHABET)
-               `(,(car expression)
-                 ,(handle-complex-expression
-                   (let ((arg (check-1-arg expression)))
-                     (if (string? arg)
-                         (if (string-prefix? "^" arg)
-                             `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T)
-                             `(RE-COMPILE-CHAR-SET ,arg #F))
-                         arg)))))
-              ((SEXP)
-               (handle-complex-expression (check-1-arg expression)))
-              (else
-               (error "Unknown matcher expression:" expression))))
-           ((symbol? expression)
-            expression)
-           (else
-            (error "Unknown matcher expression:" expression))))
-
-    (define (check-1-arg expression)
-      (if (and (pair? (cdr expression))
-              (null? (cddr expression)))
-         (cadr expression)
-         (error "Malformed expression:" expression)))
-
-    (define (handle-complex-expression expression)
-      (if (or (char? expression)
-             (string? expression)
-             (symbol? expression))
-         expression
-         (let loop ((bindings* bindings))
-           (if (pair? bindings*)
-               (if (equal? expression (caar bindings*))
-                   (cdar bindings*)
-                   (loop (cdr bindings*)))
-               (let ((variable (generate-uninterned-symbol)))
-                 (set! bindings (cons (cons expression variable) bindings))
-                 variable)))))
-
-    (let ((expression (do-expression expression)))
-      (if (pair? bindings)
-         `(LET ,(map (lambda (b) `(,(cdr b) ,(car b))) bindings)
-            ,(receiver expression))
-         (receiver expression)))))
+  (let ((external-bindings (list 'BINDINGS))
+       (internal-bindings (list 'BINDINGS)))
+    (let ((expression
+          (canonicalize-matcher-expression expression
+                                           external-bindings
+                                           internal-bindings)))
+      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                          (cdr external-bindings))
+                     (receiver
+                      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                                           (cdr internal-bindings))
+                                      expression))))))
+
+(define (canonicalize-matcher-expression expression
+                                        external-bindings internal-bindings)
+  (define (do-expression expression)
+    (cond ((and (pair? expression)
+               (symbol? (car expression))
+               (list? (cdr expression)))
+          (case (car expression)
+            ((ALT SEQ)
+             `(,(car expression)
+               ,@(flatten-expressions (map do-expression (cdr expression))
+                                      (car expression))))
+            ((*)
+             `(,(car expression)
+               ,(do-expression (check-1-arg expression))))
+            ((+)
+             (do-expression
+              (let ((expression (check-1-arg expression)))
+                `(SEQ ,expression (* ,expression)))))
+            ((?)
+             (do-expression
+              `(ALT ,(check-1-arg expression) (SEQ))))
+            ((CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI)
+             `(,(car expression)
+               ,(handle-complex-expression (check-1-arg expression)
+                                           internal-bindings)))
+            ((STRING)
+             (let ((string (check-1-arg expression)))
+               (if (and (string? string) (fix:= (string-length string) 1))
+                   `(CHAR ,(string-ref string 0))
+                   `(STRING
+                     ,(handle-complex-expression string
+                                                 internal-bindings)))))
+            ((STRING-CI)
+             (let ((string (check-1-arg expression)))
+               (if (and (string? string) (fix:= (string-length string) 1))
+                   `(CHAR-CI ,(string-ref string 0))
+                   `(STRING-CI
+                     ,(handle-complex-expression string
+                                                 internal-bindings)))))
+            ((ALPHABET)
+             `(,(car expression)
+               ,(let ((arg (check-1-arg expression)))
+                  (if (string? arg)
+                      (handle-complex-expression
+                       (if (string-prefix? "^" arg)
+                           `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T)
+                           `(RE-COMPILE-CHAR-SET ,arg #F))
+                       external-bindings)
+                      (handle-complex-expression arg internal-bindings)))))
+            ((SEXP)
+             (handle-complex-expression (check-1-arg expression)
+                                        internal-bindings))
+            (else
+             (error "Unknown matcher expression:" expression))))
+         ((symbol? expression)
+          expression)
+         (else
+          (error "Unknown matcher expression:" expression))))
+  (do-expression expression))
 \f
 ;;;; Matchers
 

diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 3df8e8263dfeef5c79ed26940367cb93362aaa08..9c5c3bc895d19566f974d592e0f678b3c8d91e4c 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.2 2001/06/26 19:01:17 cph Exp $
+;;; $Id: parser.scm,v 1.3 2001/06/26 21:02:06 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -38,10 +38,10 @@
     (optimize-expression (generate-parser-code expression))))
 
 (define (generate-parser-code expression)
-  (with-buffer-name
-    (lambda ()
-      (with-canonical-parser-expression expression
-       (lambda (expression)
+  (with-canonical-parser-expression expression
+    (lambda (expression)
+      (with-buffer-name
+       (lambda ()
          (compile-parser-expression
           expression
           (no-pointers)
@@ -80,7 +80,8 @@
 ;;;; Canonicalization
 
 (define (with-canonical-parser-expression expression receiver)
-  (let ((bindings '()))
+  (let ((external-bindings (list 'BINDINGS))
+       (internal-bindings (list 'BINDINGS)))
     (define (do-expression expression)
       (cond ((and (pair? expression)
                  (symbol? (car expression))
@@ -101,49 +102,30 @@
                (do-expression
                 `(ALT ,(check-1-arg expression) (SEQ))))
               ((MATCH NOISE)
-               (check-1-arg expression)
-               expression)
+               `(,(car expression)
+                 ,(canonicalize-matcher-expression (check-1-arg expression)
+                                                   external-bindings
+                                                   internal-bindings)))
               ((DEFAULT TRANSFORM ELEMENT-TRANSFORM ENCAPSULATE)
                (check-2-args expression)
                `(,(car expression) ,(cadr expression)
                                    ,(do-expression (caddr expression))))
               ((SEXP)
-               (let ((expression (check-1-arg expression)))
-                 (if (symbol? expression)
-                     expression
-                     (let loop ((bindings* bindings))
-                       (if (pair? bindings*)
-                           (if (equal? expression (caar bindings*))
-                               (cdar bindings*)
-                               (loop (cdr bindings*)))
-                           (let ((variable (generate-uninterned-symbol)))
-                             (set! bindings
-                                   (cons (cons expression variable) bindings))
-                             variable))))))
+               (handle-complex-expression (check-1-arg expression)
+                                          internal-bindings))
               (else
                (error "Unknown parser expression:" expression))))
            ((symbol? expression)
             expression)
            (else
             (error "Unknown parser expression:" expression))))
-
-    (define (check-1-arg expression)
-      (if (and (pair? (cdr expression))
-              (null? (cddr expression)))
-         (cadr expression)
-         (error "Malformed expression:" expression)))
-
-    (define (check-2-args expression)
-      (if (not (and (pair? (cdr expression))
-                   (pair? (cddr expression))
-                   (null? (cdddr expression))))
-         (error "Malformed expression:" expression)))
-
     (let ((expression (do-expression expression)))
-      (if (pair? bindings)
-         `(LET ,(map (lambda (b) `(,(cdr b) ,(car b))) bindings)
-            ,(receiver expression))
-         (receiver expression)))))
+      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                          (cdr external-bindings))
+                     (receiver
+                      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                                           (cdr internal-bindings))
+                                      expression))))))
 \f
 ;;;; Parsers
 
@@ -168,7 +150,7 @@
 (define-parser (match matcher)
   (with-current-pointer pointers
     (lambda (start-pointers)
-      (compile-matcher matcher start-pointers
+      (compile-matcher-expression matcher start-pointers
        (lambda (pointers)
          (if-succeed pointers
                      `(VECTOR (GET-PARSER-BUFFER-TAIL
@@ -177,7 +159,7 @@
        if-fail))))
 
 (define-parser (noise matcher)
-  (compile-matcher matcher pointers
+  (compile-matcher-expression matcher pointers
     (lambda (pointers) (if-succeed pointers `(VECTOR)))
     if-fail))
 

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index c8571a30083142c256ecb2ca327a65b65b5310f0..848c045ccd2a924145336db78d819de821ff69d9 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.2 2001/06/26 18:52:35 cph Exp $
+;;; $Id: shared.scm,v 1.3 2001/06/26 21:02:09 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -33,13 +33,47 @@
 
 (define (with-variable-bindings expressions receiver)
   (let ((variables
-        (map (lambda (x) x (generate-uninterned-symbol)) expressions)))
-    `(LET ,(map list variables expressions)
-       ,(apply receiver variables))))
+        (map (lambda (x) x (generate-uninterned-symbol))
+             expressions)))
+    (maybe-make-let (map list variables expressions)
+                   (apply receiver variables))))
 
 (define (with-variable-binding expression receiver)
   (with-variable-bindings (list expression) receiver))
 
+(define (maybe-make-let bindings body)
+  (if (pair? bindings)
+      `(LET ,bindings ,body)
+      body))
+
+(define (check-1-arg expression)
+  (if (and (pair? (cdr expression))
+          (null? (cddr expression)))
+      (cadr expression)
+      (error "Malformed expression:" expression)))
+
+(define (check-2-args expression)
+  (if (not (and (pair? (cdr expression))
+               (pair? (cddr expression))
+               (null? (cdddr expression))))
+      (error "Malformed expression:" expression)))
+
+(define (handle-complex-expression expression bindings)
+  (if (or (char? expression)
+         (string? expression)
+         (symbol? expression))
+      expression
+      (let loop ((bindings* (cdr bindings)))
+       (if (pair? bindings*)
+           (if (equal? expression (caar bindings*))
+               (cdar bindings*)
+               (loop (cdr bindings*)))
+           (let ((variable (generate-uninterned-symbol)))
+             (set-cdr! bindings
+                       (cons (cons expression variable)
+                             (cdr bindings)))
+             variable)))))
+\f
 ;;;; Buffer pointers
 
 (define (no-pointers)