[PATCH] Restrict clear_eh to handlers in the current context

[Bob Rogers]

   If sub A pushes an error handler and then calls B, B can do a
'clear_eh' to get rid of A's handler.  This seems to work until B
returns, at which point the control stack unwinding done by
RetContinuation destroys the rest of the stack looking for the missing
handler.  The patch detects the problem in clear_eh, and signals a
real_exception.

   Perhaps more controversially, it also makes it an error if clear_eh
finds something other than an exception at TOS.  The original code did
nothing, which doesn't seem right.  Error handlers are lexical features
of the source code, as are most other things on the control stack [1],
so finding a non-exception at TOS indicates a compiler bug (or a logic
error in hand-written PIR).  Fortunately, this doesn't affect any of the
existing test cases -- so I added a new one to test regression.

   You could also argue that the stack unwinding in
RetContinuation.invoke is broken.  I tend to agree, but any such fix
would be superceded by an implemention of rezipping.  This pop_exception
fix might also have to change, but probably only in detail.

                                        -- Bob

[1]  The sole exception is the return address used by the bsr/jsr and
     ret instructions; these aren't bound to any lexical features of the
     compiled language.


Index: src/ops/core.ops
===================================================================
--- src/ops/core.ops    (revision 10945)
+++ src/ops/core.ops    (working copy)
@@ -645,12 +645,16 @@
 
 =item B<push_eh>(labelconst INT)
 
-Create an exception handler for the given catch label and push it onto
-the control stack.
+Create an exception handler that transfers control to the specified
+catch label and push it onto the control stack.  Such handlers remain
+in effect in the current dynamic context, and are popped automatically
+on exit.
 
 =item B<clear_eh>()
 
-Clear out the most recently placed exception.
+Remove the exception on the top of the control stack.  A "No exception
+to pop" error is signalled if the top of the stack is not an
+exception, or the exception does not belong to the current context.
 
 =item B<throw>(in PMC)
 
Index: src/exceptions.c
===================================================================
--- src/exceptions.c    (revision 10945)
+++ src/exceptions.c    (working copy)
@@ -327,12 +327,22 @@
 {
     Stack_entry_type type;
     PMC *handler;
+    parrot_context_t *current_ctx = CONTEXT(interpreter->ctx);
+    parrot_context_t *prev_ctx = current_ctx->prev;
+    Stack_Chunk_t *prev_base = (prev_ctx ? prev_ctx->control_stack : NULL);
 
-    handler = stack_peek(interpreter, 
CONTEXT(interpreter->ctx)->control_stack, &type);
+    if (prev_base == current_ctx->control_stack) {
+        real_exception(interpreter, NULL, INVALID_OPERATION,
+                       "No exception to pop.");
+    }
+    handler = stack_peek(interpreter, current_ctx->control_stack, &type);
     if (type != STACK_ENTRY_PMC ||
-            handler->vtable->base_type != enum_class_Exception_Handler)
-        return; /* no exception on TOS */
-    (void)stack_pop(interpreter, &CONTEXT(interpreter->ctx)->control_stack, 
NULL,
+            handler->vtable->base_type != enum_class_Exception_Handler) {
+        /* no exception on TOS */
+        real_exception(interpreter, NULL, INVALID_OPERATION,
+                       "No exception to pop.");
+    }
+    (void)stack_pop(interpreter, &current_ctx->control_stack, NULL,
                     STACK_ENTRY_PMC);
 }
 
Index: t/pmc/exception.t
===================================================================
--- t/pmc/exception.t   (revision 10945)
+++ t/pmc/exception.t   (working copy)
@@ -6,7 +6,7 @@
 use warnings;
 use lib qw( . lib ../lib ../../lib );
 use Test::More;
-use Parrot::Test tests => 26;
+use Parrot::Test tests => 28;
 
 =head1 NAME
 
@@ -591,3 +591,42 @@
 Error: something happened
 Outer value
 OUTPUT
+
+pir_output_like(<<'CODE', <<'OUTPUT', 'clear_eh out of context (1)');
+.sub main :main
+       pushmark 1
+       clear_eh
+       print "no exceptions.\n"
+.end
+CODE
+/No exception to pop./
+OUTPUT
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'clear_eh out of context (2)');
+.sub main :main
+       .local pmc outer, cont
+       push_eh handler
+       test1()
+       print "skipped.\n"
+       goto done
+handler:
+       .local pmc exception
+       .get_results (exception)
+       print "Error: "
+       print exception
+       print "\n"
+done:
+       print "done.\n"
+.end
+.sub test1
+       .local pmc exit
+       print "[in test1]\n"
+       ## clear_eh is illegal here, and signals an exception.
+       clear_eh
+       print "[cleared]\n"
+.end
+CODE
+[in test1]
+Error: No exception to pop.
+done.
+OUTPUT