summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-01-17 00:28:07 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-01-17 00:28:07 (GMT)
commit09472fab726b19e26a46d7b05426356a1ceff8cd (patch)
tree400fb6a62c9934846c003b2748698b373c84358b /generic/tclCmdIL.c
parentadba9fe738d1390234b5d5bbb461df81d094ea7e (diff)
downloadtcl-09472fab726b19e26a46d7b05426356a1ceff8cd.zip
tcl-09472fab726b19e26a46d7b05426356a1ceff8cd.tar.gz
tcl-09472fab726b19e26a46d7b05426356a1ceff8cd.tar.bz2
Basic implementation of TIP#57 - TclX's [lassign] command into Tcl core
Not a direct copy * Better use of Tcl object API * More extensive test suite * More extensive documentation
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c98
1 files changed, 97 insertions, 1 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 0b8de0d..e570d56 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.58 2003/12/24 04:18:18 davygrvy Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.59 2004/01/17 00:28:08 dkf Exp $
*/
#include "tclInt.h"
@@ -2024,6 +2024,102 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * Tcl_LassignObjCmd --
+ *
+ * This object-based procedure is invoked to process the "lassign" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_LassignObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Tcl_Obj *valueObj; /* Value to assign to variable, as read from
+ * the list object or created in the emptyObj
+ * variable. */
+ Tcl_Obj *emptyObj = NULL; /* If non-NULL, an empty object created for
+ * being assigned to variables once we have
+ * run out of values from the list object. */
+ Tcl_Obj **listObjv; /* The contents of the list. */
+ int listObjc; /* The length of the list. */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list varname ?varname ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First assign values out of the list to variables.
+ */
+
+ for (i=0 ; i+2<objc ; i++) {
+ /*
+ * We do this each time round the loop because that is robust
+ * against shimmering nasties.
+ */
+ if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (valueObj == NULL) {
+ if (emptyObj == NULL) {
+ TclNewObj(emptyObj);
+ Tcl_IncrRefCount(emptyObj);
+ }
+ valueObj = emptyObj;
+ }
+ if (Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ if (emptyObj != NULL) {
+ Tcl_DecrRefCount(emptyObj);
+ }
+ return TCL_ERROR;
+ }
+ }
+ if (emptyObj != NULL) {
+ Tcl_DecrRefCount(emptyObj);
+ }
+
+ /*
+ * Now place a list of any values left over into the interpreter
+ * result.
+ *
+ * First, figure out how many values were not assigned by getting
+ * the length of the list. Note that I do not expect this
+ * operation to fail.
+ */
+
+ if (Tcl_ListObjGetElements(interp, objv[1],
+ &listObjc, &listObjv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (listObjc > objc-2) {
+ /*
+ * OK, there were left-overs. Make a list of them and slap
+ * that back in the interpreter result.
+ */
+ Tcl_SetObjResult(interp,
+ Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2));
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LindexObjCmd --
*
* This object-based procedure is invoked to process the "lindex" Tcl