diff options
| -rw-r--r-- | generic/tclOOInt.h | 1 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 158 | ||||
| -rw-r--r-- | tests/oo.test | 137 |
3 files changed, 157 insertions, 139 deletions
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index e7d727a..41c674c 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -97,6 +97,7 @@ typedef struct ProcedureMethod { GetFrameInfoValueProc *gfivProc; /* Callback to allow for fine tuning of how * the method reports itself. */ + Command cmd; /* Space used to connect to [info frame] */ ExtraFrameInfo efi; /* Space used to store data for [info frame] */ Tcl_Interp *interp; /* Interpreter in which to compute the name of * the method. */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 1347aa5..5cff201 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -25,10 +25,8 @@ typedef struct { CallFrame *framePtr; /* Reference to the call frame itself (it's * actually allocated on the Tcl stack). */ ProcErrorProc *errProc; /* The error handler for the body. */ - Tcl_Obj *nameObj; /* The "name" of the command. */ - Command cmd; /* The command structure. Mostly bogus. */ - Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a - * recursive call returns. */ + Tcl_Obj *nameObj; /* The "name" of the command. Only used for a + * few moments, so not reference. */ } PMFrameData; /* @@ -72,8 +70,6 @@ static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static inline void InitFrameInfo(Tcl_Interp *interp, - ProcedureMethod *pmPtr, Tcl_ObjectContext context); static Tcl_Obj * RenderMethodName(void *clientData); static Tcl_Obj * RenderDeclarerName(void *clientData); static int InvokeForwardMethod(void *clientData, @@ -111,6 +107,20 @@ static const Tcl_MethodType fwdMethodType = { ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) + +static inline ProcedureMethod * +AllocProcedureMethodRecord( + int flags) +{ + ProcedureMethod *pmPtr = (ProcedureMethod *) + ckalloc(sizeof(ProcedureMethod)); + memset(pmPtr, 0, sizeof(ProcedureMethod)); + pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; + pmPtr->flags = flags & USE_DECLARER_NS; + pmPtr->refCount = 1; + pmPtr->cmd.clientData = &pmPtr->efi; + return pmPtr; +} /* * ---------------------------------------------------------------------- @@ -331,12 +341,7 @@ TclOONewProcInstanceMethod( if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); - memset(pmPtr, 0, sizeof(ProcedureMethod)); - pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->refCount = 1; - + pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { @@ -392,12 +397,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } - pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); - memset(pmPtr, 0, sizeof(ProcedureMethod)); - pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->refCount = 1; - + pmPtr = AllocProcedureMethodRecord(flags); method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); @@ -671,7 +671,36 @@ InvokeProcedureMethod( Tcl_ObjectContextSkippedArgs(context)); } - InitFrameInfo(interp, pmPtr, context); + /* + * Finishes filling out the extra frame info so that [info frame] works if + * that is not already set up. + */ + + if (pmPtr->efi.length == 0) { + Tcl_Method method = Tcl_ObjectContextMethod(context); + + pmPtr->efi.length = 2; + pmPtr->efi.fields[0].name = "method"; + pmPtr->efi.fields[0].proc = RenderMethodName; + pmPtr->efi.fields[0].clientData = pmPtr; + pmPtr->callSiteFlags = ((CallContext *) + context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); + pmPtr->interp = interp; + pmPtr->method = method; + if (pmPtr->gfivProc != NULL) { + pmPtr->efi.fields[1].name = ""; + pmPtr->efi.fields[1].proc = pmPtr->gfivProc; + pmPtr->efi.fields[1].clientData = pmPtr; + } else { + if (Tcl_MethodDeclarerObject(method) != NULL) { + pmPtr->efi.fields[1].name = "object"; + } else { + pmPtr->efi.fields[1].name = "class"; + } + pmPtr->efi.fields[1].proc = RenderDeclarerName; + pmPtr->efi.fields[1].clientData = pmPtr; + } + } /* * Allocate the special frame data. @@ -702,13 +731,6 @@ InvokeProcedureMethod( result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] - * won't crash on us. [Bug 3001438] - */ - - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (pmPtr->refCount-- <= 1) { @@ -728,48 +750,6 @@ InvokeProcedureMethod( Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc); } -/* - * Finishes filling out the extra frame info so that [info frame] works. - */ -static inline void -InitFrameInfo( - Tcl_Interp *interp, /* For object name resolution later. */ - ProcedureMethod *pmPtr, /* What we're writing to. */ - Tcl_ObjectContext context) /* The calling context, used to figure out how - * we're using the method. */ -{ - Tcl_Method method = Tcl_ObjectContextMethod(context); - - if (pmPtr->efi.length) { - /* - * Do nothing if already set up. - */ - return; - } - - pmPtr->efi.length = 2; - pmPtr->efi.fields[0].name = "method"; - pmPtr->efi.fields[0].proc = RenderMethodName; - pmPtr->efi.fields[0].clientData = pmPtr; - pmPtr->callSiteFlags = ((CallContext *) - context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR); - pmPtr->interp = interp; - pmPtr->method = method; - if (pmPtr->gfivProc != NULL) { - pmPtr->efi.fields[1].name = ""; - pmPtr->efi.fields[1].proc = pmPtr->gfivProc; - pmPtr->efi.fields[1].clientData = pmPtr; - } else { - if (Tcl_MethodDeclarerObject(method) != NULL) { - pmPtr->efi.fields[1].name = "object"; - } else { - pmPtr->efi.fields[1].name = "class"; - } - pmPtr->efi.fields[1].proc = RenderDeclarerName; - pmPtr->efi.fields[1].clientData = pmPtr; - } -} - static int FinalizePMCall( void *data[], @@ -792,13 +772,6 @@ FinalizePMCall( } /* - * Restore the old cmdPtr so that a subsequent use of [info frame] won't - * crash on us. [Bug 3001438] - */ - - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - - /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! @@ -862,29 +835,15 @@ PushMethodCallFrame( } /* - * Save the old cmdPtr so that when this recursive call returns, we can - * restore it. To do otherwise causes crashes in [info frame] after we - * return from a recursive call. [Bug 3001438] - */ - - fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr; - - /* - * Compile the body. This operation may fail. - */ - - memset(&fdPtr->cmd, 0, sizeof(Command)); - fdPtr->cmd.nsPtr = nsPtr; - fdPtr->cmd.clientData = &pmPtr->efi; - pmPtr->procPtr->cmdPtr = &fdPtr->cmd; - - /* + * Compile the body. + * * [Bug 2037727] Always call TclProcCompileProc so that we check not only * that we have bytecode, but also that it remains valid. Note that we set * the namespace of the code here directly; this is a hack, but the * alternative is *so* slow... */ + pmPtr->procPtr->cmdPtr = &pmPtr->cmd; if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; @@ -895,12 +854,12 @@ PushMethodCallFrame( pmPtr->procPtr->bodyPtr, nsPtr, "body of method", TclGetString(fdPtr->nameObj)); if (result != TCL_OK) { - goto failureReturn; + return result; } /* * Make the stack frame and fill it out with information about this call. - * This operation may fail. + * This operation doesn't ever actually fail. */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, @@ -912,15 +871,6 @@ PushMethodCallFrame( fdPtr->framePtr->procPtr = pmPtr->procPtr; return TCL_OK; - - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] won't - * crash on us. [Bug 3001438] - */ - - failureReturn: - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - return result; } /* @@ -1357,6 +1307,8 @@ CloneProcedureMethod( pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; + pm2Ptr->cmd.clientData = &pm2Ptr->efi; + pm2Ptr->efi.length = 0; /* Trigger a reinit of this. */ Tcl_IncrRefCount(argsObj); Tcl_IncrRefCount(bodyObj); if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, diff --git a/tests/oo.test b/tests/oo.test index 8bc6363..8e2cb5f 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3296,56 +3296,121 @@ test oo-22.2 {OO and info frame: Bug 3001438} -setup { } -match glob -cleanup { c destroy } -result {* cmd {info frame 0} method test class ::c level 0} -test oo-22.3 {OO and coroutines and info frame} -constraints knownBug -setup { - oo::class create A { - self { - variable result stop - method WithWorkers {nworkers args script} { - set workers {} - try { - for {set n 1} {$n <= $nworkers} {incr n} { - lappend workers [set worker [[self] new]] - $worker schedule {*}$args - } - return [uplevel 1 $script] - } finally { - foreach worker $workers {$worker destroy} - } - } - method run {nworkers} { - set result {} - set stopvar [my varname stop] - set stop false - my WithWorkers $nworkers [list my Work [my varname result]] { - after idle [namespace code {set stop true}] - vwait $stopvar - } - return $result +# Common code for oo-22.{3,4,5,6} +oo::class create WorkerBase +oo::class create WorkerSupport { + superclass oo::class WorkerBase + variable result stop + method WithWorkers {nworkers args script} { + set workers {} + try { + for {set n 1} {$n <= $nworkers} {incr n} { + lappend workers [set worker [[self] new]] + $worker schedule {*}$args } + return [uplevel 1 $script] + } finally { + foreach worker $workers {$worker destroy} + } + } + method run {nworkers} { + set result {} + set stopvar [my varname stop] + set stop false + my WithWorkers $nworkers [list my Work [my varname result]] { + after idle [namespace code {set stop true}] + vwait $stopvar } - method schedule {args} { - set coro [namespace current]::coro - if {![llength [info commands $coro]]} { - coroutine $coro {*}$args - } + return $result + } +} +oo::class create Worker { + superclass WorkerBase + method schedule {args} { + set coro [namespace current]::coro + if {![llength [info commands $coro]]} { + coroutine $coro {*}$args } + } + method Work args {error unimplemented} + method dump {} { + info frame [expr {[info frame] - 1}] + } +} +test oo-22.3 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly restored pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker method Work {var} { after 0 [info coroutine] yield - lappend $var [dump] + lappend $var [my dump] } } -} -body { - # Triggers a crash with incorrectly restored procPtr->cmdPtr - proc dump {} { - # Called from [A Work] after a coroutine suspend/resume - info frame [expr {[info frame] - 1}] + A run 2 +} -cleanup { + catch {rename dump {}} + catch {A destroy} +} -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} +test oo-22.4 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker + method Work {var} { + after 0 [info coroutine] + yield + lappend $var [my dump] + } + } + # Copies the methods, changing the declarer + # Test it works with the source class still around + oo::copy A B + B run 2 +} -cleanup { + catch {rename dump {}} + catch {A destroy} + catch {B destroy} +} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} +test oo-22.5 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker + method Work {var} { + after 0 [info coroutine] + yield + lappend $var [my dump] + } + } + # Copies the methods, changing the declarer + # Test it works with the source class deleted + oo::copy A B + catch {A destroy} + B run 2 +} -cleanup { + catch {rename dump {}} + catch {B destroy} +} -match glob -result {{* method Work class ::B *} {* method Work class ::B *}} +test oo-22.6 {OO and coroutines and info frame: Bug 87271f7cd6} -body { + # Triggers a crash with incorrectly cloned pmPtr->procPtr->cmdPtr + WorkerSupport create A { + superclass Worker + method Work {var} { + after 0 [info coroutine] + yield + lappend $var [my dump] + } } + # Copies the methods, changing the declarer + # Test it works in the original source class with the copy around + oo::copy A B + B run 2 A run 2 } -cleanup { catch {rename dump {}} catch {A destroy} + catch {B destroy} } -match glob -result {{* method Work class ::A *} {* method Work class ::A *}} +WorkerBase destroy # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { |