diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | doc/lassign.n | 55 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 98 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | tests/cmdIL.test | 84 |
6 files changed, 249 insertions, 4 deletions
@@ -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 |