diff options
| -rw-r--r-- | ChangeLog | 20 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 19 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 148 | ||||
| -rw-r--r-- | generic/tclCompile.c | 27 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclExecute.c | 117 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 26 |
8 files changed, 357 insertions, 16 deletions
@@ -1,8 +1,24 @@ +2007-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/tclCompile.c (TclCompileScript): Ensure that we get our + count in our INST_START_CMD calls right, even when there's a failure + to compile a command directly. + + * generic/tclNamesp.c (Tcl_SetEnsembleSubcommandList) + (Tcl_SetEnsembleMappingDict): Special code to make sure that + * generic/tclCmdIL.c (TclInitInfoCmd): [info exists] is compiled right + while not allowing changes to the ensemble to cause havok. + + * generic/tclCompCmds.c (TclCompileInfoCmd): Simple compiler for the + [info] command that only handles [info exists]. + * generic/tclExecute.c (TclExecuteByteCode:INST_EXIST_*): New + instructions to allow the testing of whether a variable exists. + 2007-11-14 Andreas Kupries <andreask@activestate.com> * tests/chanio.test: New file. This is essentially a duplicate of - 'io.test', with all channel commands converted to their 'chan - xxx' notation. + 'io.test', with all channel commands converted to their 'chan xxx' + notation. * tests/io.test: Fixed typo in test description. 2007-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk> diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index ba6febb..2647a4c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.124 2007/11/11 19:32:14 msofer Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.125 2007/11/14 23:05:01 dkf Exp $ */ #include "tclInt.h" @@ -110,8 +110,6 @@ static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); /* TIP #280 - New 'info' subcommand 'frame' */ static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -161,7 +159,7 @@ static const struct { {"commands", InfoCommandsCmd}, {"complete", InfoCompleteCmd}, {"default", InfoDefaultCmd}, - {"exists", InfoExistsCmd}, + {"exists", TclInfoExistsCmd}, {"frame", InfoFrameCmd}, {"functions", InfoFunctionsCmd}, {"globals", TclInfoGlobalsCmd}, @@ -416,6 +414,13 @@ TclInitInfoCmd( } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); } + + /* + * Enable compilation of the [info exists] subcommand. + */ + + ((Command *)ensemble)->compileProc = &TclCompileInfoCmd; + return ensemble; } @@ -990,7 +995,7 @@ InfoDefaultCmd( /* *---------------------------------------------------------------------- * - * InfoExistsCmd -- + * TclInfoExistsCmd -- * * Called to implement the "info exists" command that determines whether * a variable exists. Handles the following syntax: @@ -1007,8 +1012,8 @@ InfoDefaultCmd( *---------------------------------------------------------------------- */ -static int -InfoExistsCmd( +int +TclInfoExistsCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f16d579..02cf81c 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.126 2007/11/14 00:56:44 hobbs Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.127 2007/11/14 23:05:01 dkf Exp $ */ #include "tclInt.h" @@ -5735,6 +5735,152 @@ TclCompileVariableCmd( } /* + *---------------------------------------------------------------------- + * + * TclCompileInfoCmd -- + * + * Procedure called to compile the "info" command. Only handles the + * "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 +TclCompileInfoCmd( + 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 isScalar, simpleVarName, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords != 3) { + return TCL_ERROR; + } + + /* + * Ensure that the next word is "exists"; that's the only case we will + * deal with. + */ + + 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; + + /* + * 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. + */ + + 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; + } + + 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. + */ + + return TCL_ERROR; + } + + TclNewStringObj(existsObj, word, numBytes); + if (Tcl_DictObjGet(NULL, mapObj, existsObj, &targetCmdObj) != TCL_OK + || targetCmdObj == NULL) { + /* + * We've not got a valid subcommand. + */ + + TclDecrRefCount(existsObj); + return TCL_ERROR; + } + TclDecrRefCount(existsObj); + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + if (cmdPtr == NULL || cmdPtr->objProc != &TclInfoExistsCmd) { + /* + * Maps to something unexpected. Help! + */ + + return TCL_ERROR; + } + + /* + * OK, it really is [info exists]! + */ + } else { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + tokenPtr = TokenAfter(tokenPtr); + PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, + &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[2]); + + /* + * Emit instruction to check the variable for existence. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } else { + TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); + } + } + } else { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } + + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclCompile.c b/generic/tclCompile.c index dce11bf..7cf5918 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.140 2007/11/13 21:42:44 dkf Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.141 2007/11/14 23:05:02 dkf Exp $ */ #include "tclInt.h" @@ -388,6 +388,17 @@ InstructionDesc tclInstructionTable[] = { {"regexp", 2, -1, 1, {OPERAND_INT1}}, /* Regexp: push (regexp stknext stktop) opnd == nocase */ + + {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, + /* Test if scalar variable at index op1 in call frame exists */ + {"existArray", 5, 0, 1, {OPERAND_LVT4}}, + /* Test if array element exists; array at slot op1, element is + * stktop */ + {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, + /* Test if array element exists; element is stktop, array name is + * stknext */ + {"existStk", 1, 0, 0, {OPERAND_NONE}}, + /* Test if general variable exists; unparsed variable name is stktop*/ {0} }; @@ -1381,6 +1392,20 @@ TclCompileScript( } goto finishCommand; } else { + if (envPtr->atCmdStart && savedCodeNext != 0) { + /* + * Decrease the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + unsigned char *fixPtr = envPtr->codeNext - 4; + + TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, + fixPtr); + } + /* * Restore numCommands and codeNext to their * correct values, removing any commands compiled diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 618f704..711aa42 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,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.83 2007/11/12 02:07:19 hobbs Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.84 2007/11/14 23:05:02 dkf Exp $ */ #ifndef _TCLCOMPILATION @@ -640,8 +640,14 @@ typedef struct ByteCode { #define INST_REGEXP 127 +/* For [info exists] compilation */ +#define INST_EXIST_SCALAR 128 +#define INST_EXIST_ARRAY 139 +#define INST_EXIST_ARRAY_STK 130 +#define INST_EXIST_STK 131 + /* The last opcode */ -#define LAST_INST_OPCODE 127 +#define LAST_INST_OPCODE 131 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 44cb8e8..bc6ea42 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.348 2007/11/12 22:12:06 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.349 2007/11/14 23:05:02 dkf Exp $ */ #include "tclInt.h" @@ -3107,6 +3107,121 @@ TclExecuteByteCode( * --------------------------------------------------------- */ + /* + * --------------------------------------------------------- + * Start of INST_EXIST instructions. + */ + { + int opnd, pcAdjustment; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + +#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) + + case INST_EXIST_SCALAR: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = &(compiledLocals[opnd]); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (ReadTraced(varPtr)) { + DECACHE_STACK_INFO(); + if (TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, + TCL_TRACE_READS, 0, opnd) != TCL_OK) { + varPtr = NULL; + } + CACHE_STACK_INFO(); + } + /* + * Tricky! Arrays always exist. + */ + if (varPtr == NULL || varPtr->value.objPtr == NULL) { + objResultPtr = constants[0]; + } else { + objResultPtr = constants[1]; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 0, 1); + + case INST_EXIST_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); + part2Ptr = OBJ_AT_TOS; + arrayPtr = &(compiledLocals[opnd]); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (!varPtr) { + objResultPtr = constants[0]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + } else if (!ReadTraced(varPtr)) { + objResultPtr = constants[varPtr->value.objPtr != NULL ? 1:0]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + } + } + varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", + 0, 0, arrayPtr, opnd); + if (varPtr&&(ReadTraced(varPtr)||(arrayPtr&&ReadTraced(arrayPtr)))) { + DECACHE_STACK_INFO(); + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, + part2Ptr, TCL_TRACE_READS, 0, opnd) != TCL_OK) { + varPtr = NULL; + } + CACHE_STACK_INFO(); + } + if (varPtr == NULL) { + objResultPtr = constants[0]; + } else { + objResultPtr = constants[varPtr->value.objPtr != NULL ? 1 : 0]; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + + case INST_EXIST_ARRAY_STK: + cleanup = 2; + pcAdjustment = 1; + part2Ptr = OBJ_AT_TOS; /* element name */ + part1Ptr = OBJ_UNDER_TOS; /* array name */ + TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); + goto doExistStk; + + case INST_EXIST_STK: + cleanup = 1; + pcAdjustment = 1; + part2Ptr = NULL; + part1Ptr = OBJ_AT_TOS; /* variable name */ + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + + doExistStk: + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", + /*createPart1*/0, /*createPart2*/0, &arrayPtr); + if (varPtr&&(ReadTraced(varPtr)||(arrayPtr&&ReadTraced(arrayPtr)))) { + DECACHE_STACK_INFO(); + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + part2Ptr, TCL_TRACE_READS, 0, -1) != TCL_OK) { + varPtr = NULL; + } + CACHE_STACK_INFO(); + } + if (!varPtr) { + objResultPtr = constants[0]; + } else { + objResultPtr = constants[varPtr->value.objPtr != NULL ? 1:0]; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } + + /* + * End of INST_EXIST instructions. + * --------------------------------------------------------- + */ + case INST_UPVAR: { int opnd; Var *varPtr, *otherPtr; diff --git a/generic/tclInt.h b/generic/tclInt.h index 40ca85f..d7fb7a2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.345 2007/11/14 10:54:55 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.346 2007/11/14 23:05:03 dkf Exp $ */ #ifndef _TCLINT @@ -2471,6 +2471,8 @@ MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); +MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -2941,6 +2943,8 @@ MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index a6f89cf..df5fb56 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.152 2007/11/11 19:32:16 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.153 2007/11/14 23:05:03 dkf Exp $ */ #include "tclInt.h" @@ -5352,6 +5352,18 @@ Tcl_SetEnsembleSubcommandList( ensemblePtr->nsPtr->exportLookupEpoch++; + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + if (subcmdList != NULL) { + cmdPtr->compileProc = NULL; + } + } + return TCL_OK; } @@ -5417,6 +5429,18 @@ Tcl_SetEnsembleMappingDict( ensemblePtr->nsPtr->exportLookupEpoch++; + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + if (mapDict == NULL) { + cmdPtr->compileProc = NULL; + } + } + return TCL_OK; } |