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:

3 files changed, 224 insertions, 6 deletions

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_*]}