update tcl/tk

1 files changed, 2783 insertions, 0 deletions

diff --git a/tcl8.6/generic/tclProc.c b/tcl8.6/generic/tclProc.c
new file mode 100644
index 0000000..533b817
--- /dev/null
+++ b/tcl8.6/generic/tclProc.c
@@ -0,0 +1,2783 @@
+/*
+ * 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.
+ * Copyright (c) 2004-2006 Miguel Sofer
+ * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * Variables that are part of the [apply] command implementation and which
+ * have to be passed to the other side of the NRE call.
+ */
+
+typedef struct {
+    Command cmd;
+    ExtraFrameInfo efi;
+} ApplyExtraData;
+
+/*
+ * Prototypes for static functions in this file
+ */
+
+static void		DupLambdaInternalRep(Tcl_Obj *objPtr,
+			    Tcl_Obj *copyPtr);
+static void		FreeLambdaInternalRep(Tcl_Obj *objPtr);
+static int		InitArgsAndLocals(Tcl_Interp *interp,
+			    Tcl_Obj *procNameObj, int skip);
+static void		InitResolvedLocals(Tcl_Interp *interp,
+			    ByteCode *codePtr, Var *defPtr,
+			    Namespace *nsPtr);
+static void		InitLocalCache(Proc *procPtr);
+static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
+static void		ProcBodyFree(Tcl_Obj *objPtr);
+static int		ProcWrongNumArgs(Tcl_Interp *interp, int skip);
+static void		MakeProcError(Tcl_Interp *interp,
+			    Tcl_Obj *procNameObj);
+static void		MakeLambdaError(Tcl_Interp *interp,
+			    Tcl_Obj *procNameObj);
+static int		SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+
+static Tcl_NRPostProc ApplyNR2;
+static Tcl_NRPostProc InterpProcNR2;
+static Tcl_NRPostProc Uplevel_Callback;
+
+/*
+ * The ProcBodyObjType type
+ */
+
+const Tcl_ObjType tclProcBodyType = {
+    "procbody",			/* name for this type */
+    ProcBodyFree,		/* FreeInternalRep function */
+    ProcBodyDup,		/* DupInternalRep function */
+    NULL,			/* UpdateString function; Tcl_GetString and
+				 * Tcl_GetStringFromObj should panic
+				 * instead. */
+    NULL			/* SetFromAny function; Tcl_ConvertToType
+				 * should panic instead. */
+};
+
+/*
+ * The [upvar]/[uplevel] level reference type. Uses the longValue field
+ * to remember the integer value of a parsed #<integer> format.
+ *
+ * Uses the default behaviour throughout, and never disposes of the string
+ * rep; it's just a cache type.
+ */
+
+static const Tcl_ObjType levelReferenceType = {
+    "levelReference",
+    NULL, NULL, NULL, NULL
+};
+
+/*
+ * The type of lambdas. Note that every lambda will *always* have a string
+ * representation.
+ *
+ * Internally, ptr1 is a pointer to a Proc instance that is not bound to a
+ * command name, and ptr2 is a pointer to the namespace that the Proc instance
+ * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
+ */
+
+const Tcl_ObjType tclLambdaType = {
+    "lambdaExpr",		/* name */
+    FreeLambdaInternalRep,	/* freeIntRepProc */
+    DupLambdaInternalRep,	/* dupIntRepProc */
+    NULL,			/* updateStringProc */
+    SetLambdaFromAny		/* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ProcObjCmd --
+ *
+ *	This object-based function 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(
+    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;
+    const char *procName;
+    const char *simpleName, *procArgs, *procBody;
+    Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+    Tcl_Command cmd;
+
+    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.
+     */
+
+    procName = TclGetString(objv[1]);
+    TclGetNamespaceForQualName(interp, procName, NULL, 0,
+	    &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
+
+    if (nsPtr == NULL) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't create procedure \"%s\": unknown namespace",
+		procName));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
+	return TCL_ERROR;
+    }
+    if (simpleName == NULL) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't create procedure \"%s\": bad procedure name",
+		procName));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Create the data structure to represent the procedure.
+     */
+
+    if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
+	    &procPtr) != TCL_OK) {
+	Tcl_AddErrorInfo(interp, "\n    (creating proc \"");
+	Tcl_AddErrorInfo(interp, simpleName);
+	Tcl_AddErrorInfo(interp, "\")");
+	return TCL_ERROR;
+    }
+
+    cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
+	TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
+
+    /*
+     * 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;
+
+    /*
+     * TIP #280: Remember the line the procedure body is starting on. In a
+     * bytecode context we ask the engine to provide us with the necessary
+     * information. This is for the initialization of the byte code compiler
+     * when the body is used for the first time.
+     *
+     * This code is nearly identical to the #280 code in SetLambdaFromAny, see
+     * this file. The differences are the different index of the body in the
+     * line array of the context, and the lambda code requires some special
+     * processing. Find a way to factor the common elements into a single
+     * function.
+     */
+
+    if (iPtr->cmdFramePtr) {
+	CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+
+	*contextPtr = *iPtr->cmdFramePtr;
+	if (contextPtr->type == TCL_LOCATION_BC) {
+	    /*
+	     * Retrieve source information from the bytecode, if possible. If
+	     * the information is retrieved successfully, context.type will be
+	     * TCL_LOCATION_SOURCE and the reference held by
+	     * context.data.eval.path will be counted.
+	     */
+
+	    TclGetSrcInfoForPc(contextPtr);
+	} else if (contextPtr->type == TCL_LOCATION_SOURCE) {
+	    /*
+	     * The copy into 'context' up above has created another reference
+	     * to 'context.data.eval.path'; account for it.
+	     */
+
+	    Tcl_IncrRefCount(contextPtr->data.eval.path);
+	}
+
+	if (contextPtr->type == TCL_LOCATION_SOURCE) {
+	    /*
+	     * We can account for source location within a proc only if the
+	     * proc body was not created by substitution.
+	     */
+
+	    if (contextPtr->line
+		    && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
+		int isNew;
+		Tcl_HashEntry *hePtr;
+		CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+
+		cfPtr->level = -1;
+		cfPtr->type = contextPtr->type;
+		cfPtr->line = ckalloc(sizeof(int));
+		cfPtr->line[0] = contextPtr->line[3];
+		cfPtr->nline = 1;
+		cfPtr->framePtr = NULL;
+		cfPtr->nextPtr = NULL;
+
+		cfPtr->data.eval.path = contextPtr->data.eval.path;
+		Tcl_IncrRefCount(cfPtr->data.eval.path);
+
+		cfPtr->cmd = NULL;
+		cfPtr->len = 0;
+
+		hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
+			procPtr, &isNew);
+		if (!isNew) {
+		    /*
+		     * Get the old command frame and release it. See also
+		     * TclProcCleanupProc in this file. Currently it seems as
+		     * if only the procbodytest::proc command of the testsuite
+		     * is able to trigger this situation.
+		     */
+
+		    CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr);
+
+		    if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
+			Tcl_DecrRefCount(cfOldPtr->data.eval.path);
+			cfOldPtr->data.eval.path = NULL;
+		    }
+		    ckfree(cfOldPtr->line);
+		    cfOldPtr->line = NULL;
+		    ckfree(cfOldPtr);
+		}
+		Tcl_SetHashValue(hePtr, cfPtr);
+	    }
+
+	    /*
+	     * 'contextPtr' is going out of scope; account for the reference
+	     * that it's holding to the path name.
+	     */
+
+	    Tcl_DecrRefCount(contextPtr->data.eval.path);
+	    contextPtr->data.eval.path = NULL;
+	}
+	TclStackFree(interp, contextPtr);
+    }
+
+    /*
+     * Optimize for no-op procs: if the body is not precompiled (like a TclPro
+     * procbody), and the argument list is just "args" and the body is empty,
+     * define a compileProc to compile a no-op.
+     *
+     * Notes:
+     *	 - cannot be done for any argument list without having different
+     *	   compiled/not-compiled behaviour in the "wrong argument #" case, or
+     *	   making this code much more complicated. In any case, it doesn't
+     *	   seem to make a lot of sense to verify the number of arguments we
+     *	   are about to ignore ...
+     *	 - could be enhanced to handle also non-empty bodies that contain only
+     *	   comments; however, parsing the body will slow down the compilation
+     *	   of all procs whose argument list is just _args_
+     */
+
+    if (objv[3]->typePtr == &tclProcBodyType) {
+	goto done;
+    }
+
+    procArgs = TclGetString(objv[2]);
+
+    while (*procArgs == ' ') {
+	procArgs++;
+    }
+
+    if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
+	int numBytes;
+
+	procArgs +=4;
+	while (*procArgs != '\0') {
+	    if (*procArgs != ' ') {
+		goto done;
+	    }
+	    procArgs++;
+	}
+
+	/*
+	 * The argument list is just "args"; check the body
+	 */
+
+	procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
+	if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
+	    goto done;
+	}
+
+	/*
+	 * 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
+ *	function knows how to handle two types of body objects: strings and
+ *	procbody. Strings are the traditional (and common) value for bodies,
+ *	procbody are values created by extensions that have loaded a
+ *	previously compiled script.
+ *
+ * Results:
+ *	Returns TCL_OK on success, along with a pointer to a Tcl procedure
+ *	definition in procPtrPtr where the cmdPtr field is not initialised.
+ *	This definition should be freed by calling TclProcCleanupProc() when
+ *	it is no longer needed. Returns TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ *	If anything goes wrong, this function returns an error message in the
+ *	interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCreateProc(
+    Tcl_Interp *interp,		/* Interpreter containing proc. */
+    Namespace *nsPtr,		/* Namespace containing this proc. */
+    const char *procName,	/* Unqualified name of this proc. */
+    Tcl_Obj *argsPtr,		/* Description of arguments. */
+    Tcl_Obj *bodyPtr,		/* Command body. */
+    Proc **procPtrPtr)		/* Returns: pointer to proc data. */
+{
+    Interp *iPtr = (Interp *) interp;
+
+    register Proc *procPtr;
+    int i, result, numArgs, plen;
+    const char *bytes, *argname, *argnamei;
+    char argnamelast;
+    register CompiledLocal *localPtr = NULL;
+    Tcl_Obj *defPtr, *errorObj, **argArray;
+    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. We increment the ref
+	 * count of the Proc struct since the command (soon to be created)
+	 * will be holding a reference to it.
+	 */
+
+	procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+	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 "slots"
+	 * allocated by the compiler for local variables. There is a local
+	 * variable slot for each formal parameter (the
+	 * "procPtr->numCompiledLocals = numArgs" assignment below). This
+	 * means that the same code can not be shared by two procedures that
+	 * have a different number of arguments, even if their bodies are
+	 * identical. Note that we don't use Tcl_DuplicateObj since we would
+	 * not want any bytecode internal representation.
+	 */
+
+	if (Tcl_IsShared(bodyPtr)) {
+	    int length;
+	    Tcl_Obj *sharedBodyPtr = bodyPtr;
+
+	    bytes = TclGetStringFromObj(bodyPtr, &length);
+	    bodyPtr = Tcl_NewStringObj(bytes, length);
+
+	    /*
+	     * TIP #280.
+	     * Ensure that the continuation line data for the original body is
+	     * not lost and applies to the new body as well.
+	     */
+
+	    TclContinuationsCopy(bodyPtr, sharedBodyPtr);
+	}
+
+	/*
+	 * Create and initialize a Proc structure for the procedure. We
+	 * increment the ref count of the procedure's body object since there
+	 * will be a reference to it in the Proc structure.
+	 */
+
+	Tcl_IncrRefCount(bodyPtr);
+
+	procPtr = 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 parsed argument is consistent with the one stored
+     * in the Proc.
+     */
+
+    result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
+    if (result != TCL_OK) {
+	goto procError;
+    }
+
+    if (precompiled) {
+	if (numArgs > procPtr->numArgs) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "procedure \"%s\": arg list contains %d entries, "
+		    "precompiled header expects %d", procName, numArgs,
+		    procPtr->numArgs));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+		    "BYTECODELIES", NULL);
+	    goto procError;
+	}
+	localPtr = procPtr->firstLocalPtr;
+    } else {
+	procPtr->numArgs = numArgs;
+	procPtr->numCompiledLocals = numArgs;
+    }
+
+    for (i = 0; i < numArgs; i++) {
+	int fieldCount, nameLength, valueLength;
+	Tcl_Obj **fieldValues;
+
+	/*
+	 * Now divide the specifier up into name and default.
+	 */
+
+	result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
+		&fieldValues);
+	if (result != TCL_OK) {
+	    goto procError;
+	}
+	if (fieldCount > 2) {
+	    errorObj = Tcl_NewStringObj(
+		"too many fields in argument specifier \"", -1);
+	    Tcl_AppendObjToObj(errorObj, argArray[i]);
+	    Tcl_AppendToObj(errorObj, "\"", -1);
+	    Tcl_SetObjResult(interp, errorObj);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+		    "FORMALARGUMENTFORMAT", NULL);
+	    goto procError;
+	}
+	if ((fieldCount == 0) || (fieldValues[0]->length == 0)) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "argument with no name", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+		    "FORMALARGUMENTFORMAT", NULL);
+	    goto procError;
+	}
+
+	argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
+	nameLength = Tcl_NumUtfChars(argname, plen);
+	if (fieldCount == 2) {
+	    const char * value = TclGetString(fieldValues[1]);
+	    valueLength = Tcl_NumUtfChars(value, fieldValues[1]->length);
+	} else {
+	    valueLength = 0;
+	}
+
+	/*
+	 * Check that the formal parameter name is a scalar.
+	 */
+
+	argnamei = argname;
+	argnamelast = argname[plen-1];
+	while (plen--) {
+	    if (argnamei[0] == '(') {
+		if (argnamelast == ')') {	/* We have an array element. */
+		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			    "formal parameter \"%s\" is an array element",
+			    Tcl_GetString(fieldValues[0])));
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			    "FORMALARGUMENTFORMAT", NULL);
+		    goto procError;
+		}
+	    } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
+		errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+		Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+		Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
+		Tcl_SetObjResult(interp, errorObj);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			"FORMALARGUMENTFORMAT", NULL);
+		goto procError;
+	    }
+	    argnamei = Tcl_UtfNext(argnamei);
+	}
+
+	if (precompiled) {
+	    /*
+	     * Compare the parsed argument with the stored one. Note that the
+	     * only flag value that makes sense at this point is VAR_ARGUMENT
+	     * (its value was kept the same as pre VarReform to simplify
+	     * tbcload's processing of older byetcodes).
+	     *
+	     * The only other flag vlaue that is important to retrieve from
+	     * precompiled procs is VAR_TEMPORARY (also unchanged). It is
+	     * needed later when retrieving the variable names.
+	     */
+
+	    if ((localPtr->nameLength != nameLength)
+		    || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
+		    || (localPtr->frameIndex != i)
+		    || !(localPtr->flags & VAR_ARGUMENT)
+		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
+		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"procedure \"%s\": formal parameter %d is "
+			"inconsistent with precompiled body", procName, i));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			"BYTECODELIES", NULL);
+		goto procError;
+	    }
+
+	    /*
+	     * Compare the default value if any.
+	     */
+
+	    if (localPtr->defValuePtr != NULL) {
+		int tmpLength;
+		const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
+			&tmpLength);
+
+		if ((valueLength != tmpLength) ||
+			Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
+		    errorObj = Tcl_ObjPrintf(
+			    "procedure \"%s\": formal parameter \"" ,procName);
+		    Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+		    Tcl_AppendToObj(errorObj, "\" has "
+			"default value inconsistent with precompiled body", -1);
+		    Tcl_SetObjResult(interp, errorObj);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			    "BYTECODELIES", NULL);
+		    goto procError;
+		}
+	    }
+	    if ((i == numArgs - 1)
+		    && (localPtr->nameLength == 4)
+		    && (localPtr->name[0] == 'a')
+		    && (strcmp(localPtr->name, "args") == 0)) {
+		localPtr->flags |= VAR_IS_ARGS;
+	    }
+
+	    localPtr = localPtr->nextPtr;
+	} else {
+	    /*
+	     * Allocate an entry in the runtime procedure frame's array of
+	     * local variables for the argument.
+	     */
+
+	    localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
+	    if (procPtr->firstLocalPtr == NULL) {
+		procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
+	    } else {
+		procPtr->lastLocalPtr->nextPtr = localPtr;
+		procPtr->lastLocalPtr = localPtr;
+	    }
+	    localPtr->nextPtr = NULL;
+	    localPtr->nameLength = nameLength;
+	    localPtr->frameIndex = i;
+	    localPtr->flags = VAR_ARGUMENT;
+	    localPtr->resolveInfo = NULL;
+
+	    if (fieldCount == 2) {
+		localPtr->defValuePtr = fieldValues[1];
+		Tcl_IncrRefCount(localPtr->defValuePtr);
+	    } else {
+		localPtr->defValuePtr = NULL;
+	    }
+	    memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
+	    if ((i == numArgs - 1)
+		    && (localPtr->nameLength == 4)
+		    && (localPtr->name[0] == 'a')
+		    && (strcmp(localPtr->name, "args") == 0)) {
+		localPtr->flags |= VAR_IS_ARGS;
+	    }
+	}
+    }
+
+    *procPtrPtr = procPtr;
+    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(localPtr);
+	}
+	ckfree(procPtr);
+    }
+    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(
+    Tcl_Interp *interp,		/* Interpreter in which to find frame. */
+    const char *name,		/* String describing frame. */
+    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
+				 * global frame indicated). */
+{
+    register Interp *iPtr = (Interp *) interp;
+    int curLevel, level, result;
+    CallFrame *framePtr;
+
+    /*
+     * Parse string to figure out which level number to go to.
+     */
+
+    result = 1;
+    curLevel = iPtr->varFramePtr->level;
+    if (*name== '#') {
+	if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
+	    goto levelError;
+	}
+    } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
+	if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
+	    goto levelError;
+	}
+	level = curLevel - level;
+    } else {
+	level = curLevel - 1;
+	result = 0;
+    }
+
+    /*
+     * Figure out which frame to use, and return it to the caller.
+     */
+
+    for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+	    framePtr = framePtr->callerVarPtr) {
+	if (framePtr->level == level) {
+	    break;
+	}
+    }
+    if (framePtr == NULL) {
+	goto levelError;
+    }
+
+    *framePtrPtr = framePtr;
+    return result;
+
+  levelError:
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
+    return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjGetFrame --
+ *
+ *	Given a description of a procedure frame, such as the first argument
+ *	to an "uplevel" or "upvar" command, locate the call frame for the
+ *	appropriate level of procedure.
+ *
+ * Results:
+ *	The return value is -1 if an error occurred in finding the frame (in
+ *	this case an error message is left in the interp's result). 1 is
+ *	returned if objPtr was either an int or an int preceded by "#" and
+ *	it specified a valid frame. 0 is returned if objPtr isn't one of the
+ *	two things above (in this case, the lookup acts as if objPtr were
+ *	"1"). The variable pointed to by framePtrPtr is filled in with the
+ *	address of the desired frame (unless an error occurs, in which case it
+ *	isn't modified).
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjGetFrame(
+    Tcl_Interp *interp,		/* Interpreter in which to find frame. */
+    Tcl_Obj *objPtr,		/* Object describing frame. */
+    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
+				 * global frame indicated). */
+{
+    register Interp *iPtr = (Interp *) interp;
+    int curLevel, level, result;
+    const char *name = NULL;
+
+    /*
+     * Parse object to figure out which level number to go to.
+     */
+
+    result = 0;
+    curLevel = iPtr->varFramePtr->level;
+
+    /*
+     * Check for integer first, since that has potential to spare us
+     * a generation of a stringrep.
+     */
+
+    if (objPtr == NULL) {
+	/* Do nothing */
+    } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)
+	    && (level >= 0)) {
+	level = curLevel - level;
+	result = 1;
+    } else if (objPtr->typePtr == &levelReferenceType) {
+	level = (int) objPtr->internalRep.longValue;
+	result = 1;
+    } else {
+	name = TclGetString(objPtr);
+	if (name[0] == '#') {
+	    if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
+		TclFreeIntRep(objPtr);
+		objPtr->typePtr = &levelReferenceType;
+		objPtr->internalRep.longValue = level;
+		result = 1;
+	    } else {
+		result = -1;
+	    }
+	} else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */
+	    /*
+	     * If this were an integer, we'd have succeeded already.
+	     * Docs say we have to treat this as a 'bad level'  error.
+	     */
+	    result = -1;
+	}
+    }
+
+    if (result == 0) {
+	level = curLevel - 1;
+	name = "1";
+    }
+    if (result != -1) {
+	if (level >= 0) {
+	    CallFrame *framePtr;
+	    for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+		    framePtr = framePtr->callerVarPtr) {
+		if (framePtr->level == level) {
+		    *framePtrPtr = framePtr;
+		    return result;
+		}
+	    }
+	}
+	if (name == NULL) {
+	    name = TclGetString(objPtr);
+	}
+    }
+
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
+    return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UplevelObjCmd --
+ *
+ *	This object function is invoked to process the "uplevel" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result value.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+Uplevel_Callback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CallFrame *savedVarFramePtr = data[0];
+
+    if (result == TCL_ERROR) {
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		"\n    (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
+    }
+
+    /*
+     * Restore the variable frame, and return.
+     */
+
+    ((Interp *)interp)->varFramePtr = savedVarFramePtr;
+    return result;
+}
+
+	/* ARGSUSED */
+int
+Tcl_UplevelObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRUplevelObjCmd(
+    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;
+    CmdFrame *invoker = NULL;
+    int word = 0;
+    int result;
+    CallFrame *savedVarFramePtr, *framePtr;
+    Tcl_Obj *objPtr;
+
+    if (objc < 2) {
+    uplevelSyntax:
+	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Find the level to use for executing the command.
+     */
+
+    result = TclObjGetFrame(interp, objv[1], &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) {
+	/*
+	 * TIP #280. Make actual argument location available to eval'd script
+	 */
+
+	TclArgumentGet(interp, objv[0], &invoker, &word);
+	objPtr = objv[0];
+
+    } 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.
+	 */
+
+	objPtr = Tcl_ConcatObj(objc, objv);
+    }
+
+    TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
+	    NULL);
+    return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(
+    Interp *iPtr,		/* Interpreter in which to look. */
+    const char *procName)	/* Name of desired procedure. */
+{
+    Tcl_Command cmd;
+    Command *cmdPtr;
+
+    cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
+    if (cmd == (Tcl_Command) NULL) {
+	return NULL;
+    }
+    cmdPtr = (Command *) cmd;
+
+    return TclIsProc(cmdPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(
+    Command *cmdPtr)		/* Command to test. */
+{
+    Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
+
+    if (origCmd != NULL) {
+	cmdPtr = (Command *) origCmd;
+    }
+    if (cmdPtr->deleteProc == TclProcDeleteProc) {
+	return cmdPtr->objClientData;
+    }
+    return NULL;
+}
+
+static int
+ProcWrongNumArgs(
+    Tcl_Interp *interp,
+    int skip)
+{
+    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
+    register Proc *procPtr = framePtr->procPtr;
+    int localCt = procPtr->numCompiledLocals, numArgs, i;
+    Tcl_Obj **desiredObjs;
+    const char *final = NULL;
+
+    /*
+     * Build up desired argument list for Tcl_WrongNumArgs
+     */
+
+    numArgs = framePtr->procPtr->numArgs;
+    desiredObjs = TclStackAlloc(interp,
+	    (int) sizeof(Tcl_Obj *) * (numArgs+1));
+
+    if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
+	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
+    } else {
+#ifdef AVOID_HACKS_FOR_ITCL
+	desiredObjs[0] = framePtr->objv[skip-1];
+#else
+	desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1);
+#endif /* AVOID_HACKS_FOR_ITCL */
+    }
+    Tcl_IncrRefCount(desiredObjs[0]);
+
+    if (localCt > 0) {
+	register Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
+
+	for (i=1 ; i<=numArgs ; i++, defPtr++) {
+	    Tcl_Obj *argObj;
+	    Tcl_Obj *namePtr = localName(framePtr, i-1);
+
+	    if (defPtr->value.objPtr != NULL) {
+		TclNewObj(argObj);
+		Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
+	    } else if (defPtr->flags & VAR_IS_ARGS) {
+		numArgs--;
+		final = "?arg ...?";
+		break;
+	    } else {
+		argObj = namePtr;
+		Tcl_IncrRefCount(namePtr);
+	    }
+	    desiredObjs[i] = argObj;
+	}
+    }
+
+    Tcl_ResetResult(interp);
+    Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
+
+    for (i=0 ; i<=numArgs ; i++) {
+	Tcl_DecrRefCount(desiredObjs[i]);
+    }
+    TclStackFree(interp, desiredObjs);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitCompiledLocals --
+ *
+ *	This routine is invoked in order to initialize the compiled locals
+ *	table for a new call frame.
+ *
+ *	DEPRECATED: functionality has been inlined elsewhere; this function
+ *	remains to insure binary compatibility with Itcl.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May invoke various name resolvers in order to determine which
+ *	variables are being referenced at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitCompiledLocals(
+    Tcl_Interp *interp,		/* Current interpreter. */
+    CallFrame *framePtr,	/* Call frame to initialize. */
+    Namespace *nsPtr)		/* Pointer to current namespace. */
+{
+    Var *varPtr = framePtr->compiledLocals;
+    Tcl_Obj *bodyPtr;
+    ByteCode *codePtr;
+
+    bodyPtr = framePtr->procPtr->bodyPtr;
+    if (bodyPtr->typePtr != &tclByteCodeType) {
+	Tcl_Panic("body object for proc attached to frame is not a byte code type");
+    }
+    codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+
+    if (framePtr->numCompiledLocals) {
+	if (!codePtr->localCachePtr) {
+	    InitLocalCache(framePtr->procPtr) ;
+	}
+	framePtr->localCachePtr = codePtr->localCachePtr;
+	framePtr->localCachePtr->refCount++;
+    }
+
+    InitResolvedLocals(interp, codePtr, varPtr, nsPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitResolvedLocals --
+ *
+ *	This routine is invoked in order to initialize the compiled locals
+ *	table for a new call frame.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May invoke various name resolvers in order to determine which
+ *	variables are being referenced at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+InitResolvedLocals(
+    Tcl_Interp *interp,		/* Current interpreter. */
+    ByteCode *codePtr,
+    Var *varPtr,
+    Namespace *nsPtr)		/* Pointer to current namespace. */
+{
+    Interp *iPtr = (Interp *) interp;
+    int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
+    CompiledLocal *firstLocalPtr, *localPtr;
+    int varNum;
+    Tcl_ResolvedVarInfo *resVarInfo;
+
+    /*
+     * Find the localPtr corresponding to varPtr
+     */
+
+    varNum = varPtr - iPtr->framePtr->compiledLocals;
+    localPtr = iPtr->framePtr->procPtr->firstLocalPtr;
+    while (varNum--) {
+	localPtr = localPtr->nextPtr;
+    }
+
+    if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) {
+	goto doInitResolvedLocals;
+    }
+
+    /*
+     * This is the first run after a recompile, or else the resolver epoch
+     * has changed: update the resolver cache.
+     */
+
+    firstLocalPtr = localPtr;
+    for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
+	if (localPtr->resolveInfo) {
+	    if (localPtr->resolveInfo->deleteProc) {
+		localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
+	    } else {
+		ckfree(localPtr->resolveInfo);
+	    }
+	    localPtr->resolveInfo = NULL;
+	}
+	localPtr->flags &= ~VAR_RESOLVED;
+
+	if (haveResolvers &&
+		!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
+	    ResolverScheme *resPtr = iPtr->resolverPtr;
+	    Tcl_ResolvedVarInfo *vinfo;
+	    int result;
+
+	    if (nsPtr->compiledVarResProc) {
+		result = nsPtr->compiledVarResProc(nsPtr->interp,
+			localPtr->name, localPtr->nameLength,
+			(Tcl_Namespace *) nsPtr, &vinfo);
+	    } else {
+		result = TCL_CONTINUE;
+	    }
+
+	    while ((result == TCL_CONTINUE) && resPtr) {
+		if (resPtr->compiledVarResProc) {
+		    result = resPtr->compiledVarResProc(nsPtr->interp,
+			    localPtr->name, localPtr->nameLength,
+			    (Tcl_Namespace *) nsPtr, &vinfo);
+		}
+		resPtr = resPtr->nextPtr;
+	    }
+	    if (result == TCL_OK) {
+		localPtr->resolveInfo = vinfo;
+		localPtr->flags |= VAR_RESOLVED;
+	    }
+	}
+    }
+    localPtr = firstLocalPtr;
+    codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS;
+
+    /*
+     * Initialize the array of local variables stored in the call frame. Some
+     * variables may have special resolution rules. In that case, we call
+     * their "resolver" procs to get our hands on the variable, and we make
+     * the compiled local a link to the real variable.
+     */
+
+  doInitResolvedLocals:
+    for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
+	varPtr->flags = 0;
+	varPtr->value.objPtr = NULL;
+
+	/*
+	 * Now invoke the resolvers to determine the exact variables that
+	 * should be used.
+	 */
+
+	resVarInfo = localPtr->resolveInfo;
+	if (resVarInfo && resVarInfo->fetchProc) {
+	    register Var *resolvedVarPtr = (Var *)
+		    resVarInfo->fetchProc(interp, resVarInfo);
+
+	    if (resolvedVarPtr) {
+		if (TclIsVarInHash(resolvedVarPtr)) {
+		    VarHashRefCount(resolvedVarPtr)++;
+		}
+		varPtr->flags = VAR_LINK;
+		varPtr->value.linkPtr = resolvedVarPtr;
+	    }
+	}
+    }
+}
+
+void
+TclFreeLocalCache(
+    Tcl_Interp *interp,
+    LocalCache *localCachePtr)
+{
+    int i;
+    Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
+
+    for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
+	register Tcl_Obj *objPtr = *namePtrPtr;
+
+	if (objPtr) {
+	    /* TclReleaseLiteral calls Tcl_DecrRefCount for us */
+	    TclReleaseLiteral(interp, objPtr);
+	}
+    }
+    ckfree(localCachePtr);
+}
+
+static void
+InitLocalCache(
+    Proc *procPtr)
+{
+    Interp *iPtr = procPtr->iPtr;
+    ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+    int localCt = procPtr->numCompiledLocals;
+    int numArgs = procPtr->numArgs, i = 0;
+
+    Tcl_Obj **namePtr;
+    Var *varPtr;
+    LocalCache *localCachePtr;
+    CompiledLocal *localPtr;
+    int new;
+
+    /*
+     * Cache the names and initial values of local variables; store the
+     * cache in both the framePtr for this execution and in the codePtr
+     * for future calls.
+     */
+
+    localCachePtr = ckalloc(sizeof(LocalCache)
+	    + (localCt - 1) * sizeof(Tcl_Obj *)
+	    + numArgs * sizeof(Var));
+
+    namePtr = &localCachePtr->varName0;
+    varPtr = (Var *) (namePtr + localCt);
+    localPtr = procPtr->firstLocalPtr;
+    while (localPtr) {
+	if (TclIsVarTemporary(localPtr)) {
+	    *namePtr = NULL;
+	} else {
+	    *namePtr = TclCreateLiteral(iPtr, localPtr->name,
+		    localPtr->nameLength, /* hash */ (unsigned int) -1,
+		    &new, /* nsPtr */ NULL, 0, NULL);
+	    Tcl_IncrRefCount(*namePtr);
+	}
+
+	if (i < numArgs) {
+	    varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
+	    varPtr->value.objPtr = localPtr->defValuePtr;
+	    varPtr++;
+	    i++;
+	}
+	namePtr++;
+	localPtr = localPtr->nextPtr;
+    }
+    codePtr->localCachePtr = localCachePtr;
+    localCachePtr->refCount = 1;
+    localCachePtr->numVars = localCt;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitArgsAndLocals --
+ *
+ *	This routine is invoked in order to initialize the arguments and other
+ *	compiled locals table for a new call frame.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Allocates memory on the stack for the compiled local variables, the
+ *	caller is responsible for freeing them. Initialises all variables. May
+ *	invoke various name resolvers in order to determine which variables
+ *	are being referenced at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InitArgsAndLocals(
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    Tcl_Obj *procNameObj,	/* Procedure name for error reporting. */
+    int skip)			/* Number of initial arguments to be skipped,
+				 * i.e., words in the "command name". */
+{
+    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
+    register Proc *procPtr = framePtr->procPtr;
+    ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+    register Var *varPtr, *defPtr;
+    int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
+    Tcl_Obj *const *argObjs;
+
+    /*
+     * Make sure that the local cache of variable names and initial values has
+     * been initialised properly .
+     */
+
+    if (localCt) {
+	if (!codePtr->localCachePtr) {
+	    InitLocalCache(procPtr) ;
+	}
+	framePtr->localCachePtr = codePtr->localCachePtr;
+	framePtr->localCachePtr->refCount++;
+	defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
+    } else {
+	defPtr = NULL;
+    }
+
+    /*
+     * Create the "compiledLocals" array. Make sure it is large enough to hold
+     * all the procedure's compiled local variables, including its formal
+     * parameters.
+     */
+
+    varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var)));
+    framePtr->compiledLocals = varPtr;
+    framePtr->numCompiledLocals = localCt;
+
+    /*
+     * Match and assign the call's actual parameters to the procedure's formal
+     * arguments. The formal arguments are described by the first numArgs
+     * entries in both the Proc structure's local variable list and the call
+     * frame's local variable array.
+     */
+
+    numArgs = procPtr->numArgs;
+    argCt = framePtr->objc - skip;	/* Set it to the number of args to the
+					 * procedure. */
+    argObjs = framePtr->objv + skip;
+    if (numArgs == 0) {
+	if (argCt) {
+	    goto incorrectArgs;
+	} else {
+	    goto correctArgs;
+	}
+    }
+    imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
+    for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
+	/*
+	 * "Normal" arguments; last formal is special, depends on it being
+	 * 'args'.
+	 */
+
+	Tcl_Obj *objPtr = argObjs[i];
+
+	varPtr->flags = 0;
+	varPtr->value.objPtr = objPtr;
+	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
+    }
+    for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
+	/*
+	 * This loop is entered if argCt < (numArgs-1). Set default values;
+	 * last formal is special.
+	 */
+
+	Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL;
+
+	if (!objPtr) {
+	    goto incorrectArgs;
+	}
+	varPtr->flags = 0;
+	varPtr->value.objPtr = objPtr;
+	Tcl_IncrRefCount(objPtr);	/* Local var reference. */
+    }
+
+    /*
+     * When we get here, the last formal argument remains to be defined:
+     * defPtr and varPtr point to the last argument to be initialized.
+     */
+
+    varPtr->flags = 0;
+    if (defPtr && defPtr->flags & VAR_IS_ARGS) {
+	Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
+
+	varPtr->value.objPtr = listPtr;
+	Tcl_IncrRefCount(listPtr);	/* Local var is a reference. */
+    } else if (argCt == numArgs) {
+	Tcl_Obj *objPtr = argObjs[i];
+
+	varPtr->value.objPtr = objPtr;
+	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
+    } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) {
+	Tcl_Obj *objPtr = defPtr->value.objPtr;
+
+	varPtr->value.objPtr = objPtr;
+	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
+    } else {
+	goto incorrectArgs;
+    }
+    varPtr++;
+
+    /*
+     * Initialise and resolve the remaining compiledLocals. In the absence of
+     * resolvers, they are undefined local vars: (flags=0, value=NULL).
+     */
+
+  correctArgs:
+    if (numArgs < localCt) {
+	if (!framePtr->nsPtr->compiledVarResProc
+		&& !((Interp *)interp)->resolverPtr) {
+	    memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
+	} else {
+	    InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr);
+	}
+    }
+
+    return TCL_OK;
+
+    /*
+     * Initialise all compiled locals to avoid problems at DeleteLocalVars.
+     */
+
+  incorrectArgs:
+    if ((skip != 1) &&
+	    TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
+	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+    }
+    memset(varPtr, 0,
+	    ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
+    return ProcWrongNumArgs(interp, skip);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPushProcCallFrame --
+ *
+ *	Compiles a proc body if necessary, then pushes a CallFrame suitable
+ *	for executing it.
+ *
+ * Results:
+ *	A standard Tcl object result value.
+ *
+ * Side effects:
+ *	The proc's body may be recompiled. A CallFrame is pushed, it will have
+ *	to be popped by the caller.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPushProcCallFrame(
+    ClientData clientData,	/* Record describing procedure to be
+				 * interpreted. */
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    int objc,			/* Count of number of arguments to this
+				 * procedure. */
+    Tcl_Obj *const objv[],	/* Argument value objects. */
+    int isLambda)		/* 1 if this is a call by ApplyObjCmd: it
+				 * needs special rules for error msg */
+{
+    Proc *procPtr = clientData;
+    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
+    CallFrame *framePtr, **framePtrPtr;
+    int result;
+    ByteCode *codePtr;
+
+    /*
+     * If necessary (i.e. if we haven't got a suitable compilation already
+     * cached) compile the procedure's body. The compiler will allocate frame
+     * slots for the procedure's non-argument local variables. Note that
+     * compiling the body might increase procPtr->numCompiledLocals if new
+     * local variables are found while compiling.
+     */
+
+    if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+	Interp *iPtr = (Interp *) interp;
+
+	/*
+	 * When we've got bytecode, this is the check for validity. That is,
+	 * the bytecode must be for the right interpreter (no cross-leaks!),
+	 * the code must be from the current epoch (so subcommand compilation
+	 * is up-to-date), the namespace must match (so variable handling
+	 * is right) and the resolverEpoch must match (so that new shadowed
+	 * commands and/or resolver changes are considered).
+	 */
+
+	codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+	if (((Interp *) *codePtr->interpHandle != iPtr)
+		|| (codePtr->compileEpoch != iPtr->compileEpoch)
+		|| (codePtr->nsPtr != nsPtr)
+		|| (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
+	    goto doCompilation;
+	}
+    } else {
+    doCompilation:
+	result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
+		(isLambda ? "body of lambda term" : "body of proc"),
+		TclGetString(objv[isLambda]));
+	if (result != TCL_OK) {
+	    return result;
+	}
+    }
+
+    /*
+     * 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.
+     */
+
+    framePtrPtr = &framePtr;
+    (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+	    (Tcl_Namespace *) nsPtr,
+	    (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC));
+
+    framePtr->objc = objc;
+    framePtr->objv = objv;
+    framePtr->procPtr = procPtr;
+
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjInterpProc --
+ *
+ *	When a Tcl procedure gets invoked during bytecode evaluation, this
+ *	object-based routine gets invoked to interpret the procedure.
+ *
+ * Results:
+ *	A standard Tcl object result value.
+ *
+ * Side effects:
+ *	Depends on the commands in the procedure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjInterpProc(
+    ClientData clientData,	/* Record describing procedure to be
+				 * interpreted. */
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    int objc,			/* Count of number of arguments to this
+				 * procedure. */
+    Tcl_Obj *const objv[])	/* Argument value objects. */
+{
+    /*
+     * Not used much in the core; external interface for iTcl
+     */
+
+    return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv);
+}
+
+int
+TclNRInterpProc(
+    ClientData clientData,	/* Record describing procedure to be
+				 * interpreted. */
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    int objc,			/* Count of number of arguments to this
+				 * procedure. */
+    Tcl_Obj *const objv[])	/* Argument value objects. */
+{
+    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
+	    /*isLambda*/ 0);
+
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRInterpProcCore --
+ *
+ *	When a Tcl procedure, lambda term or anything else that works like a
+ *	procedure gets invoked during bytecode evaluation, this object-based
+ *	routine gets invoked to interpret the body.
+ *
+ * Results:
+ *	A standard Tcl object result value.
+ *
+ * Side effects:
+ *	Nearly anything; depends on the commands in the procedure body.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNRInterpProcCore(
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    Tcl_Obj *procNameObj,	/* Procedure name for error reporting. */
+    int skip,			/* Number of initial arguments to be skipped,
+				 * i.e., words in the "command name". */
+    ProcErrorProc *errorProc)	/* How to convert results from the script into
+				 * results of the overall procedure. */
+{
+    Interp *iPtr = (Interp *) interp;
+    register Proc *procPtr = iPtr->varFramePtr->procPtr;
+    int result;
+    CallFrame *freePtr;
+    ByteCode *codePtr;
+
+    result = InitArgsAndLocals(interp, procNameObj, skip);
+    if (result != TCL_OK) {
+	freePtr = iPtr->framePtr;
+	Tcl_PopCallFrame(interp);	/* Pop but do not free. */
+	TclStackFree(interp, freePtr->compiledLocals);
+					/* Free compiledLocals. */
+	TclStackFree(interp, freePtr);	/* Free CallFrame. */
+	return TCL_ERROR;
+    }
+
+#if defined(TCL_COMPILE_DEBUG)
+    if (tclTraceExec >= 1) {
+	register CallFrame *framePtr = iPtr->varFramePtr;
+	register int i;
+
+	if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
+	    fprintf(stdout, "Calling lambda ");
+	} else {
+	    fprintf(stdout, "Calling proc ");
+	}
+	for (i = 0; i < framePtr->objc; i++) {
+	    TclPrintObject(stdout, framePtr->objv[i], 15);
+	    fprintf(stdout, " ");
+	}
+	fprintf(stdout, "\n");
+	fflush(stdout);
+    }
+#endif /*TCL_COMPILE_DEBUG*/
+
+#ifdef USE_DTRACE
+    if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
+	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+	const char *a[10];
+	int i;
+
+	for (i = 0 ; i < 10 ; i++) {
+	    a[i] = (l < iPtr->varFramePtr->objc ?
+		    TclGetString(iPtr->varFramePtr->objv[l]) : NULL);
+	    l++;
+	}
+	TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
+		a[8], a[9]);
+    }
+    if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
+	Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
+	const char *a[6]; int i[2];
+
+	TclDTraceInfo(info, a, i);
+	TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
+	TclDecrRefCount(info);
+    }
+    if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+
+	TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
+		TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
+		iPtr->varFramePtr->objc - l - 1,
+		(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
+    }
+    if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+
+	TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
+		TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
+		iPtr->varFramePtr->objc - l - 1,
+		(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
+    }
+#endif /* USE_DTRACE */
+
+    /*
+     * Invoke the commands in the procedure's body.
+     */
+
+    procPtr->refCount++;
+    codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+
+    TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
+	    NULL, NULL);
+    return TclNRExecuteByteCode(interp, codePtr);
+}
+
+static int
+InterpProcNR2(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    Proc *procPtr = iPtr->varFramePtr->procPtr;
+    CallFrame *freePtr;
+    Tcl_Obj *procNameObj = data[0];
+    ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
+
+    if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
+	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+
+	TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
+		TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
+    }
+    if (procPtr->refCount-- <= 1) {
+	TclProcCleanupProc(procPtr);
+    }
+
+    /*
+     * Free the stack-allocated compiled locals and CallFrame. It is important
+     * to pop the call frame without freeing it first: the compiledLocals
+     * cannot be freed before the frame is popped, as the local variables must
+     * be deleted. But the compiledLocals must be freed first, as they were
+     * allocated later on the stack.
+     */
+
+    if (result != TCL_OK) {
+	goto process;
+    }
+
+    done:
+    if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
+	int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+	Tcl_Obj *r = Tcl_GetObjResult(interp);
+
+	TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
+		TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
+		TclGetString(r), r);
+    }
+
+    freePtr = iPtr->framePtr;
+    Tcl_PopCallFrame(interp);		/* Pop but do not free. */
+    TclStackFree(interp, freePtr->compiledLocals);
+					/* Free compiledLocals. */
+    TclStackFree(interp, freePtr);	/* Free CallFrame. */
+    return result;
+
+    /*
+     * Process any non-TCL_OK result code.
+     */
+
+    process:
+    switch (result) {
+    case TCL_RETURN:
+	/*
+	 * If it is a 'return', do the TIP#90 processing now.
+	 */
+
+	result = TclUpdateReturnInfo((Interp *) interp);
+	break;
+
+    case TCL_CONTINUE:
+    case TCL_BREAK:
+	/*
+	 * It's an error to get to this point from a 'break' or 'continue', so
+	 * transform to an error now.
+	 */
+
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"invoked \"%s\" outside of a loop",
+		((result == TCL_BREAK) ? "break" : "continue")));
+	Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
+	result = TCL_ERROR;
+
+	/*
+	 * Fall through to the TCL_ERROR handling code.
+	 */
+
+    case TCL_ERROR:
+	/*
+	 * Now it _must_ be an error, so we need to log it as such. This means
+	 * filling out the error trace. Luckily, we just hand this off to the
+	 * function handed to us as an argument.
+	 */
+
+	errorProc(interp, procNameObj);
+    }
+    goto done;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 function does nothing.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May change the internal representation of the body object to compiled
+ *	code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclProcCompileProc(
+    Tcl_Interp *interp,		/* Interpreter containing procedure. */
+    Proc *procPtr,		/* Data associated with procedure. */
+    Tcl_Obj *bodyPtr,		/* Body of proc. (Usually procPtr->bodyPtr,
+				 * but could be any code fragment compiled in
+				 * the context of this procedure.) */
+    Namespace *nsPtr,		/* Namespace containing procedure. */
+    const char *description,	/* string describing this body of code. */
+    const char *procName)	/* Name of this procedure. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_CallFrame *framePtr;
+    ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+
+    /*
+     * 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)
+		&& (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
+	    return TCL_OK;
+	}
+
+	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
+	    if ((Interp *) *codePtr->interpHandle != iPtr) {
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"a precompiled script jumped interps", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			"CROSSINTERPBYTECODE", NULL);
+		return TCL_ERROR;
+	    }
+	    codePtr->compileEpoch = iPtr->compileEpoch;
+	    codePtr->nsPtr = nsPtr;
+	} else {
+	    TclFreeIntRep(bodyPtr);
+	}
+    }
+
+    if (bodyPtr->typePtr != &tclByteCodeType) {
+	Tcl_HashEntry *hePtr;
+
+#ifdef TCL_COMPILE_DEBUG
+	if (tclTraceCompile >= 1) {
+	    /*
+	     * Display a line summarizing the top level command we are about
+	     * to compile.
+	     */
+
+	    Tcl_Obj *message;
+
+	    TclNewLiteralStringObj(message, "Compiling ");
+	    Tcl_IncrRefCount(message);
+	    Tcl_AppendStringsToObj(message, description, " \"", NULL);
+	    Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
+	    fprintf(stdout, "%s\"\n", TclGetString(message));
+	    Tcl_DecrRefCount(message);
+	}
+#endif
+
+	/*
+	 * Plug the current procPtr into the interpreter and coerce the code
+	 * body to byte codes. The interpreter needs to know which proc it's
+	 * compiling so that it can access its list of compiled locals.
+	 *
+	 * 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.
+	 */
+
+	iPtr->compiledProcPtr = procPtr;
+
+	if (procPtr->numCompiledLocals > procPtr->numArgs) {
+	    CompiledLocal *clPtr = procPtr->firstLocalPtr;
+	    CompiledLocal *lastPtr = NULL;
+	    int i, numArgs = procPtr->numArgs;
+
+	    for (i = 0; i < numArgs; i++) {
+		lastPtr = clPtr;
+		clPtr = clPtr->nextPtr;
+	    }
+
+	    if (lastPtr) {
+		lastPtr->nextPtr = NULL;
+	    } else {
+		procPtr->firstLocalPtr = NULL;
+	    }
+	    procPtr->lastLocalPtr = lastPtr;
+	    while (clPtr) {
+		CompiledLocal *toFree = clPtr;
+
+		clPtr = clPtr->nextPtr;
+		if (toFree->resolveInfo) {
+		    if (toFree->resolveInfo->deleteProc) {
+			toFree->resolveInfo->deleteProc(toFree->resolveInfo);
+		    } else {
+			ckfree(toFree->resolveInfo);
+		    }
+		}
+		ckfree(toFree);
+	    }
+	    procPtr->numCompiledLocals = procPtr->numArgs;
+	}
+
+	(void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
+		/* isProcCallFrame */ 0);
+
+	/*
+	 * TIP #280: We get the invoking context from the cmdFrame which
+	 * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
+	 */
+
+	hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
+
+	/*
+	 * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
+	 */
+
+	iPtr->invokeWord = 0;
+	iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
+	TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
+	iPtr->invokeCmdFramePtr = NULL;
+	TclPopStackFrame(interp);
+    } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
+	/*
+	 * The resolver epoch has changed, but we only need to invalidate the
+	 * resolver cache.
+	 */
+
+	codePtr->nsEpoch = nsPtr->resolverEpoch;
+	codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS;
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeProcError --
+ *
+ *	Function called by TclObjInterpProc to create the stack information
+ *	upon an error from a procedure.
+ *
+ * Results:
+ *	The interpreter's error info trace is set to a value that supplements
+ *	the error code.
+ *
+ * Side effects:
+ *	none.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MakeProcError(
+    Tcl_Interp *interp,		/* The interpreter in which the procedure was
+				 * called. */
+    Tcl_Obj *procNameObj)	/* Name of the procedure. Used for error
+				 * messages and trace information. */
+{
+    int overflow, limit = 60, nameLen;
+    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+
+    overflow = (nameLen > limit);
+    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+	    "\n    (procedure \"%.*s%s\" line %d)",
+	    (overflow ? limit : nameLen), procName,
+	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcDeleteProc --
+ *
+ *	This function is invoked just before a command procedure is removed
+ *	from an interpreter. Its job is to release all the resources allocated
+ *	to the procedure.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory gets freed, unless the procedure is actively being executed.
+ *	In this case the cleanup is delayed until the last call to the current
+ *	procedure completes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclProcDeleteProc(
+    ClientData clientData)	/* Procedure to be deleted. */
+{
+    Proc *procPtr = clientData;
+
+    if (procPtr->refCount-- <= 1) {
+	TclProcCleanupProc(procPtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcCleanupProc --
+ *
+ *	This function does all the real work of freeing up a Proc structure.
+ *	It's called only when the structure's reference count becomes zero.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory gets freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclProcCleanupProc(
+    register Proc *procPtr)	/* Procedure to be deleted. */
+{
+    register CompiledLocal *localPtr;
+    Tcl_Obj *bodyPtr = procPtr->bodyPtr;
+    Tcl_Obj *defPtr;
+    Tcl_ResolvedVarInfo *resVarInfo;
+    Tcl_HashEntry *hePtr = NULL;
+    CmdFrame *cfPtr = NULL;
+    Interp *iPtr = procPtr->iPtr;
+
+    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(resVarInfo);
+	    }
+	}
+
+	if (localPtr->defValuePtr != NULL) {
+	    defPtr = localPtr->defValuePtr;
+	    Tcl_DecrRefCount(defPtr);
+	}
+	ckfree(localPtr);
+	localPtr = nextPtr;
+    }
+    ckfree(procPtr);
+
+    /*
+     * TIP #280: Release the location data associated with this Proc
+     * structure, if any. The interpreter may not exist (For example for
+     * procbody structures created by tbcload.
+     */
+
+    if (iPtr == NULL) {
+	return;
+    }
+
+    hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
+    if (!hePtr) {
+	return;
+    }
+
+    cfPtr = Tcl_GetHashValue(hePtr);
+
+    if (cfPtr) {
+	if (cfPtr->type == TCL_LOCATION_SOURCE) {
+	    Tcl_DecrRefCount(cfPtr->data.eval.path);
+	    cfPtr->data.eval.path = NULL;
+	}
+	ckfree(cfPtr->line);
+	cfPtr->line = NULL;
+	ckfree(cfPtr);
+    }
+    Tcl_DeleteHashEntry(hePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclUpdateReturnInfo --
+ *
+ *	This function is called when procedures return, and at other points
+ *	where the TCL_RETURN code is used. It examines the returnLevel and
+ *	returnCode to determine the real return status.
+ *
+ * Results:
+ *	The return value is the true completion code to use for the procedure
+ *	or script, instead of TCL_RETURN.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUpdateReturnInfo(
+    Interp *iPtr)		/* Interpreter for which TCL_RETURN exception
+				 * is being processed. */
+{
+    int code = TCL_RETURN;
+
+    iPtr->returnLevel--;
+    if (iPtr->returnLevel < 0) {
+	Tcl_Panic("TclUpdateReturnInfo: negative return level");
+    }
+    if (iPtr->returnLevel == 0) {
+	/*
+	 * Now we've reached the level to return the requested -code.
+	 * Since iPtr->returnLevel and iPtr->returnCode have completed
+	 * their task, we now reset them to default values so that any
+	 * bare "return TCL_RETURN" that may follow will work [Bug 2152286].
+	 */
+
+	code = iPtr->returnCode;
+	iPtr->returnLevel = 1;
+	iPtr->returnCode = TCL_OK;
+	if (code == TCL_ERROR) {
+	    iPtr->flags |= ERR_LEGACY_COPY;
+	}
+    }
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetObjInterpProc --
+ *
+ *	Returns a pointer to the TclObjInterpProc function; this is different
+ *	from the value obtained from the TclObjInterpProc reference on systems
+ *	like Windows where import and export versions of a function exported
+ *	by a DLL exist.
+ *
+ * Results:
+ *	Returns the internal address of the TclObjInterpProc function.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclObjCmdProcType
+TclGetObjInterpProc(void)
+{
+    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, NULL on error.
+ *
+ * Side effects:
+ *	The reference count in the ByteCode attached to the Proc is bumped up
+ *	by one, since the internal rep stores a pointer to it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclNewProcBodyObj(
+    Proc *procPtr)		/* the Proc struct to store as the internal
+				 * representation. */
+{
+    Tcl_Obj *objPtr;
+
+    if (!procPtr) {
+	return NULL;
+    }
+
+    TclNewObj(objPtr);
+    if (objPtr) {
+	objPtr->typePtr = &tclProcBodyType;
+	objPtr->internalRep.twoPtrValue.ptr1 = 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(
+    Tcl_Obj *srcPtr,		/* Object to copy. */
+    Tcl_Obj *dupPtr)		/* Target object for the duplication. */
+{
+    Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+
+    dupPtr->typePtr = &tclProcBodyType;
+    dupPtr->internalRep.twoPtrValue.ptr1 = 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(
+    Tcl_Obj *objPtr)		/* The object to clean up. */
+{
+    Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+
+    if (procPtr->refCount-- <= 1) {
+	TclProcCleanupProc(procPtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny --
+ *
+ *	How to manage the internal representations of lambda term objects.
+ *	Syntactically they look like a two- or three-element list, where the
+ *	first element is the formal arguments, the second is the the body, and
+ *	the (optional) third is the namespace to execute the lambda term
+ *	within (the global namespace is assumed if it is absent).
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupLambdaInternalRep(
+    Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
+    register Tcl_Obj *copyPtr)	/* Object with internal rep to set. */
+{
+    Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+    Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
+
+    copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
+    copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+
+    procPtr->refCount++;
+    Tcl_IncrRefCount(nsObjPtr);
+    copyPtr->typePtr = &tclLambdaType;
+}
+
+static void
+FreeLambdaInternalRep(
+    register Tcl_Obj *objPtr)	/* CmdName object with internal representation
+				 * to free. */
+{
+    Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+    Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
+
+    if (procPtr->refCount-- == 1) {
+	TclProcCleanupProc(procPtr);
+    }
+    TclDecrRefCount(nsObjPtr);
+    objPtr->typePtr = NULL;
+}
+
+static int
+SetLambdaFromAny(
+    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
+    register Tcl_Obj *objPtr)	/* The object to convert. */
+{
+    Interp *iPtr = (Interp *) interp;
+    const char *name;
+    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
+    int isNew, objc, result;
+    CmdFrame *cfPtr = NULL;
+    Proc *procPtr;
+
+    if (interp == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Convert objPtr to list type first; if it cannot be converted, or if its
+     * length is not 2, then it cannot be converted to tclLambdaType.
+     */
+
+    result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
+    if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't interpret \"%s\" as a lambda expression",
+		Tcl_GetString(objPtr)));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
+	return TCL_ERROR;
+    }
+
+    argsPtr = objv[0];
+    bodyPtr = objv[1];
+
+    /*
+     * Create and initialize the Proc struct. The cmdPtr field is set to NULL
+     * to signal that this is an anonymous function.
+     */
+
+    name = TclGetString(objPtr);
+
+    if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr,
+	    &procPtr) != TCL_OK) {
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		"\n    (parsing lambda expression \"%s\")", name));
+	return TCL_ERROR;
+    }
+
+    /*
+     * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
+     * procPtr->refCount = 1;
+     */
+
+    procPtr->cmdPtr = NULL;
+
+    /*
+     * TIP #280: Remember the line the apply body is starting on. In a Byte
+     * code context we ask the engine to provide us with the necessary
+     * information. This is for the initialization of the byte code compiler
+     * when the body is used for the first time.
+     *
+     * NOTE: The body is the second word in the 'objPtr'. Its location,
+     * accessible through 'context.line[1]' (see below) is therefore only the
+     * first approximation of the actual line the body is on. We have to use
+     * the string rep of the 'objPtr' to determine the exact line. This is
+     * available already through 'name'. Use 'TclListLines', see 'switch'
+     * (tclCmdMZ.c).
+     *
+     * This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see
+     * this file. The differences are the different index of the body in the
+     * line array of the context, and the special processing mentioned in the
+     * previous paragraph to track into the list. Find a way to factor the
+     * common elements into a single function.
+     */
+
+    if (iPtr->cmdFramePtr) {
+	CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+
+	*contextPtr = *iPtr->cmdFramePtr;
+	if (contextPtr->type == TCL_LOCATION_BC) {
+	    /*
+	     * Retrieve the source context from the bytecode. This call
+	     * accounts for the reference to the source file, if any, held in
+	     * 'context.data.eval.path'.
+	     */
+
+	    TclGetSrcInfoForPc(contextPtr);
+	} else if (contextPtr->type == TCL_LOCATION_SOURCE) {
+	    /*
+	     * We created a new reference to the source file path name when we
+	     * created 'context' above. Account for the reference.
+	     */
+
+	    Tcl_IncrRefCount(contextPtr->data.eval.path);
+
+	}
+
+	if (contextPtr->type == TCL_LOCATION_SOURCE) {
+	    /*
+	     * We can record source location within a lambda only if the body
+	     * was not created by substitution.
+	     */
+
+	    if (contextPtr->line
+		    && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
+		int buf[2];
+
+		/*
+		 * Move from approximation (line of list cmd word) to actual
+		 * location (line of 2nd list element).
+		 */
+
+		cfPtr = ckalloc(sizeof(CmdFrame));
+		TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
+
+		cfPtr->level = -1;
+		cfPtr->type = contextPtr->type;
+		cfPtr->line = ckalloc(sizeof(int));
+		cfPtr->line[0] = buf[1];
+		cfPtr->nline = 1;
+		cfPtr->framePtr = NULL;
+		cfPtr->nextPtr = NULL;
+
+		cfPtr->data.eval.path = contextPtr->data.eval.path;
+		Tcl_IncrRefCount(cfPtr->data.eval.path);
+
+		cfPtr->cmd = NULL;
+		cfPtr->len = 0;
+	    }
+
+	    /*
+	     * 'contextPtr' is going out of scope. Release the reference that
+	     * it's holding to the source file path
+	     */
+
+	    Tcl_DecrRefCount(contextPtr->data.eval.path);
+	}
+	TclStackFree(interp, contextPtr);
+    }
+    Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr,
+	    &isNew), cfPtr);
+
+    /*
+     * Set the namespace for this lambda: given by objv[2] understood as a
+     * global reference, or else global per default.
+     */
+
+    if (objc == 2) {
+	TclNewLiteralStringObj(nsObjPtr, "::");
+    } else {
+	const char *nsName = TclGetString(objv[2]);
+
+	if ((*nsName != ':') || (*(nsName+1) != ':')) {
+	    TclNewLiteralStringObj(nsObjPtr, "::");
+	    Tcl_AppendObjToObj(nsObjPtr, objv[2]);
+	} else {
+	    nsObjPtr = objv[2];
+	}
+    }
+
+    Tcl_IncrRefCount(nsObjPtr);
+
+    /*
+     * Free the list internalrep of objPtr - this will free argsPtr, but
+     * bodyPtr retains a reference from the Proc structure. Then finish the
+     * conversion to tclLambdaType.
+     */
+
+    TclFreeIntRep(objPtr);
+
+    objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
+    objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+    objPtr->typePtr = &tclLambdaType;
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ApplyObjCmd --
+ *
+ *	This object-based function is invoked to process the "apply" Tcl
+ *	command. See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result value.
+ *
+ * Side effects:
+ *	Depends on the content of the lambda term (i.e., objv[1]).
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ApplyObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRApplyObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Proc *procPtr = NULL;
+    Tcl_Obj *lambdaPtr, *nsObjPtr;
+    int result;
+    Tcl_Namespace *nsPtr;
+    ApplyExtraData *extraPtr;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Set lambdaPtr, convert it to tclLambdaType in the current interp if
+     * necessary.
+     */
+
+    lambdaPtr = objv[1];
+    if (lambdaPtr->typePtr == &tclLambdaType) {
+	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+    }
+
+#define JOE_EXTENSION 0
+/*
+ * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
+ * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
+ * the code. (MS)
+ */
+
+#if JOE_EXTENSION
+    else {
+	/*
+	 * Joe English's suggestion to allow cmdNames to function as lambdas.
+	 */
+
+	Tcl_Obj *elemPtr;
+	int numElem;
+
+	if ((lambdaPtr->typePtr == &tclCmdNameType) ||
+		(TclListObjGetElements(interp, lambdaPtr, &numElem,
+		&elemPtr) == TCL_OK && numElem == 1)) {
+	    return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
+	}
+    }
+#endif
+
+    if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
+	result = SetLambdaFromAny(interp, lambdaPtr);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+    }
+
+    /*
+     * Find the namespace where this lambda should run, and push a call frame
+     * for that namespace. Note that TclObjInterpProc() will pop it.
+     */
+
+    nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
+    result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData));
+    memset(&extraPtr->cmd, 0, sizeof(Command));
+    procPtr->cmdPtr = &extraPtr->cmd;
+    extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
+
+    /*
+     * TIP#280 (semi-)HACK!
+     *
+     * Using cmd.clientData to tell [info frame] how to render the lambdaPtr.
+     * The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL.
+     * This condition holds here because of the memset() above, and nowhere
+     * else (in the core). Regular commands always have a valid hPtr, and
+     * lambda's never.
+     */
+
+    extraPtr->efi.length = 1;
+    extraPtr->efi.fields[0].name = "lambda";
+    extraPtr->efi.fields[0].proc = NULL;
+    extraPtr->efi.fields[0].clientData = lambdaPtr;
+    extraPtr->cmd.clientData = &extraPtr->efi;
+
+    result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
+    if (result == TCL_OK) {
+	TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
+	result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
+    }
+    return result;
+}
+
+static int
+ApplyNR2(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    ApplyExtraData *extraPtr = data[0];
+
+    TclStackFree(interp, extraPtr);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeLambdaError --
+ *
+ *	Function called by TclObjInterpProc to create the stack information
+ *	upon an error from a lambda term.
+ *
+ * Results:
+ *	The interpreter's error info trace is set to a value that supplements
+ *	the error code.
+ *
+ * Side effects:
+ *	none.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MakeLambdaError(
+    Tcl_Interp *interp,		/* The interpreter in which the procedure was
+				 * called. */
+    Tcl_Obj *procNameObj)	/* Name of the procedure. Used for error
+				 * messages and trace information. */
+{
+    int overflow, limit = 60, nameLen;
+    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+
+    overflow = (nameLen > limit);
+    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+	    "\n    (lambda term \"%.*s%s\" line %d)",
+	    (overflow ? limit : nameLen), procName,
+	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetCmdFrameForProcedure --
+ *
+ *	How to get the CmdFrame information for a procedure.
+ *
+ * Results:
+ *	A pointer to the CmdFrame (only guaranteed to be valid until the next
+ *	Tcl command is processed or the interpreter's state is otherwise
+ *	modified) or a NULL if the information is not available.
+ *
+ * Side effects:
+ *	none.
+ *
+ *----------------------------------------------------------------------
+ */
+
+CmdFrame *
+TclGetCmdFrameForProcedure(
+    Proc *procPtr)		/* The procedure whose cmd-frame is to be
+				 * looked up. */
+{
+    Tcl_HashEntry *hePtr;
+
+    if (procPtr == NULL || procPtr->iPtr == NULL) {
+	return NULL;
+    }
+    hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr);
+    if (hePtr == NULL) {
+	return NULL;
+    }
+    return (CmdFrame *) Tcl_GetHashValue(hePtr);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */