Attachment "944803.patch" to
ticket [944803ffff]
added by
dgp
2006-02-02 02:12:11.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.2942
diff -u -u -r1.2942 ChangeLog
--- ChangeLog 1 Feb 2006 18:27:42 -0000 1.2942
+++ ChangeLog 1 Feb 2006 19:06:58 -0000
@@ -1,5 +1,16 @@
2006-02-01 Don Porter <[email protected]>
+ 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
Index: doc/apply.n
===================================================================
RCS file: doc/apply.n
diff -N doc/apply.n
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ doc/apply.n 1 Feb 2006 19:06:58 -0000
@@ -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
Index: doc/uplevel.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/uplevel.n,v
retrieving revision 1.5
diff -u -u -r1.5 uplevel.n
--- doc/uplevel.n 27 Oct 2004 14:43:54 -0000 1.5
+++ doc/uplevel.n 1 Feb 2006 19:06:58 -0000
@@ -62,9 +62,9 @@
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 @@
.CE
.SH "SEE ALSO"
-namespace(n), upvar(n)
+apply(n), namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variables
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.188
diff -u -u -r1.188 tclBasic.c
--- generic/tclBasic.c 1 Feb 2006 18:27:43 -0000 1.188
+++ generic/tclBasic.c 1 Feb 2006 19:06:59 -0000
@@ -105,6 +105,7 @@
*/
{"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},
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.266
diff -u -u -r1.266 tclInt.h
--- generic/tclInt.h 1 Feb 2006 18:27:46 -0000 1.266
+++ generic/tclInt.h 1 Feb 2006 19:06:59 -0000
@@ -2246,6 +2246,9 @@
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[]);
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.84
diff -u -u -r1.84 tclProc.c
--- generic/tclProc.c 23 Jan 2006 11:01:59 -0000 1.84
+++ generic/tclProc.c 1 Feb 2006 19:07:00 -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-2006 Miguel Sofer
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -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 @@
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 @@
}
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 @@
} 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 @@
* 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 @@
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 @@
*/
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 @@
}
}
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 @@
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 @@
*/
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 @@
#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 @@
}
/*
+ * 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
Index: tests/apply.test
===================================================================
RCS file: tests/apply.test
diff -N tests/apply.test
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/apply.test 1 Feb 2006 19:07:01 -0000
@@ -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.7 2001/07/03 23:39:24 hobbs 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
Index: tests/proc-old.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/proc-old.test,v
retrieving revision 1.13
diff -u -u -r1.13 proc-old.test
--- tests/proc-old.test 29 Oct 2004 15:39:10 -0000 1.13
+++ tests/proc-old.test 1 Feb 2006 19:07:01 -0000
@@ -274,10 +274,10 @@
} {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"}}
Index: tests/proc.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/proc.test,v
retrieving revision 1.17
diff -u -u -r1.17 proc.test
--- tests/proc.test 22 Sep 2004 15:48:23 -0000 1.17
+++ tests/proc.test 1 Feb 2006 19:07:01 -0000
@@ -101,12 +101,12 @@
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_*]}
