From ef7eef0b3a1a4180213c8c3d092305cc020b1b04 Mon Sep 17 00:00:00 2001
From: Stephen Weeks <tene@allalone.org>
Date: Wed, 25 Nov 2009 00:11:16 -0700
Subject: [PATCH] Basic implementation of CATCH and a test for try and catch.

---
 src/NQP/Actions.pm   | 70 +++++++++++++++++++++++++++++++++++---------
 src/NQP/Grammar.pm   |  5 ++++
 t/nqp/44-try-catch.t | 69 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 130 insertions(+), 14 deletions(-)
 create mode 100644 t/nqp/44-try-catch.t

diff --git a/src/NQP/Actions.pm b/src/NQP/Actions.pm
index 9039305..d2a0578 100644
--- a/src/NQP/Actions.pm
+++ b/src/NQP/Actions.pm
@@ -13,7 +13,7 @@ sub xblock_immediate($xblock) {
 
 sub block_immediate($block) {
     $block.blocktype('immediate');
-    unless $block.symtable() {
+    unless $block.symtable() || $block.handlers() {
         my $stmts := PAST::Stmts.new( :node($block) );
         for $block.list { $stmts.push($_); }
         $block := $stmts;
@@ -162,6 +162,46 @@ method statement_control:sym<return>($/) {
     make PAST::Op.new( $<EXPR>.ast, :pasttype('return'), :node($/) );
 }
 
+method statement_control:sym<CATCH>($/) {
+    unless @BLOCK[0].handlers() {
+        @BLOCK[0].handlers([]);
+    }
+    my $block := $<block>.ast;
+    unless $block.arity {
+        $block.unshift(
+            PAST::Op.new( :pasttype('bind'),
+                PAST::Var.new( :scope('lexical'), :name('$!'), :isdecl(1) ),
+                PAST::Var.new( :scope('lexical'), :name('$_')),
+            ),
+        );
+        $block.unshift( PAST::Var.new( :name('$_'), :scope('parameter') ) );
+        $block.symbol('$_', :scope('lexical') );
+        $block.symbol('$!', :scope('lexical') );
+        $block.arity(1);
+    }
+    $block.blocktype('declaration');
+    @BLOCK[0].handlers.unshift(
+        PAST::Control.new(
+            :handle_types_except('CONTROL'),
+            :node($/),
+            PAST::Stmts.new(
+                PAST::Op.new( :pasttype('call'),
+                    $block,
+                    PAST::Var.new( :scope('register'), :name('exception')),
+                ),
+                PAST::Op.new( :pasttype('bind'),
+                    PAST::Var.new( :scope('keyed'),
+                        PAST::Var.new( :scope('register'), :name('exception')),
+                        'handled'
+                    ),
+                    1
+                )
+            ),
+        )
+    );
+    make PAST::Stmts.new(:node($/));
+}
+
 method statement_prefix:sym<INIT>($/) {
     @BLOCK[0].loadinit.push($<blorst>.ast);
     make PAST::Stmts.new(:node($/));
@@ -172,19 +212,21 @@ method statement_prefix:sym<try>($/) {
     if $past.WHAT ne 'PAST::Block()' {
         $past := PAST::Block.new($past, :blocktype('immediate'), :node($/));
     }
-    my $default := PAST::Control.new(
-        :handle_types_except('CONTROL'),
-        PAST::Stmts.new(
-            PAST::Op.new( :pasttype('bind'),
-                PAST::Var.new( :scope('keyed'),
-                    PAST::Var.new( :scope('register'), :name('exception')),
-                    'handled'
-                ),
-                1
-            )
-        )
-    );
-    $past.handlers([$default]);
+    unless $past.handlers() {
+        $past.handlers([PAST::Control.new(
+                :handle_types_except('CONTROL'),
+                PAST::Stmts.new(
+                    PAST::Op.new( :pasttype('bind'),
+                        PAST::Var.new( :scope('keyed'),
+                            PAST::Var.new( :scope('register'), :name('exception')),
+                            'handled'
+                        ),
+                        1
+                    )
+                )
+            )]
+        );
+    }
     make $past;
 }
 
diff --git a/src/NQP/Grammar.pm b/src/NQP/Grammar.pm
index 3bf999a..9b25d56 100644
--- a/src/NQP/Grammar.pm
+++ b/src/NQP/Grammar.pm
@@ -177,6 +177,11 @@ token statement_control:sym<for> {
     <xblock>
 }
 
+token statement_control:sym<CATCH> {
+    <sym> \s :s
+    <block>
+}
+
 proto token statement_prefix { <...> }
 token statement_prefix:sym<INIT> { <sym> <blorst> }
 
diff --git a/t/nqp/44-try-catch.t b/t/nqp/44-try-catch.t
new file mode 100644
index 0000000..864c38e
--- /dev/null
+++ b/t/nqp/44-try-catch.t
@@ -0,0 +1,69 @@
+#! nqp
+
+# Tests for try and catch
+
+plan(7);
+
+sub oops($msg = "oops!") { # throw an exception
+    my $ex := Q:PIR { %r = new ['Exception'] };
+    $ex<message> := $msg;
+    pir::throw($ex);
+}
+
+my $ok := 1;
+try {
+    oops();
+    $ok := 0;
+}
+
+ok($ok, "exceptions exit a try block");
+
+sub foo() {
+    try {
+        return 1;
+    }
+    return 0;
+}
+
+ok(foo(), "control exceptions are not caught by a try block");
+
+ok(try oops(), "statement prefix form of try works");
+
+{
+    CATCH { ok(1, "CATCH blocks are invoked when an exception occurs"); }
+    oops();
+}
+
+
+$ok := 1;
+sub bar() {
+    CATCH { $ok := 0; }
+    return;
+}
+bar();
+ok($ok, "CATCH blocks ignore control exceptions");
+
+$ok := 1;
+{
+    {
+        {
+            oops();
+            CATCH { $ok := $ok * 2; pir::rethrow($!); }
+        }
+        CATCH { $ok := $ok * 2; pir::rethrow($!); }
+    }
+    CATCH { $ok := $ok * 2; pir::rethrow($!); }
+    CATCH { ok($ok == 8, "rethrow and multiple exception handlers work") }
+}
+
+$ok := 1;
+
+{
+    for 1, 2, 3, 4 {
+        $ok := $ok * 2;
+        oops();
+    }
+    CATCH { my &c := $!<resume>; &c(); }
+}
+
+ok($ok == 16, "resuming from resumable exceptions works");