Attachment "apply2.patch" to
ticket [944803ffff]
added by
msofer
2004-04-30 17:28:36.
? generic/tclObj.c.ORIG
? generic/tclProc.c.lambda
? unix/.log
? unix/.ofl
? unix/ERR
? unix/dltest.marker
? unix/nsPtr
? 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 30 Apr 2004 10:08:21 -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 30 Apr 2004 10:08:23 -0000
@@ -1659,6 +1659,9 @@
EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void));
EXTERN void TclFinalizeLock _ANSI_ARGS_((void));
EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void));
+EXTERN int TclGetNamespaceFromObj _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_Namespace **nsPtrPtr));
EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *pattern, Tcl_Obj *unquotedPrefix,
int globFlags, Tcl_GlobTypeData* types));
@@ -1843,6 +1846,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/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.37
diff -u -r1.37 tclNamesp.c
--- generic/tclNamesp.c 24 Mar 2004 21:54:32 -0000 1.37
+++ generic/tclNamesp.c 30 Apr 2004 10:08:26 -0000
@@ -180,9 +180,6 @@
static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
static void FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
-static int GetNamespaceFromObj _ANSI_ARGS_((
- Tcl_Interp *interp, Tcl_Obj *objPtr,
- Tcl_Namespace **nsPtrPtr));
static int InvokeImportedCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
@@ -2496,7 +2493,7 @@
/*
*----------------------------------------------------------------------
*
- * GetNamespaceFromObj --
+ * TclGetNamespaceFromObj --
*
* Gets the namespace specified by the name in a Tcl_Obj.
*
@@ -2518,8 +2515,8 @@
*----------------------------------------------------------------------
*/
-static int
-GetNamespaceFromObj(interp, objPtr, nsPtrPtr)
+int
+TclGetNamespaceFromObj(interp, objPtr, nsPtrPtr)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_Obj *objPtr; /* The object to be resolved as the name
* of a namespace. */
@@ -2772,7 +2769,7 @@
if (objc == 2) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else if ((objc == 3) || (objc == 4)) {
- if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+ if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
if (namespacePtr == NULL) {
@@ -3108,7 +3105,7 @@
* namespace object along the way.
*/
- result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
+ result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr);
if (result != TCL_OK) {
return result;
}
@@ -3213,7 +3210,7 @@
* Check whether the given namespace exists
*/
- if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+ if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
@@ -3520,7 +3517,7 @@
* Resolve the namespace reference.
*/
- result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
+ result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr);
if (result != TCL_OK) {
return result;
}
@@ -3685,7 +3682,7 @@
if (objc == 2) {
nsPtr = Tcl_GetCurrentNamespace(interp);
} else if (objc == 3) {
- result = GetNamespaceFromObj(interp, objv[2], &nsPtr);
+ result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr);
if (result != TCL_OK) {
return result;
}
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 30 Apr 2004 10:08:27 -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,203 @@
}
+
+/*
+ * 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 *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 = &tclLambdaType;
+}
+
+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 tclLambdaType.
+ */
+
+ 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) {
+ 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 tclLambdaType.
+ */
+
+ objPtr->typePtr->freeIntRepProc(objPtr);
+
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr;
+ 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, *nsObjPtr, *errPtr;
+ int result;
+ Command cmd;
+ Tcl_Namespace *nsPtr;
+
+ 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;
+ }
+ 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 TclObjInterpProc((ClientData) procPtr, interp, objc-1, objv+1);
+}
