From 5c77bc40b5194039c1f6ae8e1b20aeca002540ec Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 Oct 2001 04:59:25 +0000
Subject: [PATCH] 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.

---
 v7/src/star-parser/matcher.scm | 106 ++++++++++++++---------------
 v7/src/star-parser/parser.scm  | 118 +++++++++++++++++----------------
 v7/src/star-parser/shared.scm  |  39 +++++------
 3 files changed, 132 insertions(+), 131 deletions(-)

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index a960adc6b..ac3ded551 100644
--- 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 41c7236ab..cf3c6c23b 100644
--- 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 485373a2c..df8a0d6fc 100644
--- 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))
 
-(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))
 
 (define (make-kf-identifier)
   (generate-identifier 'KF))
-- 
2.25.1