summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclAssembly.c1
-rw-r--r--generic/tclCompCmds.c34
-rw-r--r--generic/tclCompile.c3
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclExecute.c24
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclOO.c6
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,