has_block_handler.diff

--- src/Perl6/Actions.pm.orig   2011-08-02 12:56:25.000000000 +0000
+++ src/Perl6/Actions.pm        2011-08-04 14:05:13.000000000 +0000
@@ -706,6 +706,9 @@ class Perl6::Actions is HLL::Actions {
     }

     method statement_control:sym<CATCH>($/) {
+        if has_block_handler($*ST.cur_lexpad(), 'CONTROL', 1) {
+            $/.CURSOR.panic("only one CATCH block allowed");
+        }
         my $block := $<block>.ast;
         push_block_handler($/, $*ST.cur_lexpad(), $block);
         $*ST.cur_lexpad().handlers()[0].handle_types_except('CONTROL');
@@ -713,6 +716,9 @@ class Perl6::Actions is HLL::Actions {
     }

     method statement_control:sym<CONTROL>($/) {
+        if has_block_handler($*ST.cur_lexpad(), 'CONTROL') {
+            $/.CURSOR.panic("only one CONTROL block allowed");
+        }
         my $block := $<block>.ast;
         push_block_handler($/, $*ST.cur_lexpad(), $block);
         $*ST.cur_lexpad().handlers()[0].handle_types('CONTROL');
@@ -748,22 +754,28 @@ class Perl6::Actions is HLL::Actions {
     }   
 
     method statement_prefix:sym<try>($/) {
-        my $block := PAST::Op.new(:pasttype<call>, block_closure($<blorst>.ast)); # XXX should be immediate
-        my $past := PAST::Op.new( :pasttype('try'), $block );
-
-        # On failure, capture the exception object into $!.
-        $past.push(
-            PAST::Op.new(:pasttype<bind_6model>,
-                PAST::Var.new(:name<$!>, :scope<lexical_6model>),
-                PAST::Op.new(:name<&EXCEPTION>, :pasttype<call>,
-                    PAST::Op.new(:inline("    .get_results (%r)\n    finalize %r")))));
+        my $block := $<blorst>.ast;
+        my $past;
+        if has_block_handler($block, 'CONTROL', 1) {
+            # we already have a CATCH block, nothing to do here
+            $past := PAST::Op.new( :pasttype('call'), block_closure($block) );
+        } else {
+            $block := PAST::Op.new(:pasttype<call>, block_closure($block)); # XXX should be immediate
+            $past := PAST::Op.new( :pasttype('try'), $block );
 
-        # Otherwise, put Mu into $!.
-        $past.push(
-            PAST::Op.new(:pasttype<bind_6model>,
-                PAST::Var.new( :name<$!>, :scope<lexical_6model> ),
-                PAST::Var.new( :name<Mu>, :scope<lexical_6model> )));
+            # On failure, capture the exception object into $!.
+            $past.push(
+                PAST::Op.new(:pasttype<bind_6model>,
+                    PAST::Var.new(:name<$!>, :scope<lexical_6model>),
+                    PAST::Op.new(:name<&EXCEPTION>, :pasttype<call>,
+                        PAST::Op.new(:inline("    .get_results (%r)\n    finalize %r")))));
 
+            # Otherwise, put Mu into $!.
+            $past.push(
+                PAST::Op.new(:pasttype<bind_6model>,
+                    PAST::Var.new( :name<$!>, :scope<lexical_6model> ),
+                    PAST::Var.new( :name<Mu>, :scope<lexical_6model> )));
+        }
         make $past;
     }   
 
@@ -3568,6 +3583,23 @@ class Perl6::Actions is HLL::Actions {
         );
     }

+    sub has_block_handler($block, $type, $except?) {
+        my @handlers := $block.handlers();
+        my $ret := 0;
+        for @handlers {
+            my $ltype;
+            if (pir::defined($except)) {
+                $ltype := $_.handle_types_except();
+            } else {
+                $ltype := $_.handle_types();
+            }
+            if (pir::defined($ltype) && $ltype eq $type) {
+                $ret := 1;
+            }
+        }
+        $ret;
+    }
+
     # Handles the case where we have a default value closure for an
     # attribute.
     method install_attr_init($/) {