Added compilation of [info object isa object] (i.e., object verification).

7 files changed, 56 insertions, 4 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 19d6232..9256556 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -481,6 +481,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
     {"tclooClass",	ASSEM_1BYTE,	INST_TCLOO_CLASS,	1,	1},
+    {"tclooIsObject",	ASSEM_1BYTE,	INST_TCLOO_IS_OBJECT,	1,	1},
     {"tclooNamespace",	ASSEM_1BYTE,	INST_TCLOO_NS,		1,	1},
     {"tclooSelf",	ASSEM_1BYTE,	INST_TCLOO_SELF,	0,	1},
     {"tryCvtToNumeric",	ASSEM_1BYTE,	INST_TRY_CVT_TO_NUMERIC,1,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index e476cf0..0829072 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3688,6 +3688,42 @@ TclCompileInfoObjectClassCmd(
 }
 
 int
+TclCompileInfoObjectIsACmd(
+    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)
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * We only handle [info object isa object <somevalue>]. The first three
+     * words are compressed to a single token by the ensemble compilation
+     * engine.
+     */
+
+    if (parsePtr->numWords != 3) {
+	return TCL_ERROR;
+    }
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
+	    || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(tokenPtr);
+
+    /*
+     * Issue the code.
+     */
+
+    CompileWord(envPtr,		tokenPtr,		interp, 2);
+    TclEmitOpcode(		INST_TCLOO_IS_OBJECT,	envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileInfoObjectNamespaceCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d47e0f6..475a85e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -487,14 +487,20 @@ InstructionDesc const tclInstructionTable[] = {
     {"tclooSelf",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
-   {"tclooClass",	 1,	0,	  0,	{OPERAND_NONE}},
+    {"tclooClass",	 1,	0,	  0,	{OPERAND_NONE}},
 	/* Push the class of the TclOO object named at the top of the stack
 	 * onto the stack.
 	 * Stack:  ... object => ... class */
-   {"tclooNamespace",	 1,	0,	  0,	{OPERAND_NONE}},
+    {"tclooNamespace",	 1,	0,	  0,	{OPERAND_NONE}},
 	/* Push the namespace of the TclOO object named at the top of the
 	 * stack onto the stack.
 	 * Stack:  ... object => ... namespace */
+    {"tclooIsObject",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Push whether the value named at the top of the stack is a TclOO
+	 * object (i.e., a boolean). Can corrupt the interpreter result
+	 * despite not throwing, so not safe for use in a post-exception
+	 * context.
+	 * Stack:  ... value => ... boolean */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index a31a33b..3db3a78 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -701,9 +701,10 @@ typedef struct ByteCode {
 #define INST_TCLOO_SELF			153
 #define INST_TCLOO_CLASS		154
 #define INST_TCLOO_NS			155
+#define INST_TCLOO_IS_OBJECT		156
 
 /* The last opcode */
-#define LAST_INST_OPCODE		155
+#define LAST_INST_OPCODE		156
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index bf07dd7..ad79482 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4234,6 +4234,11 @@ TEBCresume(
     {
 	Object *oPtr;
 
+    case INST_TCLOO_IS_OBJECT:
+	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+	objResultPtr = TCONST(oPtr != NULL ? 1 : 0);
+	TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+	NEXT_INST_F(1, 1, 1);
     case INST_TCLOO_CLASS:
 	oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
 	if (oPtr == NULL) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 06bcd95..48297b9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3578,6 +3578,9 @@ MODULE_SCOPE int	TclCompileInfoLevelCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileInfoObjectClassCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileInfoObjectIsACmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index ff3e1e5..e09ee4e 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -53,7 +53,7 @@ static const EnsembleImplMap infoObjectCmds[] = {
     {"definition", InfoObjectDefnCmd,	    NULL, NULL, NULL, 0},
     {"filters",	   InfoObjectFiltersCmd,    NULL, NULL, NULL, 0},
     {"forward",	   InfoObjectForwardCmd,    NULL, NULL, NULL, 0},
-    {"isa",	   InfoObjectIsACmd,	    NULL, NULL, NULL, 0},
+    {"isa",	   InfoObjectIsACmd,	    TclCompileInfoObjectIsACmd, NULL, NULL, 0},
     {"methods",	   InfoObjectMethodsCmd,    NULL, NULL, NULL, 0},
     {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
     {"mixins",	   InfoObjectMixinsCmd,	    NULL, NULL, NULL, 0},