diff options
Diffstat (limited to 'contrib/tcl/generic/tclProc.c')
| -rw-r--r-- | contrib/tcl/generic/tclProc.c | 721 |
1 files changed, 544 insertions, 177 deletions
diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c index 0b34e23bdf0b9..14238d9f56261 100644 --- a/contrib/tcl/generic/tclProc.c +++ b/contrib/tcl/generic/tclProc.c @@ -5,15 +5,16 @@ * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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.72 96/02/15 11:42:48 + * SCCS: @(#) tclProc.c 1.113 97/06/23 15:51:52 */ #include "tclInt.h" +#include "tclCompile.h" /* * Forward references to procedures defined later in this file: @@ -27,13 +28,13 @@ static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * - * Tcl_ProcCmd -- + * Tcl_ProcObjCmd -- * - * This procedure is invoked to process the "proc" Tcl command. - * See the user documentation for details on what it does. + * 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 result value. + * A standard Tcl object result value. * * Side effects: * A new procedure gets created. @@ -43,44 +44,113 @@ static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); /* ARGSUSED */ int -Tcl_ProcCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +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; - int result, argCount, i; + char *fullName, *procName, *args, *bytes, *p; char **argArray = NULL; - Arg *lastArgPtr; - register Arg *argPtr = NULL; /* Initialization not needed, but - * prevents compiler warning. */ + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_Obj *defPtr, *bodyPtr; + Tcl_DString ds; + int numArgs, length, result, i; + register CompiledLocal *localPtr; - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " name args body\"", (char *) NULL); + 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); + } + + /* + * 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->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1); - strcpy(procPtr->command, argv[3]); - procPtr->argPtr = NULL; - + procPtr->nsPtr = nsPtr; + 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. */ - result = Tcl_SplitList(interp, argv[2], &argCount, &argArray); + args = Tcl_GetStringFromObj(objv[2], &length); + result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { goto procError; } - lastArgPtr = NULL; - for (i = 0; i < argCount; i++) { + + procPtr->numArgs = numArgs; + procPtr->numCompiledLocals = numArgs; + for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; char **fieldValues; @@ -95,62 +165,122 @@ Tcl_ProcCmd(dummy, interp, argc, argv) } if (fieldCount > 2) { ckfree((char *) fieldValues); - Tcl_AppendResult(interp, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "too many fields in argument specifier \"", argArray[i], "\"", (char *) NULL); - result = TCL_ERROR; goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree((char *) fieldValues); - Tcl_AppendResult(interp, "procedure \"", argv[1], + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", fullName, "\" has argument with no name", (char *) NULL); - result = TCL_ERROR; goto procError; } - nameLength = strlen(fieldValues[0]) + 1; + + nameLength = strlen(fieldValues[0]); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]) + 1; + valueLength = strlen(fieldValues[1]); } else { valueLength = 0; } - argPtr = (Arg *) ckalloc((unsigned) - (sizeof(Arg) - sizeof(argPtr->name) + nameLength - + valueLength)); - if (lastArgPtr == NULL) { - procPtr->argPtr = argPtr; + + /* + * 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 { - lastArgPtr->nextPtr = argPtr; + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; } - lastArgPtr = argPtr; - argPtr->nextPtr = NULL; - strcpy(argPtr->name, fieldValues[0]); + localPtr->nextPtr = NULL; + localPtr->nameLength = nameLength; + localPtr->frameIndex = i; + localPtr->isArg = 1; + localPtr->isTemp = 0; + localPtr->flags = VAR_SCALAR; if (fieldCount == 2) { - argPtr->defValue = argPtr->name + nameLength; - strcpy(argPtr->defValue, fieldValues[1]); + localPtr->defValuePtr = + Tcl_NewStringObj(fieldValues[1], valueLength); + Tcl_IncrRefCount(localPtr->defValuePtr); } else { - argPtr->defValue = NULL; + localPtr->defValuePtr = NULL; } + strcpy(localPtr->name, fieldValues[0]); + ckfree((char *) fieldValues); } - Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr, - ProcDeleteProc); + /* + * Now create a command for the procedure. This will 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); + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, + (ClientData) procPtr, ProcDeleteProc); ckfree((char *) argArray); return TCL_OK; procError: - ckfree(procPtr->command); - while (procPtr->argPtr != NULL) { - argPtr = procPtr->argPtr; - procPtr->argPtr = argPtr->nextPtr; - ckfree((char *) argPtr); + 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 result; + return TCL_ERROR; } /* @@ -240,13 +370,13 @@ TclGetFrame(interp, string, framePtrPtr) /* *---------------------------------------------------------------------- * - * Tcl_UplevelCmd -- + * Tcl_UplevelObjCmd -- * - * This procedure is invoked to process the "uplevel" Tcl command. - * See the user documentation for details on what it does. + * This object procedure is invoked to process the "uplevel" Tcl + * command. See the user documentation for details on what it does. * * Results: - * A standard Tcl result value. + * A standard Tcl object result value. * * Side effects: * See the user documentation. @@ -256,36 +386,38 @@ TclGetFrame(interp, string, framePtrPtr) /* ARGSUSED */ int -Tcl_UplevelCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +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; - int result; + char *optLevel; + int length, result; CallFrame *savedVarFramePtr, *framePtr; - if (argc < 2) { + if (objc < 2) { uplevelSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?level? command ?arg ...?\"", (char *) NULL); + 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. */ - result = TclGetFrame(interp, argv[1], &framePtr); + optLevel = Tcl_GetStringFromObj(objv[1], &length); + result = TclGetFrame(interp, optLevel, &framePtr); if (result == -1) { return TCL_ERROR; } - argc -= (result+1); - if (argc == 0) { + objc -= (result+1); + if (objc == 0) { goto uplevelSyntax; } - argv += (result+1); + objv += (result+1); /* * Modify the interpreter state to execute in the given frame. @@ -298,19 +430,17 @@ Tcl_UplevelCmd(dummy, interp, argc, argv) * Execute the residual arguments as a command. */ - if (argc == 1) { - result = Tcl_Eval(interp, argv[0]); + if (objc == 1) { + result = Tcl_EvalObj(interp, objv[0]); } else { - char *cmd; - - cmd = Tcl_Concat(argc, argv); - result = Tcl_Eval(interp, cmd); - ckfree(cmd); + 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_AddErrorInfo(interp, msg); + Tcl_AddObjErrorInfo(interp, msg, -1); } /* @@ -345,14 +475,15 @@ TclFindProc(iPtr, procName) Interp *iPtr; /* Interpreter in which to look. */ char *procName; /* Name of desired procedure. */ { - Tcl_HashEntry *hPtr; + Tcl_Command cmd; Command *cmdPtr; - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName); - if (hPtr == NULL) { - return NULL; + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, + (Tcl_Namespace *) NULL, /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return NULL; } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + cmdPtr = (Command *) cmd; if (cmdPtr->proc != InterpProc) { return NULL; } @@ -392,8 +523,8 @@ TclIsProc(cmdPtr) * * InterpProc -- * - * When a Tcl procedure gets invoked, this routine gets invoked - * to interpret the procedure. + * 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. @@ -412,43 +543,261 @@ InterpProc(clientData, interp, argc, argv) * invoked. */ int argc; /* Count of number of arguments to this * procedure. */ - char **argv; /* Argument values. */ + register char **argv; /* Argument values. */ { - register Proc *procPtr = (Proc *) clientData; - register Arg *argPtr; - register Interp *iPtr; - char **args; - CallFrame frame; - char *value; + register Tcl_Obj *objPtr; + register int i; int result; /* - * Set up a call frame for the new procedure invocation. + * 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. */ - iPtr = procPtr->iPtr; - Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); - if (iPtr->varFramePtr != NULL) { - frame.level = iPtr->varFramePtr->level + 1; - } else { - frame.level = 1; - } - frame.argc = argc; - frame.argv = argv; - frame.callerPtr = iPtr->framePtr; - frame.callerVarPtr = iPtr->varFramePtr; - iPtr->framePtr = &frame; - iPtr->varFramePtr = &frame; - iPtr->returnCode = TCL_OK; +#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; /* - * Match the actual arguments against the procedure's formal - * parameters to compute local variables. + * Use TclObjInterpProc to actually interpret the procedure. */ - for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1; - argPtr != NULL; - argPtr = argPtr->nextPtr, args++, argc--) { + 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. + */ + + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + (Tcl_Namespace *) procPtr->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 = procPtr->nsPtr; + 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 @@ -456,31 +805,40 @@ InterpProc(clientData, interp, argc, argv) * actual arguments. */ - if ((argPtr->nextPtr == NULL) - && (strcmp(argPtr->name, "args") == 0)) { - if (argc < 0) { - argc = 0; - } - value = Tcl_Merge(argc, args); - Tcl_SetVar(interp, argPtr->name, value, 0); - ckfree(value); - argc = 0; - break; - } else if (argc > 0) { - value = *args; - } else if (argPtr->defValue != NULL) { - value = argPtr->defValue; + 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_AppendResult(interp, "no value given for parameter \"", - argPtr->name, "\" to \"", argv[0], "\"", - (char *) NULL); + 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; } - Tcl_SetVar(interp, argPtr->name, value, 0); + varPtr++; + localPtr = localPtr->nextPtr; } - if (argc > 0) { - Tcl_AppendResult(interp, "called \"", argv[0], + 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; @@ -490,62 +848,63 @@ InterpProc(clientData, interp, argc, argv) * 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_Eval(interp, procPtr->command); + result = Tcl_EvalObj(interp, procPtr->bodyPtr); procPtr->refCount--; if (procPtr->refCount <= 0) { CleanupProc(procPtr); } - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } else if (result == TCL_ERROR) { - char msg[100]; - - /* - * Record information telling where the error occurred. - */ - sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0], - iPtr->errorLine); - Tcl_AddErrorInfo(interp, msg); - } else if (result == TCL_BREAK) { - iPtr->result = "invoked \"break\" outside of a loop"; - result = TCL_ERROR; - } else if (result == TCL_CONTINUE) { - iPtr->result = "invoked \"continue\" outside of a loop"; - result = TCL_ERROR; + 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: /* - * Delete the call frame for this procedure invocation (it's - * important to remove the call frame from the interpreter - * before deleting it, so that traces invoked during the - * deletion don't see the partially-deleted frame). + * Pop and free the call frame for this procedure invocation. */ - - procDone: - iPtr->framePtr = frame.callerPtr; - iPtr->varFramePtr = frame.callerVarPtr; - + + Tcl_PopCallFrame(interp); + /* - * The check below is a hack. The problem is that there could be - * unset traces on the variables, which cause scripts to be evaluated. - * This will clear the ERR_IN_PROGRESS flag, losing stack trace - * information if the procedure was exiting with an error. The - * code below preserves the flag. Unfortunately, that isn't - * really enough: we really should preserve the errorInfo variable - * too (otherwise a nested error in the trace script will trash - * errorInfo). What's really needed is a general-purpose - * mechanism for saving and restoring interpreter state. + * Free the compiledLocals array if malloc'ed storage was used. */ - if (iPtr->flags & ERR_IN_PROGRESS) { - TclDeleteVars(iPtr, &frame.varTable); - iPtr->flags |= ERR_IN_PROGRESS; - } else { - TclDeleteVars(iPtr, &frame.varTable); + if (compiledLocals != localStorage) { + ckfree((char *) compiledLocals); } return result; +#undef NUM_LOCALS } /* @@ -602,14 +961,22 @@ static void CleanupProc(procPtr) register Proc *procPtr; /* Procedure to be deleted. */ { - register Arg *argPtr; + register CompiledLocal *localPtr; + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Tcl_Obj *defPtr; - ckfree((char *) procPtr->command); - for (argPtr = procPtr->argPtr; argPtr != NULL; ) { - Arg *nextPtr = argPtr->nextPtr; + if (bodyPtr != NULL) { + Tcl_DecrRefCount(bodyPtr); + } + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { + CompiledLocal *nextPtr = localPtr->nextPtr; - ckfree((char *) argPtr); - argPtr = nextPtr; + if (localPtr->defValuePtr != NULL) { + defPtr = localPtr->defValuePtr; + Tcl_DecrRefCount(defPtr); + } + ckfree((char *) localPtr); + localPtr = nextPtr; } ckfree((char *) procPtr); } |