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

3 files changed, 103 insertions, 3 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d601396..09fe3e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.94 2003/12/24 04:18:18 davygrvy Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.95 2004/01/17 00:28:08 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -114,6 +114,8 @@ static CmdInfo builtInCmds[] = {
         (CompileProc *) NULL,		1},
     {"lappend",		(Tcl_CmdProc *) NULL,	Tcl_LappendObjCmd,
         TclCompileLappendCmd,		1},
+    {"lassign",		(Tcl_CmdProc *) NULL,	Tcl_LassignObjCmd,
+        (CompileProc *) NULL,		1},
     {"lindex",		(Tcl_CmdProc *) NULL,	Tcl_LindexObjCmd,
         TclCompileLindexCmd,		1},
     {"linsert",		(Tcl_CmdProc *) NULL,	Tcl_LinsertObjCmd,
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
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6423e4f..3c4b7b7 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.140 2004/01/13 23:15:03 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.141 2004/01/17 00:28:08 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -1910,6 +1910,8 @@ EXTERN int	Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int	Tcl_LassignObjCmd _ANSI_ARGS_((ClientData clientData,
+		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData,