From 8324cc91dbdb33bfd5799067e96c62769b8fb9c9 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Nov 2012 20:40:55 +0000 Subject: Working towards a BCCed [next]. This version almost works, except for a problem with restoring the context namespace upon return (which produces very strange results!) --- generic/tclCompCmds.c | 29 +++++++++++++++++++++++++ generic/tclCompile.c | 4 ++++ generic/tclCompile.h | 5 ++++- generic/tclExecute.c | 59 +++++++++++++++++++++++++++++++++++++++++++++++++-- generic/tclInt.h | 4 ++++ generic/tclOO.c | 9 ++++---- generic/tclOOBasic.c | 12 +++++------ 7 files changed, 108 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5beb7bd..96bb9a4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5535,6 +5535,35 @@ IndexTailVarIfKnown( return localIndex; } +/* + * Compilations of commands relating to TclOO. + */ + +int +TclCompileObjectNextCmd( + 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 > 255) { + return TCL_ERROR; + } + + for (i=0 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); + return TCL_OK; +} + int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee8511c..188b3f8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -484,9 +484,13 @@ InstructionDesc const tclInstructionTable[] = { * qualified version, or produces the empty string if no such command * exists. Never generates errors. * Stack: ... cmdName => ... fullCmdName */ + {"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. */ + {"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. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 08d59fd..e623e87 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -698,10 +698,13 @@ typedef struct ByteCode { #define INST_INFO_LEVEL_NUM 150 #define INST_INFO_LEVEL_ARGS 151 #define INST_RESOLVE_COMMAND 152 + +/* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 +#define INST_TCLOO_NEXT 154 /* The last opcode */ -#define LAST_INST_OPCODE 153 +#define LAST_INST_OPCODE 154 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e24cb3..f6b99bf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4208,10 +4208,18 @@ TEBCresume( TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); } - case INST_TCLOO_SELF: { - CallFrame *framePtr = iPtr->varFramePtr; + + /* + * ----------------------------------------------------------------- + * Start of TclOO support instructions. + */ + + { + CallFrame *framePtr; CallContext *contextPtr; + case INST_TCLOO_SELF: + framePtr = iPtr->varFramePtr; if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE(("=> ERROR: no TclOO call context\n")); @@ -4230,9 +4238,56 @@ TEBCresume( objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + + case INST_TCLOO_NEXT: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE(("%d => ERROR: no TclOO call context\n", opnd)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "next may only be called from inside a method", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + goto gotError; + } + contextPtr = framePtr->clientData; + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + + pcAdjustment = 2; + cleanup = opnd; + DECACHE_STACK_INFO(); + + /* + * BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG + * + * Bug somewhere near here. The iPtr->varFramePtr must be updated as + * below, but TclOONextRestoreFrame (in tclOOBasic.c) seems to be + * unable to restore the frame upon return... + * + * If TclOONextRestoreFrame is wrong for use here (and it might be!) + * it should be copied to this file and adjusted afterwards. It is + * *correct* for its other uses. + */ + + iPtr->varFramePtr = framePtr->callerVarPtr; + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + NULL, NULL, NULL); + pc += pcAdjustment; + TEBC_YIELD(); + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1); } /* + * End of TclOO support instructions. * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..549ada9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2804,6 +2804,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclOONextRestoreFrame; MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, struct NRE_callback *tailcallPtr); @@ -3620,6 +3621,9 @@ MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextCmd(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 d6d2d6a..68ed766 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -437,10 +437,11 @@ InitFoundation( * ensemble. */ - Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, - NULL, NULL); + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); 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 0676618..cd57063 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -25,8 +25,6 @@ static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], Tcl_Interp *interp, int result); -static int RestoreFrame(ClientData data[], - Tcl_Interp *interp, int result); /* * ---------------------------------------------------------------------- @@ -805,7 +803,7 @@ TclOONextObjCmd( * that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } @@ -874,8 +872,8 @@ TclOONextToObjCmd( * context. Note that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, - INT2PTR(contextPtr->index), NULL); + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + contextPtr, INT2PTR(contextPtr->index), NULL); contextPtr->index = i-1; iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, @@ -904,8 +902,8 @@ TclOONextToObjCmd( return TCL_ERROR; } -static int -RestoreFrame( +int +TclOONextRestoreFrame( ClientData data[], Tcl_Interp *interp, int result) -- cgit v0.12 From eaaed023dfb41a1d60c320fccf77c54204c4143e Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 20:39:10 +0000 Subject: reorder to preserve main BC development branch sequence better --- generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7036f6a..c390971 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -488,17 +488,17 @@ 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. */ - {"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. */ - {"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 */ + {"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. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cab517d..c860307 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -701,9 +701,9 @@ typedef struct ByteCode { /* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 -#define INST_TCLOO_NEXT 154 -#define INST_TCLOO_CLASS 155 -#define INST_TCLOO_NS 156 +#define INST_TCLOO_CLASS 154 +#define INST_TCLOO_NS 155 +#define INST_TCLOO_NEXT 156 /* The last opcode */ #define LAST_INST_OPCODE 156 -- cgit v0.12