diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 3439 |
1 files changed, 1184 insertions, 2255 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index d008217..abfd152 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1,106 +1,48 @@ /* * tclProc.c -- * - * This file contains routines that implement Tcl procedures, including - * the "proc" and "uplevel" commands. + * This file contains routines that implement Tcl procedures, + * including the "proc" and "uplevel" commands. * * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #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 */ -static void DupLambdaInternalRep(Tcl_Obj *objPtr, - Tcl_Obj *copyPtr); -static void FreeLambdaInternalRep(Tcl_Obj *objPtr); -static int InitArgsAndLocals(Tcl_Interp *interp, - Tcl_Obj *procNameObj, int skip); -static void InitResolvedLocals(Tcl_Interp *interp, - ByteCode *codePtr, Var *defPtr, - Namespace *nsPtr); -static void InitLocalCache(Proc *procPtr); -static int PushProcCallFrame(ClientData clientData, - register Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int isLambda); -static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); -static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); -static 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 Tcl_NRPostProc ApplyNR2; -static Tcl_NRPostProc InterpProcNR2; -static Tcl_NRPostProc Uplevel_Callback; +static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); +static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName, + Proc **procPtrPtr)); +static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, + char *procName, int nameLen, int returnCode)); +static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* * The ProcBodyObjType type */ -const Tcl_ObjType tclProcBodyType = { +Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ - ProcBodyFree, /* FreeInternalRep function */ - ProcBodyDup, /* DupInternalRep function */ - NULL, /* UpdateString function; Tcl_GetString and - * Tcl_GetStringFromObj should panic - * instead. */ - NULL /* SetFromAny function; Tcl_ConvertToType - * should panic instead. */ -}; - -/* - * 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 const Tcl_ObjType levelReferenceType = { - "levelReference", - NULL, NULL, NULL, NULL -}; - -/* - * The type of lambdas. Note that every lambda will *always* have a string - * representation. - * - * Internally, ptr1 is a pointer to a Proc instance that is not bound to a - * command name, and ptr2 is a pointer to the namespace that the Proc instance - * will execute within. - */ - -static const Tcl_ObjType lambdaType = { - "lambdaExpr", /* name */ - FreeLambdaInternalRep, /* freeIntRepProc */ - DupLambdaInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetLambdaFromAny /* setFromAnyProc */ + ProcBodyFree, /* FreeInternalRep procedure */ + ProcBodyDup, /* DupInternalRep procedure */ + ProcBodyUpdateString, /* UpdateString procedure */ + ProcBodySetFromAny /* SetFromAny procedure */ }; /* @@ -108,7 +50,7 @@ static const Tcl_ObjType lambdaType = { * * Tcl_ProcObjCmd -- * - * This object-based function is invoked to process the "proc" Tcl + * This object-based procedure is invoked to process the "proc" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -122,16 +64,16 @@ static const Tcl_ObjType lambdaType = { /* ARGSUSED */ int -Tcl_ProcObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_ProcObjCmd(dummy, interp, objc, objv) + 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; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + char *fullName; + CONST char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; @@ -142,51 +84,47 @@ Tcl_ProcObjCmd( } /* - * Determine the namespace where the procedure should reside. Unless the - * command name includes namespace qualifiers, this will be the current - * namespace. + * Determine the namespace where the procedure should reside. Unless + * the command name includes namespace qualifiers, this will be the + * current namespace. */ fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, + 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create procedure \"", fullName, + "\": unknown namespace", (char *) NULL); + return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create procedure \"", fullName, + "\": bad procedure name", (char *) NULL); + return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", - NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; + (char *) NULL); + return TCL_ERROR; } /* - * Create the data structure to represent the procedure. + * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], - &procPtr) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); - Tcl_AddErrorInfo(interp, "\")"); - return TCL_ERROR; + &procPtr) != TCL_OK) { + return TCL_ERROR; } /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace + * Now create a command for the procedure. This will initially be in + * the current namespace unless the procedure's name included namespace * qualifiers. To create the new command in the right namespace, we * generate a fully qualified name for it. */ @@ -198,10 +136,12 @@ Tcl_ProcObjCmd( } Tcl_DStringAppend(&ds, procName, -1); - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); - Tcl_DStringFree(&ds); + Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc, + (ClientData) procPtr, TclProcDeleteProc); + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + Tcl_DStringFree(&ds); /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the @@ -211,132 +151,113 @@ Tcl_ProcObjCmd( procPtr->cmdPtr = (Command *) cmd; - /* - * TIP #280: Remember the line the procedure body is starting on. In a - * bytecode context we ask the engine to provide us with the necessary +#ifdef TCL_TIP280 + /* TIP #280 Remember the line the procedure body is starting on. In a + * Byte code context we ask the engine to provide us with the necessary * information. This is for the initialization of the byte code compiler * when the body is used for the first time. - * - * This code is nearly identical to the #280 code in SetLambdaFromAny, see - * this file. The differences are the different index of the body in the - * line array of the context, and the lamdba code requires some special - * processing. Find a way to factor the common elements into a single - * function. */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame context = *iPtr->cmdFramePtr; - *contextPtr = *iPtr->cmdFramePtr; - if (contextPtr->type == TCL_LOCATION_BC) { - /* - * Retrieve source information from the bytecode, if possible. If - * the information is retrieved successfully, context.type will be - * TCL_LOCATION_SOURCE and the reference held by - * context.data.eval.path will be counted. - */ + if (context.type == TCL_LOCATION_BC) { + TclGetSrcInfoForPc (&context); + /* May get path in context */ + } else if (context.type == TCL_LOCATION_SOURCE) { + /* context now holds another reference */ + Tcl_IncrRefCount (context.data.eval.path); + } - TclGetSrcInfoForPc(contextPtr); - } else if (contextPtr->type == TCL_LOCATION_SOURCE) { - /* - * The copy into 'context' up above has created another reference - * to 'context.data.eval.path'; account for it. - */ + /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We + * cannot assume that 'line' is valid here, we have to check. If the + * outer context is an eval (bc, prebc, eval) we do not save any + * information. Counting relative to the beginning of the proc body is + * more sensible than counting relative to the outer eval block. + */ - Tcl_IncrRefCount(contextPtr->data.eval.path); - } + if ((context.type == TCL_LOCATION_SOURCE) && + context.line && + (context.nline >= 4) && + (context.line [3] >= 0)) { + int isNew; + Tcl_HashEntry* hePtr; + CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame)); + + cfPtr->level = -1; + cfPtr->type = context.type; + cfPtr->line = (int*) ckalloc (sizeof (int)); + cfPtr->line [0] = context.line [3]; + cfPtr->nline = 1; + cfPtr->framePtr = NULL; + cfPtr->nextPtr = NULL; + + if (context.type == TCL_LOCATION_SOURCE) { + cfPtr->data.eval.path = context.data.eval.path; + /* Transfer of reference. The reference going away (release of + * the context) is replaced by the reference in the + * constructed cmdframe */ + } else { + cfPtr->type = TCL_LOCATION_EVAL; + cfPtr->data.eval.path = NULL; + } - if (contextPtr->type == TCL_LOCATION_SOURCE) { - /* - * We can account for source location within a proc only if the - * proc body was not created by substitution. - */ + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; - if (contextPtr->line - && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { - int isNew; - Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); - - cfPtr->level = -1; - cfPtr->type = contextPtr->type; - cfPtr->line = ckalloc(sizeof(int)); - cfPtr->line[0] = contextPtr->line[3]; - cfPtr->nline = 1; - cfPtr->framePtr = NULL; - cfPtr->nextPtr = NULL; - - cfPtr->data.eval.path = contextPtr->data.eval.path; - Tcl_IncrRefCount(cfPtr->data.eval.path); - - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.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. - */ + hePtr = Tcl_CreateHashEntry (iPtr->linePBodyPtr, (char*) 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. + */ - CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr); + CmdFrame* cfOldPtr = (CmdFrame *) 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); + if (cfOldPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfOldPtr->data.eval.path); + cfOldPtr->data.eval.path = NULL; } - Tcl_SetHashValue(hePtr, cfPtr); + ckfree((char *) cfOldPtr->line); + cfOldPtr->line = NULL; + ckfree((char *) cfOldPtr); } - - /* - * 'contextPtr' is going out of scope; account for the reference - * that it's holding to the path name. - */ - - Tcl_DecrRefCount(contextPtr->data.eval.path); - contextPtr->data.eval.path = NULL; + Tcl_SetHashValue (hePtr, cfPtr); } - TclStackFree(interp, contextPtr); } +#endif /* - * Optimize for no-op procs: if the body is not precompiled (like a TclPro + * Optimize for noop procs: if the body is not precompiled (like a TclPro * procbody), and the argument list is just "args" and the body is empty, - * define a compileProc to compile a no-op. + * define a compileProc to compile a noop. * * Notes: - * - cannot be done for any argument list without having different - * compiled/not-compiled behaviour in the "wrong argument #" case, or - * making this code much more complicated. In any case, it doesn't - * seem to make a lot of sense to verify the number of arguments we - * are about to ignore ... - * - could be enhanced to handle also non-empty bodies that contain only - * comments; however, parsing the body will slow down the compilation - * of all procs whose argument list is just _args_ - */ + * - cannot be done for any argument list without having different + * compiled/not-compiled behaviour in the "wrong argument #" case, + * or making this code much more complicated. In any case, it doesn't + * seem to make a lot of sense to verify the number of arguments we + * are about to ignore ... + * - could be enhanced to handle also non-empty bodies that contain + * only comments; however, parsing the body will slow down the + * compilation of all procs whose argument list is just _args_ */ if (objv[3]->typePtr == &tclProcBodyType) { goto done; } - procArgs = TclGetString(objv[2]); + procArgs = Tcl_GetString(objv[2]); while (*procArgs == ' ') { procArgs++; } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - int numBytes; - procArgs +=4; - while (*procArgs != '\0') { + while(*procArgs != '\0') { if (*procArgs != ' ') { goto done; } @@ -347,9 +268,12 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = Tcl_GetStringFromObj(objv[3], &numBytes); - if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { - goto done; + procBody = Tcl_GetString(objv[3]); + while (*procBody != '\0') { + if (!isspace(UCHAR(*procBody))) { + goto done; + } + procBody++; } /* @@ -359,7 +283,7 @@ Tcl_ProcObjCmd( ((Command *) cmd)->compileProc = TclCompileNoOp; } - done: + done: return TCL_OK; } @@ -368,204 +292,207 @@ Tcl_ProcObjCmd( * * TclCreateProc -- * - * Creates the data associated with a Tcl procedure definition. This - * function knows how to handle two types of body objects: strings and - * procbody. Strings are the traditional (and common) value for bodies, - * procbody are values created by extensions that have loaded a - * previously compiled script. + * Creates the data associated with a Tcl procedure definition. + * This procedure knows how to handle two types of body objects: + * strings and procbody. Strings are the traditional (and common) value + * for bodies, procbody are values created by extensions that have + * loaded a previously compiled script. * * Results: - * Returns TCL_OK on success, along with a pointer to a Tcl procedure - * definition in procPtrPtr where the cmdPtr field is not initialised. - * This definition should be freed by calling TclProcCleanupProc() when - * it is no longer needed. Returns TCL_ERROR if anything goes wrong. + * Returns TCL_OK on success, along with a pointer to a Tcl + * procedure definition in procPtrPtr. This definition should + * be freed by calling TclCleanupProc() when it is no longer + * needed. Returns TCL_ERROR if anything goes wrong. * * Side effects: - * If anything goes wrong, this function returns an error message in the - * interpreter. + * If anything goes wrong, this procedure returns an error + * message in the interpreter. * *---------------------------------------------------------------------- */ - int -TclCreateProc( - Tcl_Interp *interp, /* Interpreter containing proc. */ - Namespace *nsPtr, /* Namespace containing 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. */ +TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) + Tcl_Interp *interp; /* interpreter containing proc */ + Namespace *nsPtr; /* namespace containing 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; + Interp *iPtr = (Interp*)interp; + 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; if (bodyPtr->typePtr == &tclProcBodyType) { - /* - * Because the body is a TclProProcBody, the actual body is already - * compiled, and it is not shared with anyone else, so it's OK not to - * unshare it (as a matter of fact, it is bad to unshare it, because - * there may be no source code). - * - * We don't create and initialize a Proc structure for the procedure; - * rather, we use what is in the body object. We increment the ref - * count of the Proc struct since the command (soon to be created) - * will be holding a reference to it. - */ - - procPtr = bodyPtr->internalRep.otherValuePtr; - procPtr->iPtr = iPtr; - procPtr->refCount++; - precompiled = 1; + /* + * Because the body is a TclProProcBody, the actual body is already + * compiled, and it is not shared with anyone else, so it's OK not to + * unshare it (as a matter of fact, it is bad to unshare it, because + * there may be no source code). + * + * We don't create and initialize a Proc structure for the procedure; + * rather, we use what is in the body object. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the Proc struct + * since the command (soon to be created) will be holding a reference + * to it. + */ + + procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; + procPtr->iPtr = iPtr; + procPtr->refCount++; + precompiled = 1; } else { - /* - * If the procedure's body object is shared because its string value - * is identical to, e.g., the body of another procedure, we must - * create a private copy for this procedure to use. Such sharing of - * procedure bodies is rare but can cause problems. A procedure body - * is compiled in a context that includes the number of "slots" - * allocated by the compiler for local variables. There is a local - * variable slot for each formal parameter (the - * "procPtr->numCompiledLocals = numArgs" assignment below). This - * means that the same code can not be shared by two procedures that - * have a different number of arguments, even if their bodies are - * identical. Note that we don't use Tcl_DuplicateObj since we would - * not want any bytecode internal representation. - */ - - if (Tcl_IsShared(bodyPtr)) { - Tcl_Obj *sharedBodyPtr = bodyPtr; - - bytes = TclGetStringFromObj(bodyPtr, &length); - bodyPtr = Tcl_NewStringObj(bytes, length); - + /* + * If the procedure's body object is shared because its string value is + * identical to, e.g., the body of another procedure, we must create a + * private copy for this procedure to use. Such sharing of procedure + * bodies is rare but can cause problems. A procedure body is compiled + * in a context that includes the number of compiler-allocated "slots" + * for local variables. Each formal parameter is given a local variable + * slot (the "procPtr->numCompiledLocals = numArgs" assignment + * below). This means that the same code can not be shared by two + * procedures that have a different number of arguments, even if their + * bodies are identical. Note that we don't use Tcl_DuplicateObj since + * we would not want any bytecode internal representation. + */ + + if (Tcl_IsShared(bodyPtr)) { +#ifdef TCL_TIP280 + Tcl_Obj* sharedBodyPtr = bodyPtr; +#endif + bytes = Tcl_GetStringFromObj(bodyPtr, &length); + bodyPtr = Tcl_NewStringObj(bytes, length); +#ifdef TCL_TIP280 /* * 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); - } + TclContinuationsCopy (bodyPtr, sharedBodyPtr); +#endif + } - /* - * Create and initialize a Proc structure for the procedure. We - * increment the ref count of the procedure's body object since there - * will be a reference to it in the Proc structure. - */ + /* + * Create and initialize a Proc structure for the procedure. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the procedure's + * body object since there will be a reference to it in the Proc + * structure. + */ - Tcl_IncrRefCount(bodyPtr); + Tcl_IncrRefCount(bodyPtr); - procPtr = ckalloc(sizeof(Proc)); - procPtr->iPtr = iPtr; - procPtr->refCount = 1; - procPtr->bodyPtr = bodyPtr; - procPtr->numArgs = 0; /* Actual argument count is set below. */ - procPtr->numCompiledLocals = 0; - procPtr->firstLocalPtr = NULL; - procPtr->lastLocalPtr = NULL; + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->bodyPtr = bodyPtr; + procPtr->numArgs = 0; /* actual argument count is set below. */ + procPtr->numCompiledLocals = 0; + procPtr->firstLocalPtr = NULL; + procPtr->lastLocalPtr = NULL; } /* - * Break up the argument list into argument specifiers, then process each - * argument specifier. If the body is precompiled, processing is limited - * to checking that the parsed argument is consistent with the one stored - * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. + * Break up the argument list into argument specifiers, then process + * each argument specifier. + * If the body is precompiled, processing is limited to checking that + * the the parsed argument is consistent with the one stored in the + * Proc. + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ - args = TclGetStringFromObj(argsPtr, &length); + args = Tcl_GetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { - goto procError; + goto procError; } if (precompiled) { - if (numArgs > procPtr->numArgs) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "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; + if (numArgs > procPtr->numArgs) { + char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE]; + sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d", + numArgs, procPtr->numArgs); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + buf, (char *) NULL); + goto procError; + } + localPtr = procPtr->firstLocalPtr; } else { - procPtr->numArgs = numArgs; - procPtr->numCompiledLocals = numArgs; - } - - for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength, valueLength; - const char **fieldValues; - - /* - * Now divide the specifier up into name and default. - */ - - result = Tcl_SplitList(interp, argArray[i], &fieldCount, - &fieldValues); - if (result != TCL_OK) { - goto procError; - } - if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_AppendResult(interp, - "too many fields in argument specifier \"", - argArray[i], "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); - goto procError; - } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); - Tcl_AppendResult(interp, "argument with no name", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); - goto procError; - } - - nameLength = strlen(fieldValues[0]); - if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); - } else { - valueLength = 0; - } - - /* - * Check that the formal parameter name is a scalar. - */ - - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { + procPtr->numArgs = numArgs; + procPtr->numCompiledLocals = numArgs; + } + for (i = 0; i < numArgs; i++) { + int fieldCount, nameLength, valueLength; + CONST char **fieldValues; + + /* + * Now divide the specifier up into name and default. + */ + + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "too many fields in argument specifier \"", + argArray[i], "\"", (char *) NULL); + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has argument with no name", (char *) NULL); + goto procError; + } + + nameLength = strlen(fieldValues[0]); + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]); + } else { + valueLength = 0; + } + + /* + * Check that the formal parameter name is a scalar. + */ + + p = fieldValues[0]; + while (*p != '\0') { + if (*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(fieldValues); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + if (*q == ')') { /* we have an array element */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has formal parameter \"", fieldValues[0], + "\" that is an array element", + (char *) NULL); + ckfree((char *) fieldValues); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], "\" is not a simple name", NULL); - ckfree(fieldValues); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has formal parameter \"", fieldValues[0], + "\" that is not a simple name", + (char *) NULL); + ckfree((char *) fieldValues); goto procError; } p++; @@ -573,122 +500,119 @@ TclCreateProc( if (precompiled) { /* - * 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. + * 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 */ if ((localPtr->nameLength != nameLength) || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) - || !(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(fieldValues); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + || ((localPtr->flags & ~VAR_UNDEFINED) + != (VAR_SCALAR | VAR_ARGUMENT)) + || ((localPtr->defValuePtr == NULL) + && (fieldCount == 2)) + || ((localPtr->defValuePtr != NULL) + && (fieldCount != 2))) { + char buf[80 + TCL_INTEGER_SPACE]; + sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body", + i); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + buf, (char *) NULL); + ckfree((char *) fieldValues); goto procError; } - /* - * Compare the default value if any. - */ - - if (localPtr->defValuePtr != NULL) { - int tmpLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, - &tmpLength); - - if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); - goto procError; - } - } - if ((i == numArgs - 1) - && (localPtr->nameLength == 4) - && (localPtr->name[0] == 'a') - && (strcmp(localPtr->name, "args") == 0)) { - localPtr->flags |= VAR_IS_ARGS; - } - - localPtr = localPtr->nextPtr; - } else { - /* - * Allocate an entry in the runtime procedure frame's array of - * local variables for the argument. - */ - - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); - if (procPtr->firstLocalPtr == NULL) { - procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; - } else { - procPtr->lastLocalPtr->nextPtr = localPtr; - procPtr->lastLocalPtr = localPtr; - } - localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; - localPtr->frameIndex = i; - localPtr->flags = VAR_ARGUMENT; - localPtr->resolveInfo = NULL; - - if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); - Tcl_IncrRefCount(localPtr->defValuePtr); - } else { - localPtr->defValuePtr = NULL; - } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); - if ((i == numArgs - 1) - && (localPtr->nameLength == 4) - && (localPtr->name[0] == 'a') - && (strcmp(localPtr->name, "args") == 0)) { - localPtr->flags |= VAR_IS_ARGS; - } - } - - ckfree(fieldValues); + /* + * compare the default value if any + */ + + if (localPtr->defValuePtr != NULL) { + int tmpLength; + char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, + &tmpLength); + if ((valueLength != tmpLength) + || (strncmp(fieldValues[1], tmpPtr, + (size_t) tmpLength))) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\": formal parameter \"", + fieldValues[0], + "\" has default value inconsistent with precompiled body", + (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } + } + + localPtr = localPtr->nextPtr; + } else { + /* + * Allocate an entry in the runtime procedure frame's array of + * local variables for the argument. + */ + + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameLength+1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameLength; + localPtr->frameIndex = i; + localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; + localPtr->resolveInfo = NULL; + + if (fieldCount == 2) { + localPtr->defValuePtr = + Tcl_NewStringObj(fieldValues[1], valueLength); + Tcl_IncrRefCount(localPtr->defValuePtr); + } else { + localPtr->defValuePtr = NULL; + } + memcpy(localPtr->name, fieldValues[0], nameLength + 1); + } + + ckfree((char *) fieldValues); } + /* + * Now initialize the new procedure's cmdPtr field. This will be used + * later when the procedure is called to determine what namespace the + * procedure will run in. This will be different than the current + * namespace if the proc was renamed into a different namespace. + */ + *procPtrPtr = procPtr; - ckfree(argArray); + ckfree((char *) argArray); return TCL_OK; - procError: +procError: if (precompiled) { - procPtr->refCount--; + procPtr->refCount--; } else { - Tcl_DecrRefCount(bodyPtr); - while (procPtr->firstLocalPtr != NULL) { - localPtr = procPtr->firstLocalPtr; - procPtr->firstLocalPtr = localPtr->nextPtr; + Tcl_DecrRefCount(bodyPtr); + while (procPtr->firstLocalPtr != NULL) { + localPtr = procPtr->firstLocalPtr; + procPtr->firstLocalPtr = localPtr->nextPtr; - defPtr = localPtr->defValuePtr; - if (defPtr != NULL) { - Tcl_DecrRefCount(defPtr); - } + defPtr = localPtr->defValuePtr; + if (defPtr != NULL) { + Tcl_DecrRefCount(defPtr); + } - ckfree(localPtr); - } - ckfree(procPtr); + ckfree((char *) localPtr); + } + ckfree((char *) procPtr); } if (argArray != NULL) { - ckfree(argArray); + ckfree((char *) argArray); } return TCL_ERROR; } @@ -698,19 +622,19 @@ TclCreateProc( * * TclGetFrame -- * - * Given a description of a procedure frame, such as the first argument - * to an "uplevel" or "upvar" command, locate the call frame for the - * appropriate level of procedure. + * Given a description of a procedure frame, such as the first + * argument to an "uplevel" or "upvar" command, locate the + * call frame for the appropriate level of procedure. * * Results: - * The return value is -1 if an error occurred in finding the frame (in - * this case an error message is left in the interp's result). 1 is - * returned if string was either a number or a number preceded by "#" and - * it specified a valid frame. 0 is returned if string isn't one of the - * two things above (in this case, the lookup acts as if string were - * "1"). The variable pointed to by framePtrPtr is filled in with the - * address of the desired frame (unless an error occurs, in which case it - * isn't modified). + * The return value is -1 if an error occurred in finding the frame + * (in this case an error message is left in the interp's result). + * 1 is returned if string was either a number or a number preceded + * by "#" and it specified a valid frame. 0 is returned if string + * isn't one of the two things above (in this case, the lookup + * acts as if string were "1"). The variable pointed to by + * framePtrPtr is filled in with the address of the desired frame + * (unless an error occurs, in which case it isn't modified). * * Side effects: * None. @@ -719,11 +643,11 @@ TclCreateProc( */ int -TclGetFrame( - Tcl_Interp *interp, /* Interpreter in which to find frame. */ - const char *name, /* String describing frame. */ - CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if - * global frame indicated). */ +TclGetFrame(interp, string, framePtrPtr) + Tcl_Interp *interp; /* Interpreter in which to find frame. */ + CONST char *string; /* String describing frame. */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL + * if global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; @@ -734,176 +658,47 @@ TclGetFrame( */ result = 1; - curLevel = iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TclObjGetFrame -- - * - * Given a description of a procedure frame, such as the first argument - * to an "uplevel" or "upvar" command, locate the call frame for the - * appropriate level of procedure. - * - * Results: - * The return value is -1 if an error occurred in finding the frame (in - * this case an error message is left in the interp's result). 1 is - * returned if objPtr was either a number or a number preceded by "#" and - * it specified a valid frame. 0 is returned if objPtr isn't one of the - * two things above (in this case, the lookup acts as if objPtr were - * "1"). The variable pointed to by framePtrPtr is filled in with the - * address of the desired frame (unless an error occurs, in which case it - * isn't modified). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclObjGetFrame( - Tcl_Interp *interp, /* Interpreter in which to find frame. */ - Tcl_Obj *objPtr, /* Object describing frame. */ - CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if - * global frame indicated). */ -{ - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - const char *name; - - /* - * Parse object to figure out which level number to go to. - */ - - result = 1; - curLevel = iPtr->varFramePtr->level; - if (objPtr == NULL) { - name = "1"; - goto haveLevel1; - } - - name = TclGetString(objPtr); - if (objPtr->typePtr == &levelReferenceType) { - if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) { - level = curLevel - objPtr->internalRep.ptrAndLongRep.value; - } else { - level = objPtr->internalRep.ptrAndLongRep.value; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (*string == '#') { + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { + return -1; } if (level < 0) { - goto levelError; - } - /* TODO: Consider skipping the typePtr checks */ - } else if (objPtr->typePtr == &tclIntType -#ifndef NO_WIDE_TYPE - || objPtr->typePtr == &tclWideIntType -#endif - ) { - if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { - goto levelError; - } - level = curLevel - level; - } else if (*name == '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; + levelError: + Tcl_AppendResult(interp, "bad level \"", string, "\"", + (char *) NULL); + return -1; } - - /* - * Cache for future reference. - * - * TODO: Use the new ptrAndLongRep intrep - */ - - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - 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) { + } else if (isdigit(UCHAR(*string))) { /* INTL: digit */ + if (Tcl_GetInt(interp, string, &level) != TCL_OK) { return -1; } - - /* - * Cache for future reference. - * - * TODO: Use the new ptrAndLongRep intrep - */ - - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - 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 (might even be - * NULL...) - */ - - haveLevel1: level = curLevel - 1; result = 0; } /* - * Figure out which frame to use, and return it to the caller. + * Figure out which frame to use, and modify the interpreter so + * its variables come from that frame. */ - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; } - } - if (framePtr == NULL) { - goto levelError; } *framePtrPtr = framePtr; return result; - - levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; } /* @@ -911,8 +706,8 @@ TclObjGetFrame( * * Tcl_UplevelObjCmd -- * - * This object function is invoked to process the "uplevel" Tcl command. - * See the user documentation for details on what it does. + * This object procedure is invoked to process the "uplevel" Tcl + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. @@ -923,55 +718,21 @@ 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_UplevelObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + 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; + char *optLevel; int result; CallFrame *savedVarFramePtr, *framePtr; - Tcl_Obj *objPtr; if (objc < 2) { - uplevelSyntax: + uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } @@ -980,15 +741,16 @@ TclNRUplevelObjCmd( * Find the level to use for executing the command. */ - result = TclObjGetFrame(interp, objv[1], &framePtr); + optLevel = TclGetString(objv[1]); + result = TclGetFrame(interp, optLevel, &framePtr); 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. @@ -1002,26 +764,38 @@ TclNRUplevelObjCmd( */ if (objc == 1) { - /* - * TIP #280. Make actual argument location available to eval'd script - */ - - TclArgumentGet(interp, objv[0], &invoker, &word); - objPtr = objv[0]; - +#ifdef TCL_TIP280 + /* TIP #280. Make argument location available to eval'd script */ + CmdFrame* invoker = NULL; + int word = 0; + TclArgumentGet (interp, objv[0], &invoker, &word); + result = TclEvalObjEx(interp, objv[0], TCL_EVAL_DIRECT, invoker, word); +#else + result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); +#endif } else { /* * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete the - * object when it decrements its refcount after eval'ing it. + * between, then evaluate the result. Tcl_EvalObjEx will delete + * the 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) { + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); } - TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, - NULL); - return TclNREvalObjEx(interp, objPtr, 0, invoker, word); + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; } /* @@ -1029,17 +803,18 @@ TclNRUplevelObjCmd( * * TclFindProc -- * - * Given the name of a procedure, return a pointer to the record - * describing the procedure. The procedure will be looked up using the - * usual rules: first in the current namespace and then in the global - * namespace. + * Given the name of a procedure, return a pointer to the + * record describing the procedure. The procedure will be + * looked up using the usual rules: first in the current + * namespace and then in the global namespace. * * Results: - * NULL is returned if the name doesn't correspond to any procedure. - * Otherwise, the return value is a pointer to the procedure's record. If - * the name is found but refers to an imported command that points to a - * "real" procedure defined in another namespace, a pointer to that - * "real" procedure's structure is returned. + * NULL is returned if the name doesn't correspond to any + * procedure. Otherwise, the return value is a pointer to + * the procedure's record. If the name is found but refers + * to an imported command that points to a "real" procedure + * defined in another namespace, a pointer to that "real" + * procedure's structure is returned. * * Side effects: * None. @@ -1048,20 +823,29 @@ TclNRUplevelObjCmd( */ Proc * -TclFindProc( - Interp *iPtr, /* Interpreter in which to look. */ - const char *procName) /* Name of desired procedure. */ +TclFindProc(iPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + 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); + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, + (Tcl_Namespace *) NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { - return NULL; + return NULL; } cmdPtr = (Command *) cmd; - return TclIsProc(cmdPtr); + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->proc != TclProcInterpProc) { + return NULL; + } + return (Proc *) cmdPtr->clientData; } /* @@ -1072,9 +856,9 @@ TclFindProc( * Tells whether a command is a Tcl procedure or not. * * Results: - * If the given command is actually a Tcl procedure, the return value is - * the address of the record describing the procedure. Otherwise the - * return value is 0. + * If the given command is actually a Tcl procedure, the + * return value is the address of the record describing + * the procedure. Otherwise the return value is 0. * * Side effects: * None. @@ -1083,701 +867,328 @@ TclFindProc( */ Proc * -TclIsProc( - Command *cmdPtr) /* Command to test. */ +TclIsProc(cmdPtr) + Command *cmdPtr; /* Command to test. */ { - Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); + Tcl_Command origCmd; + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } - if (cmdPtr->deleteProc == TclProcDeleteProc) { - return cmdPtr->objClientData; + if (cmdPtr->proc == TclProcInterpProc) { + return (Proc *) cmdPtr->clientData; } - 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; + return (Proc *) 0; } /* *---------------------------------------------------------------------- * - * TclInitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled locals - * table for a new call frame. + * TclProcInterpProc -- * - * DEPRECATED: functionality has been inlined elsewhere; this function - * remains to insure binary compatibility with Itcl. + * When a Tcl procedure gets invoked with an argc/argv array of + * strings, this routine gets invoked to interpret the procedure. * * Results: - * None. + * A standard Tcl result value, usually TCL_OK. * * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. + * Depends on the commands in the procedure. * *---------------------------------------------------------------------- */ -void -TclInitCompiledLocals( - Tcl_Interp *interp, /* Current interpreter. */ - CallFrame *framePtr, /* Call frame to initialize. */ - Namespace *nsPtr) /* Pointer to current namespace. */ +int +TclProcInterpProc(clientData, interp, argc, argv) + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int argc; /* Count of number of arguments to this + * procedure. */ + register CONST char **argv; /* Argument values. */ { - 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.otherValuePtr; - - if (framePtr->numCompiledLocals) { - if (!codePtr->localCachePtr) { - InitLocalCache(framePtr->procPtr) ; - } - framePtr->localCachePtr = codePtr->localCachePtr; - framePtr->localCachePtr->refCount++; - } + register Tcl_Obj *objPtr; + register int i; + int result; - 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. - * - *---------------------------------------------------------------------- - */ + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ -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; +#define NUM_ARGS 20 + Tcl_Obj *(objStorage[NUM_ARGS]); + register Tcl_Obj **objv = objStorage; /* - * Find the localPtr corresponding to varPtr + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. */ - varNum = varPtr - iPtr->framePtr->compiledLocals; - localPtr = iPtr->framePtr->procPtr->firstLocalPtr; - while (varNum--) { - localPtr = localPtr->nextPtr; + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); } - if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { - goto doInitResolvedLocals; + for (i = 0; i < argc; i++) { + objv[i] = Tcl_NewStringObj(argv[i], -1); + Tcl_IncrRefCount(objv[i]); } + objv[argc] = 0; /* - * This is the first run after a recompile, or else the resolver epoch - * has changed: update the resolver cache. + * Use TclObjInterpProc to actually interpret the procedure. */ - 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; + result = TclObjInterpProc(clientData, interp, argc, objv); /* - * 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. + * Move the interpreter's object result to the string result, + * then reset the object result. */ - 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; + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); - /* - * 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. - */ + /* + * Decrement the ref counts on the objv elements since we are done + * with them. + */ - if (objPtr) { - if (interp) { - TclReleaseLiteral(interp, objPtr); - } else { - Tcl_DecrRefCount(objPtr); - } - } + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + TclDecrRefCount(objPtr); } - ckfree(localCachePtr); -} - -static void -InitLocalCache( - Proc *procPtr) -{ - Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; - 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. + * Free the objv array if malloc'ed storage was used. */ - 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; + if (objv != objStorage) { + ckfree((char *) objv); } - codePtr->localCachePtr = localCachePtr; - localCachePtr->refCount = 1; - localCachePtr->numVars = localCt; + return result; +#undef NUM_ARGS } /* *---------------------------------------------------------------------- * - * InitArgsAndLocals -- + * TclObjInterpProc -- * - * This routine is invoked in order to initialize the arguments and other - * compiled locals table for a new call frame. + * When a Tcl procedure gets invoked during bytecode evaluation, this + * object-based routine gets invoked to interpret the procedure. * * Results: - * A standard Tcl result. + * A standard Tcl object result value. * * 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. + * Depends on the commands in the procedure. * *---------------------------------------------------------------------- */ -static int -InitArgsAndLocals( - 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". */ +int +TclObjInterpProc(clientData, interp, objc, objv) + 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. */ { - CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; - register Var *varPtr, *defPtr; - int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; - Tcl_Obj *const *argObjs; + Interp *iPtr = (Interp *) interp; + Proc *procPtr = (Proc *) clientData; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; + CallFrame frame; + register CallFrame *framePtr = &frame; + register Var *varPtr; + register CompiledLocal *localPtr; + char *procName; + int nameLen, localCt, numArgs, argCt, i, result; /* - * Make sure that the local cache of variable names and initial values has - * been initialised properly . + * This procedure generates an array "compiledLocals" that holds the + * storage for local variables. It starts out with stack-allocated space + * but uses dynamically-allocated storage if needed. */ - if (localCt) { - if (!codePtr->localCachePtr) { - InitLocalCache(procPtr) ; - } - framePtr->localCachePtr = codePtr->localCachePtr; - framePtr->localCachePtr->refCount++; - defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); - } else { - defPtr = NULL; - } +#define NUM_LOCALS 20 + Var localStorage[NUM_LOCALS]; + Var *compiledLocals = localStorage; /* - * Create the "compiledLocals" array. Make sure it is large enough to hold - * all the procedure's compiled local variables, including its formal - * parameters. + * Get the procedure's name. */ - varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); - framePtr->compiledLocals = varPtr; - framePtr->numCompiledLocals = localCt; + procName = Tcl_GetStringFromObj(objv[0], &nameLen); /* - * Match and assign the call's actual parameters to the procedure's formal - * arguments. The formal arguments are described by the first numArgs - * entries in both the Proc structure's local variable list and the call - * frame's local variable array. + * If necessary, compile the procedure's body. The compiler will + * allocate frame slots for the procedure's non-argument local + * variables. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found + * while compiling. */ - numArgs = procPtr->numArgs; - argCt = framePtr->objc - skip; /* Set it to the number of args to the - * procedure. */ - argObjs = framePtr->objv + skip; - if (numArgs == 0) { - if (argCt) { - goto incorrectArgs; - } else { - goto correctArgs; - } - } - imax = ((argCt < numArgs-1) ? argCt : numArgs-1); - for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { - /* - * "Normal" arguments; last formal is special, depends on it being - * 'args'. - */ - - Tcl_Obj *objPtr = argObjs[i]; + result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + "body of proc", procName, &procPtr); - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } - 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 ? defPtr->value.objPtr : NULL; - - if (!objPtr) { - goto incorrectArgs; - } - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var reference. */ + if (result != TCL_OK) { + return result; } /* - * When we get here, the last formal argument remains to be defined: - * defPtr and varPtr point to the last argument to be initialized. + * Create the "compiledLocals" array. Make sure it is large enough to + * hold all the procedure's compiled local variables, including its + * formal parameters. */ - varPtr->flags = 0; - if (defPtr && defPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); - - varPtr->value.objPtr = listPtr; - Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ - } else if (argCt == numArgs) { - Tcl_Obj *objPtr = argObjs[i]; - - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } 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; + localCt = procPtr->numCompiledLocals; + if (localCt > NUM_LOCALS) { + compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var)); } - varPtr++; /* - * Initialise and resolve the remaining compiledLocals. In the absence of - * resolvers, they are undefined local vars: (flags=0, value=NULL). + * Set up and push a new call frame for the new procedure invocation. + * This call frame will execute in the proc's namespace, which might + * be different than the current namespace. The proc's namespace is + * that of its command, which can change if the command is renamed + * from one namespace to another. */ - correctArgs: - if (numArgs < localCt) { - if (!framePtr->nsPtr->compiledVarResProc - && !((Interp *)interp)->resolverPtr) { - memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); - } else { - InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); - } + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); + + if (result != TCL_OK) { + return result; } - return TCL_OK; + framePtr->objc = objc; + framePtr->objv = objv; /* ref counts for args are incremented below */ /* - * Initialise all compiled locals to avoid problems at DeleteLocalVars. + * Initialize and resolve compiled variable references. */ - incorrectArgs: - memset(varPtr, 0, - ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); - return ProcWrongNumArgs(interp, skip); -} - -/* - *---------------------------------------------------------------------- - * - * PushProcCallFrame -- - * - * Compiles a proc body if necessary, then pushes a CallFrame suitable - * for executing it. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * The proc's body may be recompiled. A CallFrame is pushed, it will have - * to be popped by the caller. - * - *---------------------------------------------------------------------- - */ + framePtr->procPtr = procPtr; + framePtr->numCompiledLocals = localCt; + framePtr->compiledLocals = compiledLocals; -static int -PushProcCallFrame( - 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 isLambda) /* 1 if this is a call by ApplyObjCmd: it - * needs special rules for error msg */ -{ - Proc *procPtr = clientData; - Namespace *nsPtr = procPtr->cmdPtr->nsPtr; - CallFrame *framePtr, **framePtrPtr; - int result; - ByteCode *codePtr; + TclInitCompiledLocals(interp, framePtr, nsPtr); /* - * If necessary (i.e. if we haven't got a suitable compilation already - * cached) compile the procedure's body. The compiler will allocate frame - * slots for the procedure's non-argument local variables. Note that - * compiling the body might increase procPtr->numCompiledLocals if new - * local variables are found while compiling. + * Match and assign the call's actual parameters to the procedure's + * formal arguments. The formal arguments are described by the first + * numArgs entries in both the Proc structure's local variable list and + * the call frame's local variable array. */ - if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { - Interp *iPtr = (Interp *) interp; + numArgs = procPtr->numArgs; + varPtr = framePtr->compiledLocals; + localPtr = procPtr->firstLocalPtr; + argCt = objc; + for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) { + if (!TclIsVarArgument(localPtr)) { + panic("TclObjInterpProc: local variable %s is not argument but should be", + localPtr->name); + return TCL_ERROR; + } + if (TclIsVarTemporary(localPtr)) { + panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); + return TCL_ERROR; + } /* - * When we've got bytecode, this is the check for validity. That is, - * the bytecode must be for the right interpreter (no cross-leaks!), - * the code must be from the current epoch (so subcommand compilation - * is up-to-date), the namespace must match (so variable handling - * is right) and the resolverEpoch must match (so that new shadowed - * commands and/or resolver changes are considered). + * Handle the special case of the last formal being "args". When + * it occurs, assign it a list consisting of all the remaining + * actual arguments. */ - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { - goto doCompilation; - } - } else { - doCompilation: - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, - (isLambda ? "body of lambda term" : "body of proc"), - TclGetString(objv[isLambda])); - if (result != TCL_OK) { - return result; + if ((i == numArgs) && ((localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0))) { + Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i])); + varPtr->value.objPtr = listPtr; + Tcl_IncrRefCount(listPtr); /* local var is a reference */ + TclClearVarUndefined(varPtr); + argCt = 0; + break; /* done processing args */ + } else if (argCt > 0) { + Tcl_Obj *objPtr = objv[i]; + varPtr->value.objPtr = objPtr; + TclClearVarUndefined(varPtr); + Tcl_IncrRefCount(objPtr); /* since the local variable now has + * another reference to object. */ + } else if (localPtr->defValuePtr != NULL) { + Tcl_Obj *objPtr = localPtr->defValuePtr; + varPtr->value.objPtr = objPtr; + TclClearVarUndefined(varPtr); + Tcl_IncrRefCount(objPtr); /* since the local variable now has + * another reference to object. */ + } else { + goto incorrectArgs; } + varPtr++; + localPtr = localPtr->nextPtr; } + if (argCt > 0) { + Tcl_Obj *objResult; + int len, flags; - /* - * Set up and push a new call frame for the new procedure invocation. - * This call frame will execute in the proc's namespace, which might be - * different than the current namespace. The proc's namespace is that of - * its command, which can change if the command is renamed from one - * namespace to another. - */ - - framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - (Tcl_Namespace *) nsPtr, - (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); - if (result != TCL_OK) { - return result; - } - - framePtr->objc = objc; - framePtr->objv = objv; - framePtr->procPtr = procPtr; + incorrectArgs: + /* + * Build up equivalent to Tcl_WrongNumArgs message for proc + */ - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclObjInterpProc -- - * - * When a Tcl procedure gets invoked during bytecode evaluation, this - * object-based routine gets invoked to interpret the procedure. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * Depends on the commands in the procedure. - * - *---------------------------------------------------------------------- - */ + Tcl_ResetResult(interp); + objResult = Tcl_GetObjResult(interp); + Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1); -int -TclObjInterpProc( - 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. */ -{ - /* - * Not used much in the core; external interface for iTcl - */ + /* + * Quote the proc name if it contains spaces (Bug 942757). + */ - return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); -} + len = Tcl_ScanCountedElement(procName, nameLen, &flags); + if (len != nameLen) { + char *procName1 = ckalloc((unsigned) len + 1); + len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags); + Tcl_AppendToObj(objResult, procName1, len); + ckfree(procName1); + } else { + Tcl_AppendToObj(objResult, procName, len); + } -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); + localPtr = procPtr->firstLocalPtr; + for (i = 1; i <= numArgs; i++) { + if (localPtr->defValuePtr != NULL) { + Tcl_AppendStringsToObj(objResult, + " ?", localPtr->name, "?", (char *) NULL); + } else { + Tcl_AppendStringsToObj(objResult, + " ", localPtr->name, (char *) NULL); + } + localPtr = localPtr->nextPtr; + } + Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL); - if (result != TCL_OK) { - return TCL_ERROR; + result = TCL_ERROR; + goto procDone; } - return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); -} - -/* - *---------------------------------------------------------------------- - * - * TclNRInterpProcCore -- - * - * When a Tcl procedure, lambda term or anything else that works like a - * procedure gets invoked during bytecode evaluation, this object-based - * routine gets invoked to interpret the body. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * Nearly anything; depends on the commands in the procedure body. - * - *---------------------------------------------------------------------- - */ -int -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 - * results of the overall procedure. */ -{ - 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) { - 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; - } + /* + * Invoke the commands in the procedure's body. + */ -#if defined(TCL_COMPILE_DEBUG) +#ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 1) { - register CallFrame *framePtr = iPtr->varFramePtr; - register int i; - - if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { - fprintf(stdout, "Calling lambda "); - } else { - fprintf(stdout, "Calling proc "); - } - for (i = 0; i < framePtr->objc; i++) { - TclPrintObject(stdout, framePtr->objv[i], 15); + fprintf(stdout, "Calling proc "); + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); @@ -1787,157 +1198,66 @@ TclNRInterpProcCore( #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++; + char *a[10]; + int i = 0; + + while (i < 10) { + a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; } 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; +#endif /* USE_DTRACE */ - 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)); - } + iPtr->returnCode = TCL_OK; + procPtr->refCount++; 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)); + TCL_DTRACE_PROC_ENTRY(TclGetString(objv[0]), objc - 1, + (Tcl_Obj **)(objv + 1)); } -#endif /* USE_DTRACE */ - - /* - * Invoke the commands in the procedure's body. +#ifndef TCL_TIP280 + result = TclCompEvalObj(interp, procPtr->bodyPtr); +#else + /* TIP #280: No need to set the invoking context here. The body has + * already been compiled, so the part of CompEvalObj using it is bypassed. */ - procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; - - TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, - NULL, NULL); - return TclNRExecuteByteCode(interp, 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]; - + result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0); +#endif 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); + TCL_DTRACE_PROC_RETURN(TclGetString(objv[0]), result); } - if (--procPtr->refCount <= 0) { + procPtr->refCount--; + if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } - /* - * Process the result code. - */ - - switch (result) { - case TCL_RETURN: - /* - * If it is a 'return', do the TIP#90 processing now. - */ - - result = TclUpdateReturnInfo((Interp *) interp); - break; - - case TCL_CONTINUE: - case TCL_BREAK: - /* - * It's an error to get to this point from a 'break' or 'continue', so - * transform to an error now. - */ - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((result == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); - result = TCL_ERROR; - - /* - * Fall through to the TCL_ERROR handling code. - */ - - case TCL_ERROR: - /* - * Now it _must_ be an error, so we need to log it as such. This means - * filling out the error trace. Luckily, we just hand this off to the - * 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 */ + if (result != TCL_OK) { + result = ProcessProcResultCode(interp, procName, nameLen, result); } +#ifdef USE_DTRACE if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - Tcl_Obj *r = Tcl_GetObjResult(interp); + Tcl_Obj *r; - TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, + r = Tcl_GetObjResult(interp); + TCL_DTRACE_PROC_RESULT(TclGetString(objv[0]), result, TclGetString(r), r); } +#endif /* USE_DTRACE */ /* - * 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. + * Pop and free the call frame for this procedure invocation, then + * free the compiledLocals array if malloc'ed storage was used. */ - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - + procDone: + Tcl_PopCallFrame(interp); + if (compiledLocals != localStorage) { + ckfree((char *) compiledLocals); + } return result; +#undef NUM_LOCALS } /* @@ -1945,165 +1265,251 @@ InterpProcNR2( * * TclProcCompileProc -- * - * Called just before a procedure is executed to compile the body to byte - * codes. If the type of the body is not "byte code" or if the compile - * conditions have changed (namespace context, epoch counters, etc.) then - * the body is recompiled. Otherwise, this function does nothing. + * Called just before a procedure is executed to compile the + * body to byte codes. If the type of the body is not + * "byte code" or if the compile conditions have changed + * (namespace context, epoch counters, etc.) then the body + * is recompiled. Otherwise, this procedure does nothing. * * Results: * None. * * Side effects: - * May change the internal representation of the body object to compiled - * code. + * May change the internal representation of the body object + * to compiled code. * *---------------------------------------------------------------------- */ int -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. */ +TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) + 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. */ { - Interp *iPtr = (Interp *) interp; - Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; + return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, + description, procName, NULL); +} + +static int +ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, + procName, procPtrPtr) + 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. */ + Proc **procPtrPtr; /* points to storage where a replacement + * (Proc *) value may be written, when + * appropriate */ +{ + Interp *iPtr = (Interp*)interp; + int i, result; + Tcl_CallFrame frame; + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + CompiledLocal *localPtr; /* - * If necessary, compile the procedure's body. The compiler will allocate - * frame slots for the procedure's non-argument local variables. If the - * ByteCode already exists, make sure it hasn't been invalidated by - * someone redefining a core command (this might make the compiled code - * wrong). Also, if the code was compiled in/for a different interpreter, - * we recompile it. Note that compiling the body might increase - * procPtr->numCompiledLocals if new local variables are found while - * compiling. + * If necessary, compile the procedure's body. The compiler will + * allocate frame slots for the procedure's non-argument local + * variables. If the ByteCode already exists, make sure it hasn't been + * invalidated by someone redefining a core command (this might make the + * compiled code wrong). Also, if the code was compiled in/for a + * different interpreter, we recompile it. Note that compiling the body + * might increase procPtr->numCompiledLocals if new local variables are + * found while compiling. * - * Precompiled procedure bodies, however, are immutable and therefore they - * are not recompiled, even if things have changed. + * Precompiled procedure bodies, however, are immutable and therefore + * they are not recompiled, even if things have changed. */ if (bodyPtr->typePtr == &tclByteCodeType) { - if (((Interp *) *codePtr->interpHandle == iPtr) - && (codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsPtr == nsPtr) - && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { - return TCL_OK; - } - - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "CROSSINTERPBYTECODE", NULL); - return TCL_ERROR; - } - codePtr->compileEpoch = iPtr->compileEpoch; - codePtr->nsPtr = nsPtr; - } else { - TclFreeIntRep(bodyPtr); - } + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr)) { + 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 { + (*tclByteCodeType.freeIntRepProc)(bodyPtr); + bodyPtr->typePtr = (Tcl_ObjType *) NULL; + } + } } - if (bodyPtr->typePtr != &tclByteCodeType) { - Tcl_HashEntry *hePtr; + int numChars; + char *ellipsis; #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ - - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "Compiling "); - Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", NULL); - Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); - fprintf(stdout, "%s\"\n", TclGetString(message)); - Tcl_DecrRefCount(message); - } + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we + * are about to compile. + */ + + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + fprintf(stdout, "Compiling %s \"%.*s%s\"\n", + description, numChars, procName, ellipsis); + } #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. - */ - - iPtr->compiledProcPtr = procPtr; + /* + * 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. + */ + + if (procPtrPtr != NULL && procPtr->refCount > 1) { + Tcl_Command token; + Tcl_CmdInfo info; + Proc *new = (Proc *) ckalloc(sizeof(Proc)); + + new->iPtr = procPtr->iPtr; + new->refCount = 1; + new->cmdPtr = procPtr->cmdPtr; + token = (Tcl_Command) new->cmdPtr; + new->bodyPtr = Tcl_DuplicateObj(bodyPtr); + bodyPtr = new->bodyPtr; + Tcl_IncrRefCount(bodyPtr); + new->numArgs = procPtr->numArgs; + + new->numCompiledLocals = new->numArgs; + new->firstLocalPtr = NULL; + new->lastLocalPtr = NULL; + localPtr = procPtr->firstLocalPtr; + for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) { + CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) -sizeof(localPtr->name) + + localPtr->nameLength + 1)); + if (new->firstLocalPtr == NULL) { + new->firstLocalPtr = new->lastLocalPtr = copy; + } else { + new->lastLocalPtr->nextPtr = copy; + new->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; + memcpy(copy->name, localPtr->name, localPtr->nameLength + 1); + } - if (procPtr->numCompiledLocals > procPtr->numArgs) { - CompiledLocal *clPtr = procPtr->firstLocalPtr; - CompiledLocal *lastPtr = NULL; - int i, numArgs = procPtr->numArgs; - for (i = 0; i < numArgs; i++) { - lastPtr = clPtr; - clPtr = clPtr->nextPtr; + /* Reset the ClientData */ + Tcl_GetCommandInfoFromToken(token, &info); + if (info.objClientData == (ClientData) procPtr) { + info.objClientData = (ClientData) new; } - - if (lastPtr) { - lastPtr->nextPtr = NULL; - } else { - procPtr->firstLocalPtr = NULL; + if (info.clientData == (ClientData) procPtr) { + info.clientData = (ClientData) new; } - 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); + if (info.deleteData == (ClientData) procPtr) { + info.deleteData = (ClientData) new; } - procPtr->numCompiledLocals = procPtr->numArgs; - } + Tcl_SetCommandInfoFromToken(token, &info); - TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, - /* isProcCallFrame */ 0); + procPtr->refCount--; + *procPtrPtr = procPtr = new; + } + iPtr->compiledProcPtr = procPtr; - /* - * TIP #280: We get the invoking context from the cmdFrame which - * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). - */ + result = Tcl_PushCallFrame(interp, &frame, + (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); - hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); + if (result == TCL_OK) { +#ifdef TCL_TIP280 + /* TIP #280. We get the invoking context from the cmdFrame + * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). + */ - /* - * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. - */ + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); - iPtr->invokeWord = 0; - iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); - tclByteCodeType.setFromAnyProc(interp, bodyPtr); - iPtr->invokeCmdFramePtr = NULL; - TclPopStackFrame(interp); + /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. + */ + iPtr->invokeWord = 0; + iPtr->invokeCmdFramePtr = (hePtr + ? (CmdFrame*) Tcl_GetHashValue (hePtr) + : NULL); +#endif + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); +#ifdef TCL_TIP280 + iPtr->invokeCmdFramePtr = NULL; +#endif + Tcl_PopCallFrame(interp); + } + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char buf[100 + TCL_INTEGER_SPACE]; + + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + while ( (procName[numChars] & 0xC0) == 0x80 ) { + /* + * Back up truncation point so that we don't truncate + * in the middle of a multi-byte character (in UTF-8) + */ + numChars--; + ellipsis = "..."; + } + sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", + description, numChars, procName, ellipsis, + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + return result; + } } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { + /* - * The resolver epoch has changed, but we only need to invalidate the - * resolver cache. + * The resolver epoch has changed, but we only need to invalidate + * the resolver cache. */ - codePtr->nsEpoch = nsPtr->resolverEpoch; - codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + localPtr->flags &= ~(VAR_RESOLVED); + if (localPtr->resolveInfo) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree((char*)localPtr->resolveInfo); + } + localPtr->resolveInfo = NULL; + } + } } return TCL_OK; } @@ -2111,36 +1517,68 @@ TclProcCompileProc( /* *---------------------------------------------------------------------- * - * MakeProcError -- + * ProcessProcResultCode -- * - * Function called by TclObjInterpProc to create the stack information - * upon an error from a procedure. + * Procedure called by TclObjInterpProc to process a return code other + * than TCL_OK returned by a Tcl procedure. * * Results: - * The interpreter's error info trace is set to a value that supplements - * the error code. + * Depending on the argument return code, the result returned is + * another return code and the interpreter's result is set to a value + * to supplement that return code. * * Side effects: - * none. + * If the result returned is TCL_ERROR, traceback information about + * the procedure just executed is appended to the interpreter's + * "errorInfo" variable. * *---------------------------------------------------------------------- */ -static void -MakeProcError( - Tcl_Interp *interp, /* The interpreter in which the procedure was - * called. */ - Tcl_Obj *procNameObj) /* Name of the procedure. Used for error +static int +ProcessProcResultCode(interp, procName, nameLen, returnCode) + Tcl_Interp *interp; /* The interpreter in which the procedure + * was called and returned returnCode. */ + char *procName; /* Name of the procedure. Used for error * messages and trace information. */ + int nameLen; /* Number of bytes in procedure's name. */ + int returnCode; /* The unexpected result code. */ { - int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); - - overflow = (nameLen > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (procedure \"%.*s%s\" line %d)", - (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + Interp *iPtr = (Interp *) interp; + char msg[100 + TCL_INTEGER_SPACE]; + char *ellipsis = ""; + + if (returnCode == TCL_OK) { + return TCL_OK; + } + if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { + return returnCode; + } + if (returnCode == TCL_RETURN) { + return TclUpdateReturnInfo(iPtr); + } + if (returnCode != TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) + ? "invoked \"break\" outside of a loop" + : "invoked \"continue\" outside of a loop"), -1); + } + if (nameLen > 60) { + nameLen = 60; + ellipsis = "..."; + } + while ( (procName[nameLen] & 0xC0) == 0x80 ) { + /* + * Back up truncation point so that we don't truncate in the + * middle of a multi-byte character (in UTF-8) + */ + nameLen--; + ellipsis = "..."; + } + sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName, + ellipsis, iPtr->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + return TCL_ERROR; } /* @@ -2148,26 +1586,26 @@ MakeProcError( * * TclProcDeleteProc -- * - * This function is invoked just before a command procedure is removed - * from an interpreter. Its job is to release all the resources allocated - * to the procedure. + * This procedure is invoked just before a command procedure is + * removed from an interpreter. Its job is to release all the + * resources allocated to the procedure. * * Results: * None. * * Side effects: - * Memory gets freed, unless the procedure is actively being executed. - * In this case the cleanup is delayed until the last call to the current - * procedure completes. + * Memory gets freed, unless the procedure is actively being + * executed. In this case the cleanup is delayed until the + * last call to the current procedure completes. * *---------------------------------------------------------------------- */ void -TclProcDeleteProc( - ClientData clientData) /* Procedure to be deleted. */ +TclProcDeleteProc(clientData) + ClientData clientData; /* Procedure to be deleted. */ { - Proc *procPtr = clientData; + Proc *procPtr = (Proc *) clientData; procPtr->refCount--; if (procPtr->refCount <= 0) { @@ -2180,8 +1618,9 @@ TclProcDeleteProc( * * TclProcCleanupProc -- * - * This function does all the real work of freeing up a Proc structure. - * It's called only when the structure's reference count becomes zero. + * This procedure does all the real work of freeing up a Proc + * structure. It's called only when the structure's reference + * count becomes zero. * * Results: * None. @@ -2193,66 +1632,64 @@ TclProcDeleteProc( */ void -TclProcCleanupProc( - register Proc *procPtr) /* Procedure to be deleted. */ +TclProcCleanupProc(procPtr) + register Proc *procPtr; /* Procedure to be deleted. */ { register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; - Tcl_HashEntry *hePtr = NULL; - CmdFrame *cfPtr = NULL; - Interp *iPtr = procPtr->iPtr; +#ifdef TCL_TIP280 + Tcl_HashEntry* hePtr = NULL; + CmdFrame* cfPtr = NULL; + Interp* iPtr = procPtr->iPtr; +#endif if (bodyPtr != NULL) { Tcl_DecrRefCount(bodyPtr); } - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { CompiledLocal *nextPtr = localPtr->nextPtr; - resVarInfo = localPtr->resolveInfo; + resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { - resVarInfo->deleteProc(resVarInfo); + (*resVarInfo->deleteProc)(resVarInfo); } else { - ckfree(resVarInfo); + ckfree((char *) resVarInfo); } - } + } if (localPtr->defValuePtr != NULL) { defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - ckfree(localPtr); + ckfree((char *) localPtr); localPtr = nextPtr; } - ckfree(procPtr); + ckfree((char *) procPtr); - /* - * TIP #280: Release the location data associated with this Proc +#ifdef TCL_TIP280 + /* TIP #280. Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for - * procbody structures created by tbcload. + * procbody structurues created by tbcload. */ - if (!iPtr) { - return; - } + if (!iPtr) return; - hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); - if (!hePtr) { - return; - } + hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); + if (!hePtr) return; - cfPtr = Tcl_GetHashValue(hePtr); + cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr); if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); + Tcl_DecrRefCount (cfPtr->data.eval.path); cfPtr->data.eval.path = NULL; } - ckfree(cfPtr->line); - cfPtr->line = NULL; - ckfree(cfPtr); - Tcl_DeleteHashEntry(hePtr); + ckfree ((char*) cfPtr->line); cfPtr->line = NULL; + ckfree ((char*) cfPtr); + Tcl_DeleteHashEntry (hePtr); +#endif } /* @@ -2260,44 +1697,47 @@ TclProcCleanupProc( * * TclUpdateReturnInfo -- * - * This function is called when procedures return, and at other points - * where the TCL_RETURN code is used. It examines the returnLevel and - * returnCode to determine the real return status. + * This procedure is called when procedures return, and at other + * points where the TCL_RETURN code is used. It examines fields + * such as iPtr->returnCode and iPtr->errorCode and modifies + * the real return status accordingly. * * Results: - * The return value is the true completion code to use for the procedure - * or script, instead of TCL_RETURN. + * The return value is the true completion code to use for + * the procedure, instead of TCL_RETURN. * * Side effects: - * None. + * The errorInfo and errorCode variables may get modified. * *---------------------------------------------------------------------- */ int -TclUpdateReturnInfo( - Interp *iPtr) /* Interpreter for which TCL_RETURN exception - * is being processed. */ +TclUpdateReturnInfo(iPtr) + Interp *iPtr; /* Interpreter for which TCL_RETURN + * exception is being processed. */ { - int code = TCL_RETURN; - - iPtr->returnLevel--; - if (iPtr->returnLevel < 0) { - Tcl_Panic("TclUpdateReturnInfo: negative return level"); - } - 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]. - */ + int code; + char *errorCode; + Tcl_Obj *objPtr; - code = iPtr->returnCode; - iPtr->returnLevel = 1; - iPtr->returnCode = TCL_OK; - if (code == TCL_ERROR) { - iPtr->flags |= ERR_LEGACY_COPY; + code = iPtr->returnCode; + iPtr->returnCode = TCL_OK; + if (code == TCL_ERROR) { + errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE"); + objPtr = Tcl_NewStringObj(errorCode, -1); + Tcl_IncrRefCount(objPtr); + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode, + NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); + iPtr->flags |= ERROR_CODE_SET; + if (iPtr->errorInfo != NULL) { + objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1); + Tcl_IncrRefCount(objPtr); + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo, + NULL, objPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(objPtr); + iPtr->flags |= ERR_IN_PROGRESS; } } return code; @@ -2306,24 +1746,49 @@ TclUpdateReturnInfo( /* *---------------------------------------------------------------------- * + * TclGetInterpProc -- + * + * Returns a pointer to the TclProcInterpProc procedure; this is different + * from the value obtained from the TclProcInterpProc reference on systems + * like Windows where import and export versions of a procedure exported + * by a DLL exist. + * + * Results: + * Returns the internal address of the TclProcInterpProc procedure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclCmdProcType +TclGetInterpProc() +{ + return (TclCmdProcType) TclProcInterpProc; +} + +/* + *---------------------------------------------------------------------- + * * TclGetObjInterpProc -- * - * Returns a pointer to the TclObjInterpProc function; this is different - * from the value obtained from the TclObjInterpProc reference on systems - * like Windows where import and export versions of a function exported - * by a DLL exist. + * Returns a pointer to the TclObjInterpProc procedure; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a procedure exported + * by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc function. + * Returns the internal address of the TclObjInterpProc procedure. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ TclObjCmdProcType -TclGetObjInterpProc(void) +TclGetObjInterpProc() { return (TclObjCmdProcType) TclObjInterpProc; } @@ -2333,37 +1798,38 @@ TclGetObjInterpProc(void) * * TclNewProcBodyObj -- * - * Creates a new object, of type "procbody", whose internal - * representation is the given Proc struct. The newly created object's - * reference count is 0. + * Creates a new object, of type "procbody", whose internal + * representation is the given Proc struct. + * The newly created object's reference count is 0. * * Results: - * Returns a pointer to a newly allocated Tcl_Obj, NULL on error. + * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. * * Side effects: - * The reference count in the ByteCode attached to the Proc is bumped up - * by one, since the internal rep stores a pointer to it. + * The reference count in the ByteCode attached to the Proc is bumped up + * by one, since the internal rep stores a pointer to it. * *---------------------------------------------------------------------- */ Tcl_Obj * -TclNewProcBodyObj( - Proc *procPtr) /* the Proc struct to store as the internal - * representation. */ +TclNewProcBodyObj(procPtr) + Proc *procPtr; /* the Proc struct to store as the internal + * representation. */ { Tcl_Obj *objPtr; if (!procPtr) { - return NULL; + return (Tcl_Obj *) NULL; } - TclNewObj(objPtr); + objPtr = Tcl_NewStringObj("", 0); + if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = procPtr; + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.otherValuePtr = (VOID *) procPtr; - procPtr->refCount++; + procPtr->refCount++; } return objPtr; @@ -2374,27 +1840,27 @@ TclNewProcBodyObj( * * ProcBodyDup -- * - * Tcl_ObjType's Dup function for the proc body object. Bumps the - * reference count on the Proc stored in the internal representation. + * Tcl_ObjType's Dup function for the proc body object. + * Bumps the reference count on the Proc stored in the internal + * representation. * * Results: - * None. + * None. * * Side effects: - * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. + * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. * *---------------------------------------------------------------------- */ -static void -ProcBodyDup( - Tcl_Obj *srcPtr, /* Object to copy. */ - Tcl_Obj *dupPtr) /* Target object for the duplication. */ +static void ProcBodyDup(srcPtr, dupPtr) + Tcl_Obj *srcPtr; /* object to copy */ + Tcl_Obj *dupPtr; /* target object for the duplication */ { - Proc *procPtr = srcPtr->internalRep.otherValuePtr; + Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = procPtr; + dupPtr->internalRep.otherValuePtr = (VOID *) procPtr; procPtr->refCount++; } @@ -2403,668 +1869,130 @@ ProcBodyDup( * * ProcBodyFree -- * - * Tcl_ObjType's Free function for the proc body object. The reference - * count on its Proc struct is decreased by 1; if the count reaches 0, - * the proc is freed. + * Tcl_ObjType's Free function for the proc body object. + * The reference count on its Proc struct is decreased by 1; if the count + * reaches 0, the proc is freed. * * Results: - * None. + * None. * * Side effects: - * If the reference count on the Proc struct reaches 0, the struct is - * freed. + * If the reference count on the Proc struct reaches 0, the struct is freed. * *---------------------------------------------------------------------- */ static void -ProcBodyFree( - Tcl_Obj *objPtr) /* The object to clean up. */ +ProcBodyFree(objPtr) + Tcl_Obj *objPtr; /* the object to clean up */ { - Proc *procPtr = objPtr->internalRep.otherValuePtr; - + Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; procPtr->refCount--; if (procPtr->refCount <= 0) { - TclProcCleanupProc(procPtr); + TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * - * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny -- + * ProcBodySetFromAny -- * - * How to manage the internal representations of lambda term objects. - * Syntactically they look like a two- or three-element list, where the - * first element is the formal arguments, the second is the the body, and - * the (optional) third is the namespace to execute the lambda term - * within (the global namespace is assumed if it is absent). + * Tcl_ObjType's SetFromAny function for the proc body object. + * Calls panic. + * + * Results: + * Theoretically returns a TCL result code. + * + * Side effects: + * Calls panic, since we can't set the value of the object from a string + * representation (or any other internal ones). * *---------------------------------------------------------------------- */ -static void -DupLambdaInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; - - copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - - procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &lambdaType; -} - -static void -FreeLambdaInternalRep( - register Tcl_Obj *objPtr) /* CmdName object with internal representation - * to free. */ -{ - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - - procPtr->refCount--; - if (procPtr->refCount == 0) { - TclProcCleanupProc(procPtr); - } - TclDecrRefCount(nsObjPtr); - objPtr->typePtr = NULL; -} - static int -SetLambdaFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ +ProcBodySetFromAny(interp, objPtr) + Tcl_Interp *interp; /* current interpreter */ + Tcl_Obj *objPtr; /* object pointer */ { - Interp *iPtr = (Interp *) interp; - const char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; - int objc, result; - 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(NULL, objPtr, &objc, &objv); - if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - 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; - } - - argsPtr = objv[0]; - bodyPtr = objv[1]; - - /* - * Create and initialize the Proc struct. The cmdPtr field is set to NULL - * to signal that this is an anonymous function. - */ - - name = TclGetString(objPtr); - - if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr, - &procPtr) != TCL_OK) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (parsing lambda expression \"%s\")", name)); - return TCL_ERROR; - } - - /* - * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454] - * procPtr->refCount = 1; - */ - - procPtr->cmdPtr = NULL; + panic("called ProcBodySetFromAny"); /* - * TIP #280: Remember the line the apply body is starting on. In a Byte - * code context we ask the engine to provide us with the necessary - * information. This is for the initialization of the byte code compiler - * when the body is used for the first time. - * - * NOTE: The body is the second word in the 'objPtr'. Its location, - * accessible through 'context.line[1]' (see below) is therefore only the - * first approximation of the actual line the body is on. We have to use - * the string rep of the 'objPtr' to determine the exact line. This is - * available already through 'name'. Use 'TclListLines', see 'switch' - * (tclCmdMZ.c). - * - * This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see - * this file. The differences are the different index of the body in the - * line array of the context, and the special processing mentioned in the - * previous paragraph to track into the list. Find a way to factor the - * common elements into a single function. + * this to keep compilers happy. */ - if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - - *contextPtr = *iPtr->cmdFramePtr; - if (contextPtr->type == TCL_LOCATION_BC) { - /* - * Retrieve the source context from the bytecode. This call - * accounts for the reference to the source file, if any, held in - * 'context.data.eval.path'. - */ - - TclGetSrcInfoForPc(contextPtr); - } else if (contextPtr->type == TCL_LOCATION_SOURCE) { - /* - * We created a new reference to the source file path name when we - * created 'context' above. Account for the reference. - */ - - Tcl_IncrRefCount(contextPtr->data.eval.path); - - } - - if (contextPtr->type == TCL_LOCATION_SOURCE) { - /* - * We can record source location within a lambda only if the body - * was not created by substitution. - */ - - if (contextPtr->line - && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { - int isNew, buf[2]; - CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); - - /* - * Move from approximation (line of list cmd word) to actual - * location (line of 2nd list element). - */ - - TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); - - cfPtr->level = -1; - cfPtr->type = contextPtr->type; - cfPtr->line = ckalloc(sizeof(int)); - cfPtr->line[0] = buf[1]; - cfPtr->nline = 1; - cfPtr->framePtr = NULL; - cfPtr->nextPtr = NULL; - - 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, - procPtr, &isNew), cfPtr); - } - - /* - * 'contextPtr' is going out of scope. Release the reference that - * it's holding to the source file path - */ - - Tcl_DecrRefCount(contextPtr->data.eval.path); - } - TclStackFree(interp, contextPtr); - } - - /* - * Set the namespace for this lambda: given by objv[2] understood as a - * global reference, or else global per default. - */ - - if (objc == 2) { - TclNewLiteralStringObj(nsObjPtr, "::"); - } else { - const char *nsName = TclGetString(objv[2]); - - if ((*nsName != ':') || (*(nsName+1) != ':')) { - TclNewLiteralStringObj(nsObjPtr, "::"); - Tcl_AppendObjToObj(nsObjPtr, objv[2]); - } else { - nsObjPtr = objv[2]; - } - } - - Tcl_IncrRefCount(nsObjPtr); - - /* - * Free the list internalrep of objPtr - this will free argsPtr, but - * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to lambdaType. - */ - - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &lambdaType; return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_ApplyObjCmd -- + * ProcBodyUpdateString -- * - * This object-based function is invoked to process the "apply" Tcl - * command. See the user documentation for details on what it does. + * Tcl_ObjType's UpdateString function for the proc body object. + * Calls panic. * * Results: - * A standard Tcl object result value. + * None. * * Side effects: - * Depends on the content of the lambda term (i.e., objv[1]). + * Calls panic, since we this type has no string representation. * *---------------------------------------------------------------------- */ -int -Tcl_ApplyObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - 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. */ +static void +ProcBodyUpdateString(objPtr) + Tcl_Obj *objPtr; /* the object to update */ { - Interp *iPtr = (Interp *) interp; - Proc *procPtr = NULL; - Tcl_Obj *lambdaPtr, *nsObjPtr; - int result, isRootEnsemble; - Tcl_Namespace *nsPtr; - ApplyExtraData *extraPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?"); - return TCL_ERROR; - } - - /* - * Set lambdaPtr, convert it to lambdaType in the current interp if - * necessary. - */ - - lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &lambdaType) { - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; - } - -#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) || - (TclListObjGetElements(interp, lambdaPtr, &numElem, - &elemPtr) == TCL_OK && numElem == 1)) { - return Tcl_EvalObjv(interp, objc-1, objv+1, 0); - } - } -#endif - - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { - result = SetLambdaFromAny(interp, lambdaPtr); - if (result != TCL_OK) { - return result; - } - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; - } - - /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. - */ - - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return TCL_ERROR; - } - - 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) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 1; - iPtr->ensembleRewrite.numInsertedObjs = 0; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 1; - } - extraPtr->isRootEnsemble = isRootEnsemble; - - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result == TCL_OK) { - TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); - result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); - } - return result; + panic("called ProcBodyUpdateString"); } -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; -} - /* *---------------------------------------------------------------------- * - * MakeLambdaError -- + * TclCompileNoOp -- * - * Function called by TclObjInterpProc to create the stack information - * upon an error from a lambda term. + * Procedure called to compile noOp's * * Results: - * The interpreter's error info trace is set to a value that supplements - * the error code. + * The return value is TCL_OK, indicating successful compilation. * * Side effects: - * none. + * Instructions are added to envPtr to execute a noOp at runtime. * *---------------------------------------------------------------------- */ -static void -MakeLambdaError( - Tcl_Interp *interp, /* The interpreter in which the procedure was - * called. */ - Tcl_Obj *procNameObj) /* Name of the procedure. Used for error - * messages and trace information. */ -{ - int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); - - overflow = (nameLen > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (lambda term \"%.*s%s\" line %d)", - (overflow ? limit : nameLen), procName, - (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 int +TclCompileNoOp(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ { - 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; + Tcl_Token *tokenPtr; + int i, code; + int savedStackDepth = envPtr->currStackDepth; + + tokenPtr = parsePtr->tokenPtr; + for(i = 1; i < parsePtr->numWords; i++) { + tokenPtr = tokenPtr + tokenPtr->numComponents + 1; + envPtr->currStackDepth = savedStackDepth; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; } - 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; + TclEmitOpcode(INST_POP, envPtr); } - 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_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); - 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) { - if (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_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" is not a class", NULL); - 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_AppendResult(interp, "unknown method \"", - TclGetString(objv[3]), "\"", NULL); - 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_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.otherValuePtr)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); return TCL_OK; } @@ -3075,3 +2003,4 @@ Tcl_DisassembleObjCmd( * fill-column: 78 * End: */ + |