Add code to reuse existing buffer pointers where possible.

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index 0afaf032f738fe4b1aefd85cbc5ce44d6437e8ab..d6bb09694bac1067b8886d040b8c0efade761ab2 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.18 2001/10/16 16:41:08 cph Exp $
+;;; $Id: matcher.scm,v 1.19 2001/10/16 17:52:28 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -192,11 +192,11 @@
   (generate-external-procedure expression
                               preprocess-matcher-expression
                               (lambda (expression)
-                                `(,(compile-matcher-expression expression)
+                                `(,(compile-matcher-expression expression #f)
                                   (LAMBDA (KF) KF #T)
                                   (LAMBDA () #F)))))
 
-(define (compile-matcher-expression expression)
+(define (compile-matcher-expression expression pointer)
   (cond ((and (pair? expression)
              (symbol? (car expression))
              (list? (cdr expression))
@@ -206,7 +206,7 @@
                    (compiler (cdr entry)))
                (if (and arity (not (= (length (cdr expression)) arity)))
                    (error "Incorrect arity for matcher:" expression))
-               (apply compiler (cdr expression)))))
+               (apply compiler pointer (cdr expression)))))
        ((or (symbol? expression)
             (and (pair? expression) (eq? (car expression) 'SEXP)))
         (wrap-external-matcher
@@ -220,7 +220,7 @@
        (parameters (cdr form)))
     `(DEFINE-MATCHER-COMPILER ',name
        ,(if (symbol? parameters) `#F (length parameters))
-       (LAMBDA ,parameters
+       (LAMBDA (POINTER . ,parameters)
         ,@compiler-body))))
 
 (define (define-matcher-compiler keyword arity compiler)
@@ -232,6 +232,7 @@
 \f
 (define-macro (define-atomic-matcher form test-expression)
   `(DEFINE-MATCHER ,form
+     POINTER
      (WRAP-EXTERNAL-MATCHER ,test-expression)))
 
 (define-atomic-matcher (char char)
@@ -262,6 +263,7 @@
   `(NOT (PEEK-PARSER-BUFFER-CHAR ,*BUFFER-NAME*)))
 
 (define-matcher (discard-matched)
+  pointer
   (wrap-matcher
    (lambda (ks kf)
      `(BEGIN
@@ -269,23 +271,23 @@
        (,ks ,kf)))))
 
 (define-matcher (with-pointer identifier expression)
-  `(LET ((,identifier ,(fetch-pointer)))
-     ,(compile-matcher-expression expression)))
+  `(LET ((,identifier ,(or pointer (fetch-pointer))))
+     ,(compile-matcher-expression expression (or pointer identifier))))
 \f
 (define-matcher (seq . expressions)
   (if (pair? expressions)
       (if (pair? (cdr expressions))
          (wrap-matcher
           (lambda (ks kf)
-            (let loop ((expressions expressions) (kf2 kf))
-              `(,(compile-matcher-expression (car expressions))
+            (let loop ((expressions expressions) (pointer pointer) (kf2 kf))
+              `(,(compile-matcher-expression (car expressions) pointer)
                 ,(if (pair? (cdr expressions))
                      (let ((kf3 (make-kf-identifier)))
                        `(LAMBDA (,kf3)
-                          ,(loop (cdr expressions) kf3)))
+                          ,(loop (cdr expressions) #f kf3)))
                      ks)
                 ,kf2))))
-         (compile-matcher-expression (car expressions)))
+         (compile-matcher-expression (car expressions) pointer))
       (wrap-matcher (lambda (ks kf) `(,ks ,kf)))))
 
 (define-matcher (alt . expressions)
@@ -293,21 +295,27 @@
       (if (pair? (cdr expressions))
          (wrap-matcher
           (lambda (ks kf)
-            (let loop ((expressions expressions))
-              `(,(compile-matcher-expression (car expressions))
+            (let loop ((expressions expressions) (pointer pointer))
+              `(,(compile-matcher-expression (car expressions) pointer)
                 ,ks
                 ,(if (pair? (cdr expressions))
-                     (backtracking-kf (loop (cdr expressions)))
+                     (backtracking-kf pointer
+                       (lambda (pointer)
+                         (loop (cdr expressions) pointer)))
                      kf)))))
-         (compile-matcher-expression (car expressions)))
+         (compile-matcher-expression (car expressions) pointer))
       (wrap-matcher (lambda (ks kf) `(BEGIN ,ks (,kf))))))
 
 (define-matcher (* expression)
+  pointer
   (wrap-matcher
    (lambda (ks kf)
      (let ((ks2 (make-ks-identifier))
           (kf2 (make-kf-identifier)))
        `(LET ,ks2 ((,kf2 ,kf))
-         (,(compile-matcher-expression expression)
+         (,(compile-matcher-expression expression #f)
           ,ks2
-          ,(backtracking-kf `(,ks ,kf2))))))))
\ No newline at end of file
+          ,(backtracking-kf #f
+             (lambda (pointer)
+               pointer
+               `(,ks ,kf2)))))))))
\ No newline at end of file

diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 7b4898b32b0f6ea759d2abf8c08f378917b817ec..a79baca0f163abf43e5f1b64297702666991c058 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.21 2001/10/16 16:41:10 cph Exp $
+;;; $Id: parser.scm,v 1.22 2001/10/16 17:52:31 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -181,11 +181,11 @@
   (generate-external-procedure expression
                               preprocess-parser-expression
                               (lambda (expression)
-                                `(,(compile-parser-expression expression)
+                                `(,(compile-parser-expression expression #f)
                                   (LAMBDA (V KF) KF V)
                                   (LAMBDA () #F)))))
 
-(define (compile-parser-expression expression)
+(define (compile-parser-expression expression pointer)
   (cond ((and (pair? expression)
              (symbol? (car expression))
              (list? (cdr expression))
@@ -195,7 +195,7 @@
                    (compiler (cdr entry)))
                (if (and arity (not (= (length (cdr expression)) arity)))
                    (error "Incorrect arity for parser:" expression))
-               (apply compiler (cdr expression)))))
+               (apply compiler pointer (cdr expression)))))
        ((or (symbol? expression)
             (and (pair? expression) (eq? (car expression) 'SEXP)))
         (wrap-external-parser
@@ -209,7 +209,7 @@
        (parameters (cdr form)))
     `(DEFINE-PARSER-COMPILER ',name
        ,(if (symbol? parameters) `#F (length parameters))
-       (LAMBDA ,parameters
+       (LAMBDA (POINTER . ,parameters)
         ,@compiler-body))))
 
 (define (define-parser-compiler keyword arity compiler)
@@ -222,48 +222,49 @@
 (define-parser (match expression)
   (wrap-parser
    (lambda (ks kf)
-     (call-with-pointer
-      (lambda (p)
-       `(,(compile-matcher-expression expression)
-         ,(let ((kf2 (make-kf-identifier)))
-            `(LAMBDA (,kf2)
-               (,ks (VECTOR (GET-PARSER-BUFFER-TAIL ,*buffer-name* ,p))
-                    ,kf2)))
-         ,kf))))))
+     (call-with-pointer pointer
+       (lambda (p)
+        `(,(compile-matcher-expression expression p)
+          ,(let ((kf2 (make-kf-identifier)))
+             `(LAMBDA (,kf2)
+                (,ks (VECTOR (GET-PARSER-BUFFER-TAIL ,*buffer-name* ,p))
+                     ,kf2)))
+          ,kf))))))
 
 (define-parser (noise expression)
   (wrap-parser
    (lambda (ks kf)
-     `(,(compile-matcher-expression expression)
+     `(,(compile-matcher-expression expression pointer)
        ,(let ((kf2 (make-kf-identifier)))
          `(LAMBDA (,kf2)
             (,ks '#() ,kf2)))
        ,kf))))
 
 (define-parser (values . expressions)
+  pointer
   (wrap-parser
    (lambda (ks kf)
      `(,ks (VECTOR ,@expressions) ,kf))))
 
 (define-parser (transform transform expression)
-  (post-processed-parser expression
+  (post-processed-parser expression pointer
     (lambda (ks v kf)
       (handle-parser-value `(,transform ,v) ks kf))))
 
 (define-parser (map transform expression)
-  (post-processed-parser expression
+  (post-processed-parser expression pointer
     (lambda (ks v kf)
       `(,ks (VECTOR-MAP ,transform ,v) ,kf))))
 
 (define-parser (encapsulate transform expression)
-  (post-processed-parser expression
+  (post-processed-parser expression pointer
     (lambda (ks v kf)
       `(,ks (VECTOR (,transform ,v)) ,kf))))
 
-(define (post-processed-parser expression procedure)
+(define (post-processed-parser expression pointer procedure)
   (wrap-parser
    (lambda (ks kf)
-     `(,(compile-parser-expression expression)
+     `(,(compile-parser-expression expression pointer)
        ,(let ((v (make-value-identifier))
              (kf2 (make-kf-identifier)))
          `(LAMBDA (,v ,kf2)
@@ -271,10 +272,11 @@
        ,kf))))
 
 (define-parser (with-pointer identifier expression)
-  `(LET ((,identifier ,(fetch-pointer)))
-     ,(compile-parser-expression expression)))
+  `(LET ((,identifier ,(or pointer (fetch-pointer))))
+     ,(compile-parser-expression expression (or pointer identifier))))
 
 (define-parser (discard-matched)
+  pointer
   (wrap-parser
    (lambda (ks kf)
      `(BEGIN
@@ -286,17 +288,21 @@
       (if (pair? (cdr expressions))
          (wrap-parser
           (lambda (ks kf)
-            (let loop ((expressions expressions) (vs '()) (kf2 kf))
-              `(,(compile-parser-expression (car expressions))
+            (let loop
+                ((expressions expressions)
+                 (pointer pointer)
+                 (vs '())
+                 (kf2 kf))
+              `(,(compile-parser-expression (car expressions) pointer)
                 ,(let ((v (make-value-identifier))
                        (kf3 (make-kf-identifier)))
                    `(LAMBDA (,v ,kf3)
                       ,(let ((vs (cons v vs)))
                          (if (pair? (cdr expressions))
-                             (loop (cdr expressions) vs kf3)
+                             (loop (cdr expressions) #f vs kf3)
                              `(,ks (VECTOR-APPEND ,@(reverse vs)) ,kf3)))))
                 ,kf2))))
-         (compile-parser-expression (car expressions)))
+         (compile-parser-expression (car expressions) pointer))
       (wrap-parser (lambda (ks kf) `(,ks '#() ,kf)))))
 
 (define-parser (alt . expressions)
@@ -304,25 +310,31 @@
       (if (pair? (cdr expressions))
          (wrap-parser
           (lambda (ks kf)
-            (let loop ((expressions expressions))
-              `(,(compile-parser-expression (car expressions))
+            (let loop ((expressions expressions) (pointer pointer))
+              `(,(compile-parser-expression (car expressions) pointer)
                 ,ks
                 ,(if (pair? (cdr expressions))
-                     (backtracking-kf (loop (cdr expressions)))
+                     (backtracking-kf pointer
+                       (lambda (pointer)
+                         (loop (cdr expressions) pointer)))
                      kf)))))
          (compile-parser-expression (car expressions)))
       (wrap-parser (lambda (ks kf) ks `(,kf)))))
 
 (define-parser (* expression)
+  pointer
   (wrap-parser
    (lambda (ks kf)
      (let ((ks2 (make-ks-identifier))
           (v (make-value-identifier))
           (kf2 (make-kf-identifier)))
        `(LET ,ks2 ((,v '#()) (,kf2 ,kf))
-         (,(compile-parser-expression expression)
+         (,(compile-parser-expression expression #f)
           ,(let ((v2 (make-value-identifier))
                  (kf3 (make-kf-identifier)))
              `(LAMBDA (,v2 ,kf3)
                 (,ks2 (VECTOR-APPEND ,v ,v2) ,kf3)))
-          ,(backtracking-kf `(,ks ,v ,kf2))))))))
\ No newline at end of file
+          ,(backtracking-kf #f
+             (lambda (pointer)
+               pointer
+               `(,ks ,v ,kf2)))))))))
\ No newline at end of file

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index 32f07ccdc52e364f55265fd8f057c7b99022e8b3..b5f6dc439ca0a0f677e58497a751c79fa8310068 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.12 2001/10/16 16:41:13 cph Exp $
+;;; $Id: shared.scm,v 1.13 2001/10/16 17:52:33 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -78,20 +78,22 @@
     `(LET ((,v ,expression))
        ,(generator v))))
 
-(define (call-with-pointer procedure)
-  (let ((p (make-ptr-identifier)))
-    `(LET ((,p ,(fetch-pointer)))
-       ,(procedure p))))
+(define (call-with-pointer pointer procedure)
+  (if pointer
+      (procedure pointer)
+      (let ((p (make-ptr-identifier)))
+       `(LET ((,p ,(fetch-pointer)))
+          ,(procedure p)))))
 
 (define (fetch-pointer)
   `(GET-PARSER-BUFFER-POINTER ,*buffer-name*))
 
-(define (backtracking-kf body)
-  (call-with-pointer
-   (lambda (p)
-     `(LAMBDA ()
-       (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p)
-       ,body))))
+(define (backtracking-kf pointer generate-body)
+  (call-with-pointer pointer
+    (lambda (p)
+      `(LAMBDA ()
+        (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p)
+        ,(generate-body p)))))
 \f
 (define (make-kf-identifier)
   (generate-identifier 'KF))