Insert of calling point in middle of procedure code. Also cleaned up how

[apply] terms generate stack trace info.

5 files changed, 260 insertions, 156 deletions

diff --git a/ChangeLog b/ChangeLog
index a511ecd..cf6b929 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2006-10-28  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclProc.c (ObjInterpProcEx, TclObjInterpProcCore): Split the
+	core of procedures to make it easier to build procedure-like code
+	without going through horrible contortions. This is the last critical
+	component to make advanced OO systems workable as simple loadable
+	extensions. TOIPC is now in the internal stub table.
+	(MakeProcError, MakeLambdaError): Refactored ProcessProcResultCode to
+	be simpler, some of which goes to TclObjInterpProcCore, and the rest
+	of which is now in these far simpler routines which just do errorInfo
+	stack generation for different types of procedure-like entity.
+
 2006-10-27  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclVar.c (HasLocalVars): New macro to make various bits and
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index d2fbb20..4cca690 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 # 
-# RCS: @(#) $Id: tclInt.decls,v 1.102 2006/10/27 12:53:43 dkf Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.103 2006/10/28 22:48:42 dkf Exp $
 
 library tcl
 
@@ -894,10 +894,16 @@ declare 225 generic {
 declare 226 generic {
     int TclObjBeingDeleted(Tcl_Obj *objPtr)
 }
+
 declare 227 generic {
     void TclSetNsPath(Namespace *nsPtr, int pathLength,
             Tcl_Namespace *pathAry[])
 }
+declare 228 generic {
+    int TclObjInterpProcCore(register Tcl_Interp *interp, CallFrame *framePtr,
+            Tcl_Obj *procNameObj, int isLambda, int skip,
+            ProcErrorProc errorProc)
+}
 
 ##############################################################################
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 290576c..8c62cc1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.285 2006/10/27 13:31:38 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.286 2006/10/28 22:48:43 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -770,6 +770,13 @@ typedef struct Proc {
 } Proc;
 
 /*
+ * The type of functions called to process errors found during the execution
+ * of a procedure (or lambda term or ...).
+ */
+
+typedef void (*ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
+
+/*
  * The structure below defines a command trace. This is used to allow Tcl
  * clients to find out whenever a command is about to be executed.
  */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 74d6ebd..b4c5696 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.100 2006/10/27 00:39:57 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.101 2006/10/28 22:48:43 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -29,14 +29,17 @@ static void		InitCompiledLocals(Tcl_Interp *interp,
 			    Var *varPtr, Namespace *nsPtr);
 static int		ObjInterpProcEx(ClientData clientData,
 			    register Tcl_Interp *interp, int objc,
-			    Tcl_Obj *CONST objv[], int isLambda);
+			    Tcl_Obj *CONST objv[], int isLambda,
+			    ProcErrorProc errorProc);
 static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
 static void		ProcBodyFree(Tcl_Obj *objPtr);
-static int		ProcessProcResultCode(Tcl_Interp *interp,
-			    char *procName, int nameLen, int returnCode);
+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 int		ProcCompileProc (Tcl_Interp *interp, Proc *procPtr,
-			    Tcl_Obj *bodyPtr, Namespace *nsPtr, 
+			    Tcl_Obj *bodyPtr, Namespace *nsPtr,
 			    CONST char *description, CONST char *procName,
 			    Proc **procPtrPtr);
 
@@ -1111,7 +1114,7 @@ TclInitCompiledLocals(
 /*
  *----------------------------------------------------------------------
  *
- * TclObjInterpProc --
+ * TclObjInterpProc, ObjInterpProcEx --
  *
  *	When a Tcl procedure gets invoked during bytecode evaluation, this
  *	object-based routine gets invoked to interpret the procedure.
@@ -1135,10 +1138,10 @@ TclObjInterpProc(
 				 * procedure. */
     Tcl_Obj *CONST objv[])	/* Argument value objects. */
 {
-
-    return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0);
+    return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0,
+	    &MakeProcError);
 }
-	
+
 static int
 ObjInterpProcEx(
     ClientData clientData, 	/* Record describing procedure to be
@@ -1148,24 +1151,15 @@ ObjInterpProcEx(
     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 */ 
+    int isLambda,		/* 1 if this is a call by ApplyObjCmd: it
+				 * needs special rules for error msg */
+    ProcErrorProc errorProc)	/* How to convert results from the script into
+				 * results of the overall procedure. */
 {
     Proc *procPtr = (Proc *) clientData;
     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
     CallFrame *framePtr, **framePtrPtr;
-    register Var *varPtr;
-    register CompiledLocal *localPtr;
-    char *procName;
-    int nameLen, localCt, numArgs, argCt, i, imax, result;
-    Var *compiledLocals;
-    Tcl_Obj *CONST *argObjs;
-
-    /*
-     * Get the procedure's name.
-     */
-
-    procName = Tcl_GetStringFromObj(objv[0], &nameLen);
+    int result;
 
     /*
      * If necessary, compile the procedure's body. The compiler will allocate
@@ -1175,13 +1169,12 @@ ObjInterpProcEx(
      */
 
     result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
-	    "body of proc", procName, &procPtr);
+	    "body of proc", TclGetString(objv[0]), &procPtr);
 
     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
@@ -1198,8 +1191,53 @@ ObjInterpProcEx(
 	return result;
     }
 
+    framePtr->objc = objc;
+    framePtr->objv = objv;
     framePtr->procPtr = procPtr;
 
+    return TclObjInterpProcCore(interp, framePtr, objv[0], isLambda, 1,
+	    errorProc);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjInterpProcCore --
+ *
+ *	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
+TclObjInterpProcCore(
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    CallFrame *framePtr,	/* The context to execute. The procPtr field
+				 * must be non-NULL. */
+    Tcl_Obj *procNameObj,	/* Procedure name for error reporting. */
+    int isLambda,		/* 1 if this is a call by ApplyObjCmd: it
+				 * needs special rules for error msg. */
+    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. */
+{
+    register Proc *procPtr = framePtr->procPtr;
+    register Var *varPtr;
+    register CompiledLocal *localPtr;
+    int localCt, numArgs, argCt, i, imax, result;
+    Var *compiledLocals;
+    Tcl_Obj *const *argObjs;
+
     /*
      * Create the "compiledLocals" array. Make sure it is large enough to hold
      * all the procedure's compiled local variables, including its formal
@@ -1207,7 +1245,7 @@ ObjInterpProcEx(
      */
 
     localCt = procPtr->numCompiledLocals;
-    compiledLocals = (Var *) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
+    compiledLocals = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
     framePtr->numCompiledLocals = localCt;
     framePtr->compiledLocals = compiledLocals;
 
@@ -1219,8 +1257,9 @@ ObjInterpProcEx(
      */
 
     numArgs = procPtr->numArgs;
-    argCt = objc-1; /* set it to the number of args to the proc */
-    argObjs = &objv[1];
+    argCt = framePtr->objc - skip;	/* Set it to the number of args to the
+					 * procedure. */
+    argObjs = framePtr->objv + skip;
     varPtr = framePtr->compiledLocals;
     localPtr = procPtr->firstLocalPtr;
     if (numArgs == 0) {
@@ -1304,7 +1343,7 @@ ObjInterpProcEx(
 
     incorrectArgs:
 	codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr;
-	InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
+	InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
 
 	/*
 	 * Build up desired argument list for Tcl_WrongNumArgs
@@ -1314,9 +1353,10 @@ ObjInterpProcEx(
 		ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));
 
 #ifdef AVOID_HACKS_FOR_ITCL
-	desiredObjs[0] = objv[0];
+	desiredObjs[0] = framePtr->objv[0];
 #else
-	desiredObjs[0] = (isLambda? objv[0]: Tcl_NewListObj(1, objv));
+	desiredObjs[0] = (isLambda ? framePtr->objv[0] :
+		Tcl_NewListObj(1, framePtr->objv));
 #endif /* AVOID_HACKS_FOR_ITCL */
 
 	localPtr = procPtr->firstLocalPtr;
@@ -1370,18 +1410,25 @@ ObjInterpProcEx(
 	ByteCode *codePtr = (ByteCode *)
 		procPtr->bodyPtr->internalRep.otherValuePtr;
 
-	InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
+	InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
     }
 
     /*
-     * Invoke the commands in the procedure's body.
+     * Set the callframe's objc/objv to be what [info level] expects.
      */
 
-#ifdef TCL_COMPILE_DEBUG
+    framePtr->objc = ((Interp *) interp)->callObjc;
+    framePtr->objv = ((Interp *) interp)->callObjv;
+
+#if defined(TCL_COMPILE_DEBUG)
     if (tclTraceExec >= 1) {
-	fprintf(stdout, "Calling proc ");
-	for (i = 0; i < objc; i++) {
-	    TclPrintObject(stdout, objv[i], 15);
+	if (isLambda) {
+	    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");
@@ -1389,6 +1436,10 @@ ObjInterpProcEx(
     }
 #endif /*TCL_COMPILE_DEBUG*/
 
+    /*
+     * Invoke the commands in the procedure's body.
+     */
+
     procPtr->refCount++;
     result = TclCompEvalObj(interp, procPtr->bodyPtr);
     procPtr->refCount--;
@@ -1397,26 +1448,46 @@ ObjInterpProcEx(
     }
 
     if (result != TCL_OK) {
-	if (isLambda) {
-	    /*
-	     * Use a 'procName' that contains the first skip elements of objv
-	     * for error reporting. This insures that we do not see just
-	     * 'apply', but also the lambda expression that caused the error.
-	     *
-	     * NASTY HACK: looks one object back in objv - it was skipped by
-	     * ApplyObjCmd. Temporary solution, the whole thing needs
-	     * refactoring. 
-	     */
-	     
-	    Tcl_Obj *namePtr;
+	/*
+	 * Non-standard results are processed by passing them through quickly.
+	 * This means they all work as exceptions, unwinding the stack quickly
+	 * and neatly. Who knows how well they are handled by third-party code
+	 * though...
+	 */
 
-	    namePtr = Tcl_NewListObj(2, objv-1);
-	    procName = Tcl_GetStringFromObj(namePtr, &nameLen);
-	    result = ProcessProcResultCode(interp, procName, nameLen, result);
-	    TclDecrRefCount(namePtr);
-	} else {
-	    result = ProcessProcResultCode(interp, procName, nameLen, result);	    
+	if ((result > TCL_CONTINUE) || (result < TCL_OK)) {
+	    goto procDone;
 	}
+
+	/*
+	 * If it is a 'return', do the TIP#90 processing now.
+	 */
+
+	if (result == TCL_RETURN) {
+	    result = TclUpdateReturnInfo((Interp *) interp);
+	    goto procDone;
+	}
+
+	/*
+	 * Must be an error, a 'break' or a 'continue'. It's an error to get
+	 * to this point from a 'break' or 'continue' though, so transform to
+	 * an error now.
+	 */
+
+	if (result != TCL_ERROR) {
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendResult(interp, "invoked \"",
+		    ((result == TCL_BREAK) ? "break" : "continue"),
+		    "\" outside of a loop", NULL);
+	    result = TCL_ERROR;
+	}
+
+	/*
+	 * Now it _must_ be an error, so we need to log it as such. This means
+	 * filling out the error trace.
+	 */
+
+	(*errorProc)(interp, procNameObj);
     }
 
     /*
@@ -1437,7 +1508,6 @@ ObjInterpProcEx(
     TclStackFree(interp);	/* free compiledLocals */
     TclStackFree(interp);	/* free CallFrame */
     return result;
-#undef NUM_LOCALS
 }
 
 /*
@@ -1652,56 +1722,35 @@ ProcCompileProc(
 /*
  *----------------------------------------------------------------------
  *
- * ProcessProcResultCode --
+ * MakeProcError --
  *
- *	Function called by TclObjInterpProc to process a return code other
- *	than TCL_OK returned by a Tcl procedure.
+ *	Function called by TclObjInterpProc to create the stack information
+ *	upon an error from a procedure.
  *
  * Results:
- *	Depending on the argument return code, the result returned is another
- *	return code and the interpreter's result is set to a value to
- *	supplement that return code.
+ *	The interpreter's error info trace is set to a value that supplements
+ *	the error code.
  *
  * Side effects:
- *	If the result returned is TCL_ERROR, traceback information about the
- *	procedure just executed is appended to the interpreter's errorInfo
- *	field.
+ *	none.
  *
  *----------------------------------------------------------------------
  */
 
-static int
-ProcessProcResultCode(
+static void
+MakeProcError(
     Tcl_Interp *interp,		/* The interpreter in which the procedure was
-				 * called and returned returnCode. */
-    char *procName,		/* Name of the procedure. Used for error
+				 * called. */
+    Tcl_Obj *procNameObj)	/* Name of the procedure. Used for error
 				 * messages and trace information. */
-    int nameLen,		/* Number of bytes in procedure's name. */
-    int returnCode)		/* The unexpected result code. */
 {
-    Interp *iPtr = (Interp *) interp;
-    int overflow, limit = 60;
+    int overflow, limit = 60, nameLen;
+    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
 
-    if (returnCode == TCL_OK) {
-	return TCL_OK;
-    }
-    if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
-	return returnCode;
-    }
-    if (returnCode == TCL_RETURN) {
-	return TclUpdateReturnInfo(iPtr);
-    }
-    if (returnCode != TCL_ERROR) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "invoked \"",
-		((returnCode == TCL_BREAK) ? "break" : "continue"),
-		"\" outside of a loop", NULL);
-    }
     overflow = (nameLen > limit);
     TclFormatToErrorInfo(interp, "\n    (procedure \"%.*s%s\" line %d)",
 	    (overflow ? limit : nameLen), procName,
 	    (overflow ? "..." : ""), interp->errorLine);
-    return TCL_ERROR;
 }
 
 /*
@@ -1954,7 +2003,17 @@ ProcBodyFree(
 }
 
 /*
- * LAMBDA and APPLY implementation. [TIP#194]
+ *----------------------------------------------------------------------
+ *
+ * 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
@@ -1962,11 +2021,11 @@ DupLambdaInternalRep(
     Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
     register Tcl_Obj *copyPtr)	/* Object with internal rep to set. */
 {
-    Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
-    Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2;
+    Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+    Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
 
-    copyPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
-    copyPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
+    copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
+    copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
 
     procPtr->refCount++;
     Tcl_IncrRefCount(nsObjPtr);
@@ -1978,8 +2037,8 @@ FreeLambdaInternalRep(
     register Tcl_Obj *objPtr)	/* CmdName object with internal representation
 				 * to free. */
 {
-    Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
-    Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
+    Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+    Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
 
     procPtr->refCount--;
     if (procPtr->refCount == 0) {
@@ -2022,26 +2081,26 @@ SetLambdaFromAny(
      */
 
     name = TclGetString(objPtr);
-    
+
     if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr,
 	    bodyPtr, &procPtr) != TCL_OK) {
 	TclFormatToErrorInfo(interp,
-		"\n    (parsing lambda expression \"%s\")",
-		name, NULL);
+		"\n    (parsing lambda expression \"%s\")", name, NULL);
 	return TCL_ERROR;
     }
 
-    /* CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
+    /*
+     * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
      * procPtr->refCount = 1;
      */
-    
+
     procPtr->cmdPtr = NULL;
 
     /*
      * Set the namespace for this lambda: given by objv[2] understood as a
      * global reference, or else global per default.
      */
-    
+
     if (objc == 2) {
 	nsObjPtr = Tcl_NewStringObj("::", 2);
     } else {
@@ -2064,11 +2123,28 @@ SetLambdaFromAny(
 
     objPtr->typePtr->freeIntRepProc(objPtr);
 
-    objPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
-    objPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
+    objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
+    objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
     objPtr->typePtr = &lambdaType;
     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(
@@ -2094,20 +2170,20 @@ Tcl_ApplyObjCmd(
      * Set lambdaPtr, convert it to lambdaType in the current interp if
      * necessary.
      */
- 
+
     lambdaPtr = objv[1];
     if (lambdaPtr->typePtr == &lambdaType) {
-	procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
+	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
     }
 
 #define JOE_EXTENSION 0
 #if JOE_EXTENSION
-    /*
-     * Joe English's suggestion to allow cmdNames to function as lambdas.
-     * Requires also making tclCmdNameType non-static in tclObj.c
-     */
-
     else {
+	/*
+	 * Joe English's suggestion to allow cmdNames to function as lambdas.
+	 * Also requires making tclCmdNameType non-static in tclObj.c
+	 */
+
 	Tcl_Obj *elemPtr;
 	int numElem;
 
@@ -2124,17 +2200,17 @@ Tcl_ApplyObjCmd(
 	if (result != TCL_OK) {
 	    return result;
 	}
-	procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
+	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
     }
     procPtr->cmdPtr = &cmd;
-    
+
     /*
      * Find the namespace where this lambda should run, and push a call frame
      * for that namespace. Note that TclObjInterpProc() will pop it.
      */
-    
-    nsObjPtr = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2;
-    result  = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+
+    nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
+    result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
     if (result != TCL_OK) {
 	return result;
     }
@@ -2146,7 +2222,7 @@ Tcl_ApplyObjCmd(
 	Tcl_SetObjResult(interp, errPtr);
 	return TCL_ERROR;
     }
-    
+
     cmd.nsPtr = (Namespace *) nsPtr;
 
     isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
@@ -2158,14 +2234,49 @@ Tcl_ApplyObjCmd(
 	iPtr->ensembleRewrite.numInsertedObjs -= 1;
     }
 
-    result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1,1);
+    result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1, 1,
+	    &MakeLambdaError);
 
     if (isRootEnsemble) {
 	iPtr->ensembleRewrite.sourceObjs = NULL;
 	iPtr->ensembleRewrite.numRemovedObjs = 0;
 	iPtr->ensembleRewrite.numInsertedObjs = 0;
     }
-    return result;    
+    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);
+    TclFormatToErrorInfo(interp, "\n    (lambda term \"%.*s%s\" line %d)",
+	    (overflow ? limit : nameLen), procName,
+	    (overflow ? "..." : ""), interp->errorLine);
 }
 
 /*
diff --git a/tests/apply.test b/tests/apply.test
index e639638..10131ce 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: apply.test,v 1.8 2006/10/24 23:13:07 msofer Exp $
+# RCS: @(#) $Id: apply.test,v 1.9 2006/10/28 22:48:43 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -23,7 +23,7 @@ if {[info commands ::apply] eq {}} {
     return
 }
 
-testConstraint memory     [llength [info commands memory]]
+testConstraint memory [llength [info commands memory]]
 
 # Tests for wrong number of arguments
 
@@ -39,13 +39,11 @@ test apply-2.0 {malformed lambda} {
     set res [catch {apply $lambda} msg]
     list $res $msg
 } {1 {can't interpret "a" as a lambda expression}}
-
 test apply-2.1 {malformed lambda} {
     set lambda [list a b c d]
     set res [catch {apply $lambda} msg]
     list $res $msg
 } {1 {can't interpret "a b c d" as a lambda expression}}
-
 test apply-2.2 {malformed lambda} {
     set lambda [list {{}} boo]
     set res [catch {apply $lambda} msg]
@@ -54,7 +52,6 @@ test apply-2.2 {malformed lambda} {
     (parsing lambda expression "{{}} boo")
     invoked from within
 "apply $lambda"}}
-
 test apply-2.3 {malformed lambda} {
     set lambda [list {{a b c}} boo]
     set res [catch {apply $lambda} msg]
@@ -63,7 +60,6 @@ test apply-2.3 {malformed lambda} {
     (parsing lambda expression "{{a b c}} boo")
     invoked from within
 "apply $lambda"}}
-
 test apply-2.4 {malformed lambda} {
     set lambda [list a(1) boo]
     set res [catch {apply $lambda} msg]
@@ -72,7 +68,6 @@ test apply-2.4 {malformed lambda} {
     (parsing lambda expression "a(1) boo")
     invoked from within
 "apply $lambda"}}
-
 test apply-2.5 {malformed lambda} {
     set lambda [list a::b boo]
     set res [catch {apply $lambda} msg]
@@ -82,7 +77,6 @@ test apply-2.5 {malformed lambda} {
     invoked from within
 "apply $lambda"}}
 
-
 # Tests for runtime errors in the lambda expression
 
 test apply-3.1 {non-existing namespace} {
@@ -90,7 +84,6 @@ test apply-3.1 {non-existing namespace} {
     set res [catch {apply $lambda x} msg]
     list $res $msg
 } {1 {cannot find namespace "::NONEXIST::FOR::SURE"}}
-
 test apply-3.2 {non-existing namespace} {
     namespace eval ::NONEXIST::FOR::SURE {}
     set lambda [list x {set x 1} ::NONEXIST::FOR::SURE]
@@ -99,13 +92,11 @@ test apply-3.2 {non-existing namespace} {
     set res [catch {apply $lambda x} msg]
     list $res $msg
 } {1 {cannot find namespace "::NONEXIST::FOR::SURE"}}
-
 test apply-3.3 {non-existing namespace} {
     set lambda [list x {set x 1} NONEXIST::FOR::SURE]
     set res [catch {apply $lambda x} msg]
     list $res $msg
 } {1 {cannot find namespace "::NONEXIST::FOR::SURE"}}
-
 test apply-3.4 {non-existing namespace} {
     namespace eval ::NONEXIST::FOR::SURE {}
     set lambda [list x {set x 1} NONEXIST::FOR::SURE]
@@ -120,27 +111,23 @@ test apply-4.1 {error in arguments to lambda expression} {
     set res [catch {apply $lambda} msg]
     list $res $msg
 } {1 {wrong # args: should be "apply {x {set x 1}} x"}}
-
 test apply-4.2 {error in arguments to lambda expression} {
     set lambda [list x {set x 1}]
     set res [catch {apply $lambda a b} msg]
     list $res $msg
 } {1 {wrong # args: should be "apply {x {set x 1}} x"}}
-
 test apply-4.3 {error in arguments to lambda expression} {
     set lambda [list x {set x 1}]
     interp alias {} foo {} ::apply $lambda
     set res [catch {foo a b} msg]
     list $res $msg [rename foo {}]
 } {1 {wrong # args: should be "foo x"} {}}
-
 test apply-4.4 {error in arguments to lambda expression} {
     set lambda [list x {set x 1}]
     interp alias {} foo {} ::apply $lambda a
     set res [catch {foo b} msg]
     list $res $msg [rename foo {}]
 } {1 {wrong # args: should be "foo"} {}}
-
 test apply-4.5 {error in arguments to lambda expression} {
     set lambda [list x {set x 1}]
     namespace eval a {
@@ -168,7 +155,7 @@ test apply-5.1 {runtime error in lambda expression} {
 } {1 {foo
     while executing
 "error foo"
-    (procedure "apply {{} {error foo}}" line 1)
+    (lambda term "{} {error foo}" line 1)
     invoked from within
 "apply $lambda"}}
 
@@ -180,12 +167,10 @@ test apply-6.1 {info level} {
     set lambda [list {} {info level}]
     expr {[apply $lambda] - $lev}
 } 1
-
 test apply-6.2 {info level} {
     set lambda [list {} {info level 0}]
     apply $lambda
 } {apply {{} {info level 0}}}
-
 test apply-6.3 {info level} {
     set lambda [list args {info level 0}]
     apply $lambda x y
@@ -202,50 +187,42 @@ test apply-7.1 {namespace access} {
     set body {set x 1; set x}
     list [apply [list args $body ::testApply]] $::testApply::x
 } {1 0}
-
 test apply-7.2 {namespace access} {
     set ::testApply::x 0
     set body {variable x; set x}
     list [apply [list args $body ::testApply]] $::testApply::x
 } {0 0}
-
 test apply-7.3 {namespace access} {
     set ::testApply::x 0
     set body {variable x; set x 1}
     list [apply [list args $body ::testApply]] $::testApply::x
 } {1 1}
-
 test apply-7.4 {namespace access} {
     set ::testApply::x 0
     set body {testApply}
     apply [list args $body ::testApply]
 } testApply
-
 test apply-7.5 {namespace access} {
     set ::testApply::x 0
     set body {set x 1; set x}
     list [apply [list args $body testApply]] $::testApply::x
 } {1 0}
-
 test apply-7.6 {namespace access} {
     set ::testApply::x 0
     set body {variable x; set x}
     list [apply [list args $body testApply]] $::testApply::x
 } {0 0}
-
 test apply-7.7 {namespace access} {
     set ::testApply::x 0
     set body {variable x; set x 1}
     list [apply [list args $body testApply]] $::testApply::x
 } {1 1}
-
 test apply-7.8 {namespace access} {
     set ::testApply::x 0
     set body {testApply}
     apply [list args $body testApply]
 } testApply
 
-
 # Tests for correct argument treatment
 
 set applyBody {
@@ -260,39 +237,30 @@ set applyBody {
 test apply-8.1 {args treatment} {
     apply [list args $applyBody] 1 2 3
 } {{args {1 2 3}}}
-
 test apply-8.2 {args treatment} {
     apply [list {x args} $applyBody] 1 2
 } {{x 1} {args 2}}
-
 test apply-8.3 {args treatment} {
     apply [list {x args} $applyBody] 1 2 3
 } {{x 1} {args {2 3}}}
-
 test apply-8.4 {default values} {
     apply [list {{x 1} {y 2}} $applyBody] 
 } {{x 1} {y 2}}
-
 test apply-8.5 {default values} {
     apply [list {{x 1} {y 2}} $applyBody] 3 4
 } {{x 3} {y 4}}
-
 test apply-8.6 {default values} {
     apply [list {{x 1} {y 2}} $applyBody] 3
 } {{x 3} {y 2}}
-
 test apply-8.7 {default values} {
     apply [list {x {y 2}} $applyBody] 1
 } {{x 1} {y 2}}
-
 test apply-8.8 {default values} {
     apply [list {x {y 2}} $applyBody] 1 3
 } {{x 1} {y 3}}
-
 test apply-8.9 {default values} {
     apply [list {x {y 2} args} $applyBody] 1
 } {{x 1} {y 2} {args {}}}
-
 test apply-8.10 {default values} {
     apply [list {x {y 2} args} $applyBody] 1 3
 } {{x 1} {y 3} {args {}}}