update [catch] to use new try/catch/control

partcl · Nov 28, 2009 · 7de9dfe · 7de9dfe
1 parent a0021ef
commit 7de9dfe
Show file tree

Hide file tree

Showing 2 changed files with 25 additions and 15 deletions.
diff --git a/build/PARROT_REVISION b/build/PARROT_REVISION
@@ -1 +1 @@
-42801
+42806
diff --git a/src/PmTcl/Commands.pm b/src/PmTcl/Commands.pm
@@ -1,25 +1,35 @@
 
-# only works for code that doesn't error.
 our sub catch($code, $varname?) {
-    my $DONE_OK := 0;
+    my $retval := 0; # TCL_OK
     my $result;
     try { 
         $result := PmTcl::Compiler.eval($code);
-        $DONE_OK := 1;
-    };
-    if $DONE_OK {
-        if $varname {
-            my $lexpad := pir::find_dynamic_lex__Ps('%LEXPAD');
-            $lexpad{$varname} := $result;
+        CATCH {
+            $retval := 1; # TCL_ERROR
+            $result := $!<message>;
         }
-        return 0;
-    } else {
-        if $varname {
-            my $lexpad := pir::find_dynamic_lex__Ps('%LEXPAD');
-            $lexpad{$varname} := "XXX SOME ERROR OCCURRED";
+        CONTROL {
+            my $parrot_type := $!<type>;
+
+            # XXX using numeric type ids is potentially fragile.
+            if $parrot_type == 58 {
+                $retval := 2; # TCL_RETURN
+            } elsif $parrot_type == 60 {
+                $retval := 3; # TCL_BREAK
+            } elsif $parrot_type == 61 {
+                $retval := 4; # TCL_CONTINUE
+            } else {
+                # This isn't a standard tcl control type. Give up.
+                pir::rethrow($!);
+            }
+            $result := $!<message>;
         }
-        return 1;
+    };
+    if $varname {
+        my $lexpad := pir::find_dynamic_lex__Ps('%LEXPAD');
+        $lexpad{$varname} := $result;
     }
+    return $retval;
 }