summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c1
-rw-r--r--generic/tclCompCmdsGR.c25
-rw-r--r--generic/tclCompile.c14
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclExecute.c132
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclOO.c3
-rw-r--r--generic/tclOOBasic.c20
8 files changed, 179 insertions, 22 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..7b775a9 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -26,6 +26,7 @@
*- jumpTable testing
*- syntax (?)
*- returnCodeBranch
+ *- tclooNext, tclooNextClass
*/
#include "tclInt.h"
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b8a7e0f..b3e273f 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -3075,6 +3075,31 @@ TclCompileObjectNextCmd(
}
int
+TclCompileObjectNextToCmd(
+ 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. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ int i;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileObjectSelfCmd(
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 ee67e24..bd97e3e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -618,8 +618,18 @@ InstructionDesc const tclInstructionTable[] = {
* Stack: ... cmdName => ... fullOriginalCmdName */
{"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}},
- /* Push the identity of the current TclOO object (i.e., the name of
- * its current public access command) on the stack. */
+ /* Call the next item on the TclOO call chain, passing opnd arguments
+ * (min 1, max 255, *includes* "next"). The result of the invoked
+ * method implementation will be pushed on the stack in place of the
+ * arguments (similar to invokeStk).
+ * Stack: ... "next" arg2 arg3 -- argN => ... result */
+ {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Call the following item on the TclOO call chain defined by class
+ * className, passing opnd arguments (min 2, max 255, *includes*
+ * "nextto" and the class name). The result of the invoked method
+ * implementation will be pushed on the stack in place of the
+ * arguments (similar to invokeStk).
+ * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 6ecadf4..b047855 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -791,9 +791,10 @@ typedef struct ByteCode {
#define INST_ORIGIN_COMMAND 178
#define INST_TCLOO_NEXT 179
+#define INST_TCLOO_NEXT_CLASS 180
/* The last opcode */
-#define LAST_INST_OPCODE 179
+#define LAST_INST_OPCODE 180
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..ac0ea12 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4539,6 +4539,7 @@ TEBCresume(
Object *oPtr;
CallFrame *framePtr;
CallContext *contextPtr;
+ int skip, newDepth;
case INST_TCLOO_SELF:
framePtr = iPtr->varFramePtr;
@@ -4563,9 +4564,111 @@ TEBCresume(
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
+ case INST_TCLOO_NEXT_CLASS:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ framePtr = iPtr->varFramePtr;
+ valuePtr = OBJ_AT_DEPTH(opnd - 2);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
+ skip = 2;
+ TRACE(("%d => ", opnd));
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE_APPEND(("ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "nextto may only be called from inside a method",
+ -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
+ if (oPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
+ goto gotError;
+ } else {
+ Class *classPtr = oPtr->classPtr;
+ struct MInvoke *miPtr;
+ int i;
+ const char *methodType;
+
+ if (classPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+ for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (!miPtr->isFilter &&
+ miPtr->mPtr->declaringClassPtr == classPtr) {
+ newDepth = i;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < opnd; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ goto doInvokeNext;
+ }
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
+ O2S(valuePtr)));
+ for (i=contextPtr->index ; i>=0 ; i--) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (miPtr->isFilter
+ || miPtr->mPtr->declaringClassPtr != classPtr) {
+ continue;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
case INST_TCLOO_NEXT:
opnd = TclGetUInt1AtPtr(pc+1);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
framePtr = iPtr->varFramePtr;
+ skip = 1;
TRACE(("%d => ", opnd));
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
@@ -4580,7 +4683,8 @@ TEBCresume(
}
contextPtr = framePtr->clientData;
- if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ newDepth = contextPtr->index + 1;
+ if (newDepth >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless
* the interpreter is being torn down, in which case we might be
@@ -4605,33 +4709,31 @@ TEBCresume(
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
CACHE_STACK_INFO();
goto gotError;
- }
-
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
+ } else if (tclTraceExec >= 2) {
int i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
- TRACE(("next_in_chain "));
} else {
- fprintf(stdout, "%d: (%u) invoking next_in_chain ",
+ fprintf(stdout, "%d: (%u) invoking ",
iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
}
- for (i = 0; i < objc; i++) {
+ for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
- }
#endif /*TCL_COMPILE_DEBUG*/
+ }
+ doInvokeNext:
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
+ ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
}
pcAdjustment = 2;
@@ -4640,6 +4742,7 @@ TEBCresume(
iPtr->varFramePtr = framePtr->callerVarPtr;
pc += pcAdjustment;
TEBC_YIELD();
+
oPtr = contextPtr->oPtr;
if (oPtr->flags & FILTER_HANDLING) {
TclNRAddCallback(interp, FinalizeOONextFilter,
@@ -4650,20 +4753,21 @@ TEBCresume(
framePtr, contextPtr, INT2PTR(contextPtr->index),
INT2PTR(contextPtr->skip));
}
- if (contextPtr->callPtr->chain[++contextPtr->index].isFilter
+ contextPtr->skip = skip;
+ contextPtr->index = newDepth;
+ if (contextPtr->callPtr->chain[newDepth].isFilter
|| contextPtr->callPtr->flags & FILTER_HANDLING) {
oPtr->flags |= FILTER_HANDLING;
} else {
oPtr->flags &= ~FILTER_HANDLING;
}
- contextPtr->skip = 1;
+
{
register Method *const mPtr =
- contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ contextPtr->callPtr->chain[newDepth].mPtr;
return mPtr->typePtr->callProc(mPtr->clientData, interp,
- (Tcl_ObjectContext) contextPtr, opnd,
- &OBJ_AT_DEPTH(opnd-1));
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
}
case INST_TCLOO_IS_OBJECT:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aaa30b..7932a58 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3592,6 +3592,9 @@ MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectNextToCmd(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);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9a0682d..de00733 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -440,8 +440,9 @@ InitFoundation(
cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
NULL, TclOONextObjCmd, NULL, NULL);
cmdPtr->compileProc = TclCompileObjectNextCmd;
- Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
NULL, TclOONextToObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextToCmd;
cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
TclOOSelfObjCmd, NULL, NULL);
cmdPtr->compileProc = TclCompileObjectSelfCmd;
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 6084cf2..0b0516b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -821,6 +821,7 @@ TclOONextToObjCmd(
CallContext *contextPtr;
int i;
Tcl_Object object;
+ const char *methodType;
/*
* Start with sanity checks on the calling context to make sure that we
@@ -886,19 +887,30 @@ TclOONextToObjCmd(
* is on the chain but unreachable, or not on the chain at all.
*/
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
for (i=contextPtr->index ; i>=0 ; i--) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "method implementation by \"%s\" not reachable from here",
- TclGetString(objv[1])));
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+ NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "method has no non-filter implementation by \"%s\"",
- TclGetString(objv[1])));
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
return TCL_ERROR;
}
generated by cgit v0.12 at 2024-11-21 16:52:17 (GMT)