diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 1831 |
1 files changed, 1136 insertions, 695 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index 8cd8aa1..ce1c767 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -7,15 +7,26 @@ * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004-2006 Miguel Sofer + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * 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.125 2007/06/20 18:46:14 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tclOOInt.h" + +/* + * Variables that are part of the [apply] command implementation and which + * have to be passed to the other side of the NRE call. + */ + +typedef struct { + int isRootEnsemble; + Command cmd; + ExtraFrameInfo efi; +} ApplyExtraData; /* * Prototypes for static functions in this file @@ -26,29 +37,31 @@ static void DupLambdaInternalRep(Tcl_Obj *objPtr, static void FreeLambdaInternalRep(Tcl_Obj *objPtr); static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip); -static void InitCompiledLocals(Tcl_Interp *interp, - ByteCode *codePtr, CompiledLocal *localPtr, - Var *varPtr, Namespace *nsPtr); +static void InitResolvedLocals(Tcl_Interp *interp, + ByteCode *codePtr, Var *defPtr, + Namespace *nsPtr); +static void InitLocalCache(Proc *procPtr); static int PushProcCallFrame(ClientData clientData, register Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], int isLambda); + 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 void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, - Tcl_Obj *bodyPtr, Namespace *nsPtr, - CONST char *description, CONST char *procName, - Proc **procPtrPtr); + +static Tcl_NRPostProc ApplyNR2; +static Tcl_NRPostProc InterpProcNR2; +static Tcl_NRPostProc Uplevel_Callback; /* * The ProcBodyObjType type */ -Tcl_ObjType tclProcBodyType = { +const Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ ProcBodyFree, /* FreeInternalRep function */ ProcBodyDup, /* DupInternalRep function */ @@ -60,15 +73,15 @@ 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. */ -static Tcl_ObjType levelReferenceType = { +static const Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; @@ -82,7 +95,7 @@ static Tcl_ObjType levelReferenceType = { * will execute within. */ -static Tcl_ObjType lambdaType = { +static const Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ @@ -113,12 +126,12 @@ Tcl_ProcObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - char *fullName; - CONST char *procName, *procArgs, *procBody; + const char *fullName; + const char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; @@ -139,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; } @@ -178,13 +196,12 @@ 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); - cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), - TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); - + cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, + TclNRInterpProc, procPtr, TclProcDeleteProc); Tcl_DStringFree(&ds); /* @@ -210,11 +227,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 @@ -242,11 +257,12 @@ Tcl_ProcObjCmd( if (contextPtr->line && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + Tcl_HashEntry *hePtr; + 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; @@ -255,16 +271,35 @@ 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, + procPtr, &isNew); + if (!isNew) { + /* + * 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. + */ - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew), cfPtr); + CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr); + + if (cfOldPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfOldPtr->data.eval.path); + cfOldPtr->data.eval.path = NULL; + } + ckfree(cfOldPtr->line); + cfOldPtr->line = NULL; + ckfree(cfOldPtr); + } + Tcl_SetHashValue(hePtr, cfPtr); } /* - * '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); @@ -300,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; } @@ -312,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; } /* @@ -359,17 +393,17 @@ int TclCreateProc( Tcl_Interp *interp, /* Interpreter containing proc. */ Namespace *nsPtr, /* Namespace containing this proc. */ - CONST char *procName, /* Unqualified name of this proc. */ + const char *procName, /* Unqualified name of this proc. */ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - CONST char **argArray = NULL; + const char **argArray = NULL; register Proc *procPtr; int i, length, result, numArgs; - CONST char *args, *bytes, *p; + const char *args, *bytes, *p; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr; int precompiled = 0; @@ -387,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; @@ -408,8 +442,18 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { - bytes = Tcl_GetStringFromObj(bodyPtr, &length); + 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); } /* @@ -420,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; @@ -439,7 +483,7 @@ TclCreateProc( * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = Tcl_GetStringFromObj(argsPtr, &length); + args = TclGetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { goto procError; @@ -451,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; @@ -461,7 +507,7 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; - CONST char **fieldValues; + const char **fieldValues; /* * Now divide the specifier up into name and default. @@ -473,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; } @@ -499,23 +550,27 @@ TclCreateProc( p = fieldValues[0]; while (*p != '\0') { if (*p == '(') { - CONST char *q = p; + const char *q = p; do { q++; } 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++; @@ -523,23 +578,28 @@ TclCreateProc( if (precompiled) { /* - * Compare the parsed argument with the stored one. For the flags, - * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3 - * code in 8.4 where this is now used as an optimization - * indicator. Yes, this is a hack. -- hobbs + * Compare the parsed argument with the stored one. Note that the + * only flag value that makes sense at this point is VAR_ARGUMENT + * (its value was kept the same as pre VarReform to simplify + * tbcload's processing of older byetcodes). + * + * The only other flag vlaue that is important to retrieve from + * precompiled procs is VAR_TEMPORARY (also unchanged). It is + * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) - || ((localPtr->flags & ~VAR_UNDEFINED) - != (VAR_SCALAR | VAR_ARGUMENT)) + || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { 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; } @@ -549,7 +609,7 @@ TclCreateProc( if (localPtr->defValuePtr != NULL) { int tmpLength; - char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, + const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); if ((valueLength != tmpLength) || @@ -558,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; } } @@ -576,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 { @@ -588,7 +648,7 @@ TclCreateProc( localPtr->nextPtr = NULL; localPtr->nameLength = nameLength; localPtr->frameIndex = i; - localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; + localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { @@ -598,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') @@ -607,11 +667,11 @@ TclCreateProc( } } - ckfree((char *) fieldValues); + ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree((char *) argArray); + ckfree(argArray); return TCL_OK; procError: @@ -628,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; } @@ -666,7 +726,7 @@ TclCreateProc( int TclGetFrame( Tcl_Interp *interp, /* Interpreter in which to find frame. */ - CONST char *name, /* String describing frame. */ + const char *name, /* String describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { @@ -712,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; } @@ -752,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. @@ -760,22 +820,28 @@ 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 ) { - if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { + if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { goto levelError; } level = curLevel - level; @@ -792,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; @@ -807,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; } @@ -836,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; } @@ -858,17 +926,52 @@ TclObjGetFrame( *---------------------------------------------------------------------- */ +static int +Uplevel_Callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallFrame *savedVarFramePtr = data[0]; + + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp))); + } + + /* + * Restore the variable frame, and return. + */ + + ((Interp *)interp)->varFramePtr = savedVarFramePtr; + return result; +} + /* ARGSUSED */ int Tcl_UplevelObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv); +} + +int +TclNRUplevelObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + CmdFrame *invoker = NULL; + int word = 0; int result; CallFrame *savedVarFramePtr, *framePtr; + Tcl_Obj *objPtr; if (objc < 2) { uplevelSyntax: @@ -884,11 +987,11 @@ Tcl_UplevelObjCmd( 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. @@ -902,7 +1005,13 @@ Tcl_UplevelObjCmd( */ if (objc == 1) { - result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); + /* + * TIP #280. Make actual argument location available to eval'd script + */ + + TclArgumentGet(interp, objv[0], &invoker, &word); + objPtr = objv[0]; + } else { /* * More than one argument: concatenate them together with spaces @@ -910,22 +1019,12 @@ Tcl_UplevelObjCmd( * object when it decrements its refcount after eval'ing it. */ - Tcl_Obj *objPtr; - objPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"uplevel\" body line %d)", interp->errorLine)); - } - - /* - * Restore the variable frame, and return. - */ - iPtr->varFramePtr = savedVarFramePtr; - return result; + TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, + NULL); + return TclNREvalObjEx(interp, objPtr, 0, invoker, word); } /* @@ -954,10 +1053,9 @@ Tcl_UplevelObjCmd( Proc * TclFindProc( Interp *iPtr, /* Interpreter in which to look. */ - CONST char *procName) /* Name of desired procedure. */ + const char *procName) /* Name of desired procedure. */ { Tcl_Command cmd; - Tcl_Command origCmd; Command *cmdPtr; cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); @@ -966,14 +1064,7 @@ TclFindProc( } cmdPtr = (Command *) cmd; - origCmd = TclGetOriginalCommand(cmd); - if (origCmd != NULL) { - cmdPtr = (Command *) origCmd; - } - if (cmdPtr->objProc != TclObjInterpProc) { - return NULL; - } - return (Proc *) cmdPtr->objClientData; + return TclIsProc(cmdPtr); } /* @@ -998,16 +1089,322 @@ 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->objProc == TclObjInterpProc) { - return (Proc *) cmdPtr->objClientData; + if (cmdPtr->deleteProc == TclProcDeleteProc) { + return cmdPtr->objClientData; + } + return NULL; +} + +static int +ProcWrongNumArgs( + Tcl_Interp *interp, + int skip) +{ + CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + register Proc *procPtr = framePtr->procPtr; + register Var *defPtr; + 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 = 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]; +#else + desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); +#endif /* AVOID_HACKS_FOR_ITCL */ + } + Tcl_IncrRefCount(desiredObjs[0]); + + defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + for (i=1 ; i<=numArgs ; i++, defPtr++) { + Tcl_Obj *argObj; + Tcl_Obj *namePtr = localName(framePtr, i-1); + + if (defPtr->value.objPtr != NULL) { + TclNewObj(argObj); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + } else if (defPtr->flags & VAR_IS_ARGS) { + numArgs--; + final = "?arg ...?"; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); + } + desiredObjs[i] = argObj; + } + + Tcl_ResetResult(interp); + Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); + + for (i=0 ; i<=numArgs ; i++) { + Tcl_DecrRefCount(desiredObjs[i]); + } + TclStackFree(interp, desiredObjs); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompiledLocals( + Tcl_Interp *interp, /* Current interpreter. */ + CallFrame *framePtr, /* Call frame to initialize. */ + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Var *varPtr = framePtr->compiledLocals; + Tcl_Obj *bodyPtr; + ByteCode *codePtr; + + bodyPtr = framePtr->procPtr->bodyPtr; + if (bodyPtr->typePtr != &tclByteCodeType) { + 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) { + InitLocalCache(framePtr->procPtr) ; + } + framePtr->localCachePtr = codePtr->localCachePtr; + framePtr->localCachePtr->refCount++; + } + + InitResolvedLocals(interp, codePtr, varPtr, nsPtr); +} + +/* + *---------------------------------------------------------------------- + * + * InitResolvedLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +static void +InitResolvedLocals( + Tcl_Interp *interp, /* Current interpreter. */ + ByteCode *codePtr, + Var *varPtr, + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Interp *iPtr = (Interp *) interp; + int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); + CompiledLocal *firstLocalPtr, *localPtr; + int varNum; + Tcl_ResolvedVarInfo *resVarInfo; + + /* + * Find the localPtr corresponding to varPtr + */ + + varNum = varPtr - iPtr->framePtr->compiledLocals; + localPtr = iPtr->framePtr->procPtr->firstLocalPtr; + while (varNum--) { + localPtr = localPtr->nextPtr; + } + + if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { + 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) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree(localPtr->resolveInfo); + } + 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, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = resPtr->compiledVarResProc(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + } + localPtr = firstLocalPtr; + 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) { + register Var *resolvedVarPtr = (Var *) + resVarInfo->fetchProc(interp, resVarInfo); + + if (resolvedVarPtr) { + if (TclIsVarInHash(resolvedVarPtr)) { + VarHashRefCount(resolvedVarPtr)++; + } + varPtr->flags = VAR_LINK; + varPtr->value.linkPtr = resolvedVarPtr; + } + } + } +} + +void +TclFreeLocalCache( + Tcl_Interp *interp, + LocalCache *localCachePtr) +{ + int i; + Tcl_Obj **namePtrPtr = &localCachePtr->varName0; + + for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { + register Tcl_Obj *objPtr = *namePtrPtr; + + if (objPtr) { + /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ + TclReleaseLiteral(interp, objPtr); + } + } + ckfree(localCachePtr); +} + +static void +InitLocalCache( + Proc *procPtr) +{ + Interp *iPtr = procPtr->iPtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + int localCt = procPtr->numCompiledLocals; + int numArgs = procPtr->numArgs, i = 0; + + Tcl_Obj **namePtr; + Var *varPtr; + LocalCache *localCachePtr; + CompiledLocal *localPtr; + int new; + + /* + * Cache the names and initial values of local variables; store the + * cache in both the framePtr for this execution and in the codePtr + * for future calls. + */ + + localCachePtr = ckalloc(sizeof(LocalCache) + + (localCt - 1) * sizeof(Tcl_Obj *) + + numArgs * sizeof(Var)); + + namePtr = &localCachePtr->varName0; + varPtr = (Var *) (namePtr + localCt); + localPtr = procPtr->firstLocalPtr; + while (localPtr) { + if (TclIsVarTemporary(localPtr)) { + *namePtr = NULL; + } else { + *namePtr = TclCreateLiteral(iPtr, localPtr->name, + localPtr->nameLength, /* hash */ (unsigned int) -1, + &new, /* nsPtr */ NULL, 0, NULL); + Tcl_IncrRefCount(*namePtr); + } + + if (i < numArgs) { + varPtr->flags = (localPtr->flags & VAR_IS_ARGS); + varPtr->value.objPtr = localPtr->defValuePtr; + varPtr++; + i++; + } + namePtr++; + localPtr = localPtr->nextPtr; } - return (Proc *) 0; + codePtr->localCachePtr = localCachePtr; + localCachePtr->refCount = 1; + localCachePtr->numVars = localCt; } /* @@ -1040,14 +1437,26 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; - register Var *varPtr; - register CompiledLocal *localPtr; - int localCt, numArgs, argCt, i, imax; - Var *compiledLocals; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + register Var *varPtr, *defPtr; + int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; - Tcl_Obj **desiredObjs; - const char *final; + + /* + * Make sure that the local cache of variable names and initial values has + * been initialised properly . + */ + + if (localCt) { + if (!codePtr->localCachePtr) { + InitLocalCache(procPtr) ; + } + framePtr->localCachePtr = codePtr->localCachePtr; + framePtr->localCachePtr->refCount++; + defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + } else { + defPtr = NULL; + } /* * Create the "compiledLocals" array. Make sure it is large enough to hold @@ -1055,10 +1464,9 @@ InitArgsAndLocals( * parameters. */ - localCt = procPtr->numCompiledLocals; - compiledLocals = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); + varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); + framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; - framePtr->compiledLocals = compiledLocals; /* * Match and assign the call's actual parameters to the procedure's formal @@ -1071,8 +1479,6 @@ InitArgsAndLocals( argCt = framePtr->objc - skip; /* Set it to the number of args to the * procedure. */ argObjs = framePtr->objv + skip; - varPtr = framePtr->compiledLocals; - localPtr = procPtr->firstLocalPtr; if (numArgs == 0) { if (argCt) { goto incorrectArgs; @@ -1081,7 +1487,7 @@ InitArgsAndLocals( } } imax = ((argCt < numArgs-1) ? argCt : numArgs-1); - for (i = 0; i < imax; i++) { + for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. @@ -1089,49 +1495,33 @@ InitArgsAndLocals( Tcl_Obj *objPtr = argObjs[i]; + varPtr->flags = 0; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - varPtr->name = localPtr->name; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - varPtr++; - localPtr = localPtr->nextPtr; } - for (; i < numArgs-1; i++) { + for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* * This loop is entered if argCt < (numArgs-1). Set default values; * last formal is special. */ - if (localPtr->defValuePtr != NULL) { - Tcl_Obj *objPtr = localPtr->defValuePtr; - - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - varPtr->name = localPtr->name; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - varPtr++; - localPtr = localPtr->nextPtr; - } else { + Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL; + + if (!objPtr) { goto incorrectArgs; } + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var reference. */ } /* * When we get here, the last formal argument remains to be defined: - * localPtr and varPtr point to the last argument to be initialized. + * defPtr and varPtr point to the last argument to be initialized. */ - if (localPtr->flags & VAR_IS_ARGS) { + varPtr->flags = 0; + if (defPtr && defPtr->flags & VAR_IS_ARGS) { Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); varPtr->value.objPtr = listPtr; @@ -1141,266 +1531,41 @@ InitArgsAndLocals( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) { - Tcl_Obj *objPtr = localPtr->defValuePtr; + } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) { + Tcl_Obj *objPtr = defPtr->value.objPtr; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ } else { goto incorrectArgs; } - - varPtr->name = localPtr->name; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - - localPtr = localPtr->nextPtr; varPtr++; /* - * Initialise and resolve the remaining compiledLocals. + * Initialise and resolve the remaining compiledLocals. In the absence of + * resolvers, they are undefined local vars: (flags=0, value=NULL). */ correctArgs: - if (localPtr) { - InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); + if (numArgs < localCt) { + if (!framePtr->nsPtr->compiledVarResProc + && !((Interp *)interp)->resolverPtr) { + memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); + } else { + InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); + } } return TCL_OK; - - incorrectArgs: /* - * Do initialise all compiled locals, to avoid problems at - * DeleteLocalVars. + * Initialise all compiled locals to avoid problems at DeleteLocalVars. */ - final = NULL; - InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); - - /* - * Build up desired argument list for Tcl_WrongNumArgs - */ - - desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * (numArgs+1)); - -#ifdef AVOID_HACKS_FOR_ITCL - desiredObjs[0] = framePtr->objv[skip-1]; -#else - desiredObjs[0] = ((framePtr->isProcCallFrame & FRAME_IS_LAMBDA) - ? framePtr->objv[skip-1] - : Tcl_NewListObj(skip, framePtr->objv)); -#endif /* AVOID_HACKS_FOR_ITCL */ - Tcl_IncrRefCount(desiredObjs[0]); - - localPtr = procPtr->firstLocalPtr; - for (i=1 ; i<=numArgs ; i++) { - Tcl_Obj *argObj; - - if (localPtr->defValuePtr != NULL) { - TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL); - } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) { - numArgs--; - final = "..."; - break; - } else { - argObj = Tcl_NewStringObj(localPtr->name, -1); - } - desiredObjs[i] = argObj; - localPtr = localPtr->nextPtr; - } - - Tcl_ResetResult(interp); - Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); - - for (i=0 ; i<=numArgs ; i++) { - Tcl_DecrRefCount(desiredObjs[i]); - } - TclStackFree(interp, desiredObjs); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * InitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled locals - * table for a new call frame. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -static void -InitCompiledLocals( - Tcl_Interp *interp, /* Current interpreter. */ - ByteCode *codePtr, - CompiledLocal *localPtr, - Var *varPtr, - Namespace *nsPtr) /* Pointer to current namespace. */ -{ - Interp *iPtr = (Interp *) interp; - int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); - CompiledLocal *firstLocalPtr; - - 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. - */ - - doInitCompiledLocals: - if (!haveResolvers) { - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* Will be just '\0' if temp - * var. */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - } - return; - } else { - Tcl_ResolvedVarInfo *resVarInfo; - - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* Will be just '\0' if temp - * var. */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - - /* - * 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) { - resolvedVarPtr->refCount++; - varPtr->value.linkPtr = resolvedVarPtr; - varPtr->flags = VAR_LINK; - } - } - } - return; - } - } else { - /* - * 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) { - if (localPtr->resolveInfo->deleteProc) { - localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); - } else { - ckfree((char *) localPtr->resolveInfo); - } - 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, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } else { - result = TCL_CONTINUE; - } - - while ((result == TCL_CONTINUE) && resPtr) { - if (resPtr->compiledVarResProc) { - result = (*resPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } - resPtr = resPtr->nextPtr; - } - if (result == TCL_OK) { - localPtr->resolveInfo = vinfo; - localPtr->flags |= VAR_RESOLVED; - } - } - } - localPtr = firstLocalPtr; - codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; - goto doInitCompiledLocals; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclInitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled locals - * table for a new call frame. - * - * DEPRECATED: functionality has been inlined elsewhere; this function - * remains to insure binary compatibility with Itcl. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -void -TclInitCompiledLocals( - Tcl_Interp *interp, /* Current interpreter. */ - CallFrame *framePtr, /* Call frame to initialize. */ - Namespace *nsPtr) /* Pointer to current namespace. */ -{ - Var *varPtr = framePtr->compiledLocals; - Tcl_Obj *bodyPtr; - ByteCode *codePtr; - CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr; - - bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { - Tcl_Panic("body object for proc attached to frame is not a byte code type"); - } - codePtr = bodyPtr->internalRep.otherValuePtr; - - InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); + incorrectArgs: + memset(varPtr, 0, + ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); + return ProcWrongNumArgs(interp, skip); } /* @@ -1423,20 +1588,21 @@ TclInitCompiledLocals( 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. */ int objc, /* Count of number of arguments to this * procedure. */ - Tcl_Obj *CONST objv[], /* Argument value objects. */ + Tcl_Obj *const objv[], /* Argument value objects. */ 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; + ByteCode *codePtr; /* * If necessary (i.e. if we haven't got a suitable compilation already @@ -1448,7 +1614,6 @@ PushProcCallFrame( if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { Interp *iPtr = (Interp *) interp; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; /* * When we've got bytecode, this is the check for validity. That is, @@ -1459,7 +1624,8 @@ PushProcCallFrame( * commands and/or resolver changes are considered). */ - 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)) { @@ -1467,9 +1633,9 @@ PushProcCallFrame( } } else { doCompilation: - result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, (isLambda ? "body of lambda term" : "body of proc"), - TclGetString(objv[isLambda]), &procPtr); + TclGetString(objv[isLambda])); if (result != TCL_OK) { return result; } @@ -1517,28 +1683,44 @@ 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. */ int objc, /* Count of number of arguments to this * procedure. */ - Tcl_Obj *CONST objv[]) /* Argument value objects. */ + Tcl_Obj *const objv[]) /* Argument value objects. */ { - int result; + /* + * Not used much in the core; external interface for iTcl + */ - result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); - if (result == TCL_OK) { - return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); - } else { + return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); +} + +int +TclNRInterpProc( + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *const objv[]) /* Argument value objects. */ +{ + int result = PushProcCallFrame(clientData, interp, objc, objv, + /*isLambda*/ 0); + + if (result != TCL_OK) { return TCL_ERROR; } + return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } /* *---------------------------------------------------------------------- * - * TclObjInterpProcCore -- + * TclNRInterpProcCore -- * * When a Tcl procedure, lambda term or anything else that works like a * procedure gets invoked during bytecode evaluation, this object-based @@ -1554,27 +1736,34 @@ TclObjInterpProc( */ int -TclObjInterpProcCore( +TclNRInterpProcCore( register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ 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. */ { - register Proc *procPtr = ((Interp *)interp)->varFramePtr->procPtr; + Interp *iPtr = (Interp *) interp; + register Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; + ByteCode *codePtr; result = InitArgsAndLocals(interp, procNameObj, skip); if (result != TCL_OK) { - goto procDone; + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return TCL_ERROR; } #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - register CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + register CallFrame *framePtr = iPtr->varFramePtr; register int i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { @@ -1591,37 +1780,114 @@ TclObjInterpProcCore( } #endif /*TCL_COMPILE_DEBUG*/ +#ifdef USE_DTRACE + if (TCL_DTRACE_PROC_ARGS_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + const char *a[10]; + int i; + + for (i = 0 ; i < 10 ; i++) { + a[i] = (l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL); + l++; + } + TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); + const 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); + } + 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)); + } + 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++; - ((Interp *)interp)->numLevels++; + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - if (TclInterpReady(interp) == TCL_ERROR) { - result = TCL_ERROR; - } else { - register ByteCode *codePtr = - procPtr->bodyPtr->internalRep.otherValuePtr; + TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, + NULL, NULL); + return TclNRExecuteByteCode(interp, codePtr); +} - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - } +static int +InterpProcNR2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr = iPtr->varFramePtr->procPtr; + CallFrame *freePtr; + Tcl_Obj *procNameObj = data[0]; + ProcErrorProc *errorProc = (ProcErrorProc *)data[1]; - ((Interp *)interp)->numLevels--; - procPtr->refCount--; - if (procPtr->refCount <= 0) { + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + + TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result); + } + if (--procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } /* - * 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: /* @@ -1638,10 +1904,10 @@ TclObjInterpProcCore( * 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; /* @@ -1655,38 +1921,9 @@ TclObjInterpProcCore( * function handed to us as an argument. */ - (*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 */ + errorProc(interp, procNameObj); } - - procDone: - /* - * 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 = ((Interp *)interp)->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - return result; + goto done; } /* @@ -1714,35 +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.) */ - Namespace *nsPtr, /* Namespace containing procedure. */ - CONST char *description, /* string describing this body of code. */ - CONST char *procName) /* Name of this procedure. */ -{ - return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, - procName, NULL); -} - -static int -ProcCompileProc( - 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. */ - Proc **procPtrPtr) /* Points to storage where a replacement - * (Proc *) value may be written. */ + const char *description, /* string describing this body of code. */ + const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; - int i; Tcl_CallFrame *framePtr; - Proc *saveProcPtr; - ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; - CompiledLocal *localPtr; + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1759,35 +1976,37 @@ ProcCompileProc( */ 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)) { return TCL_OK; - } else { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); - return TCL_ERROR; - } - codePtr->compileEpoch = iPtr->compileEpoch; - codePtr->nsPtr = nsPtr; - } else { - bodyPtr->typePtr->freeIntRepProc(bodyPtr); - bodyPtr->typePtr = NULL; + } + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + 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 { + 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; @@ -1795,87 +2014,57 @@ ProcCompileProc( 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. - */ - - saveProcPtr = iPtr->compiledProcPtr; - - if (procPtrPtr != NULL && procPtr->refCount > 1) { - Tcl_Command token; - Tcl_CmdInfo info; - Proc *newProc = (Proc *) ckalloc(sizeof(Proc)); - - newProc->iPtr = procPtr->iPtr; - newProc->refCount = 1; - newProc->cmdPtr = procPtr->cmdPtr; - token = (Tcl_Command) newProc->cmdPtr; - newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr); - bodyPtr = newProc->bodyPtr; - Tcl_IncrRefCount(bodyPtr); - newProc->numArgs = procPtr->numArgs; - - newProc->numCompiledLocals = newProc->numArgs; - newProc->firstLocalPtr = NULL; - newProc->lastLocalPtr = NULL; - localPtr = procPtr->firstLocalPtr; - for (i=0; i<newProc->numArgs; i++, localPtr=localPtr->nextPtr) { - CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + localPtr->nameLength + 1)); - - if (newProc->firstLocalPtr == NULL) { - newProc->firstLocalPtr = newProc->lastLocalPtr = copy; - } else { - newProc->lastLocalPtr->nextPtr = copy; - newProc->lastLocalPtr = copy; - } - copy->nextPtr = NULL; - copy->nameLength = localPtr->nameLength; - copy->frameIndex = localPtr->frameIndex; - copy->flags = localPtr->flags; - copy->defValuePtr = localPtr->defValuePtr; - if (copy->defValuePtr) { - Tcl_IncrRefCount(copy->defValuePtr); - } - copy->resolveInfo = localPtr->resolveInfo; - strcpy(copy->name, localPtr->name); - } + /* + * 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. + */ - /* - * Reset the ClientData - */ + iPtr->compiledProcPtr = procPtr; + + if (procPtr->numCompiledLocals > procPtr->numArgs) { + CompiledLocal *clPtr = procPtr->firstLocalPtr; + CompiledLocal *lastPtr = NULL; + int i, numArgs = procPtr->numArgs; - Tcl_GetCommandInfoFromToken(token, &info); - if (info.objClientData == (ClientData) procPtr) { - info.objClientData = (ClientData) newProc; + for (i = 0; i < numArgs; i++) { + lastPtr = clPtr; + clPtr = clPtr->nextPtr; } - if (info.clientData == (ClientData) procPtr) { - info.clientData = (ClientData) newProc; + + if (lastPtr) { + lastPtr->nextPtr = NULL; + } else { + procPtr->firstLocalPtr = NULL; } - if (info.deleteData == (ClientData) procPtr) { - info.deleteData = (ClientData) newProc; + procPtr->lastLocalPtr = lastPtr; + while (clPtr) { + CompiledLocal *toFree = clPtr; + + clPtr = clPtr->nextPtr; + if (toFree->resolveInfo) { + if (toFree->resolveInfo->deleteProc) { + toFree->resolveInfo->deleteProc(toFree->resolveInfo); + } else { + ckfree(toFree->resolveInfo); + } + } + ckfree(toFree); } - Tcl_SetCommandInfoFromToken(token, &info); - - procPtr->refCount--; - *procPtrPtr = procPtr = newProc; + procPtr->numCompiledLocals = procPtr->numArgs; } - iPtr->compiledProcPtr = procPtr; - (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 @@ -1889,12 +2078,10 @@ ProcCompileProc( */ iPtr->invokeWord = 0; - iPtr->invokeCmdFramePtr = - (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL); - (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr); + iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); + 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 @@ -1939,7 +2126,7 @@ MakeProcError( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* @@ -1966,7 +2153,7 @@ void TclProcDeleteProc( ClientData clientData) /* Procedure to be deleted. */ { - Proc *procPtr = (Proc *) clientData; + Proc *procPtr = clientData; procPtr->refCount--; if (procPtr->refCount <= 0) { @@ -2012,9 +2199,9 @@ TclProcCleanupProc( resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { - (*resVarInfo->deleteProc)(resVarInfo); + resVarInfo->deleteProc(resVarInfo); } else { - ckfree((char *) resVarInfo); + ckfree(resVarInfo); } } @@ -2022,18 +2209,18 @@ 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 * structure, if any. The interpreter may not exist (For example for - * procbody structurues created by tbcload. + * procbody structures created by tbcload. */ - if (!iPtr) { + if (iPtr == NULL) { return; } @@ -2042,15 +2229,17 @@ TclProcCleanupProc( return; } - cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); + 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); } @@ -2087,9 +2276,14 @@ TclUpdateReturnInfo( if (iPtr->returnLevel == 0) { /* * Now we've reached the level to return the requested -code. + * Since iPtr->returnLevel and iPtr->returnCode have completed + * their task, we now reset them to default values so that any + * bare "return TCL_RETURN" that may follow will work [Bug 2152286]. */ code = iPtr->returnCode; + iPtr->returnLevel = 1; + iPtr->returnCode = TCL_OK; if (code == TCL_ERROR) { iPtr->flags |= ERR_LEGACY_COPY; } @@ -2155,7 +2349,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = procPtr; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2185,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++; } @@ -2215,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); } } @@ -2266,6 +2459,7 @@ FreeLambdaInternalRep( TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); + objPtr->typePtr = NULL; } static int @@ -2274,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 = Tcl_ListObjGetElements(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; } @@ -2338,11 +2537,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 @@ -2369,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; @@ -2390,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; } /* @@ -2406,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 @@ -2415,7 +2611,7 @@ SetLambdaFromAny( if (objc == 2) { TclNewLiteralStringObj(nsObjPtr, "::"); } else { - char *nsName = Tcl_GetString(objv[2]); + const char *nsName = TclGetString(objv[2]); if ((*nsName != ':') || (*(nsName+1) != ':')) { TclNewLiteralStringObj(nsObjPtr, "::"); @@ -2433,7 +2629,7 @@ SetLambdaFromAny( * conversion to lambdaType. */ - objPtr->typePtr->freeIntRepProc(objPtr); + TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; @@ -2463,18 +2659,27 @@ Tcl_ApplyObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv); +} + +int +TclNRApplyObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; - Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr; + Tcl_Obj *lambdaPtr, *nsObjPtr; int result, isRootEnsemble; - Command cmd; Tcl_Namespace *nsPtr; - ExtraFrameInfo efi; + ApplyExtraData *extraPtr; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?"); return TCL_ERROR; } @@ -2489,18 +2694,23 @@ Tcl_ApplyObjCmd( } #define JOE_EXTENSION 0 +/* + * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT + * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt + * the code. (MS) + */ + #if JOE_EXTENSION else { /* * Joe English's suggestion to allow cmdNames to function as lambdas. - * Also requires making tclCmdNameType non-static in tclObj.c */ Tcl_Obj *elemPtr; int numElem; if ((lambdaPtr->typePtr == &tclCmdNameType) || - (Tcl_ListObjGetElements(interp, lambdaPtr, &numElem, + (TclListObjGetElements(interp, lambdaPtr, &numElem, &elemPtr) == TCL_OK && numElem == 1)) { return Tcl_EvalObjv(interp, objc-1, objv+1, 0); } @@ -2515,25 +2725,6 @@ Tcl_ApplyObjCmd( procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } - memset(&cmd, 0, sizeof(Command)); - procPtr->cmdPtr = &cmd; - - /* - * 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. - */ - - efi.length = 1; - efi.fields[0].name = "lambda"; - efi.fields[0].proc = NULL; - efi.fields[0].clientData = lambdaPtr; - cmd.clientData = &efi; - /* * Find the namespace where this lambda should run, and push a call frame * for that namespace. Note that TclObjInterpProc() will pop it. @@ -2542,18 +2733,29 @@ Tcl_ApplyObjCmd( nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { - return result; - } - - if (nsPtr == NULL) { - TclNewLiteralStringObj(errPtr, "cannot find namespace \""); - Tcl_AppendObjToObj(errPtr, nsObjPtr); - Tcl_AppendToObj(errPtr, "\"", -1); - Tcl_SetObjResult(interp, errPtr); return TCL_ERROR; } - cmd.nsPtr = (Namespace *) nsPtr; + extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData)); + memset(&extraPtr->cmd, 0, sizeof(Command)); + procPtr->cmdPtr = &extraPtr->cmd; + extraPtr->cmd.nsPtr = (Namespace *) nsPtr; + + /* + * 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. + */ + + extraPtr->efi.length = 1; + extraPtr->efi.fields[0].name = "lambda"; + extraPtr->efi.fields[0].proc = NULL; + extraPtr->efi.fields[0].clientData = lambdaPtr; + extraPtr->cmd.clientData = &extraPtr->efi; isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); if (isRootEnsemble) { @@ -2563,18 +2765,29 @@ Tcl_ApplyObjCmd( } else { iPtr->ensembleRewrite.numInsertedObjs -= 1; } + extraPtr->isRootEnsemble = isRootEnsemble; - result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { - result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError); + TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); + result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); } + return result; +} - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; +static int +ApplyNR2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ApplyExtraData *extraPtr = data[0]; + + if (extraPtr->isRootEnsemble) { + ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } + TclStackFree(interp, extraPtr); return result; } @@ -2610,7 +2823,235 @@ MakeLambdaError( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DisassembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const types[] = { + "lambda", "method", "objmethod", "proc", "script", NULL + }; + enum Types { + 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 < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * 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; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = SetLambdaFromAny(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_PROC: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procName"); + return TCL_ERROR; + } + + 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; + } + + /* + * 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) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; + } + codeObjPtr = objv[2]; + break; + + case DISAS_CLASS_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of a class method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == 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, + (char *) objv[3]); + goto methodBody; + case DISAS_OBJECT_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of an instance method. + */ + + 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_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_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) { + 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; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + default: + CLANG_ASSERT(0); + } + + /* + * Do the actual disassembly. + */ + + if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + 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)); + return TCL_OK; } /* |