diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 608 |
1 files changed, 330 insertions, 278 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index 80c792c..ce1c767 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -11,8 +11,6 @@ * * 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.168 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -75,9 +73,9 @@ const Tcl_ObjType tclProcBodyType = { }; /* - * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, - * encoding the type of level reference in ptr1 and the actual parsed out - * offset in ptr2. + * The [upvar]/[uplevel] level reference type. Uses the ptrAndLongRep field, + * encoding the type of level reference in ptr and the actual parsed out + * offset in value. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. @@ -132,7 +130,7 @@ Tcl_ProcObjCmd( { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - char *fullName; + const char *fullName; const char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; @@ -154,20 +152,25 @@ Tcl_ProcObjCmd( &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": unknown namespace", + fullName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\": bad procedure name", + fullName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create procedure \"%s\" in non-global namespace with" + " name starting with \":\"", procName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -193,7 +196,7 @@ Tcl_ProcObjCmd( Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, procName, -1); @@ -255,11 +258,11 @@ Tcl_ProcObjCmd( && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -268,11 +271,11 @@ Tcl_ProcObjCmd( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew); + procPtr, &isNew); if (!isNew) { /* * Get the old command frame and release it. See also @@ -287,9 +290,9 @@ Tcl_ProcObjCmd( Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - ckfree((char *) cfOldPtr->line); + ckfree(cfOldPtr->line); cfOldPtr->line = NULL; - ckfree((char *) cfOldPtr); + ckfree(cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } @@ -332,8 +335,10 @@ Tcl_ProcObjCmd( } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { + int numBytes; + procArgs +=4; - while(*procArgs != '\0') { + while (*procArgs != '\0') { if (*procArgs != ' ') { goto done; } @@ -344,12 +349,9 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = TclGetString(objv[3]); - while (*procBody != '\0') { - if (!isspace(UCHAR(*procBody))) { - goto done; - } - procBody++; + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { + goto done; } /* @@ -419,7 +421,7 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.otherValuePtr; + procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -440,8 +442,18 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + Tcl_Obj *sharedBodyPtr = bodyPtr; + bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); + + /* + * TIP #280. + * Ensure that the continuation line data for the original body is + * not lost and applies to the new body as well. + */ + + TclContinuationsCopy(bodyPtr, sharedBodyPtr); } /* @@ -452,7 +464,7 @@ TclCreateProc( Tcl_IncrRefCount(bodyPtr); - procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr = ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; @@ -483,6 +495,8 @@ TclCreateProc( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -505,15 +519,20 @@ TclCreateProc( goto procError; } if (fieldCount > 2) { - ckfree((char *) fieldValues); - Tcl_AppendResult(interp, - "too many fields in argument specifier \"", - argArray[i], "\"", NULL); + ckfree(fieldValues); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "too many fields in argument specifier \"%s\"", + argArray[i])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree((char *) fieldValues); - Tcl_AppendResult(interp, "argument with no name", NULL); + ckfree(fieldValues); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument with no name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } @@ -537,17 +556,21 @@ TclCreateProc( } while (*q != '\0'); q--; if (*q == ')') { /* We have an array element. */ - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], - "\" is an array element", NULL); - ckfree((char *) fieldValues); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is an array element", + fieldValues[0])); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], - "\" is not a simple name", NULL); - ckfree((char *) fieldValues); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" is not a simple name", + fieldValues[0])); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; @@ -574,7 +597,9 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree((char *) fieldValues); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } @@ -584,7 +609,7 @@ TclCreateProc( if (localPtr->defValuePtr != NULL) { int tmpLength; - char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, + const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); if ((valueLength != tmpLength) || @@ -593,7 +618,9 @@ TclCreateProc( "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", procName, fieldValues[0])); - ckfree((char *) fieldValues); + ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } } @@ -611,9 +638,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameLength + 1)); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -633,7 +658,7 @@ TclCreateProc( } else { localPtr->defValuePtr = NULL; } - strcpy(localPtr->name, fieldValues[0]); + memcpy(localPtr->name, fieldValues[0], nameLength + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -642,11 +667,11 @@ TclCreateProc( } } - ckfree((char *) fieldValues); + ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree((char *) argArray); + ckfree(argArray); return TCL_OK; procError: @@ -663,12 +688,12 @@ TclCreateProc( Tcl_DecrRefCount(defPtr); } - ckfree((char *) localPtr); + ckfree(localPtr); } - ckfree((char *) procPtr); + ckfree(procPtr); } if (argArray != NULL) { - ckfree((char *) argArray); + ckfree(argArray); } return TCL_ERROR; } @@ -747,8 +772,8 @@ TclGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -787,7 +812,7 @@ TclObjGetFrame( register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; - const char *name = TclGetString(objPtr); + const char *name; /* * Parse object to figure out which level number to go to. @@ -795,18 +820,24 @@ TclObjGetFrame( result = 1; curLevel = iPtr->varFramePtr->level; + if (objPtr == NULL) { + name = "1"; + goto haveLevel1; + } + + name = TclGetString(objPtr); if (objPtr->typePtr == &levelReferenceType) { - if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) { - level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) { + level = curLevel - objPtr->internalRep.ptrAndLongRep.value; } else { - level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + level = objPtr->internalRep.ptrAndLongRep.value; } if (level < 0) { goto levelError; } /* TODO: Consider skipping the typePtr checks */ } else if (objPtr->typePtr == &tclIntType -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG || objPtr->typePtr == &tclWideIntType #endif ) { @@ -827,8 +858,8 @@ TclObjGetFrame( TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + objPtr->internalRep.ptrAndLongRep.ptr = NULL; + objPtr->internalRep.ptrAndLongRep.value = level; } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ if (Tcl_GetInt(interp, name, &level) != TCL_OK) { return -1; @@ -842,14 +873,16 @@ TclObjGetFrame( TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + objPtr->internalRep.ptrAndLongRep.ptr = (void *) 1; /* non-NULL */ + objPtr->internalRep.ptrAndLongRep.value = level; level = curLevel - level; } else { /* - * Don't cache as the object *isn't* a level reference. + * Don't cache as the object *isn't* a level reference (might even be + * NULL...) */ + haveLevel1: level = curLevel - 1; result = 0; } @@ -871,8 +904,8 @@ TclObjGetFrame( return result; levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -954,11 +987,11 @@ TclNRUplevelObjCmd( if (result == -1) { return TCL_ERROR; } - objc -= (result+1); + objc -= result + 1; if (objc == 0) { goto uplevelSyntax; } - objv += (result+1); + objv += result + 1; /* * Modify the interpreter state to execute in the given frame. @@ -976,7 +1009,7 @@ TclNRUplevelObjCmd( * TIP #280. Make actual argument location available to eval'd script */ - TclArgumentGet (interp, objv[0], &invoker, &word); + TclArgumentGet(interp, objv[0], &invoker, &word); objPtr = objv[0]; } else { @@ -1067,26 +1100,6 @@ TclIsProc( return NULL; } -/* - *---------------------------------------------------------------------- - * - * InitArgsAndLocals -- - * - * This routine is invoked in order to initialize the arguments and other - * compiled locals table for a new call frame. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Allocates memory on the stack for the compiled local variables, the - * caller is responsible for freeing them. Initialises all variables. May - * invoke various name resolvers in order to determine which variables - * are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - static int ProcWrongNumArgs( Tcl_Interp *interp, @@ -1107,13 +1120,17 @@ ProcWrongNumArgs( desiredObjs = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * (numArgs+1)); + if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { + desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); + } else { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; + #ifdef AVOID_HACKS_FOR_ITCL - desiredObjs[0] = framePtr->objv[skip-1]; + desiredObjs[0] = framePtr->objv[skip-1]; #else - desiredObjs[0] = ((framePtr->isProcCallFrame & FRAME_IS_LAMBDA) - ? framePtr->objv[skip-1] - : Tcl_NewListObj(skip, framePtr->objv)); + desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); #endif /* AVOID_HACKS_FOR_ITCL */ + } Tcl_IncrRefCount(desiredObjs[0]); defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); @@ -1156,7 +1173,6 @@ ProcWrongNumArgs( * DEPRECATED: functionality has been inlined elsewhere; this function * remains to insure binary compatibility with Itcl. * - * Results: * None. * @@ -1166,6 +1182,7 @@ ProcWrongNumArgs( * *---------------------------------------------------------------------- */ + void TclInitCompiledLocals( Tcl_Interp *interp, /* Current interpreter. */ @@ -1180,7 +1197,7 @@ TclInitCompiledLocals( if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.otherValuePtr; + codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1249,7 +1266,7 @@ InitResolvedLocals( if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - ckfree((char *) localPtr->resolveInfo); + ckfree(localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } @@ -1287,7 +1304,7 @@ InitResolvedLocals( codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; /* - * Initialize the array of local variables stored in the call frame. Some + * 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. @@ -1318,7 +1335,7 @@ InitResolvedLocals( } } } - + void TclFreeLocalCache( Tcl_Interp *interp, @@ -1330,28 +1347,20 @@ TclFreeLocalCache( for (i = 0; i < localCachePtr->numVars; i++, 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. - */ - if (objPtr) { - if (interp) { - TclReleaseLiteral(interp, objPtr); - } else { - Tcl_DecrRefCount(objPtr); - } + /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ + TclReleaseLiteral(interp, objPtr); } } - ckfree((char *) localCachePtr); + ckfree(localCachePtr); } - + static void InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1367,9 +1376,9 @@ InitLocalCache( * for future calls. */ - localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache) - + (localCt-1)*sizeof(Tcl_Obj *) - + numArgs*sizeof(Var)); + localCachePtr = ckalloc(sizeof(LocalCache) + + (localCt - 1) * sizeof(Tcl_Obj *) + + numArgs * sizeof(Var)); namePtr = &localCachePtr->varName0; varPtr = (Var *) (namePtr + localCt); @@ -1391,12 +1400,32 @@ InitLocalCache( i++; } namePtr++; - localPtr=localPtr->nextPtr; + localPtr = localPtr->nextPtr; } codePtr->localCachePtr = localCachePtr; localCachePtr->refCount = 1; localCachePtr->numVars = localCt; } + +/* + *---------------------------------------------------------------------- + * + * InitArgsAndLocals -- + * + * This routine is invoked in order to initialize the arguments and other + * compiled locals table for a new call frame. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Allocates memory on the stack for the compiled local variables, the + * caller is responsible for freeing them. Initialises all variables. May + * invoke various name resolvers in order to determine which variables + * are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ static int InitArgsAndLocals( @@ -1408,7 +1437,7 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; @@ -1458,7 +1487,7 @@ InitArgsAndLocals( } } imax = ((argCt < numArgs-1) ? argCt : numArgs-1); - for (i = 0; i < imax; i++, varPtr++, defPtr++) { + for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. @@ -1470,13 +1499,13 @@ InitArgsAndLocals( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ } - for (; i < numArgs-1; i++, varPtr++, defPtr++) { + for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* * This loop is entered if argCt < (numArgs-1). Set default values; * last formal is special. */ - Tcl_Obj *objPtr = defPtr->value.objPtr; + Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL; if (!objPtr) { goto incorrectArgs; @@ -1492,7 +1521,7 @@ InitArgsAndLocals( */ varPtr->flags = 0; - if (defPtr->flags & VAR_IS_ARGS) { + if (defPtr && defPtr->flags & VAR_IS_ARGS) { Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); varPtr->value.objPtr = listPtr; @@ -1502,7 +1531,7 @@ InitArgsAndLocals( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) { + } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) { Tcl_Obj *objPtr = defPtr->value.objPtr; varPtr->value.objPtr = objPtr; @@ -1559,7 +1588,7 @@ InitArgsAndLocals( static int PushProcCallFrame( - ClientData clientData, /* Record describing procedure to be + ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1595,8 +1624,8 @@ PushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { @@ -1654,7 +1683,7 @@ PushProcCallFrame( int TclObjInterpProc( - ClientData clientData, /* Record describing procedure to be + ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1671,7 +1700,7 @@ TclObjInterpProc( int TclNRInterpProc( - ClientData clientData, /* Record describing procedure to be + ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1713,7 +1742,7 @@ TclNRInterpProcCore( Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ - ProcErrorProc errorProc) /* How to convert results from the script into + ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ { Interp *iPtr = (Interp *) interp; @@ -1751,9 +1780,10 @@ TclNRInterpProcCore( } #endif /*TCL_COMPILE_DEBUG*/ +#ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - char *a[10]; + const char *a[10]; int i; for (i = 0 ; i < 10 ; i++) { @@ -1780,19 +1810,26 @@ TclNRInterpProcCore( iPtr->varFramePtr->objc - l - 1, (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + + TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, + iPtr->varFramePtr->objc - l - 1, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); + } +#endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } static int @@ -1805,7 +1842,7 @@ InterpProcNR2( Proc *procPtr = iPtr->varFramePtr->procPtr; CallFrame *freePtr; Tcl_Obj *procNameObj = data[0]; - ProcErrorProc *errorProc = data[1]; + ProcErrorProc *errorProc = (ProcErrorProc *)data[1]; if (TCL_DTRACE_PROC_RETURN_ENABLED()) { int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; @@ -1818,9 +1855,39 @@ InterpProcNR2( } /* - * Process the result code. + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. + */ + + if (result != TCL_OK) { + goto process; + } + + done: + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Obj *r = Tcl_GetObjResult(interp); + + TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, + TclGetString(r), r); + } + + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return result; + + /* + * Process any non-TCL_OK result code. */ + process: switch (result) { case TCL_RETURN: /* @@ -1837,10 +1904,10 @@ InterpProcNR2( * transform to an error now. */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((result == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invoked \"%s\" outside of a loop", + ((result == TCL_BREAK) ? "break" : "continue"))); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; /* @@ -1855,46 +1922,8 @@ InterpProcNR2( */ errorProc(interp, procNameObj); - - default: - /* - * Process other results (OK and non-standard) by doing nothing - * special, skipping directly to the code afterwards that cleans up - * associated memory. - * - * Non-standard results are processed by passing them through quickly. - * This means they all work as exceptions, unwinding the stack quickly - * and neatly. Who knows how well they are handled by third-party code - * though... - */ - - (void) 0; /* do nothing */ } - - if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, - TclGetString(r), r); - } - - /* - * Free the stack-allocated compiled locals and CallFrame. It is important - * to pop the call frame without freeing it first: the compiledLocals - * cannot be freed before the frame is popped, as the local variables must - * be deleted. But the compiledLocals must be freed first, as they were - * allocated later on the stack. - */ - - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - - return result; + goto done; } /* @@ -1922,16 +1951,15 @@ TclProcCompileProc( Tcl_Interp *interp, /* Interpreter containing procedure. */ Proc *procPtr, /* Data associated with procedure. */ Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, - * but could be any code fragment compiled in - * the context of this procedure.) */ + * but could be any code fragment compiled in + * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ const char *description, /* string describing this body of code. */ const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - Proc *saveProcPtr; - ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1948,7 +1976,7 @@ TclProcCompileProc( */ if (bodyPtr->typePtr == &tclByteCodeType) { - if (((Interp *) *codePtr->interpHandle == iPtr) + if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { @@ -1957,27 +1985,28 @@ TclProcCompileProc( if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "a precompiled script jumped interps", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - bodyPtr->typePtr->freeIntRepProc(bodyPtr); - bodyPtr->typePtr = NULL; - } + TclFreeIntRep(bodyPtr); + } } if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we are about + * to compile. + */ Tcl_Obj *message; @@ -1985,23 +2014,22 @@ TclProcCompileProc( Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); - fprintf(stdout, "%s\"\n", TclGetString(message)); + fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); - } + } #endif - /* - * Plug the current procPtr into the interpreter and coerce the code - * body to byte codes. The interpreter needs to know which proc it's - * compiling so that it can access its list of compiled locals. - * - * TRICKY NOTE: Be careful to push a call frame with the proper - * namespace context, so that the byte codes are compiled in the - * appropriate class context. - */ + /* + * Plug the current procPtr into the interpreter and coerce the code + * body to byte codes. The interpreter needs to know which proc it's + * compiling so that it can access its list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the proper + * namespace context, so that the byte codes are compiled in the + * appropriate class context. + */ - saveProcPtr = iPtr->compiledProcPtr; - iPtr->compiledProcPtr = procPtr; + iPtr->compiledProcPtr = procPtr; if (procPtr->numCompiledLocals > procPtr->numArgs) { CompiledLocal *clPtr = procPtr->firstLocalPtr; @@ -2021,13 +2049,21 @@ TclProcCompileProc( procPtr->lastLocalPtr = lastPtr; while (clPtr) { CompiledLocal *toFree = clPtr; + clPtr = clPtr->nextPtr; - ckfree((char *) toFree); + if (toFree->resolveInfo) { + if (toFree->resolveInfo->deleteProc) { + toFree->resolveInfo->deleteProc(toFree->resolveInfo); + } else { + ckfree(toFree->resolveInfo); + } + } + ckfree(toFree); } procPtr->numCompiledLocals = procPtr->numArgs; } - TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, + TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); /* @@ -2043,10 +2079,9 @@ TclProcCompileProc( iPtr->invokeWord = 0; iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); - tclByteCodeType.setFromAnyProc(interp, bodyPtr); + TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); - iPtr->compiledProcPtr = saveProcPtr; } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { /* * The resolver epoch has changed, but we only need to invalidate the @@ -2166,7 +2201,7 @@ TclProcCleanupProc( if (resVarInfo->deleteProc) { resVarInfo->deleteProc(resVarInfo); } else { - ckfree((char *) resVarInfo); + ckfree(resVarInfo); } } @@ -2174,10 +2209,10 @@ TclProcCleanupProc( defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - ckfree((char *) localPtr); + ckfree(localPtr); localPtr = nextPtr; } - ckfree((char *) procPtr); + ckfree(procPtr); /* * TIP #280: Release the location data associated with this Proc @@ -2185,7 +2220,7 @@ TclProcCleanupProc( * procbody structures created by tbcload. */ - if (!iPtr) { + if (iPtr == NULL) { return; } @@ -2196,13 +2231,15 @@ TclProcCleanupProc( cfPtr = Tcl_GetHashValue(hePtr); - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); - cfPtr->data.eval.path = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + cfPtr->data.eval.path = NULL; + } + ckfree(cfPtr->line); + cfPtr->line = NULL; + ckfree(cfPtr); } - ckfree((char *) cfPtr->line); - cfPtr->line = NULL; - ckfree((char *) cfPtr); Tcl_DeleteHashEntry(hePtr); } @@ -2312,7 +2349,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = procPtr; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2342,10 +2379,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.otherValuePtr; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = procPtr; + dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2372,10 +2409,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.otherValuePtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - procPtr->refCount--; - if (procPtr->refCount <= 0) { + if (procPtr->refCount-- < 2) { TclProcCleanupProc(procPtr); } } @@ -2423,6 +2459,7 @@ FreeLambdaInternalRep( TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); + objPtr->typePtr = NULL; } static int @@ -2431,22 +2468,27 @@ SetLambdaFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; - char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; - int objc, result; + const char *name; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; + int isNew, objc, result; + CmdFrame *cfPtr = NULL; Proc *procPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Convert objPtr to list type first; if it cannot be converted, or if its * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjGetElements(interp, objPtr, &objc, &objv); + result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - TclNewLiteralStringObj(errPtr, "can't interpret \""); - Tcl_AppendObjToObj(errPtr, objPtr); - Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); - Tcl_SetObjResult(interp, errPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't interpret \"%s\" as a lambda expression", + Tcl_GetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } @@ -2524,19 +2566,19 @@ SetLambdaFromAny( if (contextPtr->line && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { - int isNew, buf[2]; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ - TclListLines(name, contextPtr->line[1], 2, buf); + cfPtr = ckalloc(sizeof(CmdFrame)); + TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (int *) ckalloc(sizeof(int)); + cfPtr->line = ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -2545,11 +2587,8 @@ SetLambdaFromAny( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; - - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew), cfPtr); + cfPtr->cmd = NULL; + cfPtr->len = 0; } /* @@ -2561,6 +2600,8 @@ SetLambdaFromAny( } TclStackFree(interp, contextPtr); } + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, + &isNew), cfPtr); /* * Set the namespace for this lambda: given by objv[2] understood as a @@ -2570,7 +2611,7 @@ SetLambdaFromAny( if (objc == 2) { TclNewLiteralStringObj(nsObjPtr, "::"); } else { - char *nsName = TclGetString(objv[2]); + const char *nsName = TclGetString(objv[2]); if ((*nsName != ':') || (*(nsName+1) != ':')) { TclNewLiteralStringObj(nsObjPtr, "::"); @@ -2588,7 +2629,7 @@ SetLambdaFromAny( * conversion to lambdaType. */ - objPtr->typePtr->freeIntRepProc(objPtr); + TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; @@ -2663,7 +2704,6 @@ TclNRApplyObjCmd( else { /* * Joe English's suggestion to allow cmdNames to function as lambdas. - * Also requires making tclCmdNameType non-static in tclObj.c */ Tcl_Obj *elemPtr; @@ -2872,26 +2912,28 @@ Tcl_DisassembleObjCmd( 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. - */ + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; + /* + * 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. @@ -2901,10 +2943,9 @@ Tcl_DisassembleObjCmd( 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; - } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; } codeObjPtr = objv[2]; break; @@ -2924,8 +2965,10 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" is not a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, @@ -2957,14 +3000,18 @@ Tcl_DisassembleObjCmd( methodBody: if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", - TclGetString(objv[3]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "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); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { @@ -2987,15 +3034,20 @@ Tcl_DisassembleObjCmd( } codeObjPtr = procPtr->bodyPtr; break; + default: + CLANG_ASSERT(0); } /* * Do the actual disassembly. */ - if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags + if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); |