Full bytecode compilation for [lassign]

6 files changed, 283 insertions, 11 deletions

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,