Doc improvements.

Use freeProc field of pseudo interpreter to store the magic value.

7 files changed, 79 insertions, 50 deletions

diff --git a/ChangeLog b/ChangeLog
index 97fcc85..5993378 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2013-02-15  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/regc_nfa.c:	[Bug 3604074] Fix regexp optimization to
+	* tests/regexp.test:	stop hanging on the expression
+	((((((((a)*)*)*)*)*)*)*)* .  Thanks to Bjørn Grathwohl for discovery.
+
 2013-02-14  Harald Oehlmann  <oehhar@users.sf.net>
 
 	* library/msgcat/msgcat.tcl: [Bug 3604576]: Catch missing registry entry
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 2c2397f..65147d4 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -1248,6 +1248,7 @@ fixempties(
 {
     struct state *s;
     struct state *nexts;
+    struct state *to;
     struct arc *a;
     struct arc *nexta;
     int progress;
@@ -1258,15 +1259,50 @@ fixempties(
 
     do {
 	progress = 0;
-	for (s = nfa->states; s != NULL && !NISERR()
-		&& s->no != FREESTATE; s = nexts) {
+	for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
 	    nexts = s->next;
-	    for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
+	    for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) {
+		if (a->type == EMPTY) {
+
+		    /*
+		     *  Mark a for deletion; copy arcs to preserve graph
+		     * connectivity after it is gone.
+		     */
+
+		    unempty(nfa, a);
+		}
+	    }
+
+	    /*
+	     * Now pass through and delete the marked arcs.  Doing all the
+	     * deletion after all the marking prevents arc copying from
+	     * resurrecting deleted arcs which can cause failure to converge.
+	     * [Tcl Bug 3604074]
+	     */
+
+	    for (a = s->outs; a != NULL; a = nexta) {
 		nexta = a->outchain;
-		if (a->type == EMPTY && unempty(nfa, a)) {
+		if (a->from == NULL) {
 		    progress = 1;
+		    to = a->to;
+		    a->from = s;
+		    freearc(nfa, a);
+		    if (to->nins == 0) {
+			while ((a = to->outs)) {
+			    freearc(nfa, a);
+			}
+			if (nexts == to) {
+			    nexts = to->next;
+			}
+			freestate(nfa, to);
+		    }
+		    if (s->nouts == 0) {
+			while ((a = s->ins)) {
+			    freearc(nfa, a);
+			}
+			freestate(nfa, s);
+		    }
 		}
-		assert(nexta == NULL || s->no != FREESTATE);
 	    }
 	}
 	if (progress && f != NULL) {
@@ -1288,7 +1324,6 @@ unempty(
 {
     struct state *from = a->from;
     struct state *to = a->to;
-    int usefrom;		/* work on from, as opposed to to? */
 
     assert(a->type == EMPTY);
     assert(from != nfa->pre && to != nfa->post);
@@ -1299,47 +1334,30 @@ unempty(
     }
 
     /*
-     * Decide which end to work on.
+     *  Mark arc for deletion.
      */
 
-    usefrom = 1;		/* default: attack from */
+    a->from = NULL;
+
     if (from->nouts > to->nins) {
-	usefrom = 0;
-    } else if (from->nouts == to->nins) {
-	/*
-	 * Decide on secondary issue: move/copy fewest arcs.
-	 */
-
-	if (from->nins > to->nouts) {
-	    usefrom = 0;
-	}
+	copyouts(nfa, to, from);
+	return 1;
+    }
+    if (from->nouts < to->nins) {
+	copyins(nfa, from, to);
+	return 1;
     }
 
-    freearc(nfa, a);
-    if (usefrom) {
-	if (from->nouts == 0) {
-	    /*
-	     * Was the state's only outarc.
-	     */
-
-	    moveins(nfa, from, to);
-	    freestate(nfa, from);
-	} else {
-	    copyins(nfa, from, to);
-	}
-    } else {
-	if (to->nins == 0) {
-	    /*
-	     * Was the state's only inarc.
-	     */
+    /*
+     * from->nouts == to->nins . decide on secondary issue:  copy fewest arcs
+     */
 
-	    moveouts(nfa, to, from);
-	    freestate(nfa, to);
-	} else {
-	    copyouts(nfa, to, from);
-	}
+    if (from->nins > to->nouts) {
+	copyouts(nfa, to, from);
+	return 1;
     }
 
+    copyins(nfa, from, to);
     return 1;
 }
 
diff --git a/generic/tcl.h b/generic/tcl.h
index 8c8e774..5f956b0 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -504,11 +504,11 @@ typedef struct Tcl_Interp
     /* TIP #330: Strongly discourage extensions from using the string
      * result. */
 #ifdef USE_INTERP_RESULT
-    char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
+    char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
 				/* If the last command returned a string
 				 * result, this points to it. */
     void (*freeProc) (char *blockPtr)
-	    TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
+	    TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
 				/* Zero means the string result is statically
 				 * allocated. TCL_DYNAMIC means it was
 				 * allocated with ckalloc and should be freed
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index d3f49de..c07ee02 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -1413,15 +1413,16 @@ Tcl_UtfToExternal(
  *
  * Tcl_InitSubsystems/Tcl_FindExecutable --
  *
- *	This function computes the absolute path name of the current
- *	application, given its argv[0] value.
+ *	This function initializes everything needed for the Tcl library
+ *	to be able to operate.
  *
  * Results:
  *	None.
  *
  * Side effects:
  *	The absolute pathname for the application is computed and stored to be
- *	returned later be [info nameofexecutable].
+ *	returned later by [info nameofexecutable]. The system encoding is
+ *	determined and stored to be returned later by [encoding system]
  *
  *---------------------------------------------------------------------------
  */
@@ -1433,11 +1434,11 @@ MODULE_SCOPE const TclStubs tclStubs;
  * to initialize the stub table. */
 static const struct {
     const char *version; /* a real interpreter has interp->result here. */
-    void (*unused2) (void); /* a real interpreter has interp->freeProc here. */
-    int magic; /* a real interpreter has interp->errorLine here. */
+    void (*magic) (void); /* a real interpreter has interp->freeProc here. */
+    int errorLine;
     const struct TclStubs *stubTable;
 } dummyInterp = {
-    TCL_PATCH_LEVEL, 0, TCL_STUB_MAGIC, &tclStubs
+    TCL_PATCH_LEVEL, INT2PTR(TCL_STUB_MAGIC), 0, &tclStubs
 };
 
 Tcl_Interp *
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index 5a2dc53..c22c4c4 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -107,8 +107,8 @@ TclpLoadMemory(
     Tcl_FSUnloadFileProc **unloadProcPtr)
 				/* Dummy: unused by this implementation */
 {
-    Tcl_SetResult(interp, "dynamic loading from memory is not available "
-	    "on this system", TCL_STATIC);
+    Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
+	    "is not available on this system", -1));
     return TCL_ERROR;
 }
 
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index c5c0d92..74d4660 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -73,7 +73,7 @@ Tcl_InitStubs(
 	return NULL;
     }
 
-    if(iPtr->errorLine == TCL_STUB_MAGIC) {
+    if(iPtr->freeProc == INT2PTR(TCL_STUB_MAGIC)) {
 	actualVersion = iPtr->result;
 	tclStubsPtr = stubsPtr;
     } else {
diff --git a/tests/regexp.test b/tests/regexp.test
index 7cafd1b..21f5720 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -819,6 +819,10 @@ test regexp-22.1 {Bug 1810038} {
 test regexp-22.2 {regexp compile and backrefs, Bug 1857126} {
     regexp -- {([bc])\1} bb
 } 1
+test regexp-22.3 {Bug 3604074} {
+    # This will hang in interps where the bug is not fixed
+    regexp ((((((((a)*)*)*)*)*)*)*)* a
+} 1
 
 test regexp-23.1 {regexp -all and -line} {
     set string ""