yet another small introspector: [self]

7 files changed, 71 insertions, 3 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index a266350..132ee68 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -476,6 +476,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"strmatch",	ASSEM_BOOL,	INST_STR_MATCH,		2,	1},
     {"strneq",		ASSEM_1BYTE,	INST_STR_NEQ,		2,	1},
     {"sub",		ASSEM_1BYTE,	INST_SUB,		2,	1},
+    {"tclooSelf",	ASSEM_1BYTE,	INST_TCLOO_SELF,	0,	1},
     {"tryCvtToNumeric",	ASSEM_1BYTE,	INST_TRY_CVT_TO_NUMERIC,1,	1},
     {"uminus",		ASSEM_1BYTE,	INST_UMINUS,		1,	1},
     {"unset",		ASSEM_BOOL_LVT4,INST_UNSET_SCALAR,	0,	0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 64417c5..3f916a6 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4687,6 +4687,40 @@ IndexTailVarIfKnown(
     return localIndex;
 }
 
+int
+TclCompileObjectSelfCmd(
+    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)		/* Holds resulting instructions. */
+{
+    /*
+     * We only handle [self] and [self object] (which is the same operation).
+     * These are the only very common operations on [self] for which
+     * bytecoding is at all reasonable.
+     */
+
+    if (parsePtr->numWords > 2) {
+	return TCL_ERROR;
+    } else if (parsePtr->numWords == 2) {
+	Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0 ||
+		strncmp(tokenPtr[1].start, "object", tokenPtr[1].size) != 0) {
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * This delegates the entire problem to a single opcode.
+     */
+
+    TclEmitOpcode(		INST_TCLOO_SELF,		envPtr);
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4c84953..3ee0fdf 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -448,6 +448,9 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the argument words to a stack depth (i.e., [info level <n>])
 	 * of the interpreter as an object on the stack.
 	 * Stack:  ... depth => ... argList */
+    {"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. */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 4e039a2..044bef9 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -686,9 +686,10 @@ typedef struct ByteCode {
 #define INST_COROUTINE_NAME		142
 #define INST_INFO_LEVEL_NUM		143
 #define INST_INFO_LEVEL_ARGS		144
+#define INST_TCLOO_SELF			145
 
 /* The last opcode */
-#define LAST_INST_OPCODE		144
+#define LAST_INST_OPCODE		145
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1041f65..0ec16e9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -17,6 +17,7 @@
 
 #include "tclInt.h"
 #include "tclCompile.h"
+#include "tclOOInt.h"
 #include "tommath.h"
 #include <math.h>
 
@@ -4106,6 +4107,29 @@ TEBCresume(
 	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 	NEXT_INST_F(1, 1, 1);
     }
+    case INST_TCLOO_SELF: {
+	CallFrame *framePtr = iPtr->varFramePtr;
+	CallContext *contextPtr;
+
+	if (framePtr == NULL ||
+		!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	    TRACE(("=> ERROR: no TclOO call context\n"));
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "self may only be called from inside a method",
+		    -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+	    goto gotError;
+	}
+	contextPtr = framePtr->clientData;
+
+	/*
+	 * Call out to get the name; it's expensive to compute but cached.
+	 */
+
+	objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
+	TRACE_WITH_OBJ(("=> "), objResultPtr);
+	NEXT_INST_F(1, 0, 1);
+    }
 
     /*
      * -----------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0b84914..9bf492c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3598,6 +3598,9 @@ MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileObjectSelfCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileRegexpCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 04a2bf7..d6d2d6a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -314,6 +314,7 @@ InitFoundation(
     Foundation *fPtr = ckalloc(sizeof(Foundation));
     Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
     Tcl_DString buffer;
+    Command *cmdPtr;
     int i;
 
     /*
@@ -440,8 +441,9 @@ InitFoundation(
 	    NULL);
     Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
 	    NULL, NULL);
-    Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
-	    NULL);
+    cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
+	    TclOOSelfObjCmd, NULL, NULL);
+    cmdPtr->compileProc = TclCompileObjectSelfCmd;
     Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
 	    NULL);
     Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,