Rewrite control structures again. These seem correct, after many

hours of thought and testing.  Also make new top-level wrapper for
code generators, and eliminate a couple of unused definitions.

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index a960adc6ba8faa326d4edb4f495c8a8608647b69..ac3ded55112b8d3c45197ec92aaf6ac235b4a8c1 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.16 2001/10/15 17:01:05 cph Exp $
+;;; $Id: matcher.scm,v 1.17 2001/10/16 04:59:18 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -189,23 +189,12 @@
     (optimize-expression (generate-matcher-code expression))))
 
 (define (generate-matcher-code expression)
-  (let ((external-bindings (list 'BINDINGS))
-       (internal-bindings (list 'BINDINGS)))
-    (let ((expression
-          (preprocess-matcher-expression expression
-                                         external-bindings
-                                         internal-bindings)))
-      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-                          (cdr external-bindings))
-       (with-buffer-name
-         (lambda ()
-           (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-                                (cdr internal-bindings))
-                           (call-with-pointer
-                            (lambda (p)
-                              `(,(compile-matcher-expression expression)
-                                (LAMBDA (KF) KF #T)
-                                ,(make-kf p #F)))))))))))
+  (generate-external-procedure expression
+                              preprocess-matcher-expression
+                              (lambda (expression)
+                                `(,(compile-matcher-expression expression)
+                                  (LAMBDA (KF) KF #T)
+                                  (LAMBDA () #F)))))
 
 (define (compile-matcher-expression expression)
   (cond ((and (pair? expression)
@@ -288,18 +277,21 @@
       (if (pair? (cdr expressions))
          (wrap-matcher
           (lambda (ks kf)
-            (call-with-pointer
-             (lambda (p)
-               (let loop
-                   ((expressions expressions)
-                    (kf2 (make-kf p `(,kf))))
-                 `(,(compile-matcher-expression (car expressions))
-                   ,(if (pair? (cdr expressions))
-                        (let ((kf3 (make-kf-identifier)))
+            (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) kf3)))
-                        ks)
-                   ,kf2))))))
+                             ,(loop (cdr expressions)
+                                    `(LAMBDA ()
+                                       ,(backtrack-to p)
+                                       (,kf3)))))
+                       ,kf2)))
+                  `(,(compile-matcher-expression (car expressions))
+                    ,ks
+                    ,kf2)))))
          (compile-matcher-expression (car expressions)))
       (wrap-matcher (lambda (ks kf) `(,ks ,kf)))))
 
@@ -310,32 +302,40 @@
           (lambda (ks kf)
             (call-with-pointer
              (lambda (p)
-               (let loop ((expressions expressions))
-                 `(,(compile-matcher-expression (car expressions))
-                   ,ks
-                   ,(if (pair? (cdr expressions))
-                        (make-kf p (loop (cdr expressions)))
-                        kf)))))))
+               (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)))))))))
          (compile-matcher-expression (car expressions)))
-      (wrap-matcher (lambda (ks kf) ks `(,kf)))))
+      (wrap-matcher (lambda (ks kf) `(BEGIN ,ks (,kf))))))
 
 (define-matcher (* expression)
   (wrap-matcher
    (lambda (ks kf)
-     (call-with-pointer
-      (lambda (p)
-       (let ((ks2 (make-ks-identifier))
-             (kf2 (make-kf-identifier)))
-         `(LET ,ks2 ((,kf2 ,(make-kf p `(,ks ,kf))))
-            ,(call-with-pointer
-              (lambda (p2)
-                `(,(compile-matcher-expression expression)
-                  ,(let ((kf3 (make-kf-identifier)))
-                     `(LAMBDA (,kf3)
-                        (,ks2 ,(make-kf p2 `(,ks ,kf3)))))
-                  ,(make-kf p2 `(,ks ,kf2))))))))))))
-
-;;; Edwin Variables:
-;;; Eval: (scheme-indent-method 'define-matcher-optimizer 2)
-;;; Eval: (scheme-indent-method 'with-buffer-name 0)
-;;; End:
+     (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

diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 41c7236ab1959fe32d11431424d21265bae3bed0..cf3c6c23b086e21c0d69dfd50cf3f38bd3abbe7c 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.19 2001/10/15 17:01:07 cph Exp $
+;;; $Id: parser.scm,v 1.20 2001/10/16 04:59:21 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -178,23 +178,12 @@
     (optimize-expression (generate-parser-code expression))))
 
 (define (generate-parser-code expression)
-  (let ((external-bindings (list 'BINDINGS))
-       (internal-bindings (list 'BINDINGS)))
-    (let ((expression
-          (preprocess-parser-expression expression
-                                        external-bindings
-                                        internal-bindings)))
-      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-                          (cdr external-bindings))
-       (with-buffer-name
-         (lambda ()
-           (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-                                (cdr internal-bindings))
-                           (call-with-pointer
-                            (lambda (p)
-                              `(,(compile-parser-expression expression)
-                                (LAMBDA (V KF) KF V)
-                                ,(make-kf p #f)))))))))))
+  (generate-external-procedure expression
+                              preprocess-parser-expression
+                              (lambda (expression)
+                                `(,(compile-parser-expression expression)
+                                  (LAMBDA (V KF) KF V)
+                                  (LAMBDA () #F)))))
 
 (define (compile-parser-expression expression)
   (cond ((and (pair? expression)
@@ -297,21 +286,27 @@
       (if (pair? (cdr expressions))
          (wrap-parser
           (lambda (ks kf)
-            (call-with-pointer
-             (lambda (p)
-               (let loop
-                   ((expressions expressions)
-                    (vs '())
-                    (kf2 (make-kf p `(,kf))))
-                 `(,(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))))))
+            (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)))
       (wrap-parser (lambda (ks kf) `(,ks '#() ,kf)))))
 
@@ -322,12 +317,24 @@
           (lambda (ks kf)
             (call-with-pointer
              (lambda (p)
-               (let loop ((expressions expressions))
-                 `(,(compile-parser-expression (car expressions))
-                   ,ks
-                   ,(if (pair? (cdr expressions))
-                        (make-kf p (loop (cdr expressions)))
-                        kf)))))))
+               (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)))))))))
          (compile-parser-expression (car expressions)))
       (wrap-parser (lambda (ks kf) ks `(,kf)))))
 
@@ -335,21 +342,18 @@
   (wrap-parser
    (lambda (ks kf)
      (let ((ks2 (make-ks-identifier))
-          (kf2 (make-kf-identifier))
-          (v (make-value-identifier)))
-       (call-with-pointer
-       (lambda (p)
-         `(LET ,ks2 ((,v '#()) (,kf2 ,(make-kf p `(,ks '#() ,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)
-                              ,(make-kf p `(,ks ,v ,kf3)))))
-                  ,(make-kf p `(,ks ,v ,kf2))))))))))))
-
-;;; Edwin Variables:
-;;; Eval: (scheme-indent-method 'with-buffer-name 0)
-;;; End:
+          (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

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index 485373a2c74fa35ea7f9e9b11f5206b45191ed2f..df8a0d6fc56b61d58cf3ecfa4bcc321e9fd79f5a 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.10 2001/10/15 17:01:10 cph Exp $
+;;; $Id: shared.scm,v 1.11 2001/10/16 04:59:25 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -23,25 +23,24 @@
 
 (declare (usual-integrations))
 \f
-(define (with-buffer-name thunk)
-  (let ((v (generate-uninterned-symbol)))
-    `(LAMBDA (,v)
-       ,(fluid-let ((*buffer-name* v)
-                   (*id-counters* '()))
-         (thunk)))))
+(define (generate-external-procedure expression preprocessor generator)
+  (fluid-let ((*id-counters* '()))
+    (let ((external-bindings (list 'BINDINGS))
+         (internal-bindings (list 'BINDINGS))
+         (b (generate-identifier 'B)))
+      (let ((expression
+            (preprocessor expression external-bindings internal-bindings)))
+       (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                            (cdr external-bindings))
+                       `(LAMBDA (,b)
+                          ,(fluid-let ((*buffer-name* b))
+                             (maybe-make-let (map (lambda (b)
+                                                    (list (cdr b) (car b)))
+                                                  (cdr internal-bindings))
+                                             (generator expression)))))))))
 
 (define *buffer-name*)
 
-(define (with-variable-bindings expressions receiver)
-  (let ((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)
@@ -87,10 +86,8 @@
 (define (fetch-pointer)
   `(GET-PARSER-BUFFER-POINTER ,*buffer-name*))
 
-(define (make-kf p body)
-  `(LAMBDA ()
-     (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p)
-     ,body))
+(define (backtrack-to p)
+  `(SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p))
 \f
 (define (make-kf-identifier)
   (generate-identifier 'KF))