diff options
Diffstat (limited to 'generic/tclCompCmds.c')
| -rw-r--r-- | generic/tclCompCmds.c | 355 |
1 files changed, 287 insertions, 68 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 02cf81c..ba85435 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -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: tclCompCmds.c,v 1.127 2007/11/14 23:05:01 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.128 2007/11/16 14:11:52 dkf Exp $ */ #include "tclInt.h" @@ -224,6 +224,8 @@ TclCompileAppendCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr, *valueTokenPtr; @@ -238,7 +240,7 @@ TclCompileAppendCmd( * append varName == set varName */ - return TclCompileSetCmd(interp, parsePtr, envPtr); + return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); } else if (numWords > 3) { /* * APPEND instructions currently only handle one value. @@ -324,6 +326,8 @@ TclCompileBreakCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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) { @@ -361,6 +365,8 @@ TclCompileCatchCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { JumpFixup jumpFixup; @@ -559,6 +565,8 @@ TclCompileContinueCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { /* @@ -600,6 +608,8 @@ TclCompileDictCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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; @@ -1178,6 +1188,8 @@ TclCompileExprCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *firstWordPtr; @@ -1221,6 +1233,8 @@ TclCompileForCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; @@ -1385,6 +1399,8 @@ TclCompileForeachCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { Proc *procPtr = envPtr->procPtr; @@ -1847,6 +1863,8 @@ TclCompileIfCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { JumpFixupArray jumpFalseFixupArray; @@ -2162,6 +2180,8 @@ TclCompileIncrCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr, *incrTokenPtr; @@ -2279,6 +2299,8 @@ TclCompileLappendCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr; @@ -2386,6 +2408,8 @@ TclCompileLassignCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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; @@ -2499,6 +2523,8 @@ TclCompileLindexCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *idxTokenPtr, *valTokenPtr; @@ -2594,6 +2620,8 @@ TclCompileListCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { DefineLineInformation; /* TIP #280 */ @@ -2656,6 +2684,8 @@ TclCompileLlengthCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr; @@ -2716,6 +2746,8 @@ TclCompileLsetCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { int tempDepth; /* Depth used for emitting one part of the @@ -2872,6 +2904,8 @@ TclCompileRegexpCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the @@ -3025,6 +3059,8 @@ TclCompileReturnCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { /* @@ -3216,6 +3252,8 @@ TclCompileSetCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr, *valueTokenPtr; @@ -3315,6 +3353,8 @@ TclCompileStringCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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. */ { DefineLineInformation; /* TIP #280 */ @@ -3534,6 +3574,8 @@ TclCompileSwitchCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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; /* Pointer to tokens in command. */ @@ -4367,6 +4409,8 @@ TclCompileWhileCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *testTokenPtr, *bodyTokenPtr; @@ -5001,6 +5045,8 @@ int TclCompileInvertOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr); @@ -5010,6 +5056,8 @@ int TclCompileNotOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr); @@ -5019,6 +5067,8 @@ int TclCompileAddOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD, @@ -5029,6 +5079,8 @@ int TclCompileMulOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT, @@ -5039,6 +5091,8 @@ int TclCompileAndOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND, @@ -5049,6 +5103,8 @@ int TclCompileOrOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR, @@ -5059,6 +5115,8 @@ int TclCompileXorOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR, @@ -5069,6 +5127,8 @@ int TclCompilePowOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { /* @@ -5097,6 +5157,8 @@ int TclCompileLshiftOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr); @@ -5106,6 +5168,8 @@ int TclCompileRshiftOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr); @@ -5115,6 +5179,8 @@ int TclCompileModOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr); @@ -5124,6 +5190,8 @@ int TclCompileNeqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr); @@ -5133,6 +5201,8 @@ int TclCompileStrneqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr); @@ -5142,6 +5212,8 @@ int TclCompileInOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr); @@ -5151,6 +5223,8 @@ int TclCompileNiOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN, @@ -5161,6 +5235,8 @@ int TclCompileLessOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr); @@ -5170,6 +5246,8 @@ int TclCompileLeqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr); @@ -5179,6 +5257,8 @@ int TclCompileGreaterOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr); @@ -5188,6 +5268,8 @@ int TclCompileGeqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr); @@ -5197,6 +5279,8 @@ int TclCompileEqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr); @@ -5206,6 +5290,8 @@ int TclCompileStreqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr); @@ -5215,6 +5301,8 @@ int TclCompileMinusOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { Tcl_Token *tokenPtr = parsePtr->tokenPtr; @@ -5253,6 +5341,8 @@ int TclCompileDivOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) { Tcl_Token *tokenPtr = parsePtr->tokenPtr; @@ -5308,7 +5398,7 @@ TclCompileDivOpCmd( static int IndexTailVarIfKnown( Tcl_Interp *interp, - Tcl_Token *varTokenPtr, /* Token representing the variable name */ + Tcl_Token *varTokenPtr, /* Token representing the variable name */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Obj *tailPtr; @@ -5406,6 +5496,8 @@ TclCompileUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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, *otherTokenPtr, *localTokenPtr; @@ -5515,6 +5607,8 @@ TclCompileNamespaceCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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, *otherTokenPtr, *localTokenPtr; @@ -5605,6 +5699,8 @@ TclCompileGlobalCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr; @@ -5678,6 +5774,8 @@ TclCompileVariableCmd( Tcl_Interp *interp, /* Used for error reporting. */ 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 *varTokenPtr, *valueTokenPtr; @@ -5737,109 +5835,230 @@ TclCompileVariableCmd( /* *---------------------------------------------------------------------- * - * TclCompileInfoCmd -- + * TclCompileEnsemble -- * - * Procedure called to compile the "info" command. Only handles the - * "exists" subcommand. + * Procedure called to compile an ensemble command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "info exists" - * subcommand at runtime. + * Instructions are added to envPtr to execute the subcommands of the + * ensemble at runtime if a compile-time mapping is possible. * *---------------------------------------------------------------------- */ int -TclCompileInfoCmd( +TclCompileEnsemble( Tcl_Interp *interp, /* Used for error reporting. */ 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; - int isScalar, simpleVarName, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *argTokensPtr; + Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; + Tcl_Command ensemble = (Tcl_Command) cmdPtr; + Tcl_Parse synthetic; + int len, numBytes, result; + const char *word; + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard. + */ - numWords = parsePtr->numWords; - if (numWords != 3) { return TCL_ERROR; } + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + /* - * Ensure that the next word is "exists"; that's the only case we will - * deal with. + * There's a sporting chance we'll be able to compile this. But now we + * must check properly. To do that, check that we're compiling an + * ensemble that has [info exists] as its appropriate subcommand. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && - tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = tokenPtr[1].start; - int numBytes = tokenPtr[1].size; - Command *cmdPtr; - Tcl_Obj *mapObj, *existsObj, *targetCmdObj; - Tcl_DString ds; - + if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK + || mapObj == NULL) { /* - * There's a sporting chance we'll be able to compile this. But now we - * must check properly. To do that, look up what we expect to be - * called (inefficient, should be in context?) and check that that's - * an ensemble that has [info exists] as its appropriate subcommand. + * Either not an ensemble or a mapping isn't installed. Crud. Too hard + * to proceed. */ - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, parsePtr->tokenPtr[1].start, - parsePtr->tokenPtr[1].size); - cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), - (Tcl_Namespace *) envPtr->iPtr->globalNsPtr, 0); - Tcl_DStringFree(&ds); - if (cmdPtr == NULL || cmdPtr->compileProc != &TclCompileInfoCmd) { - /* - * Not [info], and can't be bothered to follow rabbit hole of - * renaming. This is an optimization, darnit! - */ + return TCL_ERROR; + } - return TCL_ERROR; - } + TclNewStringObj(subcmdObj, word, numBytes); + if (Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj) != TCL_OK + || targetCmdObj == NULL) { + /* + * We've not got a valid subcommand. + */ - if (Tcl_GetEnsembleMappingDict(interp, (Tcl_Command) cmdPtr, - &mapObj) != TCL_OK || mapObj == NULL) { - /* - * Either not an ensemble or a mapping isn't installed. Crud. Too - * hard to proceed. - */ + TclDecrRefCount(subcmdObj); + return TCL_ERROR; + } + TclDecrRefCount(subcmdObj); - return TCL_ERROR; - } + /* + * The command we map to is the first word out of the map element. Note + * that we reject dealing with lists that are multiple elements long here; + * our rewriting-fu is not yet strong enough. + */ - TclNewStringObj(existsObj, word, numBytes); - if (Tcl_DictObjGet(NULL, mapObj, existsObj, &targetCmdObj) != TCL_OK - || targetCmdObj == NULL) { - /* - * We've not got a valid subcommand. - */ + if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK + || len != 1) { + return TCL_ERROR; + } + targetCmdObj = elems[0]; + Tcl_IncrRefCount(targetCmdObj); - TclDecrRefCount(existsObj); - return TCL_ERROR; - } - TclDecrRefCount(existsObj); + /* + * Check to see if there's also a subcommand list; must check to see if + * the subcommand we are calling is in that list if it exists, since that + * list filters the entries in the map. + */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); - if (cmdPtr == NULL || cmdPtr->objProc != &TclInfoExistsCmd) { - /* - * Maps to something unexpected. Help! - */ + (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); + if (listObj != NULL) { + int i, sclen; + char *str; + if (Tcl_ListObjGetElements(NULL, listObj, &len,&elems) != TCL_OK){ + TclDecrRefCount(targetCmdObj); return TCL_ERROR; } + for (i=0 ; i<len ; i++) { + str = Tcl_GetStringFromObj(elems[i], &sclen); + if (sclen == numBytes && + memcmp(word, str, (unsigned) numBytes) == 0) { + goto doneSubcmdListSearch; + } + } + TclDecrRefCount(targetCmdObj); + return TCL_ERROR; + } + + /* + * OK, we definitely map to something. But what? + */ + doneSubcmdListSearch: + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + TclDecrRefCount(targetCmdObj); + if (cmdPtr == NULL || cmdPtr->compileProc == NULL) { /* - * OK, it really is [info exists]! + * Maps to an undefined command or a command without a compiler. + * Cannot compile. */ + + return TCL_ERROR; + } + + /* + * Should check if we mapped to another ensemble here, and go round the + * peek-inside scheme above if so. [TO-DO] + */ + + /* + * Now we've done the mapping process, can now actually try to compile. + * We do this by handing off to the subcommand's actual compiler. But to + * do that, we have to perform some trickery to rewrite the arguments. + */ + + argTokensPtr = TokenAfter(tokenPtr); + memcpy(&synthetic, parsePtr, sizeof(Tcl_Parse)); + synthetic.numWords--; + synthetic.numTokens -= (argTokensPtr - parsePtr->tokenPtr) - 2; + if (synthetic.numTokens <= NUM_STATIC_TOKENS) { + synthetic.tokenPtr = synthetic.staticTokens; + synthetic.tokensAvailable = NUM_STATIC_TOKENS; } else { + synthetic.tokenPtr = (Tcl_Token *) + ckalloc(sizeof(Tcl_Token) * synthetic.numTokens); + synthetic.tokensAvailable = synthetic.numTokens; + } + + /* + * Now we have the space to work in, install something rewritten. + */ + + synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; + synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; + synthetic.tokenPtr[0].size = (tokenPtr->start + tokenPtr->size) + - parsePtr->tokenPtr[0].start; + synthetic.tokenPtr[0].numComponents = 1; + + synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; + synthetic.tokenPtr[1].start = synthetic.tokenPtr[0].start; + synthetic.tokenPtr[1].size = synthetic.tokenPtr[0].size; + synthetic.tokenPtr[1].numComponents = 0; + + /* + * Copy over the real argument tokens. + */ + + memcpy(synthetic.tokenPtr + 2, argTokensPtr, + sizeof(Tcl_Token) * (synthetic.numTokens - 2)); + + /* + * Hand off compilation to the subcommand compiler. At last! + */ + + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + + /* + * Clean up if necessary. + */ + + if (synthetic.tokenPtr != synthetic.staticTokens) { + ckfree((char *) synthetic.tokenPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileInfoExistsCmd -- + * + * Procedure called to compile the "info exists" subcommand. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "info exists" + * subcommand at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInfoExistsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + 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; + int isScalar, simpleVarName, localIndex; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { return TCL_ERROR; } @@ -5851,9 +6070,9 @@ TclCompileInfoCmd( * qualifiers. */ - tokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, - &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[2]); + &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); /* * Emit instruction to check the variable for existence. |