/* * tclProc.c -- * * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclProc.c,v 1.44.2.1 2003/07/18 23:35:39 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * 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 ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, char *procName, int nameLen, int returnCode)); static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* * The ProcBodyObjType type */ Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ ProcBodyFree, /* FreeInternalRep procedure */ ProcBodyDup, /* DupInternalRep procedure */ ProcBodyUpdateString, /* UpdateString procedure */ ProcBodySetFromAny /* SetFromAny procedure */ }; /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- * * This object-based procedure is invoked to process the "proc" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * A new procedure gets created. * *---------------------------------------------------------------------- */ /* 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. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; char *fullName; CONST char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } /* * 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); if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create procedure \"", fullName, "\": unknown namespace", (char *) 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; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", (char *) NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], &procPtr) != TCL_OK) { return TCL_ERROR; } /* * Now create a command for the procedure. This will initially be in * the current namespace unless the procedure's name included namespace * qualifiers. To create the new command in the right namespace, we * generate a fully qualified name for it. */ Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); Tcl_DStringAppend(&ds, "::", 2); } 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 * procedure will run in. This will be different than the current * namespace if the proc was renamed into a different namespace. */ procPtr->cmdPtr = (Command *) cmd; /* * Optimize for noop procs: if the body is not precompiled (like a TclPro * procbody), and the argument list is just "args" and the body is empty, * define a compileProc to compile a noop. * * Notes: * - cannot be done for any argument list without having different * compiled/not-compiled behaviour in the "wrong argument #" case, * or making this code much more complicated. In any case, it doesn't * seem to make a lot of sense to verify the number of arguments we * are about to ignore ... * - could be enhanced to handle also non-empty bodies that contain * only comments; however, parsing the body will slow down the * compilation of all procs whose argument list is just _args_ */ if (objv[3]->typePtr == &tclProcBodyType) { goto done; } procArgs = Tcl_GetString(objv[2]); while (*procArgs == ' ') { procArgs++; } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { procArgs +=4; while(*procArgs != '\0') { if (*procArgs != ' ') { goto done; } procArgs++; } /* * The argument list is just "args"; check the body */ procBody = Tcl_GetString(objv[3]); while (*procBody != '\0') { if (!isspace(UCHAR(*procBody))) { goto done; } procBody++; } /* * The body is just spaces: link the compileProc */ ((Command *) cmd)->compileProc = TclCompileNoOp; } done: return TCL_OK; } /* *---------------------------------------------------------------------- * * 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. * * 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. * * Side effects: * If anything goes wrong, this procedure 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 */ { Interp *iPtr = (Interp*)interp; CONST char **argArray = NULL; register Proc *procPtr; int i, length, result, numArgs; CONST char *args, *bytes, *p; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to * unshare it (as a matter of fact, it is bad to unshare it, because * there may be no source code). * * We don't create and initialize a Proc structure for the procedure; * rather, we use what is in the body object. Note that * we initialize its cmdPtr field below after we've created the command * for the procedure. We increment the ref count of the Proc struct * since the command (soon to be created) will be holding a reference * to it. */ procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* * If the procedure's body object is shared because its string value is * identical to, e.g., the body of another procedure, we must create a * private copy for this procedure to use. Such sharing of procedure * bodies is rare but can cause problems. A procedure body is compiled * in a context that includes the number of 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)) { bytes = Tcl_GetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); } /* * Create and initialize a Proc structure for the procedure. Note that * we initialize its cmdPtr field below after we've created the command * for the procedure. We increment the ref count of the procedure's * body object since there will be a reference to it in the Proc * structure. */ Tcl_IncrRefCount(bodyPtr); 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. */ args = Tcl_GetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { 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; } 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 { 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); 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); ckfree((char *) fieldValues); goto procError; } p++; } 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 */ 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); 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; } strcpy(localPtr->name, fieldValues[0]); } 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: if (precompiled) { procPtr->refCount--; } else { Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { localPtr = procPtr->firstLocalPtr; procPtr->firstLocalPtr = localPtr->nextPtr; defPtr = localPtr->defValuePtr; if (defPtr != NULL) { Tcl_DecrRefCount(defPtr); } ckfree((char *) localPtr); } ckfree((char *) procPtr); } if (argArray != NULL) { ckfree((char *) argArray); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * 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. * * 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). * * Side effects: * None. * *---------------------------------------------------------------------- */ 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). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; /* * Parse string to figure out which level number to go to. */ result = 1; curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; if (*string == '#') { if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { return -1; } if (level < 0) { levelError: Tcl_AppendResult(interp, "bad level \"", string, "\"", (char *) NULL); return -1; } } else if (isdigit(UCHAR(*string))) { /* INTL: digit */ if (Tcl_GetInt(interp, string, &level) != TCL_OK) { return -1; } level = curLevel - level; } else { level = curLevel - 1; result = 0; } /* * Figure out which frame to use, and modify the interpreter so * its variables come from that frame. */ 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; } } *framePtrPtr = framePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_UplevelObjCmd -- * * This object procedure is invoked to process the "uplevel" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* 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. */ { register Interp *iPtr = (Interp *) interp; char *optLevel; int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } /* * Find the level to use for executing the command. */ optLevel = TclGetString(objv[1]); result = TclGetFrame(interp, optLevel, &framePtr); if (result == -1) { return TCL_ERROR; } objc -= (result+1); if (objc == 0) { goto uplevelSyntax; } objv += (result+1); /* * Modify the interpreter state to execute in the given frame. */ savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = framePtr; /* * Execute the residual arguments as a command. */ if (objc == 1) { result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); } 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. */ 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); } /* * Restore the variable frame, and return. */ iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * 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. * * 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. * * Side effects: * None. * *---------------------------------------------------------------------- */ Proc * TclFindProc(iPtr, procName) Interp *iPtr; /* Interpreter in which to look. */ CONST char *procName; /* Name of desired procedure. */ { Tcl_Command cmd; Tcl_Command origCmd; Command *cmdPtr; cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, (Tcl_Namespace *) NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return NULL; } cmdPtr = (Command *) cmd; origCmd = TclGetOriginalCommand(cmd); if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } if (cmdPtr->proc != TclProcInterpProc) { return NULL; } return (Proc *) cmdPtr->clientData; } /* *---------------------------------------------------------------------- * * TclIsProc -- * * 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. * * Side effects: * None. * *---------------------------------------------------------------------- */ Proc * TclIsProc(cmdPtr) Command *cmdPtr; /* Command to test. */ { Tcl_Command origCmd; origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } if (cmdPtr->proc == TclProcInterpProc) { return (Proc *) cmdPtr->clientData; } return (Proc *) 0; } /* *---------------------------------------------------------------------- * * TclProcInterpProc -- * * When a Tcl procedure gets invoked with an argc/argv array of * strings, this routine gets invoked to interpret the procedure. * * Results: * A standard Tcl result value, usually TCL_OK. * * Side effects: * Depends on the commands in the procedure. * *---------------------------------------------------------------------- */ 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. */ { register Tcl_Obj *objPtr; register int i; int result; /* * 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. */ #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. */ if ((argc + 1) > NUM_ARGS) { objv = (Tcl_Obj **) ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); } for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } objv[argc] = 0; /* * Use TclObjInterpProc to actually interpret the procedure. */ result = TclObjInterpProc(clientData, interp, argc, objv); /* * Move the interpreter's object result to the string result, * then reset the object result. */ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* * Decrement the ref counts on the objv elements since we are done * with them. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; TclDecrRefCount(objPtr); } /* * Free the objv array if malloc'ed storage was used. */ if (objv != objStorage) { ckfree((char *) objv); } return result; #undef NUM_ARGS } /* *---------------------------------------------------------------------- * * 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, 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. */ { Interp *iPtr = (Interp *) interp; register 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; Tcl_Obj *objResult = Tcl_GetObjResult(interp); /* * 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. */ #define NUM_LOCALS 20 Var localStorage[NUM_LOCALS]; Var *compiledLocals = localStorage; /* * Get the procedure's name. */ procName = Tcl_GetStringFromObj(objv[0], &nameLen); /* * 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. */ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); if (result != TCL_OK) { return result; } /* * Create the "compiledLocals" array. Make sure it is large enough to * hold all the procedure's compiled local variables, including its * formal parameters. */ localCt = procPtr->numCompiledLocals; if (localCt > NUM_LOCALS) { compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var)); } /* * 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. */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); if (result != TCL_OK) { return result; } framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ /* * Initialize and resolve compiled variable references. */ framePtr->procPtr = procPtr; framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = compiledLocals; TclInitCompiledLocals(interp, framePtr, nsPtr); /* * 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; } /* * Handle the special case of the last formal being "args". When * it occurs, assign it a list consisting of all the remaining * actual arguments. */ if ((i == numArgs) && ((localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0))) { Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i])); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ TclClearVarUndefined(varPtr); argCt = 0; break; /* done processing args */ } else if (argCt > 0) { Tcl_Obj *objPtr = objv[i]; varPtr->value.objPtr = objPtr; TclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* since the local variable now has * another reference to object. */ } else if (localPtr->defValuePtr != NULL) { Tcl_Obj *objPtr = localPtr->defValuePtr; varPtr->value.objPtr = objPtr; TclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* since the local variable now has * another reference to object. */ } else { goto incorrectArgs; } varPtr++; localPtr = localPtr->nextPtr; } if (argCt > 0) { incorrectArgs: /* * Build up equivalent to Tcl_WrongNumArgs message for proc */ Tcl_ResetResult(interp); Tcl_AppendStringsToObj(objResult, "wrong # args: should be \"", procName, (char *) NULL); 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); result = TCL_ERROR; goto procDone; } /* * Invoke the commands in the procedure's body. */ #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 1) { fprintf(stdout, "Calling proc "); for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); fflush(stdout); } #endif /*TCL_COMPILE_DEBUG*/ iPtr->returnCode = TCL_OK; procPtr->refCount++; result = TclCompEvalObj(interp, procPtr->bodyPtr); procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } if (result != TCL_OK) { result = ProcessProcResultCode(interp, procName, nameLen, result); } /* * Pop and free the call frame for this procedure invocation, then * free the compiledLocals array if malloc'ed storage was used. */ procDone: Tcl_PopCallFrame(interp); if (compiledLocals != localStorage) { ckfree((char *) compiledLocals); } return result; #undef NUM_LOCALS } /* *---------------------------------------------------------------------- * * 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. * * Results: * None. * * Side effects: * 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. */ { Interp *iPtr = (Interp*)interp; int result; Tcl_CallFrame frame; Proc *saveProcPtr; ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; /* * 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. */ 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 (bodyPtr->typePtr != &tclByteCodeType) { int numChars; char *ellipsis; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* * Display a line summarizing the top level command we * are about to compile. */ numChars = strlen(procName); ellipsis = ""; if (numChars > 50) { numChars = 50; ellipsis = "..."; } fprintf(stdout, "Compiling %s \"%.*s%s\"\n", description, numChars, procName, ellipsis); } #endif /* * Plug the current procPtr into the interpreter and coerce * the code body to byte codes. The interpreter needs to * know which proc it's compiling so that it can access its * list of compiled locals. * * TRICKY NOTE: Be careful to push a call frame with the * proper namespace context, so that the byte codes are * compiled in the appropriate class context. */ saveProcPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = procPtr; result = Tcl_PushCallFrame(interp, &frame, (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); Tcl_PopCallFrame(interp); } iPtr->compiledProcPtr = saveProcPtr; if (result != TCL_OK) { if (result == TCL_ERROR) { char buf[100 + TCL_INTEGER_SPACE]; numChars = strlen(procName); ellipsis = ""; if (numChars > 50) { numChars = 50; ellipsis = "..."; } while ( (procName[numChars] & 0xC0) == 0x80 ) { /* * Back up truncation point so that we don't truncate * in the middle of a multi-byte character (in UTF-8) */ numChars--; ellipsis = "..."; } sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", description, numChars, procName, ellipsis, interp->errorLine); Tcl_AddObjErrorInfo(interp, buf, -1); } return result; } } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { register CompiledLocal *localPtr; /* * 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; } } } return TCL_OK; } /* *---------------------------------------------------------------------- * * ProcessProcResultCode -- * * Procedure called by TclObjInterpProc to process a return code other * than TCL_OK returned by a Tcl 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. * * Side effects: * If the result returned is TCL_ERROR, traceback information about * the procedure just executed is appended to the interpreter's * "errorInfo" variable. * *---------------------------------------------------------------------- */ static int ProcessProcResultCode(interp, procName, nameLen, returnCode) Tcl_Interp *interp; /* The interpreter in which the procedure * was called and returned returnCode. */ char *procName; /* Name of the procedure. Used for error * messages and trace information. */ int nameLen; /* Number of bytes in procedure's name. */ int returnCode; /* The unexpected result code. */ { 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; } /* *---------------------------------------------------------------------- * * 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. * * 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. * *---------------------------------------------------------------------- */ void TclProcDeleteProc(clientData) ClientData clientData; /* Procedure to be deleted. */ { Proc *procPtr = (Proc *) clientData; procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * * 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. * * Results: * None. * * Side effects: * Memory gets freed. * *---------------------------------------------------------------------- */ void TclProcCleanupProc(procPtr) register Proc *procPtr; /* Procedure to be deleted. */ { register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; if (bodyPtr != NULL) { Tcl_DecrRefCount(bodyPtr); } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { CompiledLocal *nextPtr = localPtr->nextPtr; resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { (*resVarInfo->deleteProc)(resVarInfo); } else { ckfree((char *) resVarInfo); } } if (localPtr->defValuePtr != NULL) { defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } ckfree((char *) localPtr); localPtr = nextPtr; } ckfree((char *) 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. * * Results: * The return value is the true completion code to use for * the procedure, instead of TCL_RETURN. * * Side effects: * The errorInfo and errorCode variables may get modified. * *---------------------------------------------------------------------- */ int TclUpdateReturnInfo(iPtr) Interp *iPtr; /* Interpreter for which TCL_RETURN * exception is being processed. */ { int code; char *errorCode; code = iPtr->returnCode; iPtr->returnCode = TCL_OK; if (code == TCL_ERROR) { errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE"); Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode, NULL, Tcl_NewStringObj(errorCode, -1), TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; if (iPtr->errorInfo != NULL) { Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo, NULL, Tcl_NewStringObj(iPtr->errorInfo, -1), TCL_GLOBAL_ONLY); iPtr->flags |= ERR_IN_PROGRESS; } } return code; } /* *---------------------------------------------------------------------- * * 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. * * Results: * Returns the internal address of the TclObjInterpProc procedure. * * Side effects: * None. * *---------------------------------------------------------------------- */ TclObjCmdProcType TclGetObjInterpProc() { return (TclObjCmdProcType) TclObjInterpProc; } /* *---------------------------------------------------------------------- * * 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. * * Results: * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. * * Side effects: * The reference count in the ByteCode attached to the Proc is bumped up * by one, since the internal rep stores a pointer to it. * *---------------------------------------------------------------------- */ Tcl_Obj * TclNewProcBodyObj(procPtr) Proc *procPtr; /* the Proc struct to store as the internal * representation. */ { Tcl_Obj *objPtr; if (!procPtr) { return (Tcl_Obj *) NULL; } objPtr = Tcl_NewStringObj("", 0); if (objPtr) { objPtr->typePtr = &tclProcBodyType; objPtr->internalRep.otherValuePtr = (VOID *) procPtr; procPtr->refCount++; } return objPtr; } /* *---------------------------------------------------------------------- * * ProcBodyDup -- * * Tcl_ObjType's Dup function for the proc body object. * Bumps the reference count on the Proc stored in the internal * representation. * * Results: * None. * * Side effects: * 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 */ { Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; dupPtr->typePtr = &tclProcBodyType; dupPtr->internalRep.otherValuePtr = (VOID *) procPtr; procPtr->refCount++; } /* *---------------------------------------------------------------------- * * 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. * * Results: * None. * * Side effects: * 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 */ { Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * * ProcBodySetFromAny -- * * Tcl_ObjType's SetFromAny function for the proc body object. * Calls panic. * * Results: * Theoretically returns a TCL result code. * * Side effects: * Calls panic, since we can't set the value of the object from a string * representation (or any other internal ones). * *---------------------------------------------------------------------- */ static int ProcBodySetFromAny(interp, objPtr) Tcl_Interp *interp; /* current interpreter */ Tcl_Obj *objPtr; /* object pointer */ { panic("called ProcBodySetFromAny"); /* * this to keep compilers happy. */ return TCL_OK; } /* *---------------------------------------------------------------------- * * ProcBodyUpdateString -- * * Tcl_ObjType's UpdateString function for the proc body object. * Calls panic. * * Results: * None. * * Side effects: * Calls panic, since we this type has no string representation. * *---------------------------------------------------------------------- */ static void ProcBodyUpdateString(objPtr) Tcl_Obj *objPtr; /* the object to update */ { panic("called ProcBodyUpdateString"); } /* *---------------------------------------------------------------------- * * TclCompileNoOp -- * * Procedure called to compile noOp's * * Results: * The return value is TCL_OK, indicating successful compilation. * * Side effects: * Instructions are added to envPtr to execute a noOp at runtime. * *---------------------------------------------------------------------- */ 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. */ { 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; } TclEmitOpcode(INST_POP, envPtr); } } envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); return TCL_OK; }