Enhance catch and 'info returncodes'

*: Add optional arg to catch, opts, like Tcl 8.5 to allow access to the
   code given by 'return -code'
*: Use -- to signify end of options to catch
*: 'info returncodes' can give the name of a single code
*: Fix 'case' to handle 'return -code' properly

4 files changed, 87 insertions, 35 deletions

diff --git a/doc/jim_tcl.txt b/doc/jim_tcl.txt
index ece2547..0508380 100644
--- a/doc/jim_tcl.txt
+++ b/doc/jim_tcl.txt
@@ -1480,7 +1480,7 @@ will return '2'.
 
 catch
 ~~~~~
-+*catch* '?-?no?code ...? command ?varName?'+
++*catch* '?-?no?code ...?' *?--?* 'command ?resultVarName? ?optionsVarName?'+
 
 The 'catch' command may be used to prevent errors from aborting
 command interpretation.  'Catch' evalues *command*, and
@@ -1492,22 +1492,29 @@ The return value from 'catch' is a decimal string giving the code returned
 by the Tcl interpreter after executing *command*.  This will be '0'
 (+JIM_OK+) if there were no errors in *command*; otherwise it will have
 a non-zero value corresponding to one of the exceptional return codes
-(see jim.h for the definitions of code values).
+(see jim.h for the definitions of code values, or the 'info returncodes' command).
 
-If the *varName* argument is given, then it gives the name of a variable;
+If the *resultVarName* argument is given, then it gives the name of a variable;
 'catch' will set the value of the variable to the string returned from
 *command* (either a result or an error message).
 
+If the *optionsVarName* argument is given, then it gives the name of a variable;
+'catch' will set the value of the variable to a dictionary. For any return code other
+than +JIM_RETURN+, the value for the key +-code+ will be set to the return code. For +JIM_RETURN+
+it will be set to the code given in 'return -code'.
+
 Normally 'catch' will *not* catch any of the codes +JIM_EXIT+, +JIM_EVAL+ or +JIM_SIGNAL+.
 The set of codes which will be caught may be modified by specifying the one more codes before
-*command*. (In this case, *varName* must be specified).
+*command*.
 
 e.g. To catch +JIM_EXIT+ but not +JIM_BREAK+ or +JIM_CONTINUE+
 
-    catch -exit -nobreak -nocontinue { ... }
+    catch -exit -nobreak -nocontinue -- { ... }
+
+The use of +--+ is optional. It signifies that no more return code options follow.
 
 Note that if a signal marked as 'signal handle' is caught with 'catch -signal', the return value
-(stored in *varName*) is name of the signal caught.
+(stored in *resultVarName*) is name of the signal caught.
 
 cd
 ~~
@@ -2276,9 +2283,10 @@ The legal *option*'s (which may be abbreviated) are:
     are returned.  Matching is determined using the same rules as for
     'string match'.
 
-+*info returncodes*+::
++*info returncodes* ?'code'?+::
     Returns a list representing the mapping of standard return codes
-	to names. e.g. +{0 ok 1 error 2 return ...}+
+	to names. e.g. +{0 ok 1 error 2 return ...}+. If a code is given,
+	instead returns the name for the given code.
 
 +*info script*+::
     If a Tcl script file is currently being evaluated (i.e. there is a
diff --git a/jim.c b/jim.c
index 2f2aa59..609cdbc 100644
--- a/jim.c
+++ b/jim.c
@@ -11749,23 +11749,28 @@ static int Jim_CatchCoreCommand(Jim_Interp *interp, int argc,
     /* Which return codes are caught? These are the defaults */
     jim_wide mask = (1 << JIM_OK | 1 << JIM_ERR | 1 << JIM_BREAK | 1 << JIM_CONTINUE | 1 << JIM_RETURN);
 
-    for (i = 1; i < argc - 2; i++) {
+    for (i = 1; i < argc - 1; i++) {
         const char *arg = Jim_GetString(argv[i], NULL);
         jim_wide option;
         int add;
 
         /* It's a pity we can't use Jim_GetEnum here :-( */
+        if (strcmp(arg, "--") == 0) {
+            i++;
+            break;
+        }
+        if (*arg != '-') {
+            break;
+        }
+
         if (strncmp(arg, "-no", 3) == 0) {
             arg += 3;
             add = 0;
         }
-        else if (*arg == '-') {
+        else {
             arg++;
             add = 1;
         }
-        else {
-            goto wrongargs;
-        }
 
         if (Jim_StringToWide(arg, &option, 10) != JIM_OK) {
             option = -1;
@@ -11786,9 +11791,10 @@ static int Jim_CatchCoreCommand(Jim_Interp *interp, int argc,
     }
 
     argc -= i;
-    if (argc != 1 && argc != 2) {
+    if (argc < 1 || argc > 3) {
+        printf("argc=%d\n", argc);
 wrongargs:
-        Jim_WrongNumArgs(interp, 1, argv, "?-?no?code ...? script ?varName?");
+        Jim_WrongNumArgs(interp, 1, argv, "?-?no?code ... --? script ?resultVarName? ?optionVarName?");
         return JIM_ERR;
     }
     argv += i;
@@ -11801,7 +11807,6 @@ wrongargs:
     exitCode = Jim_EvalObj(interp, argv[0]);
     interp->signal_level -= sig;
 
-
     /* Catch or pass through? Only the first 64 codes can be passed through */
     if (exitCode >= 0 && exitCode < sizeof(mask) && ((1 << exitCode) & mask) == 0) {
         /* Not caught, pass it up */
@@ -11819,10 +11824,20 @@ wrongargs:
         interp->signal = 0;
     }
 
-    if (argc == 2) {
-        if (Jim_SetVariable(interp, argv[1], Jim_GetResult(interp))
-                != JIM_OK)
+    if (argc >= 2) {
+        if (Jim_SetVariable(interp, argv[1], Jim_GetResult(interp)) != JIM_OK) {
             return JIM_ERR;
+        }
+        if (argc == 3) {
+            Jim_Obj *optListObj = Jim_NewListObj(interp, NULL, 0);
+            Jim_ListAppendElement(interp, optListObj, Jim_NewStringObj(interp, "-code", -1));
+            Jim_ListAppendElement(interp, optListObj,
+                Jim_NewIntObj(interp, exitCode == JIM_RETURN ? interp->returnCode : exitCode));
+
+            if (Jim_SetVariable(interp, argv[2], optListObj) != JIM_OK) {
+                return JIM_ERR;
+            }
+        }
     }
     Jim_SetResultInt(interp, exitCode);
     return JIM_OK;
@@ -12202,18 +12217,37 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc,
             /* Redirect to Tcl proc */
             return Jim_Eval(interp, "{info nameofexecutable}");
 
-        case INFO_RETURNCODES: {
-            int i;
-            Jim_Obj *listObjPtr = Jim_NewListObj(interp, NULL, 0);
+        case INFO_RETURNCODES:
+            if (argc == 2) {
+                int i;
+                Jim_Obj *listObjPtr = Jim_NewListObj(interp, NULL, 0);
 
-            for (i = 0; jimReturnCodes[i]; i++) {
-                Jim_ListAppendElement(interp, listObjPtr, Jim_NewIntObj(interp, i));
-                Jim_ListAppendElement(interp, listObjPtr, Jim_NewStringObj(interp, jimReturnCodes[i], -1));
-            }
+                for (i = 0; jimReturnCodes[i]; i++) {
+                    Jim_ListAppendElement(interp, listObjPtr, Jim_NewIntObj(interp, i));
+                    Jim_ListAppendElement(interp, listObjPtr, Jim_NewStringObj(interp, jimReturnCodes[i], -1));
+                }
 
-            Jim_SetResult(interp, listObjPtr);
+                Jim_SetResult(interp, listObjPtr);
+            }
+            else if (argc == 3) {
+                long code;
+                const char *name;
+                if (Jim_GetLong(interp, argv[2], &code) != JIM_OK) {
+                    return JIM_ERR;
+                }
+                name = Jim_ReturnCode(code);
+                if (*name == '?') {
+                    Jim_SetResultInt(interp, code);
+                }
+                else {
+                    Jim_SetResultString(interp, name, -1);
+                }
+            }
+            else {
+                Jim_WrongNumArgs(interp, 2, argv, "?code?");
+                return JIM_ERR;
+            }
             break;
-        }
     }
     return JIM_OK;
 }
diff --git a/tclcompat.tcl b/tclcompat.tcl
index c996c19..8669ed2 100644
--- a/tclcompat.tcl
+++ b/tclcompat.tcl
@@ -47,7 +47,14 @@ proc case {var args} {
 	rename $checker ""
 
 	if {[info exists do_action]} {
-		set rc [catch [list uplevel 1 $do_action] result]
+		set rc [catch [list uplevel 1 $do_action] result opts]
+		set rcname [info returncode $rc]
+		if {$rcname in {break continue}} {
+			return -code error "invoked \"$rcname\" outside of a loop"
+		} elseif {$rcname eq "return" && $opts(-code)} {
+			# 'return -code' in the action
+			set rc $opts(-code)
+		}
 		return -code $rc $result
 	}
 }
diff --git a/tests/case.test b/tests/case.test
index ce6075a..a74f265 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -6,8 +6,11 @@ proc control {cond code} {
 	set iscond [uplevel 1 expr $cond]
 	#puts "$cond -> $iscond"
 	if {$iscond} {
-		set rc [catch [list uplevel 1 $code] error]
-		#puts "$code -> rc=$rc, error=$error"
+		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
 	}
 }
@@ -52,19 +55,19 @@ proc do_case {var} {
 			return one
 		}
 		2 {
-			return two
+			return -code ok two
 		}
 		3 {
-			continue
+			return -code continue three
 		}
 		4 {
 			return 44
 		}
 		5 {
-			break
+			return -code break five
 		}
 		6 {
-			return six
+			return eight
 		}
 	}
 	return zero