summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog11
-rw-r--r--doc/apply.n67
-rw-r--r--doc/uplevel.n10
-rw-r--r--generic/tclBasic.c3
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclProc.c273
-rw-r--r--tests/apply.test218
-rw-r--r--tests/proc-old.test6
-rw-r--r--tests/proc.test6
9 files changed, 570 insertions, 29 deletions
diff --git a/ChangeLog b/ChangeLog
index b4c1000..2c0b210 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,16 @@
2006-02-01 Don Porter <dgp@users.sourceforge.net>
+ 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:
+
TIP#181 IMPLEMENTATION
* doc/Namespace.3: New command [namespace unknown]. New public
diff --git a/doc/apply.n b/doc/apply.n
new file mode 100644
index 0000000..31099ce
--- /dev/null
+++ b/doc/apply.n
@@ -0,0 +1,67 @@
+'\"
+.so man.macros
+.TH apply n "" Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+apply \- Apply an anonymous function
+.SH SYNOPSIS
+\fBapply \fIfunc\fR ?\fIarg1 arg2 ...\fR?
+.BE
+
+.SH DESCRIPTION
+.PP
+The command \fBapply\fR applies the function \fIfunc\fR to the arguments
+\fIarg1 arg2 ...\fR and returns the result.
+.PP
+The function \fIfunc\fR is a two element list \fI{args body}\fR or a three
+element list \fI{args body namespace}\fR (as if the
+\fBlist\fR command had been used).
+The first element \fIargs\fR specifies the formal arguments to
+\fIfunc\fR. The specification of the formal arguments \fIargs\fR
+is shared with the \fBproc\fR command, and is described in detail in the
+corresponding manual page.
+.PP
+The contents of \fIbody\fR are executed by the Tcl interpreter
+after the local variables corresponding to the formal arguments are given
+the values of the actual parameters \fIarg1 arg2 ...\fR.
+When \fIbody\fR is being executed, variable names normally refer to
+local variables, which are created automatically when referenced and
+deleted when \fBapply\fR returns. One local variable is automatically
+created for each of the function's arguments.
+Global variables can only be accessed by invoking
+the \fBglobal\fR command or the \fBupvar\fR command.
+Namespace variables can only be accessed by invoking
+the \fBvariable\fR command or the \fBupvar\fR command.
+.PP
+The invocation of \fBapply\fR adds a call frame to Tcl's evaluation stack
+(the stack of frames accessed via \fBuplevel\fR). The execution of \fIbody\fR
+proceeds in this call frame, in the namespace given by \fInamespace\fR or
+in the global namespace if none was specified. If given, \fInamespace\fR is
+interpreted relative to the global namespace even if its name does not start
+with '::'.
+.PP
+The semantics of \fBapply\fR can also be described by:
+.PP
+.CS
+ proc apply {fun args} {
+ set len [llength $fun]
+ if {($len < 2) || ($len > 3)} {
+ error "can't interpret \\"$fun\\" as anonymous function"
+ }
+ lassign $fun argList body ns
+ set name ::$ns::[getGloballyUniqueName]
+ set body0 {
+ rename [lindex [info level 0] 0] {}
+ }
+ proc $name $argList ${body0}$body
+ set code [catch {uplevel 1 $name $args} res opt]
+ return -options $opt $res
+ }
+.CE
+
+.SH "SEE ALSO"
+proc(n), uplevel(n)
+
+.SH KEYWORDS
+argument, procedure, anonymous function
diff --git a/doc/uplevel.n b/doc/uplevel.n
index ee4f6c7..506b713 100644
--- a/doc/uplevel.n
+++ b/doc/uplevel.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: uplevel.n,v 1.5 2004/10/27 14:43:54 dkf Exp $
+'\" RCS: @(#) $Id: uplevel.n,v 1.6 2006/02/01 19:26:01 dgp Exp $
'\"
.so man.macros
.TH uplevel n "" Tcl "Tcl Built-In Commands"
@@ -62,9 +62,9 @@ be used to obtain the level of the current procedure.
constructs as Tcl procedures (for example, \fBuplevel\fR could
be used to implement the \fBwhile\fR construct as a Tcl procedure).
.PP
-\fBnamespace eval\fR is another way (besides procedure calls)
-that the Tcl naming context can change.
-It adds a call frame to the stack to represent the namespace context.
+The \fBnamespace eval\fR and \fBapply\fR commands offer other ways
+(besides procedure calls) that the Tcl naming context can change.
+They add a call frame to the stack to represent the namespace context.
This means each \fBnamespace eval\fR command
counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
For example, \fBinfo level 1\fR will return a list
@@ -94,7 +94,7 @@ proc do {body while condition} {
.CE
.SH "SEE ALSO"
-namespace(n), upvar(n)
+apply(n), namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variables
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
diff --git a/tests/apply.test b/tests/apply.test
new file mode 100644
index 0000000..c000c6e
--- /dev/null
+++ b/tests/apply.test
@@ -0,0 +1,218 @@
+# Commands covered: apply
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2005-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: apply.test,v 1.1 2006/02/01 19:26:02 dgp Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+if {[info commands ::apply] eq {}} {
+ return
+}
+
+# Tests for wrong number of arguments
+
+test apply-1.1 {too few arguments} {
+ set res [catch apply msg]
+ list $res $msg
+} {1 {wrong # args: should be "apply lambdaExpr ?arg1 arg2 ...?"}}
+
+# Tests for malformed lambda
+
+test apply-2.0 {malformed lambda} {
+ set lambda a
+ set res [catch {apply $lambda} msg]
+ list $res $msg
+} {1 {can't interpret "a" as a lambda expression}}
+
+test apply-2.1 {malformed lambda} {
+ set lambda [list a b c d]
+ set res [catch {apply $lambda} msg]
+ list $res $msg
+} {1 {can't interpret "a b c d" as a lambda expression}}
+
+test apply-2.2 {malformed lambda} {
+ set lambda [list {{}} boo]
+ set res [catch {apply $lambda} msg]
+ list $res $msg $::errorInfo
+} {1 {argument with no name} {argument with no name
+ (parsing lambda expression "{{}} boo")
+ invoked from within
+"apply $lambda"}}
+
+test apply-2.3 {malformed lambda} {
+ set lambda [list {{a b c}} boo]
+ set res [catch {apply $lambda} msg]
+ list $res $msg $::errorInfo
+} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c"
+ (parsing lambda expression "{{a b c}} boo")
+ invoked from within
+"apply $lambda"}}
+
+test apply-2.4 {malformed lambda} {
+ set lambda [list a(1) boo]
+ set res [catch {apply $lambda} msg]
+ list $res $msg $::errorInfo
+} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element
+ (parsing lambda expression "a(1) boo")
+ invoked from within
+"apply $lambda"}}
+
+test apply-2.5 {malformed lambda} {
+ set lambda [list a::b boo]
+ set res [catch {apply $lambda} msg]
+ list $res $msg $::errorInfo
+} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name
+ (parsing lambda expression "a::b boo")
+ invoked from within
+"apply $lambda"}}
+
+
+# Tests for runtime errors in the lambda expression
+
+test apply-3.1 {non-existing namespace} {
+ set lambda [list x {set x 1} ::NONEXIST::FOR::SURE]
+ set res [catch {apply $lambda x} msg]
+ list $res $msg
+} {1 {cannot find namespace "::::NONEXIST::FOR::SURE"}}
+
+test apply-3.2 {non-existing namespace} {
+ namespace eval ::NONEXIST::FOR::SURE {}
+ set lambda [list x {set x 1} ::NONEXIST::FOR::SURE]
+ apply $lambda x
+ namespace delete ::NONEXIST
+ set res [catch {apply $lambda x} msg]
+ list $res $msg
+} {1 {cannot find namespace "::::NONEXIST::FOR::SURE"}}
+
+test apply-4.1 {error in arguments to lambda expression} {
+ set lambda [list x {set x 1}]
+ set res [catch {apply $lambda} msg]
+ list $res $msg
+} {1 {wrong # args: should be "apply {x {set x 1}} x"}}
+
+test apply-4.2 {error in arguments to lambda expression} {
+ set lambda [list x {set x 1}]
+ set res [catch {apply $lambda x y} msg]
+ list $res $msg
+} {1 {wrong # args: should be "apply {x {set x 1}} x"}}
+
+# Tests for correct execution; as the implementation is the same as that for
+# procs, the general functionality is mostly tested elsewhere
+
+test apply-5.1 {info level} {
+ set lev [info level]
+ set lambda [list {} {info level}]
+ expr {[apply $lambda] - $lev}
+} 1
+
+test apply-5.2 {info level} {
+ set lambda [list {} {info level 0}]
+ apply $lambda
+} {apply {{} {info level 0}}}
+
+test apply-5.3 {info level} {
+ set lambda [list args {info level 0}]
+ apply $lambda x y
+} {apply {args {info level 0}} x y}
+
+# Tests for correct namespace scope
+
+namespace eval ::testApply {
+ set x 0
+ proc testApply args {return testApply}
+}
+
+test apply-6.1 {namespace access} {
+ set body {set x 1; set x}
+ list [apply [list args $body ::testApply]] $::testApply::x
+} {1 0}
+
+test apply-6.2 {namespace access} {
+ set body {variable x; set x}
+ list [apply [list args $body ::testApply]] $::testApply::x
+} {0 0}
+
+test apply-6.3 {namespace access} {
+ set body {variable x; set x 1}
+ list [apply [list args $body ::testApply]] $::testApply::x
+} {1 1}
+
+test apply-6.3 {namespace access} {
+ set body {testApply}
+ apply [list args $body ::testApply]
+} testApply
+
+
+# Tests for correct argument treatment
+
+set applyBody {
+ set res {}
+ foreach v [info locals] {
+ if {$v eq "res"} continue
+ lappend res [list $v [set $v]]
+ }
+ set res
+}
+
+test apply-7.1 {args treatment} {
+ apply [list args $applyBody] 1 2 3
+} {{args {1 2 3}}}
+
+test apply-7.2 {args treatment} {
+ apply [list {x args} $applyBody] 1 2
+} {{x 1} {args 2}}
+
+test apply-7.3 {args treatment} {
+ apply [list {x args} $applyBody] 1 2 3
+} {{x 1} {args {2 3}}}
+
+test apply-7.4 {default values} {
+ apply [list {{x 1} {y 2}} $applyBody]
+} {{x 1} {y 2}}
+
+test apply-7.5 {default values} {
+ apply [list {{x 1} {y 2}} $applyBody] 3 4
+} {{x 3} {y 4}}
+
+test apply-7.6 {default values} {
+ apply [list {{x 1} {y 2}} $applyBody] 3
+} {{x 3} {y 2}}
+
+test apply-7.7 {default values} {
+ apply [list {x {y 2}} $applyBody] 1
+} {{x 1} {y 2}}
+
+test apply-7.8 {default values} {
+ apply [list {x {y 2}} $applyBody] 1 3
+} {{x 1} {y 3}}
+
+test apply-7.9 {default values} {
+ apply [list {x {y 2} args} $applyBody] 1
+} {{x 1} {y 2} {args {}}}
+
+test apply-7.10 {default values} {
+ apply [list {x {y 2} args} $applyBody] 1 3
+} {{x 1} {y 3} {args {}}}
+
+# Tests for the avoidance of recompilation
+
+# cleanup
+
+namespace delete testApply
+
+::tcltest::cleanupTests
+return
diff --git a/tests/proc-old.test b/tests/proc-old.test
index 860279e..fe33ef4 100644
--- a/tests/proc-old.test
+++ b/tests/proc-old.test
@@ -14,7 +14,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: proc-old.test,v 1.13 2004/10/29 15:39:10 dkf Exp $
+# RCS: @(#) $Id: proc-old.test,v 1.14 2006/02/01 19:26:02 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -274,10 +274,10 @@ test proc-old-5.4 {error conditions} {
} {1 {unmatched open brace in list}}
test proc-old-5.5 {error conditions} {
list [catch {proc tproc {{} y} {return foo}} msg] $msg
-} {1 {procedure "tproc" has argument with no name}}
+} {1 {argument with no name}}
test proc-old-5.6 {error conditions} {
list [catch {proc tproc {{} y} {return foo}} msg] $msg
-} {1 {procedure "tproc" has argument with no name}}
+} {1 {argument with no name}}
test proc-old-5.7 {error conditions} {
list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
} {1 {too many fields in argument specifier "x 1 2"}}
diff --git a/tests/proc.test b/tests/proc.test
index bef0948..49f9a7b 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -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: proc.test,v 1.17 2004/09/22 15:48:23 msofer Exp $
+# RCS: @(#) $Id: proc.test,v 1.18 2006/02/01 19:26:02 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -101,12 +101,12 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e
set z [expr $a(1)+$a(2)]
puts "$z=z, $a(1)=$a(1)"
}} msg] $msg
-} {1 {procedure "p" has formal parameter "a(1)" that is an array element}}
+} {1 {formal parameter "a(1)" is an array element}}
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
catch {rename p ""}
list [catch {proc p {b:a b::a} {
}} msg] $msg
-} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}
+} {1 {formal parameter "b::a" is not a simple name}}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
catch {namespace delete {expand}[namespace children :: test_ns_*]}
generated by cgit v0.12 at 2024-11-10 07:05:06 (GMT)