From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 Oct 2001 16:41:13 +0000 (+0000)
Subject: OK, this time it's right.  I've gone through all the combinations, and
X-Git-Tag: 20090517-FFI~2498
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a5463172deee2ed63d31ca70a138c0fff8148e2c;p=mit-scheme.git

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 ac3ded551..0afaf032f 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.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 cf3c6c23b..7b4898b32 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.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 df8a0d6fc..32f07ccdc 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.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))))
 
 (define (make-kf-identifier)
   (generate-identifier 'KF))