From 0aefd12ecc49b90bb53275239ab60e815c7e2ad5 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 21 Aug 2008 14:02:14 +0000 Subject: Added disassembly of TclOO methods. --- ChangeLog | 5 + generic/tclProc.c | 363 ++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 232 insertions(+), 136 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7725eb1..5595080 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2008-08-21 Donal K. Fellows + + * generic/tclProc.c (Tcl_DisassembleObjCmd): Added ability to + disassemble TclOO methods. The code to do this is very ugly. + 2008-08-21 Pat Thoyts * generic/tclOOMethod.c: Added casts to make MSVC happy diff --git a/generic/tclProc.c b/generic/tclProc.c index d763fde..9b28fd5 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,11 +12,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.161 2008/08/14 10:49:39 das Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.162 2008/08/21 14:02:23 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tclOOInt.h" /* * Variables that are part of the [apply] command implementation and which @@ -40,14 +41,14 @@ static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, - Namespace *nsPtr); -static void InitLocalCache(Proc *procPtr); + Namespace *nsPtr); +static void InitLocalCache(Proc *procPtr); static int PushProcCallFrame(ClientData clientData, register Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); +static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); static void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, @@ -223,11 +224,9 @@ Tcl_ProcObjCmd( */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr; + CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; - if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve source information from the bytecode, if possible. If @@ -255,7 +254,7 @@ Tcl_ProcObjCmd( if (contextPtr->line && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; - Tcl_HashEntry* hePtr; + Tcl_HashEntry *hePtr; CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; @@ -272,17 +271,17 @@ Tcl_ProcObjCmd( cfPtr->cmd.str.cmd = NULL; cfPtr->cmd.str.len = 0; - hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, - &isNew); + hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, + (char *) procPtr, &isNew); if (!isNew) { /* - * Get the old command frame and release it. See also + * Get the old command frame and release it. See also * TclProcCleanupProc in this file. Currently it seems as * if only the procbodytest::proc command of the testsuite * is able to trigger this situation. */ - CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); + CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr); if (cfOldPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfOldPtr->data.eval.path); @@ -296,8 +295,8 @@ Tcl_ProcObjCmd( } /* - * 'contextPtr' is going out of scope; account for the reference that - * it's holding to the path name. + * 'contextPtr' is going out of scope; account for the reference + * that it's holding to the path name. */ Tcl_DecrRefCount(contextPtr->data.eval.path); @@ -935,8 +934,8 @@ TclNRUplevelObjCmd( { register Interp *iPtr = (Interp *) interp; - CmdFrame* invoker = NULL; - int word = 0; + CmdFrame *invoker = NULL; + int word = 0; int result; CallFrame *savedVarFramePtr, *framePtr; Tcl_Obj *objPtr; @@ -1057,16 +1056,15 @@ Proc * TclIsProc( Command *cmdPtr) /* Command to test. */ { - Tcl_Command origCmd; + Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); - origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } if (cmdPtr->deleteProc == TclProcDeleteProc) { - return (Proc *) cmdPtr->objClientData; + return cmdPtr->objClientData; } - return (Proc *) 0; + return NULL; } /* @@ -1091,7 +1089,8 @@ TclIsProc( static int ProcWrongNumArgs( - Tcl_Interp *interp, int skip) + Tcl_Interp *interp, + int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; @@ -1099,13 +1098,13 @@ ProcWrongNumArgs( int localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; - + /* * Build up desired argument list for Tcl_WrongNumArgs */ numArgs = framePtr->procPtr->numArgs; - desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, + desiredObjs = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * (numArgs+1)); #ifdef AVOID_HACKS_FOR_ITCL @@ -1189,7 +1188,7 @@ TclInitCompiledLocals( } framePtr->localCachePtr = codePtr->localCachePtr; framePtr->localCachePtr->refCount++; - } + } InitResolvedLocals(interp, codePtr, varPtr, nsPtr); } @@ -1236,44 +1235,14 @@ InitResolvedLocals( } if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { - /* - * Initialize the array of local variables stored in the call frame. - * Some variables may have special resolution rules. In that case, we - * call their "resolver" procs to get our hands on the variable, and - * we make the compiled local a link to the real variable. - */ - - doInitResolvedLocals: - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->flags = 0; - varPtr->value.objPtr = NULL; - - /* - * Now invoke the resolvers to determine the exact variables - * that should be used. - */ - - resVarInfo = localPtr->resolveInfo; - if (resVarInfo && resVarInfo->fetchProc) { - Var *resolvedVarPtr = (Var *) - (*resVarInfo->fetchProc)(interp, resVarInfo); - if (resolvedVarPtr) { - if (TclIsVarInHash(resolvedVarPtr)) { - VarHashRefCount(resolvedVarPtr)++; - } - varPtr->flags = VAR_LINK; - varPtr->value.linkPtr = resolvedVarPtr; - } - } - } - return; + goto doInitResolvedLocals; } /* * This is the first run after a recompile, or else the resolver epoch * has changed: update the resolver cache. */ - + firstLocalPtr = localPtr; for (; localPtr != NULL; localPtr = localPtr->nextPtr) { if (localPtr->resolveInfo) { @@ -1285,15 +1254,15 @@ InitResolvedLocals( localPtr->resolveInfo = NULL; } localPtr->flags &= ~VAR_RESOLVED; - + if (haveResolvers && !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_ResolvedVarInfo *vinfo; int result; - + if (nsPtr->compiledVarResProc) { - result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + result = nsPtr->compiledVarResProc(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } else { @@ -1302,7 +1271,7 @@ InitResolvedLocals( while ((result == TCL_CONTINUE) && resPtr) { if (resPtr->compiledVarResProc) { - result = (*resPtr->compiledVarResProc)(nsPtr->interp, + result = resPtr->compiledVarResProc(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } @@ -1316,7 +1285,38 @@ InitResolvedLocals( } localPtr = firstLocalPtr; codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; - goto doInitResolvedLocals; + + /* + * Initialize the array of local variables stored in the call frame. Some + * variables may have special resolution rules. In that case, we call + * their "resolver" procs to get our hands on the variable, and we make + * the compiled local a link to the real variable. + */ + + doInitResolvedLocals: + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->flags = 0; + varPtr->value.objPtr = NULL; + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo && resVarInfo->fetchProc) { + register Var *resolvedVarPtr = (Var *) + resVarInfo->fetchProc(interp, resVarInfo); + + if (resolvedVarPtr) { + if (TclIsVarInHash(resolvedVarPtr)) { + VarHashRefCount(resolvedVarPtr)++; + } + varPtr->flags = VAR_LINK; + varPtr->value.linkPtr = resolvedVarPtr; + } + } + } } void @@ -1328,12 +1328,13 @@ TclFreeLocalCache( Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { - Tcl_Obj *objPtr = *namePtrPtr; + register Tcl_Obj *objPtr = *namePtrPtr; + /* - * Note that this can be called with interp==NULL, on interp - * deletion. In that case, the literal table and objects go away - * on their own. + * Note that this can be called with interp==NULL, on interp deletion. + * In that case, the literal table and objects go away on their own. */ + if (objPtr) { if (interp) { TclReleaseLiteral(interp, objPtr); @@ -1346,7 +1347,8 @@ TclFreeLocalCache( } static void -InitLocalCache(Proc *procPtr) +InitLocalCache( + Proc *procPtr) { Interp *iPtr = procPtr->iPtr; ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; @@ -1393,7 +1395,7 @@ InitLocalCache(Proc *procPtr) } codePtr->localCachePtr = localCachePtr; localCachePtr->refCount = 1; - localCachePtr->numVars = localCt; + localCachePtr->numVars = localCt; } static int @@ -1410,7 +1412,7 @@ InitArgsAndLocals( register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; - + /* * Make sure that the local cache of variable names and initial values has * been initialised properly . @@ -1426,14 +1428,14 @@ InitArgsAndLocals( } else { defPtr = NULL; } - + /* * Create the "compiledLocals" array. Make sure it is large enough to hold * all the procedure's compiled local variables, including its formal * parameters. */ - varPtr = (Var *) TclStackAlloc(interp, (int)(localCt * sizeof(Var))); + varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; @@ -1476,13 +1478,12 @@ InitArgsAndLocals( Tcl_Obj *objPtr = defPtr->value.objPtr; - if (objPtr) { - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var reference. */ - } else { + if (!objPtr) { goto incorrectArgs; } + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var reference. */ } /* @@ -1568,7 +1569,7 @@ PushProcCallFrame( int isLambda) /* 1 if this is a call by ApplyObjCmd: it * needs special rules for error msg */ { - Proc *procPtr = (Proc *) clientData; + Proc *procPtr = clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; int result; @@ -1664,7 +1665,7 @@ TclObjInterpProc( /* * Not used much in the core; external interface for iTcl */ - + return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); } @@ -1726,7 +1727,7 @@ TclNRInterpProcCore( freePtr = iPtr->framePtr; Tcl_PopCallFrame(interp); /* Pop but do not free. */ TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ + /* Free compiledLocals. */ TclStackFree(interp, freePtr); /* Free CallFrame. */ return TCL_ERROR; } @@ -1756,7 +1757,7 @@ TclNRInterpProcCore( int i; for (i = 0 ; i < 10 ; i++) { - a[i] = (l < iPtr->varFramePtr->objc ? + a[i] = (l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL); l++; } @@ -1766,7 +1767,7 @@ TclNRInterpProcCore( if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); char *a[6]; int i[2]; - + TclDTraceInfo(info, a, i); TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); @@ -1805,7 +1806,7 @@ InterpProcNR2( CallFrame *freePtr; Tcl_Obj *procNameObj = data[0]; ProcErrorProc errorProc = data[1]; - + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; @@ -1853,7 +1854,7 @@ InterpProcNR2( * function handed to us as an argument. */ - (*errorProc)(interp, procNameObj); + errorProc(interp, procNameObj); default: /* @@ -2012,7 +2013,7 @@ TclProcCompileProc( clPtr = clPtr->nextPtr; } - if (lastPtr) { + if (lastPtr) { lastPtr->nextPtr = NULL; } else { procPtr->firstLocalPtr = NULL; @@ -2026,8 +2027,8 @@ TclProcCompileProc( procPtr->numCompiledLocals = procPtr->numArgs; } - (void) TclPushStackFrame(interp, &framePtr, - (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); + TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, + /* isProcCallFrame */ 0); /* * TIP #280: We get the invoking context from the cmdFrame which @@ -2041,9 +2042,8 @@ TclProcCompileProc( */ iPtr->invokeWord = 0; - iPtr->invokeCmdFramePtr = - (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL); - (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr); + iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); + tclByteCodeType.setFromAnyProc(interp, bodyPtr); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); iPtr->compiledProcPtr = saveProcPtr; @@ -2118,7 +2118,7 @@ void TclProcDeleteProc( ClientData clientData) /* Procedure to be deleted. */ { - Proc *procPtr = (Proc *) clientData; + Proc *procPtr = clientData; procPtr->refCount--; if (procPtr->refCount <= 0) { @@ -2164,7 +2164,7 @@ TclProcCleanupProc( resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { - (*resVarInfo->deleteProc)(resVarInfo); + resVarInfo->deleteProc(resVarInfo); } else { ckfree((char *) resVarInfo); } @@ -2194,7 +2194,7 @@ TclProcCleanupProc( return; } - cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); + cfPtr = Tcl_GetHashValue(hePtr); if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); @@ -2490,11 +2490,9 @@ SetLambdaFromAny( */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr; + CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; - if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve the source context from the bytecode. This call @@ -2655,7 +2653,7 @@ TclNRApplyObjCmd( * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt * the code. (MS) */ - + #if JOE_EXTENSION else { /* @@ -2701,11 +2699,11 @@ TclNRApplyObjCmd( /* * TIP#280 (semi-)HACK! * - * Using cmd.clientData to tell [info frame] how to render the - * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr - * for NULL. This condition holds here because of the 'memset' above, and - * nowhere else (in the core). Regular commands always have a valid - * 'hPtr', and lambda's never. + * Using cmd.clientData to tell [info frame] how to render the lambdaPtr. + * The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL. + * This condition holds here because of the memset() above, and nowhere + * else (in the core). Regular commands always have a valid hPtr, and + * lambda's never. */ extraPtr->efi.length = 1; @@ -2724,7 +2722,7 @@ TclNRApplyObjCmd( } extraPtr->isRootEnsemble = isRootEnsemble; - result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); @@ -2739,7 +2737,7 @@ ApplyNR2( int result) { ApplyExtraData *extraPtr = data[0]; - + if (extraPtr->isRootEnsemble) { ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } @@ -2804,15 +2802,20 @@ Tcl_DisassembleObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *types[] = { - "lambda", "proc", "script", NULL + "lambda", "method", "objmethod", "proc", "script", NULL }; enum Types { - DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT + DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, + DISAS_SCRIPT }; int idx, result; + Tcl_Obj *codeObjPtr = NULL; + Proc *procPtr = NULL; + Tcl_HashEntry *hPtr; + Object *oPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ @@ -2821,7 +2824,6 @@ Tcl_DisassembleObjCmd( switch ((enum Types) idx) { case DISAS_LAMBDA: { - Proc *procPtr = NULL; Command cmd; Tcl_Obj *nsObjPtr; Tcl_Namespace *nsPtr; @@ -2830,6 +2832,10 @@ Tcl_DisassembleObjCmd( * Compile (if uncompiled) and disassemble a lambda term. */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); + return TCL_ERROR; + } if (objv[2]->typePtr == &lambdaType) { procPtr = objv[2]->internalRep.twoPtrValue.ptr1; } @@ -2854,55 +2860,140 @@ Tcl_DisassembleObjCmd( return result; } TclPopStackFrame(interp); - if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", - NULL); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_PROC: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; + } else { + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script"); + return TCL_ERROR; + } + if (objv[2]->typePtr != &tclByteCodeType) { + if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ + return TCL_ERROR; + } } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + codeObjPtr = objv[2]; break; - } - case DISAS_PROC: { - Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); + case DISAS_CLASS_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); return TCL_ERROR; } /* - * Compile (if uncompiled) and disassemble a procedure. + * Look up the body of a class method. */ - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; } - TclPopStackFrame(interp); - if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", - NULL); + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" is not a class", NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); - break; - } - case DISAS_SCRIPT: + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) objv[3]); + goto methodBody; + case DISAS_OBJECT_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); + return TCL_ERROR; + } + /* - * Compile and disassemble a script. + * Look up the body of an instance method. */ - if (objv[2]->typePtr != &tclByteCodeType) { - if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ - return TCL_ERROR; + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->methodsPtr == NULL) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + + /* + * Compile (if necessary) and disassemble a method body. + */ + + methodBody: + if (hPtr == NULL) { + unknownMethod: + Tcl_AppendResult(interp, "unknown method \"", + TclGetString(objv[3]), "\"", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_AppendResult(interp, + "body not available for this kind of method", NULL); + return TCL_ERROR; + } + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of method", + TclGetString(objv[3])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; } } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2])); + codeObjPtr = procPtr->bodyPtr; break; } + + /* + * Do the actual disassembly. + */ + + if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); return TCL_OK; } -- cgit v0.12