Add Tcl_BumpObj() used to prevent leaks from Abstract List elements.

Add Abstract List (ArithSeries) support in Tcl_ListObjIndex().
Fix obj leaks in lsearch operatations on ArithSeries.
Fix obj leaks in concat operations on ArithSeries.
Add concat and lsearch tests using lseq lists.

6 files changed, 109 insertions, 7 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index 7acc13b..15ee9fb 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2478,6 +2478,25 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
 #   undef Tcl_IsShared
 #   define Tcl_IsShared(objPtr) \
 	Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
+/*
+ * Free the Obj by effectively doing:
+ *
+ *   Tcl_IncrRefCount(objPtr);
+ *   Tcl_DecrRefCount(objPtr);
+ *
+ * This will free the obj if there are no references to the obj.
+ */
+#   define Tcl_BumpObj(objPtr) \
+    TclBumpObj(objPtr, __FILE__, __LINE__)
+
+static inline void TclBumpObj(Tcl_Obj* objPtr, const char* fn, int line)
+{
+    if (objPtr) {
+        if ((objPtr)->refCount == 0) {
+            Tcl_DbDecrRefCount(objPtr, fn, line);
+	}
+    }
+}
 #else
 #   undef Tcl_IncrRefCount
 #   define Tcl_IncrRefCount(objPtr) \
@@ -2497,6 +2516,24 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
 #   undef Tcl_IsShared
 #   define Tcl_IsShared(objPtr) \
 	((objPtr)->refCount > 1)
+
+/*
+ * Declare that obj will no longer be used or referenced.
+ * This will release the obj if there is no referece count,
+ * otherwise let it be.
+ */
+#   define Tcl_BumpObj(objPtr)     \
+    TclBumpObj(objPtr);
+
+static inline void TclBumpObj(Tcl_Obj* objPtr)
+{
+    if (objPtr) {
+        if ((objPtr)->refCount == 0) {
+            Tcl_DecrRefCount(objPtr);
+	}
+    }
+}
+
 #endif
 
 /*
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index e3604be..2e68f67 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -3243,7 +3243,7 @@ Tcl_LsearchObjCmd(
     int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
     double patDouble, objDouble;
     SortInfo sortInfo;
-    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
+    Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL;
     SortStrCmpFn_t strCmpFn = TclUtfCmp;
     Tcl_RegExp regexp = NULL;
     static const char *const options[] = {
@@ -3688,9 +3688,14 @@ Tcl_LsearchObjCmd(
 
 	lower = start - groupSize;
 	upper = listc;
+	itemPtr = NULL;
 	while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
 	    i = (lower + upper)/2;
 	    i -= i % groupSize;
+
+	    Tcl_BumpObj(itemPtr);
+	    itemPtr = NULL;
+
 	    if (sortInfo.indexc != 0) {
 		itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
 		if (sortInfo.resultCode != TCL_OK) {
@@ -3789,6 +3794,9 @@ Tcl_LsearchObjCmd(
 	}
 	for (i = start; i < listc; i += groupSize) {
 	    match = 0;
+	    Tcl_BumpObj(itemPtr);
+	    itemPtr = NULL;
+
 	    if (sortInfo.indexc != 0) {
 		itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
 		if (sortInfo.resultCode != TCL_OK) {
@@ -3915,6 +3923,9 @@ Tcl_LsearchObjCmd(
 	}
     }
 
+    Tcl_BumpObj(itemPtr);
+    itemPtr = NULL;
+
     /*
      * Return everything or a single value.
      */
@@ -5481,7 +5492,7 @@ SelectObjFromSublist(
     for (i=0 ; i<infoPtr->indexc ; i++) {
 	Tcl_Size listLen;
 	int index;
-	Tcl_Obj *currentObj;
+	Tcl_Obj *currentObj, *lastObj=NULL;
 
 	if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
 	    infoPtr->resultCode = TCL_ERROR;
@@ -5512,6 +5523,8 @@ SelectObjFromSublist(
 	    return NULL;
 	}
 	objPtr = currentObj;
+	Tcl_BumpObj(lastObj);
+	lastObj = currentObj;
     }
     return objPtr;
 }
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 3c4c4d2..3604ec9 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -1981,6 +1981,7 @@ Tcl_ListObjIndex(
 {
     Tcl_Obj **elemObjs;
     Tcl_Size numElems;
+    int hasAbstractList = ABSTRACTLIST_PROC(listObj,indexProc) != 0;
 
     /* Empty string => empty list. Avoid unnecessary shimmering */
     if (listObj->bytes == &tclEmptyString) {
@@ -1988,6 +1989,9 @@ Tcl_ListObjIndex(
 	return TCL_OK;
     }
 
+    if (hasAbstractList) {
+	return Tcl_ObjTypeIndex(interp, listObj, index, objPtrPtr);
+    }
     if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
 	!= TCL_OK) {
 	return TCL_ERROR;
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index e801a2d..df64ae4 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -972,12 +972,13 @@ TestlistobjCmd(
 		!= TCL_OK) {
 		return TCL_ERROR;
 	    }
-	    if (objP->refCount <= 0) {
+	    if (objP->refCount < 0) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
-			"Tcl_ListObjIndex returned object with ref count <= 0",
+			"Tcl_ListObjIndex returned object with ref count < 0",
 			TCL_INDEX_NONE));
 		/* Keep looping since we are also looping for leaks */
 	    }
+	    Tcl_BumpObj(objP);
 	}
 	break;
 
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 8c34435..1c3b951 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1982,7 +1982,8 @@ Tcl_ConcatObj(
 	Tcl_Size length;
 
 	objPtr = objv[i];
-	if (TclListObjIsCanonical(objPtr)) {
+	if (TclListObjIsCanonical(objPtr) ||
+            ABSTRACTLIST_PROC(objPtr,indexProc)) {
 	    continue;
 	}
 	(void)Tcl_GetStringFromObj(objPtr, &length);
@@ -1994,7 +1995,8 @@ Tcl_ConcatObj(
 	resPtr = NULL;
 	for (i = 0;  i < objc;  i++) {
 	    objPtr = objv[i];
-	    if (!TclListObjIsCanonical(objPtr)) {
+	    if (!TclListObjIsCanonical(objPtr) &&
+		!ABSTRACTLIST_PROC(objPtr,indexProc)) {
 		continue;
 	    }
 	    if (resPtr) {
diff --git a/tests/lseq.test b/tests/lseq.test
index 8a406cc..2b6f286 100644
--- a/tests/lseq.test
+++ b/tests/lseq.test
@@ -421,6 +421,21 @@ test lseq-3.31 {lreverse inplace with doubles} {arithSeriesDouble has64BitLength
     lreverse [lseq 1.1 29.9 0.3]
 } {29.9 29.6 29.3 29.0 28.7 28.4 28.1 27.8 27.5 27.2 26.9 26.6 26.3 26.0 25.7 25.4 25.1 24.8 24.5 24.2 23.9 23.6 23.3 23.0 22.7 22.4 22.1 21.8 21.5 21.2 20.9 20.6 20.3 20.0 19.7 19.4 19.1 18.8 18.5 18.2 17.9 17.6 17.3 17.0 16.7 16.4 16.1 15.8 15.5 15.2 14.9 14.6 14.3 14.0 13.7 13.4 13.1 12.8 12.5 12.2 11.9 11.6 11.3 11.0 10.7 10.4 10.1 9.8 9.5 9.2 8.9 8.6 8.3 8.0 7.7 7.4 7.1 6.8 6.5 6.2 5.9 5.6 5.3 5.0 4.7 4.4 4.1 3.8 3.5 3.2 2.9 2.6 2.3 2.0 1.7 1.4 1.1}
 
+# lsearch -
+#  -- should not shimmer lseq  list
+#  -- should not leak lseq elements
+test lseq-3.32 {lsearch nested lists of lseq} arithSeriesShimmer {
+    set srchlist {}
+    for {set i 5} {$i < 25} {incr i} {
+	lappend srchlist [lseq $i count 7 by 3]
+    }
+    set a [lsearch -all -inline -index 1 $srchlist 23]
+    set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}]
+    list [lindex [tcl::unsupported::representation $a] 3] $a $b \
+        [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3]
+} {list {{20 23 26 29 32 35 38}} arithseries arithseries}
+
+
 test lseq-4.1 {end expressions} {
     set start 7
     lseq $start $start+11
@@ -465,7 +480,7 @@ test lseq-4.3 {TIP examples} -body {
 	lseq 5 5 -2
 	# -> 5
     }
-
+    set res {}
     foreach {cmd expect} [split $examples \n] {
 	if {[string trim $cmd] ne ""} {
 	    set cmd [string trimleft $cmd]
@@ -585,6 +600,36 @@ test lseq-4.16 {bug lseq - inconsistent rounding} {
     lappend res [lseq 4.03 4.208 0.013]
 } {{4.07 4.17 4.27 4.37 4.47 4.57 4.67 4.77 4.87 4.97 5.07 5.17 5.27 5.37 5.47 5.57 5.67 5.77 5.87 5.97} {4.03 4.043 4.056 4.069 4.082 4.095 4.108 4.121 4.134 4.147 4.16 4.173 4.186 4.199}}
 
+# Test abstract list in a concat
+#  -- lseq list should not shimmer
+#  -- lseq elements should not leak
+test lseq-4.17 {concat?} {
+    set rng [lseq 8 15 2]
+    set pre [list A b C]
+    set pst [list x Y z]
+    concat $pre $rng $pst
+} {A b C 8 10 12 14 x Y z}
+
+test lseq-4.18 {concat?} {
+    set rng [lseq 8 15 2]
+    set pre [list A b C]
+    set pst [list x Y z]
+    concat $rng $pre $pst
+} {8 10 12 14 A b C x Y z}
+
+# Test lseq elements as var names
+test lseq-4.19 {varnames} {
+set plist {}
+    foreach v [info proc auto_*] {
+	lappend plist proc $v [info args $v] [info body $v]
+    }
+    set res {}
+    foreach [lseq 1 to 4] $plist {
+	lappend res $2 [llength $3]
+    }
+    set res
+} {auto_import 1 auto_execok 1 auto_load_index 0 auto_qualify 2 auto_load 2}
+
 # cleanup
 ::tcltest::cleanupTests