diff options
Diffstat (limited to 'generic/tclCompCmds.c')
| -rw-r--r-- | generic/tclCompCmds.c | 193 |
1 files changed, 157 insertions, 36 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 041694f..b9bc228 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -54,7 +54,7 @@ static int CompileDictEachCmd(Tcl_Interp *interp, * The structures below define the AuxData types defined in this file. */ -const AuxDataType tclForeachInfoType = { +static const AuxDataType foreachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ @@ -62,7 +62,7 @@ const AuxDataType tclForeachInfoType = { DisassembleForeachInfo /* disassembleProc */ }; -const AuxDataType tclNewForeachInfoType = { +static const AuxDataType newForeachInfoType = { "NewForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ @@ -70,7 +70,7 @@ const AuxDataType tclNewForeachInfoType = { DisassembleNewForeachInfo /* disassembleProc */ }; -const AuxDataType tclDictUpdateInfoType = { +static const AuxDataType dictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ @@ -81,6 +81,39 @@ const AuxDataType tclDictUpdateInfoType = { /* *---------------------------------------------------------------------- * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +const AuxDataType * +TclGetAuxDataType( + const char *typeName) /* Name of AuxData type to look up. */ +{ + if (!strcmp(typeName, foreachInfoType.name)) { + return &foreachInfoType; + } else if (!strcmp(typeName, newForeachInfoType.name)) { + return &newForeachInfoType; + } else if (!strcmp(typeName, dictUpdateInfoType.name)) { + return &dictUpdateInfoType; + } else if (!strcmp(typeName, tclJumptableInfoType.name)) { + return &tclJumptableInfoType; + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. @@ -351,7 +384,7 @@ TclCompileArraySetCmd( TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); TclEmitOpcode(INST_POP, envPtr); } - + /* * Prepare for the internal foreach. */ @@ -365,7 +398,7 @@ TclCompileArraySetCmd( infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); /* * Start issuing instructions to write to the array. @@ -547,7 +580,7 @@ TclCompileCatchCmd( int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ int depth = TclGetStackDepth(envPtr); - + /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. @@ -626,7 +659,7 @@ TclCompileCatchCmd( } ExceptionRangeEnds(envPtr, range); - + /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. @@ -636,14 +669,14 @@ TclCompileCatchCmd( PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* + /* * Emit the "error case" epilogue. Push the interpreter result and the * return code. */ ExceptionRangeTarget(envPtr, range, catchOffset); TclSetStackDepth(depth + dropScript, envPtr); - + if (dropScript) { TclEmitOpcode( INST_POP, envPtr); } @@ -701,6 +734,105 @@ TclCompileCatchCmd( return TCL_OK; } +/*---------------------------------------------------------------------- + * + * TclCompileClockClicksCmd -- + * + * Procedure called to compile the "tcl::clock::clicks" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to run time. + * + * Side effects: + * Instructions are added to envPtr to execute the "clock clicks" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileClockClicksCmd( + Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token* tokenPtr; + + switch (parsePtr->numWords) { + case 1: + /* + * No args + */ + TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr); + break; + case 2: + /* + * -milliseconds or -microseconds + */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD + || tokenPtr[1].size < 4 + || tokenPtr[1].size > 13) { + return TCL_ERROR; + } else if (!strncmp(tokenPtr[1].start, "-microseconds", + tokenPtr[1].size)) { + TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); + break; + } else if (!strncmp(tokenPtr[1].start, "-milliseconds", + tokenPtr[1].size)) { + TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); + break; + } else { + return TCL_ERROR; + } + default: + return TCL_ERROR; + } + return TCL_OK; +} + + +/*---------------------------------------------------------------------- + * + * TclCompileClockReadingCmd -- + * + * Procedure called to compile the "tcl::clock::microseconds", + * "tcl::clock::milliseconds" and "tcl::clock::seconds" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to run time. + * + * Side effects: + * Instructions are added to envPtr to execute the "clock clicks" + * command at runtime. + * + * Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds. + *---------------------------------------------------------------------- + */ + +int +TclCompileClockReadingCmd( + Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr); + + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -768,7 +900,7 @@ TclCompileConcatCmd( Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = Tcl_GetStringFromObj(objPtr, &len); + bytes = TclGetStringFromObj(objPtr, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; @@ -1176,7 +1308,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = Tcl_GetStringFromObj(dictObj, &len); + bytes = TclGetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -1669,7 +1801,7 @@ TclCompileDictUpdateCmd( * can't be snagged by literal sharing and forced to shimmer dangerously. */ - infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); + infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); @@ -2530,7 +2662,7 @@ CompileEachloopCmd( ForeachInfo *infoPtr=NULL; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - + Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; int numWords, numLists, i, j, code = TCL_OK; @@ -2617,7 +2749,7 @@ CompileEachloopCmd( int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + bytes = TclGetStringFromObj(varNameObj, &numBytes); varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; @@ -2632,16 +2764,16 @@ CompileEachloopCmd( * We will compile the foreach command. */ - infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); /* * Create the collecting object, unshared. */ - + if (collect == TCL_EACH_COLLECT) { TclEmitInstInt4(INST_LIST, 0, envPtr); } - + /* * Evaluate each value list and leave it on stack. */ @@ -2655,7 +2787,7 @@ CompileEachloopCmd( } TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); - + /* * Inline compile the loop body. */ @@ -2665,7 +2797,7 @@ CompileEachloopCmd( ExceptionRangeStarts(envPtr, range); BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); - + if (collect == TCL_EACH_COLLECT) { TclEmitOpcode(INST_LMAP_COLLECT, envPtr); } else { @@ -2674,7 +2806,7 @@ CompileEachloopCmd( /* * Bottom of loop code: assign each loop variable and check whether - * to terminate the loop. Set the loop's break target. + * to terminate the loop. Set the loop's break target. */ ExceptionRangeTarget(envPtr, range, continueOffset); @@ -2688,7 +2820,7 @@ CompileEachloopCmd( * Set the jumpback distance from INST_FOREACH_STEP to the start of the * body's code. Misuse loopCtTemp for storing the jump size. */ - + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - envPtr->exceptArrayPtr[range].codeOffset; infoPtr->loopCtTemp = -jumpBackOffset; @@ -2701,7 +2833,7 @@ CompileEachloopCmd( if (collect != TCL_EACH_COLLECT) { PushStringLiteral(envPtr, ""); } - + done: if (code == TCL_ERROR) { FreeForeachInfo(infoPtr); @@ -3054,7 +3186,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3125,7 +3257,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = Tcl_GetStringFromObj(tmpObj, &len); + char *b = TclGetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3159,7 +3291,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; @@ -3173,17 +3305,6 @@ TclCompileFormatCmd( */ TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); - } else { - /* - * EVIL HACK! Force there to be a string representation in the case - * where there's just a "%s" in the format; case covered by the test - * format-20.1 (and it is horrible...) - */ - - TclEmitOpcode(INST_DUP, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_STR_EQ, envPtr); - TclEmitOpcode(INST_POP, envPtr); } return TCL_OK; } |