Tcl Source Code

Artifact 2eb93158fcabd0c7dddb3fb8f65c715255be361d:

Attachment "1574835.diff" to ticket [1574835fff] added by msofer 2006-10-12 08:39:11.

---

Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.92
diff -u -r1.92 tclProc.c
--- generic/tclProc.c	30 Sep 2006 17:56:47 -0000	1.92
+++ generic/tclProc.c	12 Oct 2006 01:37:28 -0000
@@ -29,7 +29,7 @@
 			    Var *varPtr, Namespace *nsPtr);
 static int		ObjInterpProcEx(ClientData clientData,
 			    register Tcl_Interp *interp, int objc,
-			    Tcl_Obj *CONST objv[], int skip);
+			    Tcl_Obj *CONST objv[], int isLambda);
 static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
 static void		ProcBodyFree(Tcl_Obj *objPtr);
 static int		ProcessProcResultCode(Tcl_Interp *interp,
@@ -1143,7 +1143,7 @@
     Tcl_Obj *CONST objv[])	/* Argument value objects. */
 {
 
-    return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
+    return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0);
 }
 	
 static int
@@ -1155,8 +1155,8 @@
     int objc,			/* Count of number of arguments to this
 				 * procedure. */
     Tcl_Obj *CONST objv[],	/* Argument value objects. */
-    int skip)			/* Number of initial arguments to be skipped,
-				 * ie, words in the "command name" */ 
+    int isLambda)		/* 1 if this is a call by ApplyObjCmd: it
+				 * needs special rules for error msg */ 
 {
     Proc *procPtr = (Proc *) clientData;
     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
@@ -1229,8 +1229,8 @@
      */
 
     numArgs = procPtr->numArgs;
-    argCt = objc-skip; /* set it to the number of args to the proc */
-    argObjs = &objv[skip];
+    argCt = objc-1; /* set it to the number of args to the proc */
+    argObjs = &objv[1];
     varPtr = framePtr->compiledLocals;
     localPtr = procPtr->firstLocalPtr;
     if (numArgs == 0) {
@@ -1326,7 +1326,7 @@
 #ifdef AVOID_HACKS_FOR_ITCL
 	desiredObjs[0] = objv[0];
 #else
-	desiredObjs[0] = Tcl_NewListObj(skip, objv);
+	desiredObjs[0] = Tcl_NewListObj(1, objv);
 #endif /* AVOID_HACKS_FOR_ITCL */
 
 	localPtr = procPtr->firstLocalPtr;
@@ -1407,21 +1407,25 @@
     }
 
     if (result != TCL_OK) {
-	if (skip == 1) {
-	    result = ProcessProcResultCode(interp, procName, nameLen, result);
-	} else {
+	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;
 
-	    namePtr = Tcl_NewListObj(skip, objv);
+	    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);	    
 	}
     }
 
@@ -2085,6 +2089,7 @@
     int result;
     Command cmd;
     Tcl_Namespace *nsPtr;
+    int isRootEnsemble;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
@@ -2150,7 +2155,23 @@
     
     cmd.nsPtr = (Namespace *) nsPtr;
 
-    return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2);
+    isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+    if (isRootEnsemble) {
+	iPtr->ensembleRewrite.sourceObjs = objv;
+	iPtr->ensembleRewrite.numRemovedObjs = 1;
+	iPtr->ensembleRewrite.numInsertedObjs = 0;
+    } else {
+	iPtr->ensembleRewrite.numInsertedObjs -= 1;
+    }
+
+    result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1,1);
+
+    if (isRootEnsemble) {
+	iPtr->ensembleRewrite.sourceObjs = NULL;
+	iPtr->ensembleRewrite.numRemovedObjs = 0;
+	iPtr->ensembleRewrite.numInsertedObjs = 0;
+    }
+    return result;    
 }
 
 /*