From d78f576dc5981f706b44ef783bdc285e992db779 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 30 Mar 2019 10:36:58 +0000
Subject: Implementation of [lremove].

---
 generic/tclBasic.c |   1 +
 generic/tclCmdIL.c | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h   |   3 ++
 3 files changed, 118 insertions(+)

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..0e36455 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2704,6 +2704,120 @@ 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;
+    Tcl_Obj *listObj;
+
+    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. It would
+     * be more efficient to do range coalescing; contributions accepted!
+     */
+
+    if (Tcl_IsShared(listObj)) {
+	listObj = TclListObjCopy(NULL, listObj);
+    }
+    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;
+	}
+
+	/*
+	 * 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, idx, 1, 0, NULL);
+	listLen--;
+    }
+    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 9fc778b..6a3eafe 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[]);
-- 
cgit v0.12