diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 179 |
1 files changed, 118 insertions, 61 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index 96bdcf3..1679a09 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Variables that are part of the [apply] command implementation and which @@ -67,6 +68,22 @@ const Tcl_ObjType tclProcBodyType = { * should panic instead. */ }; +#define ProcSetIntRep(objPtr, procPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (procPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ + } while (0) + +#define ProcGetIntRep(objPtr, procPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclProcBodyType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The [upvar]/[uplevel] level reference type. Uses the longValue field * to remember the integer value of a parsed #<integer> format. @@ -89,13 +106,31 @@ static const Tcl_ObjType levelReferenceType = { * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -const Tcl_ObjType tclLambdaType = { +static const Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; + +#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = (nsObjPtr); \ + Tcl_IncrRefCount((nsObjPtr)); \ + Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ + } while (0) + +#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &lambdaType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -318,7 +353,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (objv[3]->typePtr == &tclProcBodyType) { + if (Tcl_FetchIntRep(objv[3], &tclProcBodyType)) { goto done; } @@ -395,14 +430,15 @@ TclCreateProc( Interp *iPtr = (Interp *) interp; const char **argArray = NULL; - register Proc *procPtr; + register Proc *procPtr = NULL; int i, length, result, numArgs; const char *args, *bytes, *p; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr; int precompiled = 0; - if (bodyPtr->typePtr == &tclProcBodyType) { + ProcGetIntRep(bodyPtr, procPtr); + if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to @@ -415,7 +451,6 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -805,6 +840,7 @@ TclObjGetFrame( { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; + const Tcl_ObjIntRep *irPtr; const char *name = NULL; /* @@ -825,16 +861,17 @@ TclObjGetFrame( && (level >= 0)) { level = curLevel - level; result = 1; - } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + } else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) { + level = irPtr->longValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; + Tcl_ObjIntRep ir; + + ir.longValue = level; + Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); result = 1; } else { result = -1; @@ -1156,10 +1193,10 @@ TclInitCompiledLocals( ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr == NULL) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1322,7 +1359,7 @@ InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1332,6 +1369,8 @@ InitLocalCache( CompiledLocal *localPtr; int new; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Cache the names and initial values of local variables; store the * cache in both the framePtr for this execution and in the codePtr @@ -1399,11 +1438,13 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Make sure that the local cache of variable names and initial values has * been initialised properly . @@ -1578,7 +1619,8 @@ TclPushProcCallFrame( * local variables are found while compiling. */ - if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { Interp *iPtr = (Interp *) interp; /* @@ -1590,7 +1632,6 @@ TclPushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) @@ -1788,7 +1829,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1922,7 +1963,9 @@ TclProcCompileProc( { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1938,7 +1981,7 @@ TclProcCompileProc( * are not recompiled, even if things have changed. */ - if (bodyPtr->typePtr == &tclByteCodeType) { + if (codePtr != NULL) { if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) @@ -1957,11 +2000,12 @@ TclProcCompileProc( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - TclFreeIntRep(bodyPtr); + Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); + codePtr = NULL; } } - if (bodyPtr->typePtr != &tclByteCodeType) { + if (codePtr == NULL) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG @@ -2310,10 +2354,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - - procPtr->refCount++; + ProcSetIntRep(objPtr, procPtr); } return objPtr; @@ -2341,11 +2382,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + ProcGetIntRep(srcPtr, procPtr); - dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; - procPtr->refCount++; + ProcSetIntRep(dupPtr, procPtr); } /* @@ -2371,7 +2411,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + + ProcGetIntRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); @@ -2397,15 +2439,15 @@ DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; - copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &tclLambdaType; + + LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); } static void @@ -2413,14 +2455,16 @@ FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); if (procPtr->refCount-- == 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); - objPtr->typePtr = NULL; } static int @@ -2441,7 +2485,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to tclLambdaType. + * length is not 2, then it cannot be converted to lambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2582,21 +2626,42 @@ SetLambdaFromAny( } } - Tcl_IncrRefCount(nsObjPtr); - /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to tclLambdaType. + * conversion to lambdaType. */ - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &tclLambdaType; + LambdaSetIntRep(objPtr, procPtr, nsObjPtr); return TCL_OK; } + +Proc * +TclGetLambdaFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj **nsObjPtrPtr) +{ + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + + if (procPtr == NULL) { + if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { + return NULL; + } + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + } + + assert(procPtr != NULL); + if (procPtr->iPtr != (Interp *)interp) { + return NULL; + } + + *nsObjPtrPtr = nsObjPtr; + return procPtr; +} /* *---------------------------------------------------------------------- @@ -2632,7 +2697,6 @@ TclNRApplyObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; int result; @@ -2650,24 +2714,17 @@ TclNRApplyObjCmd( */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &tclLambdaType) { - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; - } + procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { - result = SetLambdaFromAny(interp, lambdaPtr); - if (result != TCL_OK) { - return result; - } - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + if (procPtr == NULL) { + return TCL_ERROR; } /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. + * Push a call frame for the lambda namespace. + * Note that TclObjInterpProc() will pop it. */ - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; |