Implement TIP 367

7 files changed, 245 insertions, 5 deletions

diff --git a/doc/lrange.n b/doc/lrange.n
index ba068f6..a4fd98b 100644
--- a/doc/lrange.n
+++ b/doc/lrange.n
@@ -72,7 +72,7 @@ elements to
 .CE
 .SH "SEE ALSO"
 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
-lset(n), lreplace(n), lsort(n),
+lset(n), lremove(n), lreplace(n), lsort(n),
 string(n)
 .SH KEYWORDS
 element, list, range, sublist
diff --git a/doc/lremove.n b/doc/lremove.n
new file mode 100644
index 0000000..b947863
--- /dev/null
+++ b/doc/lremove.n
@@ -0,0 +1,55 @@
+'\"
+'\" Copyright (c) 2019 Donal K. Fellows.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH lremove n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+lremove \- Remove elements from a list by index
+.SH SYNOPSIS
+\fBlremove \fIlist\fR ?\fIindex ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+\fBlremove\fR returns a new list formed by simultaneously removing zero or
+more elements of \fIlist\fR at each of the indices given by an arbirary number
+of \fIindex\fR arguments. The indices may be in any order and may be repeated;
+the element at index will only be removed once.  The index values are
+interpreted the same as index values for the command \fBstring index\fR,
+supporting simple index arithmetic and indices relative to the end of the
+list.  0 refers to the first element of the list, and \fBend\fR refers to the
+last element of the list.
+.SH EXAMPLES
+.PP
+Removing the third element of a list:
+.PP
+.CS
+% \fBlremove\fR {a b c d e} 2
+a b d e
+.CE
+.PP
+Removing two elements from a list:
+.PP
+.CS
+% \fBlremove\fR {a b c d e} end-1 1
+a c e
+.CE
+.PP
+Removing the same element indicated in two different ways:
+.PP
+.CS
+% \fBlremove\fR {a b c d e} 2 end-2
+a b d e
+.CE
+.SH "SEE ALSO"
+list(n), lrange(n), lsearch(n), lsearch(n)
+.SH KEYWORDS
+element, list, remove
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/lreplace.n b/doc/lreplace.n
index 32b7356..68cddfe 100644
--- a/doc/lreplace.n
+++ b/doc/lreplace.n
@@ -96,7 +96,7 @@ a b c d e f g h i
 .VE TIP505
 .SH "SEE ALSO"
 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
-lset(n), lrange(n), lsort(n),
+lset(n), lrange(n), lremove(n), lsort(n),
 string(n)
 .SH KEYWORDS
 element, list, replace
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1806557..e377951 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -262,6 +262,7 @@ static const CmdInfo builtInCmds[] = {
     {"lmap",		Tcl_LmapObjCmd,		TclCompileLmapCmd,	TclNRLmapCmd,	CMD_IS_SAFE},
     {"lpop",		Tcl_LpopObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
     {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	CMD_IS_SAFE},
+    {"lremove", 	Tcl_LremoveObjCmd,	NULL,           	NULL,	CMD_IS_SAFE},
     {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
     {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	CMD_IS_SAFE},
     {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index a1a7f3e..441090c 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2704,6 +2704,142 @@ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+typedef int list_index_t;
+
+static int
+LremoveIndexCompare(
+    const void *el1Ptr,
+    const void *el2Ptr)
+{
+    list_index_t idx1 = *((const list_index_t *) el1Ptr);
+    list_index_t idx2 = *((const list_index_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;
+    list_index_t listLen, *idxv, prevIdx, first, num;
+    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 = ckalloc((objc - 2) * sizeof(list_index_t));
+    for (i = 2; i < objc; i++) {
+	if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
+		&idxv[i - 2]) != TCL_OK) {
+	    ckfree(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(list_index_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++) {
+	list_index_t 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);
+    }
+    ckfree(idxv);
+    Tcl_SetObjResult(interp, listObj);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_LrepeatObjCmd --
  *
  *	This procedure is invoked to process the "lrepeat" Tcl command. See
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 89d7ff9..4b8d1ec 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3471,6 +3471,9 @@ MODULE_SCOPE int	Tcl_LpopObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_LrangeObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LremoveObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_LrepeatObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index e4931a4..215796f 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -19,7 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
 # Used for constraining memory leak tests
 testConstraint memory [llength [info commands memory]]
 testConstraint testobj [llength [info commands testobj]]
-
+
 test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
     lsort
 } -result {wrong # args: should be "lsort ?-option value ...? list"}
@@ -774,6 +774,52 @@ test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup {
     rename K {}
 } -result 1
 
+test cmdIL-8.1 {lremove command: error path} -returnCodes error -body {
+    lremove
+} -result {wrong # args: should be "lremove list ?index ...?"}
+test cmdIL-8.2 {lremove command: error path} -returnCodes error -body {
+    lremove {{}{}}
+} -result {list element in braces followed by "{}" instead of space}
+test cmdIL-8.3 {lremove command: error path} -returnCodes error -body {
+    lremove {a b c} gorp
+} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}
+test cmdIL-8.4 {lremove command: no indices} -body {
+    lremove {a b c}
+} -result {a b c}
+test cmdIL-8.5 {lremove command: before start} -body {
+    lremove {a b c} -1
+} -result {a b c}
+test cmdIL-8.6 {lremove command: after end} -body {
+    lremove {a b c} 3
+} -result {a b c}
+test cmdIL-8.7 {lremove command} -body {
+    lremove {a b c} 0
+} -result {b c}
+test cmdIL-8.8 {lremove command} -body {
+    lremove {a b c} 1
+} -result {a c}
+test cmdIL-8.9 {lremove command} -body {
+    lremove {a b c} end
+} -result {a b}
+test cmdIL-8.10 {lremove command} -body {
+    lremove {a b c} end-1
+} -result {a c}
+test cmdIL-8.11 {lremove command} -body {
+    lremove {a b c d e} 1 3
+} -result {a c e}
+test cmdIL-8.12 {lremove command} -body {
+    lremove {a b c d e} 3 1
+} -result {a c e}
+test cmdIL-8.13 {lremove command: same index twice} -body {
+    lremove {a b c d e} 2 2
+} -result {a b d e}
+test cmdIL-8.14 {lremove command: same index twice} -body {
+    lremove {a b c d e} 3 end-1
+} -result {a b c e}
+test cmdIL-8.15 {lremove command: many indices} -body {
+    lremove {a b c d e} 1 3 1 4 0
+} -result {c}
+
 # This belongs in info test, but adding tests there breaks tests
 # that compute source file line numbers.
 test info-20.6 {Bug 3587651} -setup {
@@ -782,8 +828,7 @@ test info-20.6 {Bug 3587651} -setup {
     }}}} -body {    namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
     namespace delete my
 } -result 1
-
-
+
 # cleanup
 ::tcltest::cleanupTests
 return