summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-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
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,