diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 1042 |
1 files changed, 1042 insertions, 0 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c new file mode 100644 index 0000000..c9039df --- /dev/null +++ b/generic/tclProc.c @@ -0,0 +1,1042 @@ +/* + * 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-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclProc.c 1.116 97/10/29 18:33:24 + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Forward references to procedures defined later in this file: + */ + +static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); +static int InterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * 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; + register Proc *procPtr; + char *fullName, *procName, *args, *bytes, *p; + char **argArray = NULL; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_Obj *defPtr, *bodyPtr; + Tcl_Command cmd; + Tcl_DString ds; + int numArgs, length, result, i; + register CompiledLocal *localPtr; + + 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 = Tcl_GetStringFromObj(objv[1], (int *) NULL); + result = TclGetNamespaceForQualName(interp, fullName, + (Namespace *) NULL, TCL_LEAVE_ERR_MSG, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + if (result != TCL_OK) { + return result; + } + 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; + } + + /* + * 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. + */ + + bodyPtr = objv[3]; + 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. + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. + */ + + args = Tcl_GetStringFromObj(objv[2], &length); + result = Tcl_SplitList(interp, args, &numArgs, &argArray); + if (result != TCL_OK) { + goto procError; + } + + procPtr->numArgs = numArgs; + procPtr->numCompiledLocals = numArgs; + for (i = 0; i < numArgs; i++) { + int fieldCount, nameLength, valueLength; + 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 \"", fullName, + "\" 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 == '(') { + char *q = p; + do { + q++; + } while (*q != '\0'); + q--; + if (*q == ')') { /* we have an array element */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", fullName, + "\" has formal parameter \"", fieldValues[0], + "\" that is an array element", + (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } + } + p++; + } + + /* + * 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->isArg = 1; + localPtr->isTemp = 0; + localPtr->flags = VAR_SCALAR; + 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 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), InterpProc, + (ClientData) procPtr, ProcDeleteProc); + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, ProcDeleteProc); + + /* + * 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; + + ckfree((char *) argArray); + return TCL_OK; + + procError: + 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 interp->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. */ + 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))) { + 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 length, 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. + * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL. + */ + + optLevel = Tcl_GetStringFromObj(objv[1], &length); + 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_EvalObj(interp, objv[0]); + } else { + Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObj(interp, cmdObjPtr); + Tcl_DecrRefCount(cmdObjPtr); /* done with object */ + } + if (result == TCL_ERROR) { + char msg[60]; + 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. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclFindProc(iPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + char *procName; /* Name of desired procedure. */ +{ + Tcl_Command cmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, + (Tcl_Namespace *) NULL, /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return NULL; + } + cmdPtr = (Command *) cmd; + if (cmdPtr->proc != InterpProc) { + return NULL; + } + return (Proc *) cmdPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * TclIsProc -- + * + * Tells whether a command is a Tcl procedure or not. + * + * Results: + * If the given command is actuall 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. */ +{ + if (cmdPtr->proc == InterpProc) { + return (Proc *) cmdPtr->clientData; + } + return (Proc *) 0; +} + +/* + *---------------------------------------------------------------------- + * + * InterpProc -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +InterpProc(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 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. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + 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. */ + 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; + Proc *procPtr = (Proc *) clientData; + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + CallFrame frame; + register CallFrame *framePtr = &frame; + register Var *varPtr; + register CompiledLocal *localPtr; + Proc *saveProcPtr; + char *procName, *bytes; + int nameLen, localCt, numArgs, argCt, length, i, result; + + /* + * 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. + * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL. + */ + + 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. 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 (bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + tclByteCodeType.freeIntRepProc(bodyPtr); + bodyPtr->typePtr = (Tcl_ObjType *) NULL; + } + } + if (bodyPtr->typePtr != &tclByteCodeType) { + char buf[100]; + int numChars; + char *ellipsis; + + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we + * are about to compile. + */ + + numChars = nameLen; + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n", + numChars, procName, ellipsis); + } + + saveProcPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = procPtr; + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + iPtr->compiledProcPtr = saveProcPtr; + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + numChars = nameLen; + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + sprintf(buf, "\n (compiling body of proc \"%.*s%s\", line %d)", + numChars, procName, ellipsis, interp->errorLine); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + 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 *) procPtr->cmdPtr->nsPtr, + /*isProcCallFrame*/ 1); + if (result != TCL_OK) { + return result; + } + + framePtr->objc = objc; + framePtr->objv = objv; /* ref counts for args are incremented below */ + framePtr->procPtr = procPtr; + framePtr->numCompiledLocals = localCt; + framePtr->compiledLocals = compiledLocals; + + /* + * Initialize the array of local variables stored in the call frame. + */ + + varPtr = framePtr->compiledLocals; + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (localPtr->flags | VAR_UNDEFINED); + varPtr++; + } + + /* + * 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 (!localPtr->isArg) { + panic("TclObjInterpProc: local variable %s is not argument but should be", + localPtr->name); + return TCL_ERROR; + } + if (localPtr->isTemp) { + 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 */ + varPtr->flags &= ~VAR_UNDEFINED; + argCt = 0; + break; /* done processing args */ + } else if (argCt > 0) { + Tcl_Obj *objPtr = objv[i]; + varPtr->value.objPtr = objPtr; + varPtr->flags &= ~VAR_UNDEFINED; + 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; + varPtr->flags &= ~VAR_UNDEFINED; + Tcl_IncrRefCount(objPtr); /* since the local variable now has + * another reference to object. */ + } else { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no value given for parameter \"", localPtr->name, + "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), + "\"", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + varPtr++; + localPtr = localPtr->nextPtr; + } + if (argCt > 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "called \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), + "\" with too many arguments", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + + /* + * Invoke the commands in the procedure's body. + */ + + if (tclTraceExec >= 1) { + fprintf(stdout, "Calling proc "); + for (i = 0; i < objc; i++) { + bytes = Tcl_GetStringFromObj(objv[i], &length); + TclPrintSource(stdout, bytes, TclMin(length, 15)); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } + + iPtr->returnCode = TCL_OK; + procPtr->refCount++; + result = Tcl_EvalObj(interp, procPtr->bodyPtr); + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } + + if (result != TCL_OK) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (procedure \"%.50s\" line %d)", + procName, iPtr->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } else if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + result = TCL_ERROR; + } else if (result == TCL_CONTINUE) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + result = TCL_ERROR; + } + } + + procDone: + + /* + * Pop and free the call frame for this procedure invocation. + */ + + Tcl_PopCallFrame(interp); + + /* + * Free the compiledLocals array if malloc'ed storage was used. + */ + + if (compiledLocals != localStorage) { + ckfree((char *) compiledLocals); + } + return result; +#undef NUM_LOCALS +} + +/* + *---------------------------------------------------------------------- + * + * ProcDeleteProc -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +ProcDeleteProc(clientData) + ClientData clientData; /* Procedure to be deleted. */ +{ + Proc *procPtr = (Proc *) clientData; + + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * CleanupProc -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupProc(procPtr) + register Proc *procPtr; /* Procedure to be deleted. */ +{ + register CompiledLocal *localPtr; + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Tcl_Obj *defPtr; + + if (bodyPtr != NULL) { + Tcl_DecrRefCount(bodyPtr); + } + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { + CompiledLocal *nextPtr = localPtr->nextPtr; + + 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; + + code = iPtr->returnCode; + iPtr->returnCode = TCL_OK; + if (code == TCL_ERROR) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, + (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + if (iPtr->errorInfo != NULL) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + } + } + return code; +} |