diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 122 | ||||
| -rw-r--r-- | generic/tclCompile.c | 19 | ||||
| -rw-r--r-- | generic/tclCompile.h | 24 | ||||
| -rw-r--r-- | generic/tclExecute.c | 121 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | tests/cmdIL.test | 311 |
8 files changed, 559 insertions, 62 deletions
@@ -1,3 +1,17 @@ +2004-01-18 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/tclCompile.c, generic/tclCompile.h: Two new opcodes, + INST_LIST_INDEX_IMM and INST_LIST_RANGE_IMM, that have operand(s) + of new type OPERAND_IDX4 which represents indexes into things like + lists (and perhaps other things eventually.) + * generic/tclExecute.c (TclExecuteByteCode): Implementation of the + new opcodes. INST_LIST_INDEX_IMM does a simple [lindex] with + either front- or end-based simple indexing. INST_LIST_RANGE_IMM + does an [lrange] with front- or end-based simple indexing for both + the reference to the first and last items in the range. + * generic/tclCompCmds.c (TclCompileLassignCmd): Generate bytecode + for the [lassign] command. + 2004-01-17 David Gravereaux <davygrvy@pobox.com> * win/tclWinInit.c: added #pragma comment(lib, "advapi32.lib") @@ -9,8 +23,6 @@ * generic/tclCmdIL.c (Tcl_LassignObjCmd): Add more shimmering protection for when the list is also one of the variables. -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. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 09fe3e6..2334d53 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.95 2004/01/17 00:28:08 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.96 2004/01/18 16:19:04 dkf Exp $ */ #include "tclInt.h" @@ -115,7 +115,7 @@ static CmdInfo builtInCmds[] = { {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, {"lassign", (Tcl_CmdProc *) NULL, Tcl_LassignObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLassignCmd, 1}, {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, TclCompileLindexCmd, 1}, {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index d5cceb4..9ec265c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.53 2004/01/13 23:15:02 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.54 2004/01/18 16:19:04 dkf Exp $ */ #include "tclInt.h" @@ -1743,6 +1743,126 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) /* *---------------------------------------------------------------------- * + * TclCompileLassignCmd -- + * + * Procedure called to compile the "lassign" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * Side effects: + * Instructions are added to envPtr to execute the "lassign" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLassignCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int simpleVarName, isScalar, localIndex, numWords, code, idx; + + numWords = parsePtr->numWords; + /* + * Check for command syntax error, but we'll punt that to runtime + */ + if (numWords < 3) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Generate code to push list being taken apart by [lassign]. + */ + tokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + + /* + * Generate code to assign values from the list to variables + */ + for (idx=0 ; idx<numWords-2 ; idx++) { + tokenPtr += tokenPtr->numComponents + 1; + + /* + * Generate the next variable name + */ + code = TclPushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar); + if (code != TCL_OK) { + return code; + } + + /* + * Emit instructions to get the idx'th item out of the list + * value on the stack and assign it to the variable. + */ + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + TclEmitOpcode(INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); + } + } else { + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); + } + } + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_STK, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + + /* + * Generate code to leave the rest of the list on the stack. + */ + TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4(-2, envPtr); /* -2 == "end" */ + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3f76988..ceda90b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.56 2004/01/13 23:15:02 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.57 2004/01/18 16:19:04 dkf Exp $ */ #include "tclInt.h" @@ -269,7 +269,7 @@ InstructionDesc tclInstructionTable[] = { * stacked objs: stktop is old value, next is new element value, next * come (operand-2) indices; pushes the new value. */ - {"return", 1, -2, 2, {OPERAND_INT4, OPERAND_UINT4}}, + {"return", 9, -2, 2, {OPERAND_INT4, OPERAND_UINT4}}, /* Compiled [return], code, level are operands; options and result * are on the stack. */ {"expon", 1, -1, 0, {OPERAND_NONE}}, @@ -278,6 +278,10 @@ InstructionDesc tclInstructionTable[] = { /* Test that top of stack is a valid list; error if not */ {"invokeExp", INT_MIN, INT_MIN, 2, {OPERAND_UINT4, OPERAND_ULIST1}}, /* Invoke with expansion: <objc,objv> = expanded <op1,top op1> */ + {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, + /* List Index: push (lindex stktop op4) */ + {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, + /* List Range: push (lrange stktop op4 op4) */ {0} }; @@ -3392,6 +3396,17 @@ TclPrintInstruction(codePtr, pc) fprintf(stdout, "0}"); break; + case OPERAND_IDX4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opnd >= -1) { + fprintf(stdout, "%d ", opnd); + } else if (opnd == -2) { + fprintf(stdout, "end "); + } else { + fprintf(stdout, "end-%d ", -2-opnd); + } + break; + case OPERAND_NONE: default: break; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 99d719d..df0fe32 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.40 2004/01/13 23:15:03 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.41 2004/01/18 16:19:04 dkf Exp $ */ #ifndef _TCLCOMPILATION @@ -522,15 +522,29 @@ typedef struct ByteCode { #define INST_LSET_LIST 96 #define INST_LSET_FLAT 97 +/* TIP#90 - 'return' command. */ + #define INST_RETURN 98 -#define INST_EXPON 99 /* TIP#123 - exponentiation */ +/* TIP#123 - exponentiation operator. */ + +#define INST_EXPON 99 + +/* TIP #157 - {expand}... language syntax support. */ #define INST_LIST_VERIFY 100 #define INST_INVOKE_EXP 101 +/* + * TIP #57 - 'lassign' command. Code generation requires immediate + * LINDEX and LRANGE operators. + */ + +#define INST_LIST_INDEX_IMM 102 +#define INST_LIST_RANGE_IMM 103 + /* The last opcode */ -#define LAST_INST_OPCODE 101 +#define LAST_INST_OPCODE 103 /* * Table describing the Tcl bytecode instructions: their name (for @@ -549,7 +563,9 @@ typedef enum InstOperandType { OPERAND_INT4, /* Four byte signed integer. */ OPERAND_UINT1, /* One byte unsigned integer. */ OPERAND_UINT4, /* Four byte unsigned integer. */ - OPERAND_ULIST1 /* List of one byte unsigned integers. */ + OPERAND_ULIST1, /* List of one byte unsigned integers. */ + OPERAND_IDX4 /* Four byte signed index (actually an + * integer, but displayed differently.) */ } InstOperandType; typedef struct InstructionDesc { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 84e5aee..2a313d2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.120 2004/01/13 23:15:03 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.121 2004/01/18 16:19:05 dkf Exp $ */ #include "tclInt.h" @@ -2492,6 +2492,49 @@ TclExecuteByteCode(interp, codePtr) O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ + case INST_LIST_INDEX_IMM: + { + /*** lindex with objc==3 and index in bytecode stream ***/ + + int listc, idx; + Tcl_Obj **listv; + + /* + * Pop the list and get the index + */ + valuePtr = *tosPtr; + opnd = TclGetInt4AtPtr(pc+1); + + /* + * Get the contents of the list, making sure that it + * really is a list in the process. + */ + result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + + /* + * Select the list item based on the index. Negative + * operand == end-based indexing. + */ + if (opnd < -1) { + idx = opnd+1 + listc; + } else { + idx = opnd; + } + if (idx >= 0 && idx < listc) { + objResultPtr = listv[idx]; + } else { + TclNewObj(objResultPtr); + } + + TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr); + NEXT_INST_F(5, 1, 1); + } + case INST_LIST_INDEX_MULTI: { /* @@ -2612,6 +2655,82 @@ TclExecuteByteCode(interp, codePtr) TRACE(("=> %s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); + case INST_LIST_RANGE_IMM: + { + /*** lrange with objc==4 and both indices in bytecode stream ***/ + + int listc, fromIdx, toIdx; + Tcl_Obj **listv; + + /* + * Pop the list and get the indices + */ + valuePtr = *tosPtr; + fromIdx = TclGetInt4AtPtr(pc+1); + toIdx = TclGetInt4AtPtr(pc+5); + + /* + * Get the contents of the list, making sure that it + * really is a list in the process. + */ + result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), + fromIdx, toIdx), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + + /* + * Skip a lot of work if we're about to throw the result away + * (common with uses of [lassign].) + */ +#ifndef TCL_COMPILE_DEBUG + if (*(pc+9) == INST_POP) { + NEXT_INST_F(10, 1, 0); + } +#endif + + /* + * Adjust the indices for end-based handling. + */ + if (fromIdx < -1) { + fromIdx += 1+listc; + if (fromIdx < -1) { + fromIdx = -1; + } + } else if (fromIdx > listc) { + fromIdx = listc; + } + if (toIdx < -1) { + toIdx += 1+listc; + if (toIdx < -1) { + toIdx = -1; + } + } else if (toIdx > listc) { + toIdx = listc; + } + + /* + * Check if we are referring to a valid, non-empty list range, + * and if so, build the list of elements in that range. + */ + if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) { + if (fromIdx<0) { + fromIdx = 0; + } + if (toIdx >= listc) { + toIdx = listc-1; + } + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx); + } else { + TclNewObj(objResultPtr); + } + + TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), + TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); + NEXT_INST_F(9, 1, 1); + } + /* * End of INST_LIST and related instructions. * --------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index 3c4b7b7..8ab9900 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.141 2004/01/17 00:28:08 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.142 2004/01/18 16:19:06 dkf Exp $ */ #ifndef _TCLINT @@ -2040,6 +2040,8 @@ EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLassignCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileListCmd _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/tests/cmdIL.test b/tests/cmdIL.test index c7a8b65..e9b1432 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -8,7 +8,7 @@ # 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.21 2004/01/17 00:52:18 dkf Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.22 2004/01/18 16:19:06 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -420,59 +420,111 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { rename test_lsort "" } +# Compiled version test cmdIL-6.1 {lassign command syntax} -body { - lassign -} -returnCodes 1 -result {wrong # args: should be "lassign list varname ?varname ...?"} + proc testLassign {} { + lassign + } + testLassign +} -returnCodes 1 -cleanup { + rename testLassign {} +} -result {wrong # args: should be "lassign list varname ?varname ...?"} test cmdIL-6.2 {lassign command syntax} -body { - lassign x -} -returnCodes 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} + proc testLassign {} { + lassign x + } + testLassign +} -returnCodes 1 -cleanup { + rename testLassign {} +} -result {wrong # args: should be "lassign list varname ?varname ...?"} +test cmdIL-6.3 {lassign command} -body { + proc testLassign {} { + set x FAIL + list [lassign a x] $x + } + testLassign +} -result {{} a} -cleanup { + rename testLassign {} +} +test cmdIL-6.4 {lassign command} -body { + proc testLassign {} { + set x FAIL + set y FAIL + list [lassign a x y] $x $y + } + testLassign +} -result {{} a {}} -cleanup { + rename testLassign {} +} +test cmdIL-6.5 {lassign command} -body { + proc testLassign {} { + set x FAIL + set y FAIL + list [lassign {a b} x y] $x $y + } + testLassign +} -result {{} a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.6 {lassign command} -body { + proc testLassign {} { + set x FAIL + set y FAIL + list [lassign {a b c} x y] $x $y + } + testLassign +} -result {c a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.7 {lassign command} -body { + proc testLassign {} { + set x FAIL + set y FAIL + list [lassign {a b c d} x y] $x $y + } + testLassign +} -result {{c d} a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.8 {lassign command - list format error} -body { + proc testLassign {} { + set x FAIL + set y FAIL + list [catch {lassign {a {b}c d} x y} msg] $msg $x $y + } + testLassign +} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} -cleanup { + rename testLassign {} +} +test cmdIL-6.9 {lassign command - assignment to arrays} -body { + proc testLassign {} { + list [lassign {a b} x(x)] $x(x) + } + testLassign +} -result {b a} -cleanup { + rename testLassign {} +} test cmdIL-6.10 {lassign command - variable update error} -body { - set x(x) {} - lassign a x + proc testLassign {} { + set x(x) {} + lassign a x + } + testLassign } -returnCodes 1 -result {can't set "x": variable is array} -cleanup { - unset x + rename testLassign {} } 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 + proc testLassign {} { + set x(x) {} + set y FAIL + list [catch {lassign a y x} msg] $msg $y + } + testLassign } -result {1 {can't set "x": variable is array} a} -cleanup { - unset x + rename testLassign {} } test cmdIL-6.12 {lassign command - memory leak testing} -setup { + unset -nocomplain x y set x(x) {} set y FAIL proc getbytes {} { @@ -498,11 +550,172 @@ test cmdIL-6.12 {lassign command - memory leak testing} -setup { rename getbytes {} rename stress {} } -test cmdIL-6.13 {lassign command - shimmering protection} { - set x {a b c} - list [lassign $x $x y] $x [set $x] $y -} {c {a b c} a b} +# Force non-compiled version +test cmdIL-6.13 {lassign command syntax} -body { + proc testLassign {} { + set lassign lassign + $lassign + } + testLassign +} -returnCodes 1 -cleanup { + rename testLassign {} +} -result {wrong # args: should be "lassign list varname ?varname ...?"} +test cmdIL-6.14 {lassign command syntax} -body { + proc testLassign {} { + set lassign lassign + $lassign x + } + testLassign +} -returnCodes 1 -cleanup { + rename testLassign {} +} -result {wrong # args: should be "lassign list varname ?varname ...?"} +test cmdIL-6.15 {lassign command} -body { + proc testLassign {} { + set lassign lassign + set x FAIL + list [$lassign a x] $x + } + testLassign +} -result {{} a} -cleanup { + rename testLassign {} +} +test cmdIL-6.16 {lassign command} -body { + proc testLassign {} { + set lassign lassign + set x FAIL + set y FAIL + list [$lassign a x y] $x $y + } + testLassign +} -result {{} a {}} -cleanup { + rename testLassign {} +} +test cmdIL-6.17 {lassign command} -body { + proc testLassign {} { + set lassign lassign + set x FAIL + set y FAIL + list [$lassign {a b} x y] $x $y + } + testLassign +} -result {{} a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.18 {lassign command} -body { + proc testLassign {} { + set lassign lassign + set x FAIL + set y FAIL + list [$lassign {a b c} x y] $x $y + } + testLassign +} -result {c a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.19 {lassign command} -body { + proc testLassign {} { + set lassign lassign + set x FAIL + set y FAIL + list [$lassign {a b c d} x y] $x $y + } + testLassign +} -result {{c d} a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.20 {lassign command - list format error} -body { + proc testLassign {} { + set lassign lassign + set x FAIL + set y FAIL + list [catch {$lassign {a {b}c d} x y} msg] $msg $x $y + } + testLassign +} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} -cleanup { + rename testLassign {} +} +test cmdIL-6.21 {lassign command - assignment to arrays} -body { + proc testLassign {} { + set lassign lassign + list [$lassign {a b} x(x)] $x(x) + } + testLassign +} -result {b a} -cleanup { + rename testLassign {} +} +test cmdIL-6.22 {lassign command - variable update error} -body { + proc testLassign {} { + set lassign lassign + set x(x) {} + $lassign a x + } + testLassign +} -returnCodes 1 -result {can't set "x": variable is array} -cleanup { + rename testLassign {} +} +test cmdIL-6.23 {lassign command - variable update error} -body { + proc testLassign {} { + set lassign lassign + set x(x) {} + set y FAIL + list [catch {$lassign a y x} msg] $msg $y + } + testLassign +} -result {1 {can't set "x": variable is array} a} -cleanup { + rename testLassign {} +} +test cmdIL-6.24 {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 + set lassign lassign + $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 {} +} +# Assorted shimmering problems +test cmdIL-6.25 {lassign command - shimmering protection} -body { + proc testLassign {} { + set x {a b c} + list [lassign $x $x y] $x [set $x] $y + } + testLassign +} -result {c {a b c} a b} -cleanup { + rename testLassign {} +} +test cmdIL-6.26 {lassign command - shimmering protection} -body { + proc testLassign {} { + set x {a b c} + set lassign lassign + list [$lassign $x $x y] $x [set $x] $y + } + testLassign +} -result {c {a b c} a b} -cleanup { + rename testLassign {} +} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: |