diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 3069 |
1 files changed, 1984 insertions, 1085 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index 09c0322..518ddb5 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1,15 +1,16 @@ /* * 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" @@ -19,19 +20,30 @@ * Prototypes for static functions in this file */ -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)); +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 int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, + Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName, + Proc **procPtrPtr); /* * The ProcBodyObjType type @@ -39,10 +51,44 @@ static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ - ProcBodyFree, /* FreeInternalRep procedure */ - ProcBodyDup, /* DupInternalRep procedure */ - ProcBodyUpdateString, /* UpdateString procedure */ - ProcBodySetFromAny /* SetFromAny procedure */ + 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 twoPtrValue field, + * encoding the type of level reference in ptr1 and the actual parsed out + * offset in ptr2. + * + * Uses the default behaviour throughout, and never disposes of the string + * rep; it's just a cache type. + */ + +static 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 Tcl_ObjType lambdaType = { + "lambdaExpr", /* name */ + FreeLambdaInternalRep, /* freeIntRepProc */ + DupLambdaInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetLambdaFromAny /* setFromAnyProc */ }; /* @@ -50,7 +96,7 @@ Tcl_ObjType tclProcBodyType = { * * Tcl_ProcObjCmd -- * - * This object-based procedure is invoked to process the "proc" Tcl + * This object-based function is invoked to process the "proc" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -64,11 +110,11 @@ Tcl_ObjType tclProcBodyType = { /* ARGSUSED */ int -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. */ +Tcl_ProcObjCmd( + 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; @@ -84,47 +130,48 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } /* - * 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, (Namespace *) NULL, - 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + TclGetNamespaceForQualName(interp, fullName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't create procedure \"", fullName, - "\": unknown namespace", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": unknown namespace", NULL); + return TCL_ERROR; } if (procName == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't create procedure \"", fullName, - "\": bad procedure name", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": bad procedure name", NULL); + return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't create procedure \"", procName, + Tcl_AppendResult(interp, "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", - (char *) NULL); - return TCL_ERROR; + 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) { - return TCL_ERROR; + &procPtr) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (creating proc \""); + Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, "\")"); + 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. */ @@ -136,12 +183,11 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } Tcl_DStringAppend(&ds, procName, -1); - 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 @@ -151,105 +197,123 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) procPtr->cmdPtr = (Command *) cmd; -#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 + /* + * 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 * 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 context = *iPtr->cmdFramePtr; - - 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); - } + CmdFrame *contextPtr; - /* 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. - */ + contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); + *contextPtr = *iPtr->cmdFramePtr; - 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_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. + */ - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + 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. + */ - 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. - */ + Tcl_IncrRefCount(contextPtr->data.eval.path); + } + + 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. + */ + + if (contextPtr->line + && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { + int isNew; + Tcl_HashEntry* hePtr; + CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); + + cfPtr->level = -1; + cfPtr->type = contextPtr->type; + cfPtr->line = (int *) 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, (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 = (CmdFrame *) 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; + if (cfOldPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfOldPtr->data.eval.path); + cfOldPtr->data.eval.path = NULL; + } + ckfree((char *) cfOldPtr->line); + cfOldPtr->line = NULL; + ckfree((char *) cfOldPtr); } - ckfree((char *) cfOldPtr->line); - cfOldPtr->line = NULL; - ckfree((char *) cfOldPtr); + Tcl_SetHashValue(hePtr, cfPtr); } - Tcl_SetHashValue (hePtr, cfPtr); + + /* + * '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; } + TclStackFree(interp, contextPtr); } -#endif /* - * Optimize for noop procs: if the body is not precompiled (like a TclPro + * Optimize for no-op 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 noop. + * define a compileProc to compile a no-op. * * 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 = Tcl_GetString(objv[2]); + procArgs = TclGetString(objv[2]); while (*procArgs == ' ') { procArgs++; @@ -268,7 +332,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * The argument list is just "args"; check the body */ - procBody = Tcl_GetString(objv[3]); + procBody = TclGetString(objv[3]); while (*procBody != '\0') { if (!isspace(UCHAR(*procBody))) { goto done; @@ -283,7 +347,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) ((Command *) cmd)->compileProc = TclCompileNoOp; } - done: + done: return TCL_OK; } @@ -292,34 +356,35 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * * TclCreateProc -- * - * 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. + * 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. * * Results: - * 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. + * 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. * * Side effects: - * If anything goes wrong, this procedure returns an error - * message in the interpreter. + * If anything goes wrong, this function returns an error message in the + * interpreter. * *---------------------------------------------------------------------- */ + int -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 */ +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. */ { - Interp *iPtr = (Interp*)interp; + Interp *iPtr = (Interp *) interp; CONST char **argArray = NULL; register Proc *procPtr; @@ -330,46 +395,44 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) 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. 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; + /* + * 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; } 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 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 + /* + * 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; -#endif - bytes = Tcl_GetStringFromObj(bodyPtr, &length); - bodyPtr = Tcl_NewStringObj(bytes, length); -#ifdef TCL_TIP280 + + bytes = TclGetStringFromObj(bodyPtr, &length); + bodyPtr = Tcl_NewStringObj(bytes, length); + /* * TIP #280. * Ensure that the continuation line data for the original body is @@ -377,121 +440,111 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) */ TclContinuationsCopy (bodyPtr, sharedBodyPtr); -#endif - } + } - /* - * 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. - */ + /* + * 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. + */ - Tcl_IncrRefCount(bodyPtr); + Tcl_IncrRefCount(bodyPtr); - 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; + 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 the parsed argument is consistent with the one stored in the - * Proc. - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. + * 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. */ - args = Tcl_GetStringFromObj(argsPtr, &length); + args = TclGetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { - goto procError; + goto procError; } if (precompiled) { - 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; + if (numArgs > procPtr->numArgs) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": arg list contains %d entries, " + "precompiled header expects %d", procName, numArgs, + procPtr->numArgs)); + 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((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 { + 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_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", NULL); + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "argument with no name", 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_AppendStringsToObj(Tcl_GetObjResult(interp), - "procedure \"", procName, - "\" has formal parameter \"", fieldValues[0], - "\" that is an array element", - (char *) NULL); + if (*q == ')') { /* We have an array element. */ + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is an array element", NULL); ckfree((char *) fieldValues); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "procedure \"", procName, - "\" has formal parameter \"", fieldValues[0], - "\" that is not a simple name", - (char *) NULL); + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is not a simple name", NULL); ckfree((char *) fieldValues); goto procError; } @@ -500,116 +553,117 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) if (precompiled) { /* - * Compare the parsed argument with the stored one. - * For the flags, we and out VAR_UNDEFINED to support bridging - * precompiled <= 8.3 code in 8.4 where this is now used as an - * optimization indicator. Yes, this is a hack. -- hobbs + * Compare the parsed argument with the stored one. Note that the + * only flag value that makes sense at this point is VAR_ARGUMENT + * (its value was kept the same as pre VarReform to simplify + * tbcload's processing of older byetcodes). + * + * The only other flag vlaue that is important to retrieve from + * precompiled procs is VAR_TEMPORARY (also unchanged). It is + * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) - || ((localPtr->flags & ~VAR_UNDEFINED) - != (VAR_SCALAR | VAR_ARGUMENT)) - || ((localPtr->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); + || !(localPtr->flags & VAR_ARGUMENT) + || (localPtr->defValuePtr == NULL && fieldCount == 2) + || (localPtr->defValuePtr != NULL && fieldCount != 2)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": formal parameter %d is " + "inconsistent with precompiled body", procName, i)); ckfree((char *) fieldValues); goto procError; } - /* - * 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); + /* + * Compare the default value if any. + */ + + if (localPtr->defValuePtr != NULL) { + int tmpLength; + 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((char *) fieldValues); + 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 = (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_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((char *) fieldValues); + 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((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((char *) localPtr); - } - ckfree((char *) procPtr); + ckfree((char *) localPtr); + } + ckfree((char *) procPtr); } if (argArray != NULL) { ckfree((char *) argArray); @@ -622,19 +676,19 @@ procError: * * 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. @@ -643,11 +697,11 @@ procError: */ int -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). */ +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). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; @@ -658,47 +712,166 @@ TclGetFrame(interp, string, framePtrPtr) */ result = 1; - curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; - if (*string == '#') { - if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { - return -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); + 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 = TclGetString(objPtr); + + /* + * Parse object to figure out which level number to go to. + */ + + result = 1; + curLevel = iPtr->varFramePtr->level; + if (objPtr->typePtr == &levelReferenceType) { + if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) { + level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } else { + level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); } if (level < 0) { - levelError: - Tcl_AppendResult(interp, "bad level \"", string, "\"", - (char *) NULL); - return -1; + 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; } - } else if (isdigit(UCHAR(*string))) { /* INTL: digit */ - if (Tcl_GetInt(interp, string, &level) != TCL_OK) { + level = curLevel - level; + } else if (*name == '#') { + if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { return -1; } + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); level = curLevel - level; } else { + /* + * Don't cache as the object *isn't* a level reference. + */ + level = curLevel - 1; result = 0; } /* - * Figure out which frame to use, and modify the interpreter so - * its variables come from that frame. + * Figure out which frame to use, and return it to the caller. */ - 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; + 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); + return -1; } /* @@ -706,8 +879,8 @@ TclGetFrame(interp, string, framePtrPtr) * * Tcl_UplevelObjCmd -- * - * This object procedure is invoked to process the "uplevel" Tcl - * command. See the user documentation for details on what it does. + * This object function 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. @@ -720,19 +893,18 @@ TclGetFrame(interp, string, framePtrPtr) /* ARGSUSED */ int -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. */ +Tcl_UplevelObjCmd( + 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; - char *optLevel; int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { - uplevelSyntax: + uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } @@ -741,8 +913,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) * Find the level to use for executing the command. */ - optLevel = TclGetString(objv[1]); - result = TclGetFrame(interp, optLevel, &framePtr); + result = TclObjGetFrame(interp, objv[1], &framePtr); if (result == -1) { return TCL_ERROR; } @@ -764,30 +935,30 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) */ if (objc == 1) { -#ifdef TCL_TIP280 - /* TIP #280. Make argument location available to eval'd script */ + /* + * 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 + result = TclEvalObjEx(interp, objv[0], 0, invoker, word); } 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); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"uplevel\" body line %d)", interp->errorLine)); } /* @@ -803,18 +974,17 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) * * 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. @@ -823,18 +993,17 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) */ Proc * -TclFindProc(iPtr, procName) - Interp *iPtr; /* Interpreter in which to look. */ - CONST char *procName; /* Name of desired procedure. */ +TclFindProc( + 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, - (Tcl_Namespace *) NULL, /*flags*/ 0); + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { - return NULL; + return NULL; } cmdPtr = (Command *) cmd; @@ -842,10 +1011,10 @@ TclFindProc(iPtr, procName) if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } - if (cmdPtr->proc != TclProcInterpProc) { + if (cmdPtr->objProc != TclObjInterpProc) { return NULL; } - return (Proc *) cmdPtr->clientData; + return (Proc *) cmdPtr->objClientData; } /* @@ -856,9 +1025,9 @@ TclFindProc(iPtr, procName) * 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. @@ -867,8 +1036,8 @@ TclFindProc(iPtr, procName) */ Proc * -TclIsProc(cmdPtr) - Command *cmdPtr; /* Command to test. */ +TclIsProc( + Command *cmdPtr) /* Command to test. */ { Tcl_Command origCmd; @@ -876,8 +1045,8 @@ TclIsProc(cmdPtr) if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } - if (cmdPtr->proc == TclProcInterpProc) { - return (Proc *) cmdPtr->clientData; + if (cmdPtr->objProc == TclObjInterpProc) { + return (Proc *) cmdPtr->objClientData; } return (Proc *) 0; } @@ -885,310 +1054,657 @@ TclIsProc(cmdPtr) /* *---------------------------------------------------------------------- * - * TclProcInterpProc -- + * InitArgsAndLocals -- * - * When a Tcl procedure gets invoked with an argc/argv array of - * strings, this routine gets invoked to interpret the procedure. + * This routine is invoked in order to initialize the arguments and other + * compiled locals table for a new call frame. * * Results: - * A standard Tcl result value, usually TCL_OK. + * A standard Tcl result. * * Side effects: - * Depends on the commands in the procedure. + * 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. * *---------------------------------------------------------------------- */ -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. */ +static int +ProcWrongNumArgs( + Tcl_Interp *interp, int skip) { - register Tcl_Obj *objPtr; - register int i; - int result; + 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; /* - * 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. + * Build up desired argument list for Tcl_WrongNumArgs */ -#define NUM_ARGS 20 - Tcl_Obj *(objStorage[NUM_ARGS]); - register Tcl_Obj **objv = objStorage; - - /* - * 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. - */ + numArgs = framePtr->procPtr->numArgs; + desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * (numArgs+1)); - if ((argc + 1) > NUM_ARGS) { - objv = (Tcl_Obj **) - ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); + if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { + desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); + } else { +#ifdef AVOID_HACKS_FOR_ITCL + desiredObjs[0] = framePtr->objv[skip-1]; +#else + desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); +#endif /* AVOID_HACKS_FOR_ITCL */ } - - for (i = 0; i < argc; i++) { - objv[i] = Tcl_NewStringObj(argv[i], -1); - Tcl_IncrRefCount(objv[i]); + 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 = "..."; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); + } + desiredObjs[i] = argObj; } - objv[argc] = 0; - - /* - * Use TclObjInterpProc to actually interpret the procedure. - */ - result = TclObjInterpProc(clientData, interp, argc, objv); + Tcl_ResetResult(interp); + Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + for (i=0 ; i<=numArgs ; i++) { + Tcl_DecrRefCount(desiredObjs[i]); + } + TclStackFree(interp, desiredObjs); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. + * - /* - * Decrement the ref counts on the objv elements since we are done - * with them. - */ + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ +void +TclInitCompiledLocals( + Tcl_Interp *interp, /* Current interpreter. */ + CallFrame *framePtr, /* Call frame to initialize. */ + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Var *varPtr = framePtr->compiledLocals; + Tcl_Obj *bodyPtr; + ByteCode *codePtr; - for (i = 0; i < argc; i++) { - objPtr = objv[i]; - TclDecrRefCount(objPtr); + 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; - /* - * Free the objv array if malloc'ed storage was used. - */ - - if (objv != objStorage) { - ckfree((char *) objv); + if (framePtr->numCompiledLocals) { + if (!codePtr->localCachePtr) { + InitLocalCache(framePtr->procPtr) ; + } + framePtr->localCachePtr = codePtr->localCachePtr; + framePtr->localCachePtr->refCount++; } - return result; -#undef NUM_ARGS + + InitResolvedLocals(interp, codePtr, varPtr, nsPtr); } /* *---------------------------------------------------------------------- * - * TclObjInterpProc -- + * InitResolvedLocals -- * - * When a Tcl procedure gets invoked during bytecode evaluation, this - * object-based routine gets invoked to interpret the procedure. + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. * * Results: - * A standard Tcl object result value. + * None. * * Side effects: - * Depends on the commands in the procedure. + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. * *---------------------------------------------------------------------- */ -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. */ +static void +InitResolvedLocals( + Tcl_Interp *interp, /* Current interpreter. */ + ByteCode *codePtr, + Var *varPtr, + Namespace *nsPtr) /* Pointer to current namespace. */ { 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; + int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); + CompiledLocal *firstLocalPtr, *localPtr; + int varNum; + Tcl_ResolvedVarInfo *resVarInfo; /* - * 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. + * Find the localPtr corresponding to varPtr */ -#define NUM_LOCALS 20 - Var localStorage[NUM_LOCALS]; - Var *compiledLocals = localStorage; + varNum = varPtr - iPtr->framePtr->compiledLocals; + localPtr = iPtr->framePtr->procPtr->firstLocalPtr; + while (varNum--) { + localPtr = localPtr->nextPtr; + } - /* - * Get the procedure's name. - */ + if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { + /* + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, we + * call their "resolver" procs to get our hands on the variable, and + * we make the compiled local a link to the real variable. + */ + + doInitResolvedLocals: + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->flags = 0; + varPtr->value.objPtr = NULL; - procName = Tcl_GetStringFromObj(objv[0], &nameLen); + /* + * Now invoke the resolvers to determine the exact variables + * that should be used. + */ + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo && resVarInfo->fetchProc) { + Var *resolvedVarPtr = (Var *) + (*resVarInfo->fetchProc)(interp, resVarInfo); + if (resolvedVarPtr) { + if (TclIsVarInHash(resolvedVarPtr)) { + VarHashRefCount(resolvedVarPtr)++; + } + varPtr->flags = VAR_LINK; + varPtr->value.linkPtr = resolvedVarPtr; + } + } + } + return; + } /* - * 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. + * This is the first run after a recompile, or else the resolver epoch + * has changed: update the resolver cache. */ - result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, - "body of proc", procName, &procPtr); + firstLocalPtr = localPtr; + for (; localPtr != NULL; localPtr = localPtr->nextPtr) { + if (localPtr->resolveInfo) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree((char *) localPtr->resolveInfo); + } + localPtr->resolveInfo = NULL; + } + localPtr->flags &= ~VAR_RESOLVED; + + if (haveResolvers && + !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { + ResolverScheme *resPtr = iPtr->resolverPtr; + Tcl_ResolvedVarInfo *vinfo; + int result; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } - if (result != TCL_OK) { - return result; + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } } + localPtr = firstLocalPtr; + codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; + goto doInitResolvedLocals; +} - /* - * Create the "compiledLocals" array. Make sure it is large enough to - * hold all the procedure's compiled local variables, including its - * formal parameters. - */ +void +TclFreeLocalCache( + Tcl_Interp *interp, + LocalCache *localCachePtr) +{ + int i; + Tcl_Obj **namePtrPtr = &localCachePtr->varName0; - localCt = procPtr->numCompiledLocals; - if (localCt > NUM_LOCALS) { - compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var)); + for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { + Tcl_Obj *objPtr = *namePtrPtr; + /* + * Note that this can be called with interp==NULL, on interp + * deletion. In that case, the literal table and objects go away + * on their own. + */ + if (objPtr) { + if (interp) { + TclReleaseLiteral(interp, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + } + } } + ckfree((char *) 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; /* - * 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. + * 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. */ - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, - (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); + localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache) + + (localCt-1)*sizeof(Tcl_Obj *) + + numArgs*sizeof(Var)); - if (result != TCL_OK) { - return result; + 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; } + codePtr->localCachePtr = localCachePtr; + localCachePtr->refCount = 1; + localCachePtr->numVars = localCt; +} - framePtr->objc = objc; - framePtr->objv = objv; /* ref counts for args are incremented below */ +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". */ +{ + 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; /* - * Initialize and resolve compiled variable references. + * Make sure that the local cache of variable names and initial values has + * been initialised properly . */ - framePtr->procPtr = procPtr; - framePtr->numCompiledLocals = localCt; - framePtr->compiledLocals = compiledLocals; + if (localCt) { + if (!codePtr->localCachePtr) { + InitLocalCache(procPtr) ; + } + framePtr->localCachePtr = codePtr->localCachePtr; + framePtr->localCachePtr->refCount++; + defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + } else { + defPtr = NULL; + } - TclInitCompiledLocals(interp, framePtr, nsPtr); + /* + * Create the "compiledLocals" array. Make sure it is large enough to hold + * all the procedure's compiled local variables, including its formal + * parameters. + */ + + varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); + framePtr->compiledLocals = varPtr; + framePtr->numCompiledLocals = localCt; /* - * 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. + * 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. */ 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; + 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++) { + /* + * "Normal" arguments; last formal is special, depends on it being + * 'args'. + */ + + Tcl_Obj *objPtr = argObjs[i]; + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + } + for (; i < numArgs-1; i++, varPtr++, defPtr++) { /* - * Handle the special case of the last formal being "args". When - * it occurs, assign it a list consisting of all the remaining - * actual arguments. + * This loop is entered if argCt < (numArgs-1). Set default values; + * last formal is special. */ - 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; + Tcl_Obj *objPtr = defPtr->value.objPtr; + + if (objPtr) { + varPtr->flags = 0; varPtr->value.objPtr = objPtr; - TclClearVarUndefined(varPtr); - Tcl_IncrRefCount(objPtr); /* since the local variable now has - * another reference to object. */ + Tcl_IncrRefCount(objPtr); /* Local var reference. */ } else { goto incorrectArgs; } - varPtr++; - localPtr = localPtr->nextPtr; } - if (argCt > 0) { - Tcl_Obj *objResult; - int len, flags; - incorrectArgs: - /* - * Build up equivalent to Tcl_WrongNumArgs message for proc - */ + /* + * When we get here, the last formal argument remains to be defined: + * defPtr and varPtr point to the last argument to be initialized. + */ - Tcl_ResetResult(interp); - objResult = Tcl_GetObjResult(interp); - Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1); - /* - * Quote the proc name if it contains spaces (Bug 942757). - */ + varPtr->flags = 0; + if (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->value.objPtr != NULL)) { + Tcl_Obj *objPtr = defPtr->value.objPtr; + + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + } else { + goto incorrectArgs; + } + varPtr++; + + /* + * Initialise and resolve the remaining compiledLocals. In the absence of + * resolvers, they are undefined local vars: (flags=0, value=NULL). + */ - len = Tcl_ScanCountedElement(procName, nameLen, &flags); - if (len != nameLen) { - char *procName1 = ckalloc((unsigned) len); - len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags); - Tcl_AppendToObj(objResult, procName1, len); - ckfree(procName1); + correctArgs: + if (numArgs < localCt) { + if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) { + memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); } else { - Tcl_AppendToObj(objResult, procName, len); + InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); } + } - 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); + return TCL_OK; - result = TCL_ERROR; - goto procDone; + + incorrectArgs: + /* + * Initialise all compiled locals to avoid problems at DeleteLocalVars. + */ + + 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. + * + *---------------------------------------------------------------------- + */ + +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 = (Proc *) clientData; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; + CallFrame *framePtr, **framePtrPtr; + int result; + ByteCode *codePtr; + + /* + * If necessary (i.e. if we haven't got a suitable compilation already + * 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. + */ + + if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { + Interp *iPtr = (Interp *) interp; + + /* + * 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). + */ + + 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 = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + (isLambda ? "body of lambda term" : "body of proc"), + TclGetString(objv[isLambda]), &procPtr); + if (result != TCL_OK) { + return result; + } } /* - * Invoke the commands in the procedure's body. + * 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. */ -#ifdef TCL_COMPILE_DEBUG + 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; + + 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. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + int result; + + result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); + if (result == TCL_OK) { + return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInterpProcCore -- + * + * 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 +TclObjInterpProcCore( + 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; + + result = InitArgsAndLocals(interp, procNameObj, skip); + if (result != TCL_OK) { + goto procDone; + } + +#if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - fprintf(stdout, "Calling proc "); - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); + 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, " "); } fprintf(stdout, "\n"); @@ -1199,61 +1715,139 @@ TclObjInterpProc(clientData, interp, objc, objv) if (TCL_DTRACE_PROC_ARGS_ENABLED()) { char *a[10]; int i = 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; + a[i] = (l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } + if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); + char *a[4]; int i[2]; - iPtr->returnCode = TCL_OK; - procPtr->refCount++; - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - TCL_DTRACE_PROC_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); + TclDTraceInfo(info, a, i); + TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); + TclDecrRefCount(info); } -#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. + + /* + * Invoke the commands in the procedure's body. */ - result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0); -#endif - if (TCL_DTRACE_PROC_RETURN_ENABLED()) { - TCL_DTRACE_PROC_RETURN(TclGetString(objv[0]), result); + procPtr->refCount++; + iPtr->numLevels++; + + if (TclInterpReady(interp) == TCL_ERROR) { + result = TCL_ERROR; + } else { + register ByteCode *codePtr = + procPtr->bodyPtr->internalRep.otherValuePtr; + + codePtr->refCount++; + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l; + + l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; + TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), + iPtr->varFramePtr->objc - l, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); + } + result = TclExecuteByteCode(interp, codePtr); + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); + } + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } } + + iPtr->numLevels--; procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } - if (result != TCL_OK) { - result = ProcessProcResultCode(interp, procName, nameLen, result); + /* + * 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); + 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 (TCL_DTRACE_PROC_RESULT_ENABLED()) { Tcl_Obj *r; r = Tcl_GetObjResult(interp); - TCL_DTRACE_PROC_RESULT(TclGetString(objv[0]), result, + TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result, TclGetString(r), r); } + procDone: /* - * Pop and free the call frame for this procedure invocation, then - * free the compiledLocals array if malloc'ed storage was used. + * 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. */ - procDone: - Tcl_PopCallFrame(interp); - if (compiledLocals != localStorage) { - ckfree((char *) compiledLocals); - } + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ return result; -#undef NUM_LOCALS } /* @@ -1261,150 +1855,149 @@ TclObjInterpProc(clientData, interp, objc, objv) * * 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 procedure 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 function 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(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. */ +TclProcCompileProc( + Tcl_Interp *interp, /* Interpreter containing procedure. */ + Proc *procPtr, /* Data associated with procedure. */ + Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, + * but could be any code fragment compiled in + * the context of this procedure.) */ + Namespace *nsPtr, /* Namespace containing procedure. */ + CONST char *description, /* string describing this body of code. */ + CONST char *procName) /* Name of this procedure. */ { - return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, - description, procName, NULL); + 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 */ +ProcCompileProc( + Tcl_Interp *interp, /* Interpreter containing procedure. */ + Proc *procPtr, /* Data associated with procedure. */ + Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, + * but could be any code fragment compiled in + * the context of this procedure.) */ + 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. */ { - Interp *iPtr = (Interp*)interp; - int i, result; - Tcl_CallFrame frame; - ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + Interp *iPtr = (Interp *) interp; + int i; + Tcl_CallFrame *framePtr; + ByteCode *codePtr = 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)) { - 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 (((Interp *) *codePtr->interpHandle == iPtr) + && (codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsPtr == nsPtr) + && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { + return TCL_OK; + } else { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_AppendResult(interp, + "a precompiled script jumped interps", NULL); + return TCL_ERROR; + } + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = nsPtr; + } else { + bodyPtr->typePtr->freeIntRepProc(bodyPtr); + bodyPtr->typePtr = NULL; + } } } if (bodyPtr->typePtr != &tclByteCodeType) { - int numChars; - char *ellipsis; + Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* - * Display a line summarizing the top level command we - * are about to compile. + * 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); + 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); } #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. + * 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. + * 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; + Proc *newProc = (Proc *) ckalloc(sizeof(Proc)); + + newProc->iPtr = procPtr->iPtr; + newProc->refCount = 1; + newProc->cmdPtr = procPtr->cmdPtr; + token = (Tcl_Command) newProc->cmdPtr; + newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr); + bodyPtr = newProc->bodyPtr; Tcl_IncrRefCount(bodyPtr); - new->numArgs = procPtr->numArgs; + newProc->numArgs = procPtr->numArgs; - new->numCompiledLocals = new->numArgs; - new->firstLocalPtr = NULL; - new->lastLocalPtr = NULL; + newProc->numCompiledLocals = newProc->numArgs; + newProc->firstLocalPtr = NULL; + newProc->lastLocalPtr = NULL; localPtr = procPtr->firstLocalPtr; - for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) { + for (i=0; i<newProc->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; + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + localPtr->nameLength + 1)); + + if (newProc->firstLocalPtr == NULL) { + newProc->firstLocalPtr = newProc->lastLocalPtr = copy; } else { - new->lastLocalPtr->nextPtr = copy; - new->lastLocalPtr = copy; + newProc->lastLocalPtr->nextPtr = copy; + newProc->lastLocalPtr = copy; } copy->nextPtr = NULL; copy->nameLength = localPtr->nameLength; @@ -1415,97 +2008,58 @@ ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, Tcl_IncrRefCount(copy->defValuePtr); } copy->resolveInfo = localPtr->resolveInfo; - memcpy(copy->name, localPtr->name, localPtr->nameLength + 1); + memcpy(copy->name, localPtr->name, localPtr->nameLength + 1); } + /* + * Reset the ClientData + */ - /* Reset the ClientData */ Tcl_GetCommandInfoFromToken(token, &info); if (info.objClientData == (ClientData) procPtr) { - info.objClientData = (ClientData) new; + info.objClientData = (ClientData) newProc; } if (info.clientData == (ClientData) procPtr) { - info.clientData = (ClientData) new; + info.clientData = (ClientData) newProc; } if (info.deleteData == (ClientData) procPtr) { - info.deleteData = (ClientData) new; + info.deleteData = (ClientData) newProc; } Tcl_SetCommandInfoFromToken(token, &info); procPtr->refCount--; - *procPtrPtr = procPtr = new; + *procPtrPtr = procPtr = newProc; } iPtr->compiledProcPtr = procPtr; - result = Tcl_PushCallFrame(interp, &frame, - (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); + (void) TclPushStackFrame(interp, &framePtr, + (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); - 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). - */ + /* + * TIP #280: We get the invoking context from the cmdFrame which + * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). + */ - Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); + hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); - /* 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); - } + /* + * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. + */ - 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; - } + iPtr->invokeWord = 0; + iPtr->invokeCmdFramePtr = + (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL); + (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr); + iPtr->invokeCmdFramePtr = NULL; + TclPopStackFrame(interp); } 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. */ - 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; - } - } + codePtr->nsEpoch = nsPtr->resolverEpoch; + codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; } return TCL_OK; } @@ -1513,68 +2067,36 @@ ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, /* *---------------------------------------------------------------------- * - * ProcessProcResultCode -- + * MakeProcError -- * - * Procedure called by TclObjInterpProc to process a return code other - * than TCL_OK returned by a Tcl procedure. + * Function called by TclObjInterpProc to create the stack information + * upon an error from a procedure. * * Results: - * 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. + * The interpreter's error info trace is set to a value that supplements + * the error code. * * Side effects: - * If the result returned is TCL_ERROR, traceback information about - * the procedure just executed is appended to the interpreter's - * "errorInfo" variable. + * none. * *---------------------------------------------------------------------- */ -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 +static void +MakeProcError( + 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 nameLen; /* Number of bytes in procedure's name. */ - int returnCode; /* The unexpected result code. */ { - 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; + 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 ? "..." : ""), interp->errorLine)); } /* @@ -1582,24 +2104,24 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) * * TclProcDeleteProc -- * - * 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. + * 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. * * 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 clientData; /* Procedure to be deleted. */ +TclProcDeleteProc( + ClientData clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *) clientData; @@ -1614,9 +2136,8 @@ TclProcDeleteProc(clientData) * * TclProcCleanupProc -- * - * 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. + * 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. * * Results: * None. @@ -1628,33 +2149,31 @@ TclProcDeleteProc(clientData) */ void -TclProcCleanupProc(procPtr) - register Proc *procPtr; /* Procedure to be deleted. */ +TclProcCleanupProc( + register Proc *procPtr) /* Procedure to be deleted. */ { register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; -#ifdef TCL_TIP280 - Tcl_HashEntry* hePtr = NULL; - CmdFrame* cfPtr = NULL; - Interp* iPtr = procPtr->iPtr; -#endif + Tcl_HashEntry *hePtr = NULL; + CmdFrame *cfPtr = NULL; + Interp *iPtr = procPtr->iPtr; 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); } else { ckfree((char *) resVarInfo); } - } + } if (localPtr->defValuePtr != NULL) { defPtr = localPtr->defValuePtr; @@ -1665,27 +2184,32 @@ TclProcCleanupProc(procPtr) } ckfree((char *) procPtr); -#ifdef TCL_TIP280 - /* TIP #280. Release the location data associated with this Proc + /* + * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for - * procbody structurues created by tbcload. + * procbody structures created by tbcload. See also Tcl_ProcObjCmd(), when + * the same ProcPtr is overwritten with a new CmdFrame. */ - 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 = (CmdFrame*) 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 ((char*) cfPtr->line); cfPtr->line = NULL; - ckfree ((char*) cfPtr); - Tcl_DeleteHashEntry (hePtr); -#endif + ckfree((char *) cfPtr->line); + cfPtr->line = NULL; + ckfree((char *) cfPtr); + Tcl_DeleteHashEntry(hePtr); } /* @@ -1693,47 +2217,44 @@ TclProcCleanupProc(procPtr) * * TclUpdateReturnInfo -- * - * 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. + * 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. * * Results: - * The return value is the true completion code to use for - * the procedure, instead of TCL_RETURN. + * The return value is the true completion code to use for the procedure + * or script, instead of TCL_RETURN. * * Side effects: - * The errorInfo and errorCode variables may get modified. + * None. * *---------------------------------------------------------------------- */ int -TclUpdateReturnInfo(iPtr) - Interp *iPtr; /* Interpreter for which TCL_RETURN - * exception is being processed. */ +TclUpdateReturnInfo( + Interp *iPtr) /* Interpreter for which TCL_RETURN exception + * is being processed. */ { - int code; - char *errorCode; - Tcl_Obj *objPtr; + int code = TCL_RETURN; - 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; + 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]. + */ + + code = iPtr->returnCode; + iPtr->returnLevel = 1; + iPtr->returnCode = TCL_OK; + if (code == TCL_ERROR) { + iPtr->flags |= ERR_LEGACY_COPY; } } return code; @@ -1742,49 +2263,24 @@ TclUpdateReturnInfo(iPtr) /* *---------------------------------------------------------------------- * - * 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 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. + * 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. * * Results: - * Returns the internal address of the TclObjInterpProc procedure. + * Returns the internal address of the TclObjInterpProc function. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ TclObjCmdProcType -TclGetObjInterpProc() +TclGetObjInterpProc(void) { return (TclObjCmdProcType) TclObjInterpProc; } @@ -1794,38 +2290,37 @@ TclGetObjInterpProc() * * 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, 0 on error. + * Returns a pointer to a newly allocated Tcl_Obj, NULL 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(procPtr) - Proc *procPtr; /* the Proc struct to store as the internal - * representation. */ +TclNewProcBodyObj( + Proc *procPtr) /* the Proc struct to store as the internal + * representation. */ { Tcl_Obj *objPtr; if (!procPtr) { - return (Tcl_Obj *) NULL; + return NULL; } - objPtr = Tcl_NewStringObj("", 0); - + TclNewObj(objPtr); if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = (VOID *) procPtr; + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.otherValuePtr = procPtr; - procPtr->refCount++; + procPtr->refCount++; } return objPtr; @@ -1836,27 +2331,27 @@ TclNewProcBodyObj(procPtr) * * 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(srcPtr, dupPtr) - Tcl_Obj *srcPtr; /* object to copy */ - Tcl_Obj *dupPtr; /* target object for the duplication */ +static void +ProcBodyDup( + Tcl_Obj *srcPtr, /* Object to copy. */ + Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; + Proc *procPtr = srcPtr->internalRep.otherValuePtr; dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = (VOID *) procPtr; + dupPtr->internalRep.otherValuePtr = procPtr; procPtr->refCount++; } @@ -1865,130 +2360,535 @@ static void ProcBodyDup(srcPtr, dupPtr) * * 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(objPtr) - Tcl_Obj *objPtr; /* the object to clean up */ +ProcBodyFree( + Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; + Proc *procPtr = objPtr->internalRep.otherValuePtr; + procPtr->refCount--; if (procPtr->refCount <= 0) { - TclProcCleanupProc(procPtr); + TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * - * ProcBodySetFromAny -- - * - * Tcl_ObjType's SetFromAny function for the proc body object. - * Calls panic. - * - * Results: - * Theoretically returns a TCL result code. + * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny -- * - * Side effects: - * Calls panic, since we can't set the value of the object from a string - * representation (or any other internal ones). + * 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). * *---------------------------------------------------------------------- */ +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); +} + static int -ProcBodySetFromAny(interp, objPtr) - Tcl_Interp *interp; /* current interpreter */ - Tcl_Obj *objPtr; /* object pointer */ +SetLambdaFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - panic("called ProcBodySetFromAny"); + Interp *iPtr = (Interp *) interp; + char *name; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; + int objc, result; + Proc *procPtr; + + /* + * Convert objPtr to list type first; if it cannot be converted, or if its + * length is not 2, then it cannot be converted to lambdaType. + */ + + result = TclListObjGetElements(interp, objPtr, &objc, &objv); + if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { + TclNewLiteralStringObj(errPtr, "can't interpret \""); + Tcl_AppendObjToObj(errPtr, objPtr); + Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); + Tcl_SetObjResult(interp, errPtr); + 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; /* - * this to keep compilers happy. + * 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. */ + if (iPtr->cmdFramePtr) { + CmdFrame *contextPtr; + + contextPtr = (CmdFrame *) 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 = (CmdFrame *) 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 = (int *) 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, + (char *) 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 { + 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. + */ + + objPtr->typePtr->freeIntRepProc(objPtr); + + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + objPtr->typePtr = &lambdaType; return TCL_OK; } /* *---------------------------------------------------------------------- * - * ProcBodyUpdateString -- + * Tcl_ApplyObjCmd -- * - * Tcl_ObjType's UpdateString function for the proc body object. - * Calls panic. + * This object-based function is invoked to process the "apply" Tcl + * command. See the user documentation for details on what it does. * * Results: - * None. + * A standard Tcl object result value. * * Side effects: - * Calls panic, since we this type has no string representation. + * Depends on the content of the lambda term (i.e., objv[1]). * *---------------------------------------------------------------------- */ -static void -ProcBodyUpdateString(objPtr) - Tcl_Obj *objPtr; /* the object to update */ +int +Tcl_ApplyObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - panic("called ProcBodyUpdateString"); -} + Interp *iPtr = (Interp *) interp; + Proc *procPtr = NULL; + Tcl_Obj *lambdaPtr, *nsObjPtr; + int result, isRootEnsemble; + Command cmd; + Tcl_Namespace *nsPtr; + ExtraFrameInfo efi; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); + 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 +#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; + } + + memset(&cmd, 0, sizeof(Command)); + procPtr->cmdPtr = &cmd; + /* + * TIP#280 (semi-)HACK! + * + * Using cmd.clientData to tell [info frame] how to render the + * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr + * for NULL. This condition holds here because of the 'memset' above, and + * nowhere else (in the core). Regular commands always have a valid + * 'hPtr', and lambda's never. + */ + + efi.length = 1; + efi.fields[0].name = "lambda"; + efi.fields[0].proc = NULL; + efi.fields[0].clientData = lambdaPtr; + cmd.clientData = &efi; + + /* + * Find the namespace where this lambda should run, and push a call frame + * for that namespace. Note that TclObjInterpProc() will pop it. + */ + + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + + cmd.nsPtr = (Namespace *) nsPtr; + + isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 1; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } else { + iPtr->ensembleRewrite.numInsertedObjs -= 1; + } + + result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); + if (result == TCL_OK) { + result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError); + } + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + + return result; +} + /* *---------------------------------------------------------------------- * - * TclCompileNoOp -- + * MakeLambdaError -- * - * Procedure called to compile noOp's + * Function called by TclObjInterpProc to create the stack information + * upon an error from a lambda term. * * Results: - * The return value is TCL_OK, indicating successful compilation. + * The interpreter's error info trace is set to a value that supplements + * the error code. * * Side effects: - * Instructions are added to envPtr to execute a noOp at runtime. + * none. * *---------------------------------------------------------------------- */ -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 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 ? "..." : ""), interp->errorLine)); +} + + +/* + *---------------------------------------------------------------------- + * + * 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. */ { - 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; + static const char *types[] = { + "lambda", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT + }; + int idx, result; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script"); + 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: { + Proc *procPtr = NULL; + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + */ + + 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; } - TclEmitOpcode(INST_POP, envPtr); + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; + } + case DISAS_PROC: { + Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + 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); + if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; + } + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objv[2]->typePtr != &tclByteCodeType) { + if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2])); + break; } - envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); return TCL_OK; } @@ -1999,4 +2899,3 @@ TclCompileNoOp(interp, parsePtr, envPtr) * fill-column: 78 * End: */ - |