summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-03-26 14:45:59 (GMT)
committerrjohnson <rjohnson>1998-03-26 14:45:59 (GMT)
commit2b5738da524e944cda39e24c0a87b745a43bd8c3 (patch)
tree6e8c9473978f6dab66c601e911721a7bd9d70b1b /generic/tclProc.c
parentc6a259aeeca4814a97cf6694814c63e74e4e18fa (diff)
downloadtcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.zip
tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.gz
tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.bz2
Initial revision
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c1042
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;
+}