summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2007-11-14 23:05:00 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2007-11-14 23:05:00 (GMT)
commite9dca7fbd88ce6c7cc5afc264a2c667f5f0d98b6 (patch)
treed61de78a8293a7d2a188189329afca632e2de56d
parent9bdde7aa4d7b94e1801005fcc63f1fe9953d216a (diff)
downloadtcl-e9dca7fbd88ce6c7cc5afc264a2c667f5f0d98b6.zip
tcl-e9dca7fbd88ce6c7cc5afc264a2c667f5f0d98b6.tar.gz
tcl-e9dca7fbd88ce6c7cc5afc264a2c667f5f0d98b6.tar.bz2
Compile [info exists] into bytecode. Includes new instructions to support it.
-rw-r--r--ChangeLog20
-rw-r--r--generic/tclCmdIL.c19
-rw-r--r--generic/tclCompCmds.c148
-rw-r--r--generic/tclCompile.c27
-rw-r--r--generic/tclCompile.h10
-rw-r--r--generic/tclExecute.c117
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclNamesp.c26
8 files changed, 357 insertions, 16 deletions
diff --git a/ChangeLog b/ChangeLog
index e36de2f..b57a641 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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;
}