? generic/tclObj.c.ORIG
? unix/.log
? unix/.ofl
? unix/ERR
? unix/dltest.marker
? unix/tclsh-head
? unix/tclsh-noAsync
? unix/tclsh-noStart
? unix/x.log
? unix/x.ofl
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.99
diff -u -r1.99 tclBasic.c
--- generic/tclBasic.c	6 Apr 2004 22:25:48 -0000	1.99
+++ generic/tclBasic.c	29 Apr 2004 18:14:07 -0000
@@ -61,6 +61,8 @@
 
     {"append",		(Tcl_CmdProc *) NULL,	Tcl_AppendObjCmd,
 	TclCompileAppendCmd,		1},
+    {"apply",		(Tcl_CmdProc *) NULL,	Tcl_ApplyObjCmd,
+        (CompileProc *) NULL,		1},
     {"array",		(Tcl_CmdProc *) NULL,	Tcl_ArrayObjCmd,
         (CompileProc *) NULL,		1},
     {"binary",		(Tcl_CmdProc *) NULL,	Tcl_BinaryObjCmd,
@@ -433,7 +435,7 @@
 	        && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
 	    Tcl_Panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
 	}
-	
+
 	hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
 	        cmdInfoPtr->name, &new);
 	if (new) {
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.154
diff -u -r1.154 tclInt.h
--- generic/tclInt.h	25 Apr 2004 20:16:31 -0000	1.154
+++ generic/tclInt.h	29 Apr 2004 18:14:08 -0000
@@ -1843,6 +1843,8 @@
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int	Tcl_ApplyObjCmd _ANSI_ARGS_((ClientData clientData,
+		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData,
 		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
 EXTERN int	Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData,
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.50
diff -u -r1.50 tclProc.c
--- generic/tclProc.c	9 Mar 2004 12:59:05 -0000	1.50
+++ generic/tclProc.c	29 Apr 2004 18:14:08 -0000
@@ -6,6 +6,7 @@
  *
  * Copyright (c) 1987-1993 The Regents of the University of California.
  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2004      Miguel Sofer
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -1721,4 +1722,174 @@
 }
 
 
+
+/*
+ * 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 tclLambdaType = {
+    "lambda",				/* name */
+    FreeLambdaInternalRep,	        /* freeIntRepProc */
+    DupLambdaInternalRep,	        /* dupIntRepProc */
+    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
+    SetLambdaFromAny			/* setFromAnyProc */
+};
+
+/*
+ * a Lambda Tcl_Obj has the form
+ *
+ *  ptr1 is a procPtr: pointer to a proc structure
+ *
+ */
+
+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;
+
+    copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+
+    procPtr->refCount++;
+    copyPtr->typePtr = &tclLambdaType;
+}
+
+static void
+FreeLambdaInternalRep(objPtr)
+    register Tcl_Obj *objPtr;	/* CmdName object with internal
+				 * representation to free. */
+{
+    Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
+
+    procPtr->refCount--;
+    if (procPtr->refCount == 0) {
+	TclProcCleanupProc(procPtr);
+    }
+}
+
+
+static int
+SetLambdaFromAny(interp, objPtr)
+    Tcl_Interp *interp;		/* Used for error reporting if not NULL. */
+    register Tcl_Obj *objPtr;	/* The object to convert. */
+{
+    Interp *iPtr = (Interp *) interp;
+    char *name;
+    Namespace *nsPtr = iPtr->globalNsPtr;
+    Tcl_Obj *argsPtr, *bodyPtr, **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 tclLambdaType.
+     */
+
+    result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
+    if ((result != TCL_OK) || (objc != 2)) {
+	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];
+    name = TclGetString(objPtr);
+    
+    if (TclCreateProc(interp, nsPtr, name, argsPtr, bodyPtr,
+        &procPtr) != TCL_OK) {
+        return TCL_ERROR;
+    }
+    procPtr->refCount++;
+    
+    /*
+     * Now initialize the new procedure's cmdPtr field. This is used at
+     * run time to determine what namespace the procedure will run in;
+     * there is no other use of the cmd field of the proc structure.
+     * We set it to NULL; it will be set before running by the executor
+     * command [lambda].
+     */
+
+    procPtr->cmdPtr = (Command *) NULL;
+
+    /*
+     * 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.
+     */
+
+    objPtr->typePtr->freeIntRepProc(objPtr);
+
+    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+    objPtr->typePtr = &tclLambdaType;
+    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;
+    Tcl_Obj *lambdaPtr;
+    int result;
+    Command *lambdaCmdPtr;
+    
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Set lambdaPtr, convert it to tclLambdaType in the current
+     * interp if necessary.
+     */
+
+    lambdaPtr = objv[1];
+    if (lambdaPtr->typePtr == &tclLambdaType) {
+	procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
+    } else {
+	procPtr = (Proc *) NULL;
+    }
 
+    if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
+	result = SetLambdaFromAny(interp, lambdaPtr);
+	if (result != TCL_OK) {
+	    return result;
+	}
+	procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
+    }
+
+    /*
+     * Set the cmd field of the proc structure to point to the
+     * apply command; this field is only used to determine the
+     * namespace in which the proc will run.
+     */
+
+    lambdaCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+    if (lambdaCmdPtr == NULL) {
+	/* FIXME: error message */
+	return TCL_ERROR;
+    }
+    procPtr->cmdPtr = lambdaCmdPtr;
+
+    return TclObjInterpProc( (ClientData) procPtr, interp, objc-1, objv+1);
+}
