summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2006-02-01 19:26:00 (GMT)
committerdgp <dgp@users.sourceforge.net>2006-02-01 19:26:00 (GMT)
commitfe312f9881e59765486f5f1d6314a5f1e0050875 (patch)
treecc5102e7480d80257995c473101cfae3119a3f13 /generic
parentbf2e20ec8703a3c6e725e464bb4e7fca8af0834c (diff)
downloadtcl-fe312f9881e59765486f5f1d6314a5f1e0050875.zip
tcl-fe312f9881e59765486f5f1d6314a5f1e0050875.tar.gz
tcl-fe312f9881e59765486f5f1d6314a5f1e0050875.tar.bz2
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:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c3
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclProc.c273
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