summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclCompCmds.c91
-rw-r--r--tests/compile.test30
2 files changed, 48 insertions, 73 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index cd43cfc..72b338c 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -582,11 +582,7 @@ TclCompileCatchCmd(
/*
* We will compile the catch command. Declare the exception range that it
* uses.
- */
-
- range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-
- /*
+ *
* If the body is a simple word, compile a BEGIN_CATCH instruction,
* followed by the instructions to eval the body.
* Otherwise, compile instructions to substitute the body text before
@@ -599,6 +595,7 @@ TclCompileCatchCmd(
* begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
*/
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
@@ -610,37 +607,11 @@ TclCompileCatchCmd(
ExceptionRangeStarts(envPtr, range);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitInvoke(envPtr, INST_EVAL_STK);
- }
- /* Stack at this point:
- * nonsimple: script <mark> result
- * simple: <mark> result
- */
-
- if (resultIndex == -1) {
- /*
- * Special case when neither result nor options are being saved. In
- * that case, we can skip quite a bit of the command epilogue; all we
- * have to do is drop the result and push the return code (and, of
- * course, finish the catch context).
- */
-
+ /* drop the script */
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_POP, envPtr);
- PushStringLiteral(envPtr, "0");
- TclEmitInstInt1( INST_JUMP1, 3, envPtr);
- TclAdjustStackDepth(-1, envPtr);
- ExceptionRangeTarget(envPtr, range, catchOffset);
- TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
- ExceptionRangeEnds(envPtr, range);
- TclEmitOpcode( INST_END_CATCH, envPtr);
-
- /*
- * Stack at this point:
- * nonsimple: script <mark> returnCode
- * simple: <mark> returnCode
- */
-
- goto dropScriptAtEnd;
}
+ ExceptionRangeEnds(envPtr, range);
/*
* Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
@@ -649,7 +620,6 @@ TclCompileCatchCmd(
PushStringLiteral(envPtr, "0");
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- /* Stack at this point: ?script? <mark> result TCL_OK */
/*
* Emit the "error case" epilogue. Push the interpreter result and the
@@ -658,22 +628,20 @@ TclCompileCatchCmd(
TclAdjustStackDepth(-2, envPtr);
ExceptionRangeTarget(envPtr, range, catchOffset);
- /* Stack at this point: ?script? */
+ /* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
- /*
- * Update the target of the jump after the "no errors" code.
- */
+ /* Stack at this point on both branches: result returnCode */
- /* Stack at this point: ?script? result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
/*
- * Push the return options if the caller wants them.
+ * Push the return options if the caller wants them. This needs to happen
+ * before INST_END_CATCH
*/
if (optsIndex != -1) {
@@ -684,52 +652,29 @@ TclCompileCatchCmd(
* End the catch
*/
- ExceptionRangeEnds(envPtr, range);
TclEmitOpcode( INST_END_CATCH, envPtr);
/*
- * At this point, the top of the stack is inconveniently ordered:
- * ?script? result returnCode ?returnOptions?
- * Reverse the stack to bring the result to the top.
- */
-
- if (optsIndex != -1) {
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- } else {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- }
-
- /*
- * Store the result and remove it from the stack.
- */
-
- Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
-
- /*
- * Stack is now ?script? ?returnOptions? returnCode.
- * If the options dict has been requested, it is buried on the stack under
- * the return code. Reverse the stack to bring it to the top, store it and
- * remove it from the stack.
+ * Save the result and return options if the caller wants them. This needs
+ * to happen after INST_END_CATCH (compile-3.6/7).
*/
if (optsIndex != -1) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
- dropScriptAtEnd:
-
/*
- * Stack is now ?script? result. Get rid of the subst'ed script if it's
- * hanging arond.
+ * At this point, the top of the stack is inconveniently ordered:
+ * result returnCode
+ * Reverse the stack to store the result.
*/
- if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ if (resultIndex != -1) {
+ Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
}
+ TclEmitOpcode( INST_POP, envPtr);
return TCL_OK;
}
diff --git a/tests/compile.test b/tests/compile.test
index 36e24de..2852bf2 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -167,6 +167,36 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*}
-cleanup {namespace delete catchtest}
}
+test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{
+ -setup {
+ namespace eval catchtest {
+ variable options1 {}
+ }
+ trace add variable catchtest::options1 write catchtest::failtrace
+ proc catchtest::failtrace {n1 n2 op} {
+ return -code error "trace on $n1 fails by request"
+ }
+ }
+ -body {
+ proc catchtest::x {} {
+ variable options1
+ set count 0
+ for {set i 0} {$i < 10} {incr i} {
+ set status2 [catch {
+ set status1 [catch {
+ return -code error -level 0 "original failure"
+ } result1 options1]
+ } result2 options2]
+ incr count
+ }
+ list $count $result2
+ }
+ catchtest::x
+ }
+ -result {10 {can't set "options1": trace on options1 fails by request}}
+ -cleanup {namespace delete catchtest}
+}
+
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0