1 files changed, 141 insertions, 4 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 073ed20..67e871f 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2586,7 +2586,7 @@ Tcl_LpopObjCmd(
 				/* Argument objects. */
 {
     int listLen, result;
-    Tcl_Obj *elemPtr;
+    Tcl_Obj *elemPtr, *stored;
     Tcl_Obj *listPtr, **elemPtrs;
 
     if (objc < 2) {
@@ -2624,6 +2624,7 @@ Tcl_LpopObjCmd(
 
     /*
      * Second, remove the element.
+     * TclLsetFlat adds a ref count which is handled.
      */
 
     if (objc == 2) {
@@ -2634,6 +2635,7 @@ Tcl_LpopObjCmd(
 	if (result != TCL_OK) {
 	    return result;
 	}
+	Tcl_IncrRefCount(listPtr);
     } else {
 	listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
 
@@ -2642,8 +2644,9 @@ Tcl_LpopObjCmd(
 	}
     }
 
-    listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
-    if (listPtr == NULL) {
+    stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+    Tcl_DecrRefCount(listPtr);
+    if (stored == NULL) {
 	return TCL_ERROR;
     }
 
@@ -2707,6 +2710,140 @@ Tcl_LrangeObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * Tcl_LremoveObjCmd --
+ *
+ *	This procedure is invoked to process the "lremove" Tcl command. See the
+ *	user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+LremoveIndexCompare(
+    const void *el1Ptr,
+    const void *el2Ptr)
+{
+    size_t idx1 = *((const size_t *) el1Ptr);
+    size_t idx2 = *((const size_t *) el2Ptr);
+
+    /*
+     * This will put the larger element first.
+     */
+
+    return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
+}
+
+int
+Tcl_LremoveObjCmd(
+    ClientData notUsed,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    int i, idxc, listLen, prevIdx, first, num;
+    size_t *idxv;
+    Tcl_Obj *listObj;
+
+    /*
+     * Parse the arguments.
+     */
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
+	return TCL_ERROR;
+    }
+
+    listObj = objv[1];
+    if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    idxc = objc - 2;
+    if (idxc == 0) {
+	Tcl_SetObjResult(interp, listObj);
+	return TCL_OK;
+    }
+    idxv = Tcl_Alloc((objc - 2) * sizeof(size_t));
+    for (i = 2; i < objc; i++) {
+	if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
+		&idxv[i - 2]) != TCL_OK) {
+	    Tcl_Free(idxv);
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * Sort the indices, large to small so that when we remove an index we
+     * don't change the indices still to be processed.
+     */
+
+    if (idxc > 1) {
+	qsort(idxv, idxc, sizeof(size_t), LremoveIndexCompare);
+    }
+
+    /*
+     * Make our working copy, then do the actual removes piecemeal.
+     */
+
+    if (Tcl_IsShared(listObj)) {
+	listObj = TclListObjCopy(NULL, listObj);
+    }
+    num = 0;
+    first = listLen;
+    for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
+	int idx = idxv[i];
+
+	/*
+	 * Repeated index and sanity check.
+	 */
+
+	if (idx == prevIdx) {
+	    continue;
+	}
+	prevIdx = idx;
+	if (idx < 0 || idx >= listLen) {
+	    continue;
+	}
+
+	/*
+	 * Coalesce adjacent removes to reduce the number of copies.
+	 */
+
+	if (num == 0) {
+	    num = 1;
+	    first = idx;
+	} else if (idx + 1 == first) {
+	    num++;
+	    first = idx;
+	} else {
+	    /*
+	     * Note that this operation can't fail now; we know we have a list
+	     * and we're only ever contracting that list.
+	     */
+
+	    (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+	    listLen -= num;
+	    num = 1;
+	    first = idx;
+	}
+    }
+    if (num != 0) {
+	(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+    }
+    Tcl_Free(idxv);
+    Tcl_SetObjResult(interp, listObj);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_LrepeatObjCmd --
  *
  *	This procedure is invoked to process the "lrepeat" Tcl command. See
@@ -4189,7 +4326,7 @@ Tcl_LsortObjCmd(
 
     elementArray = Tcl_Alloc(length * sizeof(SortElement));
 
-    for (i=0; i < length; i++){
+    for (i=0; i < length; i++) {
 	idx = groupSize * i + groupOffset;
 	if (indexc) {
 	    /*