TIP#194 IMPLEMENTATION

        * doc/apply.n:  (New file)      New command [apply].  [Patch 944803].
        * doc/uplevel.n:
        * generic/tclBasic.c:
        * generic/tclInt.h:
        * generic/tclProc.c:
        * tests/apply.test: (New file)
        * tests/proc-old.test:
        * tests/proc.test:

3 files changed, 263 insertions, 18 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index cfd7e90..42f07a6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.188 2006/02/01 18:27:43 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.189 2006/02/01 19:26:01 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -105,6 +105,7 @@ static CmdInfo builtInCmds[] = {
      */
 
     {"append",		Tcl_AppendObjCmd,	TclCompileAppendCmd,	1},
+    {"apply",	        Tcl_ApplyObjCmd,        NULL,                   1},
     {"array",		Tcl_ArrayObjCmd,	NULL,			1},
     {"binary",		Tcl_BinaryObjCmd,	NULL,			1},
     {"break",		Tcl_BreakObjCmd,	TclCompileBreakCmd,	1},
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0dbb1bd..64dbfec 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.266 2006/02/01 18:27:46 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.267 2006/02/01 19:26:02 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -2246,6 +2246,9 @@ MODULE_SCOPE int	Tcl_AfterObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_AppendObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int	Tcl_ApplyObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[]);
 MODULE_SCOPE int	Tcl_ArrayObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 9308b81..c2dab7e 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -6,11 +6,12 @@
  *
  * Copyright (c) 1987-1993 The Regents of the University of California.
  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2004-2006 Miguel Sofer
  *
  * 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.84 2006/01/23 11:01:59 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.85 2006/02/01 19:26:02 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -20,6 +21,8 @@
  * Prototypes for static functions in this file
  */
 
+static int              ObjInterpProcEx(ClientData clientData,register Tcl_Interp *interp,
+	                    int objc, Tcl_Obj *CONST objv[], int skip);
 static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
 static void		ProcBodyFree(Tcl_Obj *objPtr);
 static int		ProcessProcResultCode(Tcl_Interp *interp,
@@ -131,6 +134,9 @@ Tcl_ProcObjCmd(
 
     if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
 	    &procPtr) != TCL_OK) {
+	Tcl_AddErrorInfo(interp, "\n    (creating proc \"");
+	Tcl_AddErrorInfo(interp, procName);
+	Tcl_AddErrorInfo(interp, "\")");
 	return TCL_ERROR;
     }
 
@@ -372,8 +378,7 @@ TclCreateProc(
 	}
 	if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
 	    ckfree((char *) fieldValues);
-	    Tcl_AppendResult(interp, "procedure \"", procName,
-		    "\" has argument with no name", NULL);
+	    Tcl_AppendResult(interp, "argument with no name", NULL);
 	    goto procError;
 	}
 
@@ -397,16 +402,16 @@ TclCreateProc(
 		} while (*q != '\0');
 		q--;
 		if (*q == ')') { /* we have an array element */
-		    Tcl_AppendResult(interp, "procedure \"", procName,
-			    "\" has formal parameter \"", fieldValues[0],
-			    "\" that is an array element", NULL);
+		    Tcl_AppendResult(interp, "formal parameter \"",
+			    fieldValues[0],
+			    "\" is an array element", NULL);
 		    ckfree((char *) fieldValues);
 		    goto procError;
 		}
 	    } else if ((*p == ':') && (*(p+1) == ':')) {
-		Tcl_AppendResult(interp, "procedure \"", procName,
-			"\" has formal parameter \"", fieldValues[0],
-			"\" that is not a simple name", NULL);
+		Tcl_AppendResult(interp, "formal parameter \"",
+			fieldValues[0],
+			"\" is not a simple name", NULL);
 		ckfree((char *) fieldValues);
 		goto procError;
 	    }
@@ -1113,6 +1118,22 @@ TclObjInterpProc(
 				 * procedure. */
     Tcl_Obj *CONST objv[])	/* Argument value objects. */
 {
+
+    return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
+}
+	
+static int
+ObjInterpProcEx(
+    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 skip)                   /* Number of initial arguments to be skipped,
+				 * ie, words in the "command name" */ 
+{
     register Proc *procPtr = (Proc *) clientData;
     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
     CallFrame *framePtr, **framePtrPtr;
@@ -1121,6 +1142,7 @@ TclObjInterpProc(
     char *procName;
     int nameLen, localCt, numArgs, argCt, i, imax, result;
     Var *compiledLocals;
+    Tcl_Obj *CONST *argObjs;
 
     /*
      * Get the procedure's name.
@@ -1183,7 +1205,8 @@ TclObjInterpProc(
      */
 
     numArgs = procPtr->numArgs;
-    argCt = objc-1; /* set it to the number of args to the proc */
+    argCt = objc-skip; /* set it to the number of args to the proc */
+    argObjs = &objv[skip];
     varPtr = framePtr->compiledLocals;
     localPtr = procPtr->firstLocalPtr;
     if (numArgs == 0) {
@@ -1194,13 +1217,13 @@ TclObjInterpProc(
 	}
     }
     imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
-    for (i = 1; i <= imax; i++) {
+    for (i = 0; i < imax; i++) {
 	/*
 	 * "Normal" arguments; last formal is special, depends on it being
 	 * 'args'.
 	 */
 
-	Tcl_Obj *objPtr = objv[i];
+	Tcl_Obj *objPtr = argObjs[i];
 
 	varPtr->value.objPtr = objPtr;
 	Tcl_IncrRefCount(objPtr);	/* local var is a reference */
@@ -1214,7 +1237,7 @@ TclObjInterpProc(
 	varPtr++;
 	localPtr = localPtr->nextPtr;
     }
-    for (; i < numArgs; i++) {
+    for (; i < (numArgs - 1); i++) {
 	/*
 	 * This loop is entered if argCt < (numArgs-1). Set default values;
 	 * last formal is special.
@@ -1245,11 +1268,11 @@ TclObjInterpProc(
      */
 
     if (localPtr->flags & VAR_IS_ARGS) {
-	Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs]));
+	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 = objv[numArgs];
+	Tcl_Obj *objPtr = argObjs[i];
 	varPtr->value.objPtr = objPtr;
 	Tcl_IncrRefCount(objPtr);	/* local var is a reference */
     } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
@@ -1279,7 +1302,7 @@ TclObjInterpProc(
 #ifdef AVOID_HACKS_FOR_ITCL
 	desiredObjs[0] = objv[0];
 #else
-	desiredObjs[0] = Tcl_NewListObj(1, objv);
+	desiredObjs[0] = Tcl_NewListObj(skip, objv);
 #endif /* AVOID_HACKS_FOR_ITCL */
 
 	localPtr = procPtr->firstLocalPtr;
@@ -1866,6 +1889,224 @@ TclCompileNoOp(
 }
 
 /*
+ * LAMBDA and APPLY implementation
+ *
+ */
+
+static void		DupLambdaInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
+			    Tcl_Obj *copyPtr));
+static void		FreeLambdaInternalRep _ANSI_ARGS_((
+    			    Tcl_Obj *objPtr));
+static int		SetLambdaFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+			    Tcl_Obj *objPtr));
+
+Tcl_ObjType lambdaType = {
+    "lambda",				/* name */
+    FreeLambdaInternalRep,	        /* freeIntRepProc */
+    DupLambdaInternalRep,	        /* dupIntRepProc */
+    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
+    SetLambdaFromAny			/* setFromAnyProc */
+};
+
+/*
+ * a Lambda Tcl_Obj has the form
+ *
+ *  ptr1 is a *Proc:     pointer to a proc structure
+ *  ptr2 is a *Tcl_Obj:  the lambda's namespace
+ */
+
+static void
+DupLambdaInternalRep(srcPtr, copyPtr)
+    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;
+
+    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+    copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr;
+
+    procPtr->refCount++;
+    Tcl_IncrRefCount(nsObjPtr);
+    copyPtr->typePtr = &lambdaType;
+}
+
+static void
+FreeLambdaInternalRep(objPtr)
+    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;
+
+    procPtr->refCount--;
+    if (procPtr->refCount == 0) {
+	TclProcCleanupProc(procPtr);
+    }
+    TclDecrRefCount(nsObjPtr);
+}
+
+
+static int
+SetLambdaFromAny(interp, objPtr)
+    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
+    register Tcl_Obj *objPtr;	/* The object to convert. */
+{
+    char *name;
+    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
+    int objc;
+    Proc *procPtr;
+    int result;
+
+    /*
+     * Convert objPtr to list type first; if it cannot be
+     * converted, or if its length is not 2, then it cannot
+     * be converted to lambdaType.
+     */
+
+    result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
+    if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
+	errPtr = Tcl_NewStringObj("can't interpret \"",-1);
+	Tcl_IncrRefCount(errPtr);
+	Tcl_AppendObjToObj(errPtr, objPtr);
+	Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
+	Tcl_SetObjResult(interp, errPtr);
+	Tcl_DecrRefCount(errPtr);
+	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_AddErrorInfo(interp, "\n    (parsing lambda expression \"");
+	Tcl_AddErrorInfo(interp, name);
+	Tcl_AddErrorInfo(interp, "\")");
+        return TCL_ERROR;
+    }
+    procPtr->refCount++;
+    procPtr->cmdPtr = (Command *) NULL;
+
+    /*
+     * Set the namespace for this lambda: given by objv[2] understood
+     * as a global reference, or else global per default.
+     */
+    
+    nsObjPtr = Tcl_NewStringObj("::", 2);
+    Tcl_IncrRefCount(nsObjPtr);    
+
+    if (objc == 3) {
+	Tcl_AppendObjToObj(nsObjPtr, objv[2]);
+    }
+	    	
+    
+    /*
+     * Free the list internalrep of objPtr - this will free argsPtr, but
+     * bodyPtr retains a reference from the Proc structure. Then finish
+     * the conversion to lambdaType.
+     */
+
+    objPtr->typePtr->freeIntRepProc(objPtr);
+
+    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr;
+    objPtr->typePtr = &lambdaType;
+    return TCL_OK;
+}
+
+int
+Tcl_ApplyObjCmd(dummy, interp, objc, objv)
+    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, *errPtr;
+    int result;
+    Command cmd;
+    Tcl_Namespace *nsPtr;
+
+#define JOE_EXTENSION 0
+#if JOE_EXTENSION
+    Tcl_Obj *elemPtr;
+    int numElem;
+#endif
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * 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;
+
+#if JOE_EXTENSION
+/*
+ * Joe English's suggestion to allow cmdNames to function as lambdas. Requires
+ * also making tclCmdNameType non-static in tclObj.c
+ *
+ */ 
+    } else if ((lambdaPtr->typePtr == &tclCmdNameType)
+	    || (TCL_OK == (Tcl_ListObjGetElements(interp, lambdaPtr, &numElem, &elemPtr))
+		    && (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 = (Proc *) 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);
+    if (result != TCL_OK) {
+	return result;
+    }
+    if (nsPtr == (Tcl_Namespace *) NULL) {
+	errPtr = Tcl_NewStringObj("cannot find namespace \"",-1);
+	Tcl_IncrRefCount(errPtr);
+	Tcl_AppendObjToObj(errPtr, nsObjPtr);
+	Tcl_AppendToObj(errPtr, "\"", -1);
+	Tcl_SetObjResult(interp, errPtr);
+	Tcl_DecrRefCount(errPtr);
+	return TCL_ERROR;
+    }
+
+    /*
+      cmd = *((Command *) Tcl_GetCommandFromObj(interp, objv[0]));
+    */
+    cmd.nsPtr = (Namespace *) nsPtr;
+
+    return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2);
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4