summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-01-18 16:19:03 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-01-18 16:19:03 (GMT)
commit4d5446b2dadf9bbe0dfc6c385e6c235a529251c5 (patch)
treefa948ad9dd4df78fe41cf6e4a405ece09de5eabe
parent2dbb65a3ede972c2fa6b8527eb2ce3a0ca0bfddc (diff)
downloadtcl-4d5446b2dadf9bbe0dfc6c385e6c235a529251c5.zip
tcl-4d5446b2dadf9bbe0dfc6c385e6c235a529251c5.tar.gz
tcl-4d5446b2dadf9bbe0dfc6c385e6c235a529251c5.tar.bz2
Full bytecode compilation for [lassign]
-rw-r--r--ChangeLog16
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCompCmds.c122
-rw-r--r--generic/tclCompile.c19
-rw-r--r--generic/tclCompile.h24
-rw-r--r--generic/tclExecute.c121
-rw-r--r--generic/tclInt.h4
-rw-r--r--tests/cmdIL.test311
8 files changed, 559 insertions, 62 deletions
diff --git a/ChangeLog b/ChangeLog
index 850c649..9c2e53b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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: