Full bytecode compilation for [lassign]

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: