Improvements to catch, return, signal, try

Improve the ability to rethrow errors
* Allow return to rethrow an error by accepting '-errorinfo stacktrace'
* Also, 'catch ... opts' now also stores opts(-errorinfo) on error
* Use these to provide better stack traces from 'case' and 'try'
* Implement 'return -level'
Make try/on/finally more Tcl 8.6 compatible
* With support for 'on' handlers and docs
Add support for catch options to try
* Otherwise it's hard to use try to catch signals
Improvements to signal handling
* catch -signal now sets a list of the handled signals as the result
* catch -signal won't execute the body at all if a handled signal is pending
* up to 64 (jim_wide) signals can now be handled
* if catch -signal is nested, the innermost catch will catch the error
* new 'signal catch' allows ignored/blocked signals to be examined and cleared.
* update docs on signal handling
exec should indicate which signal killed the child

Signed-off-by: Steve Bennett <steveb@workware.net.au>

5 files changed, 148 insertions, 60 deletions

diff --git a/tests/case.test b/tests/case.test
index a74f265..4a594ad 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -1,56 +1,12 @@
 source testing.tcl
 
-# Test that control structures can be implemented in a proc
-
-proc control {cond code} {
-	set iscond [uplevel 1 expr $cond]
-	#puts "$cond -> $iscond"
-	if {$iscond} {
-		set rc [catch [list uplevel 1 $code] error opts]
-		#puts "$code -> rc=$rc, error=$error, opts=$opts"
-		if {$rc == 2 && $opts(-code) != 0} {
-			set rc $opts(-code)
-		}
-		return -code $rc $error
-	}
-}
-
-test control-1.1 "False case" {
-	control 0 bogus
-} {}
-
-test control-1.2 "Simple case" {
-	control 1 {return result}
-} {result}
-
-test control-1.3 "Break from proc" {
-	set result {}
-	foreach i {1 2 3 4 5} {
-		control {$i == 4} {break}
-		lappend result $i
-	}
-	set result
-} {1 2 3}
-
-test control-1.4 "Return from proc" {
-	foreach i {1 2 3 4 5} {
-		control {$i == 3} {return $i}
-	}
-} {3}
-
-test control-1.5 "Continue from proc" {
-	set result {}
-	foreach i {1 2 3 4 5} {
-		control {$i == 2} {continue}
-		lappend result $i
-	}
-	set result
-} {1 3 4 5}
-
 # case is a proc, but it should be able
 # to cause a return in do_case
 proc do_case {var} {
 	case $var in {
+		0 {
+			return
+		}
 		1 {
 			return one
 		}
@@ -61,23 +17,45 @@ proc do_case {var} {
 			return -code continue three
 		}
 		4 {
-			return 44
+			return -code break four
 		}
 		5 {
-			return -code break five
+			continue
 		}
 		6 {
-			return eight
+			break
 		}
 	}
 	return zero
 }
 
-test control-2.1 "Return from case" {
-	set result {}
-	foreach i {0 1 2 3 4 5 6} {
-		lappend result [do_case $i]
-	}
-	set result
-} {zero one two 44}
+test case-2.0 "Plain from case" {
+	do_case 0
+} {}
+
+test case-2.1 "Return from case with value" {
+	do_case 1
+} {one}
 
+test case-2.2 "Return -code ok from case" {
+	do_case 2
+	list [catch {do_case 2} msg] $msg
+} {0 two}
+
+test case-2.3 "Return -code continue from case" {
+	list [catch {do_case 3} msg] $msg
+} {4 three}
+
+test case-2.4 "Return -code break from case" {
+	list [catch {do_case 4} msg] $msg
+} {3 four}
+
+if {0} {
+test case-2.5 "continue from case" {
+	list [catch {do_case 5} msg] $msg
+} {1 {invoked "continue" outside of a loop}}
+
+test case-2.6 "break from case" {
+	list [catch {do_case 6} msg] $msg
+} {1 {invoked "break" outside of a loop}}
+}
diff --git a/tests/misc.test b/tests/misc.test
index 6bd9477..cbaaa5a 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -296,4 +296,37 @@ test catch-1.7 "catch exit" {
 	dict get [info returncodes] [catch -exit {exit 5} result]
 } {exit}
 
+test catch-1.8 "catch error has -errorinfo" {
+	set rc [catch {set undefined} msg opts]
+	list $rc [info exists opts(-errorinfo)]
+} {1 1}
+
+test catch-1.9 "catch no error has no -errorinfo" {
+	set rc [catch {set x 1} msg opts]
+	list $rc [info exists opts(-errorinfo)]
+} {0 0}
+
+test return-1.1 "return can rethrow an error" {
+	proc a {} { error "from a" }
+	proc b {} { catch {a} msg opts; return {*}$opts $msg }
+	set rc [catch {b} msg opts]
+	list $rc $msg [llength $opts(-errorinfo)]
+} {1 {from a} 6}
+
+test return-1.2 "error can rethrow an error" {
+	proc a {} { error "from a" }
+	proc b {} { catch {a} msg; error $msg [info stacktrace] }
+	set rc [catch {b} msg opts]
+	list $rc $msg [llength $opts(-errorinfo)]
+} {1 {from a} 9}
+
+test return-1.3 "return can rethrow no error" {
+	proc a {} { return "from a" }
+	proc b {} { catch {a} msg opts; return {*}$opts $msg }
+	set rc [catch {b} msg opts]
+	#list $rc $msg [llength $opts(-errorinfo)]
+	list $rc $msg [info exists opts(-errorinfo)]
+} {0 {from a} 0}
+
+
 testreport
diff --git a/tests/return.test b/tests/return.test
index 3ed659a..6fcef8c 100644
--- a/tests/return.test
+++ b/tests/return.test
@@ -11,6 +11,38 @@ test return-1.2 {source file with break} {
 	list [catch {source break.tcl} msg] $msg
 } {3 {}}
 
-test return-1.2 {source file with break} {
+test return-1.3 {source file with break} {
 	list [catch {source return-break.tcl} msg] $msg
 } {3 result}
+
+proc a {level code msg} {
+	return -level $level -code $code $msg
+}
+
+proc b {level code msg} {
+	a $level $code $msg
+}
+
+test return-2.1 {return -level 0} {
+	list [catch {a 0 20 text} msg] $msg
+} {20 text}
+
+test return-2.2 {return -level 1} {
+	list [catch {a 1 20 text} msg] $msg
+} {20 text}
+
+test return-2.3 {return -level 2} {
+	list [catch {a 2 20 text} msg] $msg
+} {2 text}
+
+test return-2.4 {return -level 0} {
+	list [catch {b 0 20 text} msg] $msg
+} {20 text}
+
+test return-2.5 {return -level 1} {
+	list [catch {b 1 20 text} msg] $msg
+} {20 text}
+
+test return-2.6 {return -level 2} {
+	list [catch {b 2 20 text} msg] $msg
+} {20 text}
diff --git a/tests/stacktrace.test b/tests/stacktrace.test
index 5a1ce0a..91dccbe 100644
--- a/tests/stacktrace.test
+++ b/tests/stacktrace.test
@@ -15,7 +15,7 @@ proc main {} {
 			}
 			test err-$id1.$id2 "Stacktrace on error type $type, method $method" {
 				set rc [catch {error_caller $type $method} msg]
-				#puts stderr "err-$id1.$id2 $type, $method\n[errorInfo $msg]\n"
+				#puts "\n-----------------\n$type, $method\n[errorInfo $msg]\n\n"
 				if {$::SHOW_EXPECTED} { puts stderr "\terr-$id1.$id2 {[list $rc $msg [info stacktrace]]}" }
 
 				list $rc $msg [info stacktrace]
diff --git a/tests/try.test b/tests/try.test
index 3cc86fb..7435763 100644
--- a/tests/try.test
+++ b/tests/try.test
@@ -40,7 +40,7 @@ test try-1.4 "Error in both" {
 			error finally
 		}
 	} msg] $msg $x
-} {1 message 1}
+} {1 finally 1}
 
 test try-1.5 "break in body" {
 	list [catch {
@@ -63,3 +63,48 @@ test try-1.6 "break in finally" {
 		}
 	} msg] $msg $x
 } {3 {} 1}
+
+test try-1.7 "return value from try, not finally" {
+	list [catch {
+		try {
+			set x 0
+		} finally {
+			incr x
+		}
+	} msg] $msg $x
+} {0 0 1}
+
+test try-1.8 "return from within try" {
+	proc a {} {
+		try {
+			return 1
+		}
+		# notreached
+		return 2
+	}
+	a
+} {1}
+
+test try-1.9 "return -code from within try" {
+	proc a {} {
+		try {
+			return -code break text
+		}
+		# notreached
+		return 2
+	}
+	list [catch a msg] $msg
+} {3 text}
+
+proc c {} {
+	try {
+		error here
+	} on error {msg opts} {
+		incr opts(-level)
+		return {*}$opts $msg
+	}
+}
+
+test try-3.1 "rethrow error in try/on handler" {
+	list [catch c msg] $msg
+} {1 here}