Add control handler, make most uncaught control exceptions fatal. Als…

…o fix leave handling for uncaught exceptions.
mlschroe · Oct 12, 2011 · ac01192 · ac01192
1 parent 13ef4ae
commit ac01192
Showing 1 changed file with 63 additions and 8 deletions.
diff --git a/src/core/Exception.pm b/src/core/Exception.pm
@@ -8,7 +8,7 @@ my class Exception {
     }
 
     multi method Numeric(Exception:D:) {
-	self.Str.Numeric()
+        self.Str.Numeric()
     }
 
     method throw() {
@@ -57,13 +57,9 @@ do {
         return False;
     }
 
-    my Mu $comp := pir::compreg__Ps('perl6');
-    $comp.HOW.add_method($comp, 'handle-exception',
-        method (|$) {
-            my Mu $ex := nqp::atpos(
-                pir::perl6_current_args_rpa__P(),
-                1
-            );
+    sub print_exception(|$) is hidden_from_backtrace {
+        my Mu $ex := nqp::atpos(pir::perl6_current_args_rpa__P(), 0);
+        try {
             if is_runtime($ex.backtrace) {
                 my $e := EXCEPTION($ex);
                 my Mu $err := pir::getstderr__P();
@@ -76,8 +72,67 @@ do {
                 $err.print: $ex;
                 $err.print: "\n";
             }
+        }
+        # must not open a block here...
+        $! ?? pir::perl6_rethrow_skipnextctx__0P(nqp::getattr($!, Exception, '$!ex')) !! pir::perl6_returncc__0P($ex);
+    }
+
+    sub print_control(|$) is hidden_from_backtrace {
+        my Mu $ex := nqp::atpos(pir::perl6_current_args_rpa__P(), 0);
+        my $type = nqp::p6box_i(nqp::atkey($ex, 'type'));
+        if ($type == nqp::p6box_i(pir::const::CONTROL_OK)) {
+            my Mu $err := pir::getstderr__P();
+            my $msg = nqp::p6box_s(nqp::atkey($ex, 'message'));
+            if ($msg) {
+                $err.print: "Warning: $msg\n";
+            } else {
+                $err.print: "Warning\n";
+            }
+            my $resume := nqp::atkey($ex, 'resume');
+            if ($resume) {
+                $resume();
+            }
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_RETURN)) {
+            die("stray return control exception\n");
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_LOOP_LAST)) {
+            die("last without loop construct\n");
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_LOOP_NEXT)) {
+            die("next without loop construct\n");
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_LOOP_REDO)) {
+            die("redo without loop construct\n");
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_CONTINUE)) {
+            die("proceed without when clause\n");
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_BREAK)) {
+            # XXX: should work like leave() ?
+            die("succeed without when clause\n");
+        }
+        if ($type == nqp::p6box_i(pir::const::CONTROL_TAKE)) {
+            die("stray take statement\n");
+        }
+        pir::perl6_returncc($ex);
+        0;
+    }
+
+    my Mu $comp := pir::compreg__Ps('perl6');
+    $comp.HOW.add_method($comp, 'handle-exception',
+        method (|$) {
+            my Mu $ex := nqp::atpos(pir::perl6_current_args_rpa__P(), 1);
+            pir::perl6_invoke_catchhandler(nqp::getattr(&print_exception, Code, '$!do'), $ex);
             pir::exit(1);
             0;
         }
     );
+    $comp.HOW.add_method($comp, 'handle-control',
+        method (|$) {
+            my Mu $ex := nqp::atpos(pir::perl6_current_args_rpa__P(), 1);
+            pir::perl6_invoke_catchhandler(nqp::getattr(&print_control, Code, '$!do'), $ex);
+            pir::rethrow__0P($ex);
+        }
+    );
 }