Fix crash in BC execution when str concat and abstract list lindex operations have recursive BC execution.

Add testcase for this bug.

3 files changed, 371 insertions, 7 deletions

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 80c7e51..336815d 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2598,13 +2598,16 @@ TEBCresume(
     case INST_STR_CONCAT1:
 
 	opnd = TclGetUInt1AtPtr(pc+1);
+	DECACHE_STACK_INFO();
 	objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
 		TCL_STRING_IN_PLACE);
 	if (objResultPtr == NULL) {
+	    CACHE_STACK_INFO();
 	    TRACE_ERROR(interp);
 	    goto gotError;
 	}
 
+	CACHE_STACK_INFO();
 	TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
 	NEXT_INST_V(2, opnd, 1);
     break;
@@ -4670,6 +4673,7 @@ TEBCresume(
 
 	/* special case for AbstractList */
 	if (TclObjTypeHasProc(valuePtr,indexProc)) {
+	    DECACHE_STACK_INFO();
 	    length = TclObjTypeHasProc(valuePtr, lengthProc)(valuePtr);
 	    if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
 		CACHE_STACK_INFO();
@@ -4765,11 +4769,13 @@ TEBCresume(
 	    index = TclIndexDecode(opnd, length-1);
 
 	    /* Compute value @ index */
+	    DECACHE_STACK_INFO();
 	    if (Tcl_ObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
 		CACHE_STACK_INFO();
 		TRACE_ERROR(interp);
 		goto gotError;
 	    }
+	    CACHE_STACK_INFO();
 
 	    pcAdjustment = 5;
 	    goto lindexFastPath2;
@@ -4850,6 +4856,7 @@ TEBCresume(
 
 	if (TclObjTypeHasProc(valuePtr, setElementProc)) {
 
+	    DECACHE_STACK_INFO();
 	    objResultPtr = Tcl_ObjTypeSetElement(interp,
 		valuePtr, numIndices,
 	        &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
@@ -4858,6 +4865,7 @@ TEBCresume(
 		&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
 	}
 	if (!objResultPtr) {
+	    CACHE_STACK_INFO();
 	    TRACE_ERROR(interp);
 	    goto gotError;
 	}
@@ -4865,7 +4873,7 @@ TEBCresume(
 	/*
 	 * Set result.
 	 */
-
+	CACHE_STACK_INFO();
 	TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
 	NEXT_INST_V(5, numIndices+1, -1);
 
@@ -4978,6 +4986,7 @@ TEBCresume(
 	fromIdx = TclIndexDecode(fromIdx, objc - 1);
 
 	if (TclObjTypeHasProc(valuePtr, sliceProc)) {
+	    DECACHE_STACK_INFO();
 	    if (Tcl_ObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) {
 		objResultPtr = NULL;
 	    }
@@ -4985,10 +4994,12 @@ TEBCresume(
 	    objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx);
 	}
 	if (objResultPtr == NULL) {
+	    CACHE_STACK_INFO();
 	    TRACE_ERROR(interp);
 	    goto gotError;
 	}
 
+	CACHE_STACK_INFO();
 	TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
 	NEXT_INST_F(9, 1, 1);
 
@@ -5015,10 +5026,13 @@ TEBCresume(
 
 	    do {
 		if (isAbstractList) {
+		    DECACHE_STACK_INFO();
 		    if (Tcl_ObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) {
+			CACHE_STACK_INFO();
 			TRACE_ERROR(interp);
 			goto gotError;
 		    }
+		    CACHE_STACK_INFO();
 		} else {
 		    Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
 		}
@@ -6488,7 +6502,7 @@ TEBCresume(
 
 	pc += 5 - infoPtr->loopCtTemp;
 
-    case INST_FOREACH_STEP:
+    case INST_FOREACH_STEP: /* TODO: address abstract list indexing here! */
 	/*
 	 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
 	 * the next value list element to each loop var.
diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c
index 0799886..8c2a26e 100644
--- a/generic/tclTestABSList.c
+++ b/generic/tclTestABSList.c
@@ -319,7 +319,8 @@ DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
 
   memcpy(copyLString, srcLString, sizeof(LString));
   copyLString->string = (char*)Tcl_Alloc(srcLString->allocated);
-  strcpy(copyLString->string, srcLString->string);
+  strncpy(copyLString->string, srcLString->string, srcLString->strlen);
+  copyLString->string[srcLString->strlen] = '\0';
   copyLString->elements = NULL;
   Tcl_ObjInternalRep itr;
   itr.twoPtrValue.ptr1 = copyLString;
@@ -903,17 +904,304 @@ lLStringObjCmd(
 }
 
 /*
+** lgen - Derived from TIP 192 - Lazy Lists
+** Generate a list using a command provided as argument(s).
+** The command computes the value for a given index.
+*/
+
+/*
+ * Internal rep for the Generate Series
+ */
+typedef struct LgenSeries {
+    Tcl_Interp *interp; // used to evaluate gen script
+    Tcl_Size len;       // list length
+    Tcl_Size nargs;     // Number of arguments in genFn including "index"
+    Tcl_Obj *genFnObj;  // The preformed command as a list. Index is set in
+			// the last element (last argument)
+} LgenSeries;
+
+/*
+ * Evaluate the generation function.
+ * The provided funtion computes the value for a give index
+ */
+static Tcl_Obj*
+lgen(
+    Tcl_Obj* objPtr,
+    Tcl_Size index)
+{
+    LgenSeries *lgenSeriesPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
+    Tcl_Obj *elemObj = NULL;
+    Tcl_Interp *intrp = lgenSeriesPtr->interp;
+    Tcl_Obj *genCmd = lgenSeriesPtr->genFnObj;
+    Tcl_Size endidx = lgenSeriesPtr->nargs-1;
+
+    if (0 <= index && index < lgenSeriesPtr->len) {
+	Tcl_Obj *indexObj = Tcl_NewWideIntObj(index);
+	Tcl_ListObjReplace(intrp, genCmd, endidx, 1, 1, &indexObj);
+	// EVAL DIRECT to avoid interfering with bytecode compile which may be
+	// active on the stack
+	int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT;
+	int status = Tcl_EvalObjEx(intrp, genCmd, flags);
+	elemObj = Tcl_GetObjResult(intrp);
+	if (status != TCL_OK) {
+	    fprintf(stderr,"Error: %s\nwhile executing %s\n",
+		   elemObj ? Tcl_GetString(elemObj) : "NULL",
+		   Tcl_GetString(genCmd));
+	}
+	// Interp may be only holder of the result,
+	// incr refCount to hold on to it.
+	Tcl_IncrRefCount(elemObj);
+    }
+    return elemObj;
+}
+
+/*
+ *  Abstract List Length function
+ */
+static Tcl_Size
+lgenSeriesObjLength(Tcl_Obj *objPtr)
+{
+    LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1;
+    return lgenSeriesRepPtr->len;
+}
+
+/*
+ *  Abstract List Index function
+ */
+static int
+lgenSeriesObjIndex(
+    Tcl_Interp *interp,
+    Tcl_Obj *lgenSeriesObjPtr,
+    Tcl_Size index,
+    Tcl_Obj **elemPtr)
+{
+    LgenSeries *lgenSeriesRepPtr;
+    Tcl_Obj *element;
+
+    lgenSeriesRepPtr = (LgenSeries*)lgenSeriesObjPtr->internalRep.twoPtrValue.ptr1;
+
+    if (index < 0 || index >= lgenSeriesRepPtr->len)
+	return TCL_ERROR;
+
+    if (lgenSeriesRepPtr->interp == NULL && interp == NULL) {
+	return TCL_ERROR;
+    }
+
+    lgenSeriesRepPtr->interp = interp;
+
+    element = lgen(lgenSeriesObjPtr, index);
+    if (element) {
+	*elemPtr = element;
+    } else {
+	return TCL_ERROR;
+    }
+
+    return TCL_OK;
+}
+
+/*
+** UpdateStringRep
+*/
+
+static void
+UpdateStringOfLgen(Tcl_Obj *objPtr)
+{
+    LgenSeries *lgenSeriesRepPtr;
+    Tcl_Obj *element;
+    Tcl_Size i;
+    size_t bytlen;
+    Tcl_Obj *tmpstr = Tcl_NewObj();
+
+    lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
+
+    for (i=0, bytlen=0; i<lgenSeriesRepPtr->len; i++) {
+	element = lgen(objPtr, i);
+	if (element) {
+	    if (i) {
+		Tcl_AppendToObj(tmpstr," ",1);
+	    }
+	    Tcl_AppendObjToObj(tmpstr,element);
+	}
+    }
+
+    bytlen = Tcl_GetCharLength(tmpstr);
+    Tcl_InitStringRep(objPtr, Tcl_GetString(tmpstr), bytlen);
+    Tcl_DecrRefCount(tmpstr);
+
+    return;
+}
+
+/*
+ *  ObjType Free Internal Rep function
+ */
+static void
+FreeLgenInternalRep(Tcl_Obj *objPtr)
+{
+    LgenSeries *lgenSeries = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
+    if (lgenSeries->genFnObj) {
+	Tcl_DecrRefCount(lgenSeries->genFnObj);
+    }
+    lgenSeries->interp = NULL;
+    Tcl_Free(lgenSeries);
+    objPtr->internalRep.twoPtrValue.ptr1 = 0;
+}
+
+static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+
+/*
+ *  Abstract List ObjType definition
+ */
+
+static Tcl_ObjType lgenType = {
+    "lgenseries",
+    FreeLgenInternalRep,
+    DupLgenSeriesRep,
+    UpdateStringOfLgen,
+    NULL, /* SetFromAnyProc */
+    TCL_OBJTYPE_V2(
+	lgenSeriesObjLength,
+	lgenSeriesObjIndex,
+	NULL, /* slice */
+	NULL, /* reverse */
+	NULL, /* get elements */
+        NULL, /* set element */
+        NULL) /* replace */
+};
+
+/*
+ *  ObjType Duplicate Internal Rep Function
+ */
+static void
+DupLgenSeriesRep(
+    Tcl_Obj *srcPtr,
+    Tcl_Obj *copyPtr)
+{
+    LgenSeries *srcLgenSeries = (LgenSeries*)srcPtr->internalRep.twoPtrValue.ptr1;
+    Tcl_Size repSize = sizeof(LgenSeries);
+    LgenSeries *copyLgenSeries = (LgenSeries*)Tcl_Alloc(repSize);
+
+    copyLgenSeries->interp = srcLgenSeries->interp;
+    copyLgenSeries->nargs = srcLgenSeries->nargs;
+    copyLgenSeries->len = srcLgenSeries->len;
+    copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj);
+    Tcl_IncrRefCount(copyLgenSeries->genFnObj);
+    copyPtr->typePtr = &lgenType;
+    copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries;
+    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+    return;
+}
+
+/*
+ *  Create a new lgen Tcl_Obj
+ */
+Tcl_Obj *
+newLgenObj(
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj * const objv[])
+{
+    Tcl_WideInt length;
+    LgenSeries *lGenSeriesRepPtr;
+    Tcl_Size repSize;
+    Tcl_Obj *lGenSeriesObj;
+
+    if (objc < 2) {
+	return NULL;
+    }
+
+    if (Tcl_GetWideIntFromObj(NULL, objv[0], &length) != TCL_OK
+	|| length < 0) {
+	return NULL;
+    }
+
+    lGenSeriesObj = Tcl_NewObj();
+    repSize = sizeof(LgenSeries);
+    lGenSeriesRepPtr = (LgenSeries*)Tcl_Alloc(repSize);
+    lGenSeriesRepPtr->interp = interp; //Tcl_CreateInterp();
+    lGenSeriesRepPtr->len = length;
+
+    // Allocate array of *obj for cmd + index + args
+    // objv  length cmd arg1 arg2 arg3 ...
+    // argsv         0   1    2    3   ... index
+
+    lGenSeriesRepPtr->nargs = objc;
+    lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1);
+    // Addd 0 placeholder for index
+    Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0));
+    Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj);
+    lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr;
+    lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
+    lGenSeriesObj->typePtr = &lgenType;
+
+    if (length > 0) {
+	Tcl_InvalidateStringRep(lGenSeriesObj);
+    } else {
+	Tcl_InitStringRep(lGenSeriesObj, NULL, 0);
+    }
+    return lGenSeriesObj;
+}
+
+/*
+ *  The [lgen] command
+ */
+static int
+lGenObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj * const objv[])
+{
+    Tcl_Obj *genObj = newLgenObj(interp, objc-1, &objv[1]);
+    if (genObj) {
+	Tcl_SetObjResult(interp, genObj);
+	return TCL_OK;
+    }
+    Tcl_WrongNumArgs(interp, 1, objv, "length cmd ?args?");
+    return TCL_ERROR;
+}
+
+/*
+ *  lgen package init
+ */
+int Lgen_Init(Tcl_Interp *interp) {
+    if (Tcl_InitStubs(interp, "8.7", 0) == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
+    Tcl_PkgProvide(interp, "lgen", "1.0");
+    return TCL_OK;
+}
+
+
+
+/*
  *----------------------------------------------------------------------
  *
- * Lstring_Init --
+ * ABSListTest_Init --
+ *
+ *	Provides Abstract List implemenations via new commands
+ *
+ * lstring command
+ * Usage:
+ *      lstring /string/
+ *
+ * Description:
+ *      Creates a list where each character in the string is treated as an
+ *      element. The string is kept as a string, not an actual list. Indexing
+ *      is done by char.
+ *
+ * lgen command
+ * Usage:
+ *      lgen /length/ /cmd/ ?args...?
  *
- *	DL load init function. Defines the "lstring" command.
+ *      The /cmd/ should take the last argument as the index value, and return
+ *      a value for that element.
  *
  * Results:
- *	"lstring" command added to the interp.
+ *	The commands listed above are added to the interp.
  *
  * Side effects:
- *	A new command is defined.
+ *	New commands defined.
  *
  *----------------------------------------------------------------------
  */
@@ -923,6 +1211,7 @@ int Tcl_ABSListTest_Init(Tcl_Interp *interp) {
 	return TCL_ERROR;
     }
     Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
     Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
     return TCL_OK;
 }
diff --git a/tests/abstractlist.test b/tests/abstractlist.test
index 6930446..cca24c5 100644
--- a/tests/abstractlist.test
+++ b/tests/abstractlist.test
@@ -513,6 +513,67 @@ testConstraint [format "%sShimmer" [string totitle $not]] 1
 
 }
 
+#
+# Test fix for bug in TEBC for STR CONCAT, and LIST INDEX
+# instructions.
+# This example abstract list (lgen) causes a rescursive call in TEBC,
+# stack management was not included for these instructions in TEBC.
+#
+test abstractlist-lgen-bug {} -setup {
+    set lgenfile [makeFile {
+	# Test TIP 192 - Lazy Lists
+	set cntr 0
+	# Fatal error here when [source]'d -- It is a refcounting problem...
+	lappend res Index*2:[lgen 1 expr 2* ]:--
+	set x [lseq 17]
+	set y [lgen 17 apply {{index} {expr {$index * 6}}}] ;# expr * 6
+	foreach i $x n $y {
+	    lappend res "$i -> $n"
+	}
+	proc my_expr {offset index} {
+	    expr {$index + $offset}
+	}
+	lappend res my_expr(3):[my_expr 3 0]
+
+	lappend res [set ss [lgen 15 my_expr 7]]
+	lappend res s2:[list "Index+7:" $ss ":--"]
+
+	lappend res  foo:[list "Index-8:" [lgen 15 my_expr -8] ":--"]
+
+	set 9 [lgen 15 my_expr 7]
+	lappend res 9len=[llength $9]
+	lappend res 9(3)=[lindex $9 3]
+	lappend res bar:[list "Index+7:" $9 ":--"]
+
+	lappend res Index+7:$9:--
+
+	lappend res Index+7:[lgen 15 my_expr 7]:--
+
+	proc fib {phi n} {
+	    set d [expr {round(pow($phi, $n) / sqrt(5.0))}]
+	    return $d
+	}
+	set phi [expr {(1 + sqrt(5.0)) / 2.0}]
+
+	lappend res fib:[lmap n [lseq 5] {fib $phi $n}]
+
+	set x [lgen 20 fib $phi]
+	lappend res "First 20 fibbinacci:[lgen 20 fib $phi]"
+	lappend res "First 20 fibbinacci from x :$x"
+	unset x
+	lappend res Good-Bye!
+	set res
+    } lgen.tcl]
+} -body {
+    set tcl_traceExec 0
+    set tcl_traceCompile 0
+    set f $lgenfile
+    #set script [format "puts ====-%s-====\nsource %s\nputs ====-done-====\n" $f $f]
+    set script [format "source %s" $f]
+    #puts stderr "eval $script"
+    eval $script
+} -result {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring Index*2:0:-- {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} my_expr(3):3 {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} {s2:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {foo:Index-8: {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6} :--} 9len=15 9(3)=10 {bar:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {fib:0 1 1 2 3} {First 20 fibbinacci:0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} {First 20 fibbinacci from x :0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} Good-Bye!}
+
 # lsort
 
 # cleanup