summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclAssembly.c1
-rw-r--r--generic/tclCompCmds.c36
-rw-r--r--generic/tclCompile.c10
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclExecute.c5
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclOOInfo.c2
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},