diff options
Diffstat (limited to 'generic')
| -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 |
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, |