Compile [info exists] into bytecode. Includes new instructions to support it.

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;
 }