Improve error code generation from some of the tailcall-related bits of TEBC.

1 files changed, 42 insertions, 21 deletions

diff --git a/tests/tailcall.test b/tests/tailcall.test
index ff9b97c..b8a3210 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: tailcall.test,v 1.11 2009/12/05 22:05:30 msofer Exp $
+# RCS: @(#) $Id: tailcall.test,v 1.12 2010/01/22 10:22:51 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -45,6 +45,10 @@ if {[testConstraint testnrelevels]} {
     namespace import testnre::*
 }
 
+proc errorcode options {
+    dict get [dict merge {-errorcode NONE} $options] -errorcode
+}
+
 test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup {
     proc a i {
 	#
@@ -541,25 +545,17 @@ test tailcall-12.2 {[Bug 2649975]} -setup {
 1: exiting from foo's alpha
 }
 
-test tailcall-12.3a {[Bug 2695587]} -setup {
-    proc a {} {
-	list [catch [list tailcall foo] msg] $msg
-    }
-} -body {
-    a
-} -cleanup {
-    rename a {}
-} -result {1 {Tailcall called from within a catch environment}}
+test tailcall-12.3a {[Bug 2695587]} {
+    apply {{} {
+	list [catch [list tailcall foo] msg opt] $msg [errorcode $opt]
+    }}
+} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
 
-test tailcall-12.3b {[Bug 2695587]} -setup {
-    proc a {} {
-	list [catch {tailcall foo} msg] $msg
-    }
-} -body {
-    a
-} -cleanup {
-    rename a {}
-} -result {1 {Tailcall called from within a catch environment}}
+test tailcall-12.3b {[Bug 2695587]} {
+    apply {{} {
+	list [catch {tailcall foo} msg opt] $msg [errorcode $opt]
+    }}
+} {1 {tailcall called from within a catch environment} {TCL TAILCALL ILLEGAL}}
 
 test tailcall-13.1 {tailcall and coroutine} -setup {
     set lambda {i {
@@ -576,9 +572,30 @@ test tailcall-13.1 {tailcall and coroutine} -setup {
 } -cleanup {
     unset lambda 
 } -result {0 0 0 0 0 0}
- 
-
 
+test tailcall-14.1 {directly tailcalling the tailcall command is an error} {
+    list [catch {
+	apply {{} {
+	    apply {{} {
+		tailcall tailcall subst a
+		subst b
+	    }}
+	    subst c
+	}}
+    } msg opt] $msg [errorcode $opt]
+} {1 {tailcall cannot be invoked recursively} {TCL TAILCALL REENTRY}}
+test tailcall-14.2 {indirectly tailcalling the tailcall command is ok} {
+    list [catch {
+	apply {{} {
+	    apply {{} {
+		tailcall eval tailcall subst ok
+		subst b
+	    }}
+	    subst c
+	}}
+    } msg opt] $msg [errorcode $opt]
+} {0 ok NONE}
+
 if {[testConstraint testnrelevels]} {
     namespace forget testnre::*
     namespace delete testnre
@@ -586,3 +603,7 @@ if {[testConstraint testnrelevels]} {
 
 # cleanup
 ::tcltest::cleanupTests
+
+# Local Variables:
+# mode: tcl
+# End: