Refactor the [lrange] machinery into a single routine TclListObjRange().

Apply some optimizations. Contribution from pspjuth.

5 files changed, 192 insertions, 68 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index d628e80..3d058a4 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2536,7 +2536,6 @@ Tcl_LrangeObjCmd(
     register Tcl_Obj *const objv[])
 				/* Argument objects. */
 {
-    Tcl_Obj **elemPtrs;
     int listLen, first, last, result;
 
     if (objc != 4) {
@@ -2554,55 +2553,14 @@ Tcl_LrangeObjCmd(
     if (result != TCL_OK) {
 	return result;
     }
-    if (first < 0) {
-	first = 0;
-    }
 
     result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
 	    &last);
     if (result != TCL_OK) {
 	return result;
     }
-    if (last >= listLen) {
-	last = listLen - 1;
-    }
-
-    if (first > last) {
-	/*
-	 * Returning an empty list is easy.
-	 */
-
-	return TCL_OK;
-    }
-
-    result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
-    if (result != TCL_OK) {
-	return result;
-    }
-
-    if (Tcl_IsShared(objv[1]) ||
-	    ((ListRepPtr(objv[1])->refCount > 1))) {
-	Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
-		&elemPtrs[first]));
-    } else {
-	/*
-	 * In-place is possible.
-	 */
-
-	if (last < (listLen - 1)) {
-	    Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last,
-		    0, NULL);
-	}
-
-	/*
-	 * This one is not conditioned on (first > 0) in order to preserve the
-	 * string-canonizing effect of [lrange 0 end].
-	 */
-
-	Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL);
-	Tcl_SetObjResult(interp, objv[1]);
-    }
 
+    Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
     return TCL_OK;
 }
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f294272..c06632b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4940,11 +4940,11 @@ TEBCresume(
 		TclGetInt4AtPtr(pc+5)));
 
 	/*
-	 * Get the contents of the list, making sure that it really is a list
+	 * Get the length of the list, making sure that it really is a list
 	 * in the process.
 	 */
 
-	if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+	if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) {
 	    TRACE_ERROR(interp);
 	    goto gotError;
 	}
@@ -4978,7 +4978,10 @@ TEBCresume(
 	}
 
 	if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
-	    goto emptyList;
+	emptyList:
+	    objResultPtr = Tcl_NewObj();
+	    TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
+	    NEXT_INST_F(9, 1, 1);
 	}
 	toIdx = TclIndexDecode(toIdx, objc - 1);
 	if (toIdx < 0) {
@@ -4998,28 +5001,8 @@ TEBCresume(
 	}
 
 	fromIdx = TclIndexDecode(fromIdx, objc - 1);
-	if (fromIdx < 0) {
-	    fromIdx = 0;
-	}
 
-	if (fromIdx <= toIdx) {
-	    /* Construct the subsquence list */
-	    /* unshared optimization */
-	    if (Tcl_IsShared(valuePtr)) {
-		objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
-	    } else {
-		if (toIdx != objc - 1) {
-		    Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
-			    0, NULL);
-		}
-		Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL);
-		TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
-		NEXT_INST_F(9, 0, 0);
-	    }
-	} else {
-	emptyList:
-	    TclNewObj(objResultPtr);
-	}
+	objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
 
 	TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
 	NEXT_INST_F(9, 1, 1);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 81b1c05..27e7ce8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3065,6 +3065,8 @@ MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
 MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
 			    int *lines, Tcl_Obj *const *elems);
 MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
+MODULE_SCOPE Tcl_Obj *	TclListObjRange(Tcl_Obj *listPtr, int fromIdx,
+			    int toIdx);
 MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
 MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 7b91d63..8314306 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -423,6 +423,87 @@ TclListObjCopy(
 /*
  *----------------------------------------------------------------------
  *
+ * TclListObjRange --
+ *
+ *	Makes a slice of a list value.
+ *      *listPtr must be known to be a valid list.
+ *
+ * Results:
+ *	Returns a pointer to the sliced list.
+ *      This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ *	The possible conversion of the object referenced by listPtr
+ *	to a list object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclListObjRange(
+    Tcl_Obj *listPtr,		/* List object to take a range from. */
+    int fromIdx,		/* Index of first element to include. */
+    int toIdx)			/* Index of last element to include. */
+{
+    Tcl_Obj **elemPtrs;
+    int listLen, i, newLen;
+    List *listRepPtr;
+
+    TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
+
+    if (fromIdx < 0) {
+	fromIdx = 0;
+    }
+    if (toIdx >= listLen) {
+	toIdx = listLen-1;
+    }
+    if (fromIdx > toIdx) {
+	return Tcl_NewObj();
+    }
+
+    newLen = toIdx - fromIdx + 1;
+
+    if (Tcl_IsShared(listPtr) ||
+	    ((ListRepPtr(listPtr)->refCount > 1))) {
+	return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]);
+    }
+
+    /*
+     * In-place is possible.
+     */
+
+    /*
+     * Even if nothing below cause any changes, we still want the
+     * string-canonizing effect of [lrange 0 end].
+     */
+
+    TclInvalidateStringRep(listPtr);
+
+    /*
+     * Delete elements that should not be included.
+     */
+
+    for (i = 0; i < fromIdx; i++) {
+	TclDecrRefCount(elemPtrs[i]);
+    }
+    for (i = toIdx + 1; i < listLen; i++) {
+	TclDecrRefCount(elemPtrs[i]);
+    }
+
+    if (fromIdx > 0) {
+	memmove(elemPtrs, &elemPtrs[fromIdx],
+		(size_t) newLen * sizeof(Tcl_Obj*));
+    }
+
+    listRepPtr = ListRepPtr(listPtr);
+    listRepPtr->elemCount = newLen;
+
+    return listPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_ListObjGetElements --
  *
  *	This function returns an (objc,objv) array of the elements in a list
diff --git a/tests/lrange.test b/tests/lrange.test
index a5367a4..3077d91 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -90,7 +90,6 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} {
 	lrange $l 0 end-5
     }} {1 2 3 4 5}
 } {}
-
 test lrange-3.2 {compiled with static indices out of range, negative} {
     list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
 } [lrepeat 4 {}]
@@ -108,6 +107,107 @@ test lrange-3.6 {compiled with calculated indices, end out of range (after end)}
     list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
 } [lrepeat 4 {b c}]
 
+test lrange-4.1 {lrange pure promise} -body {
+    set ll1 [list $tcl_version 2 3 4]
+    # Shared
+    set ll2 $ll1
+    # With string rep
+    string length $ll1
+    set rep1 [tcl::unsupported::representation $ll1]
+    # Get new pure object
+    set x [lrange $ll1 0 end]
+    set rep2 [tcl::unsupported::representation $x]
+    regexp {object pointer at (\S+)} $rep1 -> obj1
+    regexp {object pointer at (\S+)} $rep2 -> obj2
+    list $rep1 $rep2 [string equal $obj1 $obj2]
+    # Check for a new clean object
+} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
+
+test lrange-4.2 {lrange pure promise} -body {
+    set ll1 [list $tcl_version 2 3 4]
+    # Shared
+    set ll2 $ll1
+    # With string rep
+    string length $ll1
+    set rep1 [tcl::unsupported::representation $ll1]
+    # Get new pure object, not compiled
+    set x [[string cat l range] $ll1 0 end]
+    set rep2 [tcl::unsupported::representation $x]
+    regexp {object pointer at (\S+)} $rep1 -> obj1
+    regexp {object pointer at (\S+)} $rep2 -> obj2
+    list $rep1 $rep2 [string equal $obj1 $obj2]
+    # Check for a new clean object
+} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
+
+test lrange-4.3 {lrange pure promise} -body {
+    set ll1 [list $tcl_version 2 3 4]
+    # With string rep
+    string length $ll1
+    set rep1 [tcl::unsupported::representation $ll1]
+    # Get pure object, unshared
+    set ll2 [lrange $ll1[set ll1 {}] 0 end]
+    set rep2 [tcl::unsupported::representation $ll2]
+    regexp {object pointer at (\S+)} $rep1 -> obj1
+    regexp {object pointer at (\S+)} $rep2 -> obj2
+    list $rep1 $rep2 [string equal $obj1 $obj2]
+    # Internal optimisations should keep the same object
+} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
+
+test lrange-4.4 {lrange pure promise} -body {
+    set ll1 [list $tcl_version 2 3 4]
+    # With string rep
+    string length $ll1
+    set rep1 [tcl::unsupported::representation $ll1]
+    # Get pure object, unshared, not compiled
+    set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end]
+    set rep2 [tcl::unsupported::representation $ll2]
+    regexp {object pointer at (\S+)} $rep1 -> obj1
+    regexp {object pointer at (\S+)} $rep2 -> obj2
+    list $rep1 $rep2 [string equal $obj1 $obj2]
+    # Internal optimisations should keep the same object
+} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
+
+# Testing for compiled vs non-compiled behaviour, and shared vs non-shared.
+# Far too many variations to check with spelt-out tests.
+# Note that this *just* checks whether the different versions are the same
+# not whether any of them is correct.
+apply {{} {
+    set lss     {{} {a} {a b c} {a b c d}}
+    set idxs    {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
+    set lrange  lrange
+
+    foreach ls $lss {
+	foreach a $idxs {
+	    foreach b $idxs {
+                # Shared, uncompiled
+                set ls2 $ls
+                set expected [list [catch {$lrange $ls $a $b} m] $m]
+                # Shared, compiled
+                set tester [list lrange $ls $a $b]
+                set script [list catch $tester m]
+                set script "list \[$script\] \$m"
+                test lrange-5.[incr n].1 {lrange shared compiled} \
+			[list apply [list {} $script]] $expected
+                # Unshared, uncompiled
+                set tester [string map [list %l [list $ls] %a $a %b $b] {
+                    [string cat l range] [lrange %l 0 end] %a %b
+                }]
+                set script [list catch $tester m]
+                set script "list \[$script\] \$m"
+                test lrange-5.$n.2 {lrange unshared uncompiled} \
+			[list apply [list {} $script]] $expected
+                # Unshared, compiled
+                set tester [string map [list %l [list $ls] %a $a %b $b] {
+                    lrange [lrange %l 0 end] %a %b
+                }]
+                set script [list catch $tester m]
+                set script "list \[$script\] \$m"
+                test lrange-5.$n.3 {lrange unshared compiled} \
+			[list apply [list {} $script]] $expected
+	    }
+	}
+    }
+}}
 
 # cleanup
 ::tcltest::cleanupTests