OK, this time it's right. I've gone through all the combinations, and

everything makes sense.  There are some minor efficiency issues which
will be resolved in the next revision.

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index ac3ded55112b8d3c45197ec92aaf6ac235b4a8c1..0afaf032f738fe4b1aefd85cbc5ce44d6437e8ab 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.17 2001/10/16 04:59:18 cph Exp $
+;;; $Id: matcher.scm,v 1.18 2001/10/16 16:41:08 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -278,20 +278,13 @@
          (wrap-matcher
           (lambda (ks kf)
             (let loop ((expressions expressions) (kf2 kf))
-              (if (pair? (cdr expressions))
-                  (call-with-pointer
-                   (lambda (p)
-                     `(,(compile-matcher-expression (car expressions))
-                       ,(let ((kf3 (make-kf-identifier)))
-                          `(LAMBDA (,kf3)
-                             ,(loop (cdr expressions)
-                                    `(LAMBDA ()
-                                       ,(backtrack-to p)
-                                       (,kf3)))))
-                       ,kf2)))
-                  `(,(compile-matcher-expression (car expressions))
-                    ,ks
-                    ,kf2)))))
+              `(,(compile-matcher-expression (car expressions))
+                ,(if (pair? (cdr expressions))
+                     (let ((kf3 (make-kf-identifier)))
+                       `(LAMBDA (,kf3)
+                          ,(loop (cdr expressions) kf3)))
+                     ks)
+                ,kf2))))
          (compile-matcher-expression (car expressions)))
       (wrap-matcher (lambda (ks kf) `(,ks ,kf)))))
 
@@ -300,25 +293,12 @@
       (if (pair? (cdr expressions))
          (wrap-matcher
           (lambda (ks kf)
-            (call-with-pointer
-             (lambda (p)
-               (let ((ks2 (make-ks-identifier))
-                     (kf2 (make-kf-identifier)))
-                 `(LET ((,ks2
-                         (LAMBDA (,kf2)
-                           (,ks
-                            (LAMBDA ()
-                              ,(backtrack-to p)
-                              (,kf2))))))
-                    ,(let loop ((expressions expressions))
-                       (if (pair? (cdr expressions))
-                           `(,(compile-matcher-expression (car expressions))
-                             ,ks2
-                             (LAMBDA ()
-                               ,(loop (cdr expressions))))
-                           `(,(compile-matcher-expression (car expressions))
-                             ,ks
-                             ,kf)))))))))
+            (let loop ((expressions expressions))
+              `(,(compile-matcher-expression (car expressions))
+                ,ks
+                ,(if (pair? (cdr expressions))
+                     (backtracking-kf (loop (cdr expressions)))
+                     kf)))))
          (compile-matcher-expression (car expressions)))
       (wrap-matcher (lambda (ks kf) `(BEGIN ,ks (,kf))))))
 
@@ -328,14 +308,6 @@
      (let ((ks2 (make-ks-identifier))
           (kf2 (make-kf-identifier)))
        `(LET ,ks2 ((,kf2 ,kf))
-         ,(call-with-pointer
-           (lambda (p)
-             `(,(compile-matcher-expression expression)
-               ,(let ((kf3 (make-kf-identifier)))
-                  `(LAMBDA (,kf3)
-                     (,ks2
-                      (LAMBDA ()
-                        ,(backtrack-to p)
-                        (,ks ,kf3)))))
-               (LAMBDA ()
-                 (,ks ,kf2))))))))))
\ No newline at end of file
+         (,(compile-matcher-expression expression)
+          ,ks2
+          ,(backtracking-kf `(,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 cf3c6c23b086e21c0d69dfd50cf3f38bd3abbe7c..7b4898b32b0f6ea759d2abf8c08f378917b817ec 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.20 2001/10/16 04:59:21 cph Exp $
+;;; $Id: parser.scm,v 1.21 2001/10/16 16:41:10 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -287,26 +287,15 @@
          (wrap-parser
           (lambda (ks kf)
             (let loop ((expressions expressions) (vs '()) (kf2 kf))
-              (if (pair? (cdr expressions))
-                  (call-with-pointer
-                   (lambda (p)
-                     `(,(compile-parser-expression (car expressions))
-                       ,(let ((v (make-value-identifier))
-                              (kf3 (make-kf-identifier)))
-                          `(LAMBDA (,v ,kf3)
-                             ,(loop (cdr expressions)
-                                    (cons v vs)
-                                    `(LAMBDA ()
-                                       ,(backtrack-to p)
-                                       (,kf3)))))
-                       ,kf2)))
-                  `(,(compile-parser-expression (car expressions))
-                    ,(let ((v (make-value-identifier))
-                           (kf3 (make-kf-identifier)))
-                       `(LAMBDA (,v ,kf3)
-                          (,ks (VECTOR-APPEND ,@(reverse (cons v vs)))
-                               ,kf3)))
-                    ,kf2)))))
+              `(,(compile-parser-expression (car expressions))
+                ,(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)
+                             `(,ks (VECTOR-APPEND ,@(reverse vs)) ,kf3)))))
+                ,kf2))))
          (compile-parser-expression (car expressions)))
       (wrap-parser (lambda (ks kf) `(,ks '#() ,kf)))))
 
@@ -315,26 +304,12 @@
       (if (pair? (cdr expressions))
          (wrap-parser
           (lambda (ks kf)
-            (call-with-pointer
-             (lambda (p)
-               (let ((ks2 (make-ks-identifier))
-                     (v (make-value-identifier))
-                     (kf2 (make-kf-identifier)))
-                 `(LET ((,ks2
-                         (LAMBDA (,v ,kf2)
-                           (,ks ,v
-                                (LAMBDA ()
-                                  ,(backtrack-to p)
-                                  (,kf2))))))
-                    ,(let loop ((expressions expressions))
-                       (if (pair? (cdr expressions))
-                           `(,(compile-parser-expression (car expressions))
-                             ,ks2
-                             (LAMBDA ()
-                               ,(loop (cdr expressions))))
-                           `(,(compile-parser-expression (car expressions))
-                             ,ks
-                             ,kf)))))))))
+            (let loop ((expressions expressions))
+              `(,(compile-parser-expression (car expressions))
+                ,ks
+                ,(if (pair? (cdr expressions))
+                     (backtracking-kf (loop (cdr expressions)))
+                     kf)))))
          (compile-parser-expression (car expressions)))
       (wrap-parser (lambda (ks kf) ks `(,kf)))))
 
@@ -345,15 +320,9 @@
           (v (make-value-identifier))
           (kf2 (make-kf-identifier)))
        `(LET ,ks2 ((,v '#()) (,kf2 ,kf))
-         ,(call-with-pointer
-           (lambda (p)
-             `(,(compile-parser-expression expression)
-               ,(let ((v2 (make-value-identifier))
-                      (kf3 (make-kf-identifier)))
-                  `(LAMBDA (,v2 ,kf3)
-                     (,ks2 (VECTOR-APPEND ,v ,v2)
-                           (LAMBDA ()
-                             ,(backtrack-to p)
-                             (,ks ,v ,kf3)))))
-               (LAMBDA ()
-                 (,ks ,v ,kf2))))))))))
\ No newline at end of file
+         (,(compile-parser-expression expression)
+          ,(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

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index df8a0d6fc56b61d58cf3ecfa4bcc321e9fd79f5a..32f07ccdc52e364f55265fd8f057c7b99022e8b3 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.11 2001/10/16 04:59:25 cph Exp $
+;;; $Id: shared.scm,v 1.12 2001/10/16 16:41:13 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -86,8 +86,12 @@
 (define (fetch-pointer)
   `(GET-PARSER-BUFFER-POINTER ,*buffer-name*))
 
-(define (backtrack-to p)
-  `(SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p))
+(define (backtracking-kf body)
+  (call-with-pointer
+   (lambda (p)
+     `(LAMBDA ()
+       (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p)
+       ,body))))
 \f
 (define (make-kf-identifier)
   (generate-identifier 'KF))