summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c363
1 files changed, 227 insertions, 136 deletions
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;
}
generated by cgit v0.12 at 2024-11-07 06:05:32 (GMT)