* generic/tclBasic.c: Implementation of TIP 90, which

        * generic/tclCmdAH.c:           extends the [catch] and [return]
        * generic/tclCompCmds.c:        commands to enable creation of a
        * generic/tclExecute.c:         proc that is a replacement for
        * generic/tclInt.h:             [return]. [Patch 531640]
        * generic/tclProc.c:
        * generic/tclResult.c:
        * tests/cmdAH.test:
        * tests/cmdMZ.test:
        * tests/error.test:
        * tests/proc-old.test:

        * library/tcltest/tcltest.tcl: The -returnCodes option to [test]
        failed to recognize the symbolic name "ok" for return code 0.

4 files changed, 137 insertions, 19 deletions

diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 0a0228b..e4fc0ce 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: cmdAH.test,v 1.31 2003/04/11 15:59:59 vincentdarley Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.32 2003/05/05 20:54:44 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -34,10 +34,13 @@ test cmdAH-0.2 {Tcl_BreakObjCmd, success} {
 
 test cmdAH-1.1 {Tcl_CatchObjCmd, errors} {
     list [catch {catch} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
 test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
     list [catch {catch foo bar baz} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {0 1}
+test cmdAH-1.3 {Tcl_CatchObjCmd, errors} {
+    list [catch {catch foo bar baz spaz} msg] $msg
+} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
 
 test cmdAH-2.1 {Tcl_CdObjCmd} {
     list [catch {cd foo bar} msg] $msg
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 0e65229..c6416df 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -11,13 +11,20 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: cmdMZ.test,v 1.13 2002/07/19 08:52:27 dkf Exp $
+# RCS: @(#) $Id: cmdMZ.test,v 1.14 2003/05/05 20:54:50 dgp Exp $
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
-    namespace import -force ::tcltest::*
+if {[catch {package require tcltest 2.0.2}]} {
+    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
+    return
 }
-set tcltest::testConstraints(nonLinuxOnly) \
+
+namespace eval ::tcl::test::cmdMZ {
+    namespace import ::tcltest::cleanupTests
+    namespace import ::tcltest::makeFile
+    namespace import ::tcltest::removeFile
+    namespace import ::tcltest::test
+
+set ::tcltest::testConstraints(nonLinuxOnly) \
 	[expr {![string equal Linux $tcl_platform(os)]}]
 
 # Tcl_PwdObjCmd
@@ -69,7 +76,113 @@ test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
     list [catch {r1} msg] $msg
 } {1 {invalid command name "r1"}}
 
-# The tests for Tcl_ReturnObjCmd are in proc-old.test
+# Some tests for Tcl_ReturnObjCmd are in proc-old.test
+
+test cmdMZ-return-1.0 {return checks for bad option values} -body {
+    return -options foo
+} -returnCodes error -match glob -result {bad -options value:*}
+test cmdMZ-return-1.1 {return checks for bad option values} -body {
+    return -code foo
+} -returnCodes error -match glob -result {bad completion code*}
+test cmdMZ-return-1.2 {return checks for bad option values} -body {
+    return -code 0x100000000
+} -returnCodes error -match glob -result {bad completion code*}
+test cmdMZ-return-1.3 {return checks for bad option values} -body {
+    return -level foo
+} -returnCodes error -match glob -result {bad -level value:*}
+test cmdMZ-return-1.4 {return checks for bad option values} -body {
+    return -level -1
+} -returnCodes error -match glob -result {bad -level value:*}
+test cmdMZ-return-1.5 {return checks for bad option values} -body {
+    return -level 3.1415926
+} -returnCodes error -match glob -result {bad -level value:*}
+
+proc dictSort {d} {
+    foreach k [lsort [dict keys $d]] {
+	lappend result $k [dict get $d $k]
+    }
+    return $result
+}
+
+test cmdMZ-return-2.0 {return option handling} {
+    list [catch return -> foo] [dictSort $foo]
+} {2 {-code 0 -level 1}}
+test cmdMZ-return-2.1 {return option handling} {
+    list [catch {return -bar soom} -> foo] [dictSort $foo]
+} {2 {-bar soom -code 0 -level 1}}
+test cmdMZ-return-2.2 {return option handling} {
+    list [catch {return -code return} -> foo] [dictSort $foo]
+} {2 {-code 0 -level 2}}
+test cmdMZ-return-2.3 {return option handling} {
+    list [catch {return -code return -level 10} -> foo] [dictSort $foo]
+} {2 {-code 0 -level 11}}
+test cmdMZ-return-2.4 {return option handling} -body {
+    return -level 0 -code error
+} -returnCodes error -result {}
+test cmdMZ-return-2.5 {return option handling} -body {
+    return -level 0 -code return
+} -returnCodes return -result {}
+test cmdMZ-return-2.6 {return option handling} -body {
+    return -level 0 -code break
+} -returnCodes break -result {}
+test cmdMZ-return-2.7 {return option handling} -body {
+    return -level 0 -code continue
+} -returnCodes continue -result {}
+test cmdMZ-return-2.8 {return option handling} -body {
+    return -level 0 -code -1
+} -returnCodes -1 -result {}
+test cmdMZ-return-2.9 {return option handling} -body {
+    return -level 0 -code 10
+} -returnCodes 10 -result {}
+test cmdMZ-return-2.10 {return option handling} {
+    list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
+} {1 {-code 1 -errorinfo {
+    while executing
+"return -level 0 -code error"} -errorline 1 -level 0}}
+test cmdMZ-return-2.11 {return option handling} {
+    list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
+} {3 {-code 3 -level 0}}
+test cmdMZ-return-2.12 {return option handling} -body {
+    return -level 0 -code error -options {-code ok}
+} -returnCodes ok -result {}
+test cmdMZ-return-2.13 {return option handling} -body {
+    return -level 0 -code error -options {-code foo}
+} -returnCodes error -match glob -result {bad completion code*}
+test cmdMZ-return-2.14 {return option handling} -body {
+    return -level 0 -code error -options {-code foo -options {-code break}}
+} -returnCodes break -result {}
+
+# Check that the result of a [return -options $opts $result] is
+# indistinguishable from that of the originally caught script, no
+# matter what the script is/does.  (TIP 90)
+set i 0
+foreach script {
+	{}
+	{format x}
+	{set}
+	{set a 1}
+	{error}
+	{error foo}
+	{error foo bar}
+	{error foo bar baz}
+	{return -level 0}
+	{return -code error}
+	{return -code error -errorinfo foo}
+	{return -code error -errorinfo foo -errorcode bar}
+	{return -code error -errorinfo foo -errorcode bar -errorline 10}
+	{return -options {x y z 2}}
+	{return -level 3 -code break sdf}
+} {
+    test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" {
+	set one [list [catch $script foo bar] $foo [dictSort $bar] \
+		$::errorCode $::errorInfo]
+	set two [list [catch {return -options $bar $foo} foo2 bar2] \
+		$foo2 [dictSort $bar2] $::errorCode $::errorInfo]
+	string equal $one $two
+    } 1
+    incr i
+}
+
 # The tests for Tcl_ScanObjCmd are in scan.test
 
 # Tcl_SourceObjCmd
@@ -127,7 +240,7 @@ test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} {
 } {1 2 3 4 5}
 test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} {
     split "a\}b\[c\{\]\$"
-} "a\\}b\\\[c\\{\\\]\\\$"
+} "a\\\}b\\\[c\\\{\\\]\\\$"
 test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} {
     split {} {}
 } {}
@@ -197,5 +310,7 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
 # The tests for Tcl_WhileObjCmd are in while.test
 
 # cleanup
-::tcltest::cleanupTests
+cleanupTests
+}
+namespace delete ::tcl::test::cmdMZ
 return
diff --git a/tests/error.test b/tests/error.test
index 1d5f9a0..1581f4c 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: error.test,v 1.9 2002/01/29 03:03:02 hobbs Exp $
+# RCS: @(#) $Id: error.test,v 1.10 2003/05/05 20:54:52 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -60,13 +60,13 @@ test error-1.5 {simple errors from commands} {
 } glorp
 
 test error-1.6 {simple errors from commands} {
-    catch {catch a b c} b
+    catch {catch a b c d} b
 } 1
 
 test error-1.7 {simple errors from commands} {
-    catch {catch a b c} b
+    catch {catch a b c d} b
     set b
-} {wrong # args: should be "catch command ?varName?"}
+} {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
 
 test error-1.8 {simple errors from commands} {nonPortable} {
     # This test is non-portable: it generates a memory fault on
@@ -124,10 +124,10 @@ test error-2.6 {errors in nested procedures} {
 
 test error-3.1 {errors in catch command} {
     list [catch {catch} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
 test error-3.2 {errors in catch command} {
     list [catch {catch a b c} msg] $msg
-} {1 {wrong # args: should be "catch command ?varName?"}}
+} {0 1}
 test error-3.3 {errors in catch command} {
     catch {unset a}
     set a(0) 22
diff --git a/tests/proc-old.test b/tests/proc-old.test
index 0292103..81d20b6 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.10 2003/03/27 21:44:05 msofer Exp $
+# RCS: @(#) $Id: proc-old.test,v 1.11 2003/05/05 20:54:52 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -483,7 +483,7 @@ test proc-old-7.14 {return with special completion code} {
 "tproc2"} none}
 test proc-old-7.15 {return with special completion code} {
     list [catch {return -badOption foo message} msg] $msg
-} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}
+} {2 message}
 
 test proc-old-8.1 {unset and undefined local arrays} {
     proc t1 {} {