* generic/tclProc.c: minor improvements to [apply]

	* tests/apply.test: new tests; apply-5.1 currently fails to
	indicate missing work in error reporting

1 files changed, 74 insertions, 21 deletions

diff --git a/tests/apply.test b/tests/apply.test
index c000c6e..9218847 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -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: apply.test,v 1.1 2006/02/01 19:26:02 dgp Exp $
+# RCS: @(#) $Id: apply.test,v 1.2 2006/02/01 20:17:28 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -87,7 +87,7 @@ 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"}}
+} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}}
 
 test apply-3.2 {non-existing namespace} {
     namespace eval ::NONEXIST::FOR::SURE {}
@@ -96,7 +96,22 @@ test apply-3.2 {non-existing namespace} {
     namespace delete ::NONEXIST
     set res [catch {apply $lambda x} msg]
     list $res $msg
-} {1 {cannot find namespace "::::NONEXIST::FOR::SURE"}}
+} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}}
+
+test apply-3.3 {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}]
@@ -110,21 +125,32 @@ test apply-4.2 {error in arguments to lambda expression} {
     list $res $msg
 } {1 {wrong # args: should be "apply {x {set x 1}} x"}}
 
+test apply-5.1 {runtime error in lambda expression} {
+    set lambda [list {} {error foo}]
+    set res [catch {apply $lambda}]
+    list $res $errorInfo
+} {1 {foo
+    while executing
+"error foo"
+    (procedure "apply" line 1) CHECK & MODIFY
+    invoked from within
+"apply $lambda"}}
+
 # 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} {
+test apply-6.1 {info level} {
     set lev [info level]
     set lambda [list {} {info level}]
     expr {[apply $lambda] - $lev}
 } 1
 
-test apply-5.2 {info level} {
+test apply-6.2 {info level} {
     set lambda [list {} {info level 0}]
     apply $lambda
 } {apply {{} {info level 0}}}
 
-test apply-5.3 {info level} {
+test apply-6.3 {info level} {
     set lambda [list args {info level 0}]
     apply $lambda x y
 } {apply {args {info level 0}} x y}
@@ -132,30 +158,57 @@ test apply-5.3 {info level} {
 # Tests for correct namespace scope
 
 namespace eval ::testApply {
-    set x 0
     proc testApply args {return testApply}
 }
 
-test apply-6.1 {namespace access} {
+test apply-7.1 {namespace access} {
+    set ::testApply::x 0
     set body {set x 1; set x}
     list [apply [list args $body ::testApply]] $::testApply::x
 } {1 0}
 
-test apply-6.2 {namespace access} {
+test apply-7.2 {namespace access} {
+    set ::testApply::x 0
     set body {variable x; set x}
     list [apply [list args $body ::testApply]] $::testApply::x
 } {0 0}
 
-test apply-6.3 {namespace access} {
+test apply-7.3 {namespace access} {
+    set ::testApply::x 0
     set body {variable x; set x 1}
     list [apply [list args $body ::testApply]] $::testApply::x
 } {1 1}
 
-test apply-6.3 {namespace access} {
+test apply-7.4 {namespace access} {
+    set ::testApply::x 0
     set body {testApply}
     apply [list args $body ::testApply]
 } testApply
 
+test apply-7.5 {namespace access} {
+    set ::testApply::x 0
+    set body {set x 1; set x}
+    list [apply [list args $body testApply]] $::testApply::x
+} {1 0}
+
+test apply-7.6 {namespace access} {
+    set ::testApply::x 0
+    set body {variable x; set x}
+    list [apply [list args $body testApply]] $::testApply::x
+} {0 0}
+
+test apply-7.7 {namespace access} {
+    set ::testApply::x 0
+    set body {variable x; set x 1}
+    list [apply [list args $body testApply]] $::testApply::x
+} {1 1}
+
+test apply-7.8 {namespace access} {
+    set ::testApply::x 0
+    set body {testApply}
+    apply [list args $body testApply]
+} testApply
+
 
 # Tests for correct argument treatment
 
@@ -168,43 +221,43 @@ set applyBody {
     set res
 }
 
-test apply-7.1 {args treatment} {
+test apply-8.1 {args treatment} {
     apply [list args $applyBody] 1 2 3
 } {{args {1 2 3}}}
 
-test apply-7.2 {args treatment} {
+test apply-8.2 {args treatment} {
     apply [list {x args} $applyBody] 1 2
 } {{x 1} {args 2}}
 
-test apply-7.3 {args treatment} {
+test apply-8.3 {args treatment} {
     apply [list {x args} $applyBody] 1 2 3
 } {{x 1} {args {2 3}}}
 
-test apply-7.4 {default values} {
+test apply-8.4 {default values} {
     apply [list {{x 1} {y 2}} $applyBody] 
 } {{x 1} {y 2}}
 
-test apply-7.5 {default values} {
+test apply-8.5 {default values} {
     apply [list {{x 1} {y 2}} $applyBody] 3 4
 } {{x 3} {y 4}}
 
-test apply-7.6 {default values} {
+test apply-8.6 {default values} {
     apply [list {{x 1} {y 2}} $applyBody] 3
 } {{x 3} {y 2}}
 
-test apply-7.7 {default values} {
+test apply-8.7 {default values} {
     apply [list {x {y 2}} $applyBody] 1
 } {{x 1} {y 2}}
 
-test apply-7.8 {default values} {
+test apply-8.8 {default values} {
     apply [list {x {y 2}} $applyBody] 1 3
 } {{x 1} {y 3}}
 
-test apply-7.9 {default values} {
+test apply-8.9 {default values} {
     apply [list {x {y 2} args} $applyBody] 1
 } {{x 1} {y 2} {args {}}}
 
-test apply-7.10 {default values} {
+test apply-8.10 {default values} {
     apply [list {x {y 2} args} $applyBody] 1 3
 } {{x 1} {y 3} {args {}}}