From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 Sep 2009 05:52:52 +0000 (-0700)
Subject: Avoid infinite loop for patterns like (* (SEQ)).
X-Git-Tag: 20100708-Gtk~297
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f811e0ae4f2299102eb7d59711d4f3e85b14b558;p=mit-scheme.git

Avoid infinite loop for patterns like (* (SEQ)).
---

diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm
index 518dbef7f..ce4ae0257 100644
--- a/src/runtime/regsexp.scm
+++ b/src/runtime/regsexp.scm
@@ -372,22 +372,32 @@ USA.
   (lambda (succeed)
     (%failure-chain succeed (insn succeed))))
 
+;;; The next two operations must fail when the instruction makes no
+;;; progress in a given iteration.  Otherwise patterns like (* (SEQ))
+;;; will loop forever.
+
 (define (insn:* insn)
   (lambda (succeed)
-    (define loop
-      (%failure-chain (lambda (position groups fail)
-			(linked position groups fail))
-		      succeed))
-    (define linked (insn loop))
+    (define (loop position groups fail)
+      ((%failure-chain (insn
+			(lambda (position* groups* fail*)
+			  (if (same-positions? position* position)
+			      (fail*)
+			      (loop position* groups* fail*))))
+		       succeed)
+       position groups fail))
     loop))
 
 (define (insn:*? insn)
   (lambda (succeed)
-    (define loop
-      (%failure-chain succeed
-		      (lambda (position groups fail)
-			(linked position groups fail))))
-    (define linked (insn loop))
+    (define (loop position groups fail)
+      ((%failure-chain succeed
+		       (insn
+			(lambda (position* groups* fail*)
+			  (if (same-positions? position* position)
+			      (fail*)
+			      (loop position* groups* fail*)))))
+       position groups fail))
     loop))
 
 (define (%failure-chain s1 s2)
@@ -465,6 +475,9 @@ USA.
 (define (next-position position)
   ((%position-type-next-position (%get-position-type position)) position))
 
+(define (same-positions? p1 p2)
+  ((%position-type-same? (%get-position-type p1)) p1 p2))
+
 (define (%get-position-type position)
   (or (find (lambda (type)
 	      ((%position-type-predicate type) position))