summaryrefslogtreecommitdiffstats
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
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
-rw-r--r--ChangeLog8
-rw-r--r--doc/lassign.n55
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdIL.c98
-rw-r--r--generic/tclInt.h4
-rw-r--r--tests/cmdIL.test84
6 files changed, 249 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index dafe1db..b248a1f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-01-17 Donal K. Fellows <dkf@users.sf.net>
+
+ BASIC IMPLEMENTATION OF TIP#57
+ * generic/tclCmdIL.c (Tcl_LassignObjCmd): Implementation of the
+ [lassign] command that takes full advantage of Tcl's object API.
+ * doc/lassign.n: New file documenting the command.
+ * tests/cmdIL.test (cmdIL-6.*): Test suite for the command.
+
2004-01-15 David Gravereaux <davygrvy@pobox.com>
* win/tclWinReg.c: Placed the requirement for advapi.lib into
diff --git a/doc/lassign.n b/doc/lassign.n
new file mode 100644
index 0000000..f27422d
--- /dev/null
+++ b/doc/lassign.n
@@ -0,0 +1,55 @@
+'\"
+'\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans
+'\" Copyright (c) 2004 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" RCS: @(#) $Id: lassign.n,v 1.1 2004/01/17 00:28:08 dkf Exp $
+'\"
+.so man.macros
+.TH lassign n 8.5 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lassign \- Assign list elements to variables
+.SH SYNOPSIS
+\fBlassign \fIlist varName \fR?\fIvarName ...\fR?
+.BE
+
+.SH DESCRIPTION
+.PP
+This command treats the value \fIlist\fR as a list and assigns
+successive elements from that list to the variables given by the
+\fIvarName\fR arguments in order. If there are more variable names
+than list elements, the remaining variables are set to the empty
+string. If there are more list elements than variables, a list of
+unassigned elements is returned.
+.SH EXAMPLES
+An illustration of how multiple assignment works, and what happens
+when there are either too few or too many elements.
+.CS
+lassign {a b c} x y z ;# Empty return
+puts $x ;# Prints "a"
+puts $y ;# Prints "b"
+puts $z ;# Prints "c"
+
+lassign {d e} x y z ;# Empty return
+puts $x ;# Prints "d"
+puts $y ;# Prints "e"
+puts $z ;# Prints ""
+
+lassign {f g h i} x y ;# Returns "h i"
+puts $x ;# Prints "f"
+puts $y ;# Prints "g"
+.CE
+The \fBlassign\fR command has other uses. It can be used to create
+the analogue of the "shift" command in many shell languages like this:
+.CS
+set ::argv [lassign $::argv argumentToReadOff]
+.CE
+.SH "SEE ALSO"
+lindex(n), list(n), lset(n), set(n)
+
+.SH KEYWORDS
+assign, element, list, multiple, set, variable
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,
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index e008dfd..94dd24f 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -8,13 +8,16 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: cmdIL.test,v 1.18 2003/11/10 18:30:41 dkf Exp $
+# RCS: @(#) $Id: cmdIL.test,v 1.19 2004/01/17 00:28:08 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
@@ -417,6 +420,85 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body {
rename test_lsort ""
}
+test cmdIL-6.1 {lassign command syntax} -body {
+ lassign
+} -code 1 -result {wrong # args: should be "lassign list varname ?varname ...?"}
+test cmdIL-6.2 {lassign command syntax} -body {
+ lassign x
+} -code 1 -result {wrong # args: should be "lassign list varname ?varname ...?"}
+test cmdIL-6.3 {lassign command} {
+ set x FAIL
+ list [lassign a x] $x
+} {{} a}
+test cmdIL-6.4 {lassign command} {
+ set x FAIL
+ set y FAIL
+ list [lassign a x y] $x $y
+} {{} a {}}
+test cmdIL-6.5 {lassign command} {
+ set x FAIL
+ set y FAIL
+ list [lassign {a b} x y] $x $y
+} {{} a b}
+test cmdIL-6.6 {lassign command} {
+ set x FAIL
+ set y FAIL
+ list [lassign {a b c} x y] $x $y
+} {c a b}
+test cmdIL-6.7 {lassign command} {
+ set x FAIL
+ set y FAIL
+ list [lassign {a b c d} x y] $x $y
+} {{c d} a b}
+test cmdIL-6.8 {lassign command - list format error} {
+ set x FAIL
+ set y FAIL
+ list [catch {lassign {a {b}c d} x y} msg] $msg $x $y
+} {1 {list element in braces followed by "c" instead of space} FAIL FAIL}
+catch {unset x y}
+test cmdIL-6.9 {lassign command - assignment to arrays} {
+ list [lassign {a b} x(x)] $x(x)
+} {b a}
+test cmdIL-6.10 {lassign command - variable update error} -body {
+ set x(x) {}
+ lassign a x
+} -code 1 -result {can't set "x": variable is array} -cleanup {
+ unset x
+}
+test cmdIL-6.11 {lassign command - variable update error} -body {
+ set x(x) {}
+ set y FAIL
+ list [catch {lassign a y x} msg] $msg $y
+} -result {1 {can't set "x": variable is array} a} -cleanup {
+ unset x
+}
+test cmdIL-6.12 {lassign command - memory leak testing} -setup {
+ set x(x) {}
+ set y FAIL
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex [lindex $lines 3] 3
+ }
+ proc stress {} {
+ global x y
+ lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y y y y y y
+ catch {lassign {} y y y y y y y y y y y y y y y y y y y y y y y y y x}
+ catch {lassign {} x}
+ }
+} -constraints memory -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ stress
+ set tmp $end
+ set end [getbytes]
+ }
+ expr {$end - $tmp}
+} -result 0 -cleanup {
+ unset -nocomplain x y i tmp end
+ rename getbytes {}
+ rename stress {}
+}
+
# cleanup
::tcltest::cleanupTests
return