move all commands that generate control exceptions into a separate NQ…

…P file.
partcl · Apr 13, 2010 · c3b8270 · c3b8270
1 parent 88b3e3c
commit c3b8270
Show file tree

Hide file tree

Showing 4 changed files with 56 additions and 57 deletions.
diff --git a/build/Makefile.in b/build/Makefile.in
@@ -28,6 +28,7 @@ GEN_SOURCES = \
   src/Partcl/Grammar.pir \
   src/Partcl/Operators.pir \
   src/Partcl/commands/array.pir \
+  src/Partcl/commands/control.pir \
   src/Partcl/commands/dict.pir \
   src/Partcl/commands/file.pir \
   src/Partcl/commands/info.pir \

diff --git a/src/Partcl.pir b/src/Partcl.pir
@@ -16,6 +16,7 @@
 .include 'src/Partcl/Actions.pir'
 .include 'src/Partcl/Compiler.pir'
 .include 'src/Partcl/Operators.pir'
+.include 'src/Partcl/commands/control.pir'
 .include 'src/Partcl/commands/main.pir'
 .include 'src/Partcl/commands/array.pir'
 .include 'src/Partcl/commands/dict.pir'

diff --git a/src/Partcl/commands/control.pm b/src/Partcl/commands/control.pm
@@ -0,0 +1,54 @@
+##  these commands are special -- we want to be able to throw a
+##  CONTROL_<FOO> exception without the NQP sub itself catching
+##  it.  So we create a bare block (which doesn't come with any
+##  exception handling) and bind it manually into the (global)
+##  namespace when loaded.
+
+INIT {
+    GLOBAL::break := -> *@args {
+        if +@args {
+            error('wrong # args: should be "break"');
+        }
+        my $exception := pir::new__ps('Exception');
+        $exception<type> := 66; # TCL_BREAK / CONTROL_LOOP_LAST
+        pir::throw($exception);
+    }
+}
+
+INIT {
+    GLOBAL::continue := -> $message = '' {
+        my $exception := pir::new__ps('Exception');
+        $exception<type> := 65; # TCL_CONTINUE / CONTROL_LOOP_NEXT
+        pir::throw($exception);
+    }
+}
+
+INIT {
+    GLOBAL::error := -> *@args {
+        my $message := '';
+        if +@args < 1 || +@args > 3 {
+            $message := 'wrong # args: should be "error message ?errorInfo? ?errorCode?"';
+        } else {
+            $message := @args[0];
+        }
+
+        if +@args >= 2 {
+            our %GLOBALS;
+            %GLOBALS{'errorInfo'} := @args[1];
+            my $errorCode := @args[2] // 'NONE';
+            %GLOBALS{'errorCode'} := $errorCode;
+        }
+
+        my $exception := pir::new__ps('Exception');
+        # use EXCEPTION_SYNTAX_ERROR - just a generic type
+        $exception<type> := 56;
+        $exception<message> := $message;
+        pir::throw($exception);
+    }
+}
+
+INIT {
+    GLOBAL::return := -> $result = '' { return $result; }
+}
+
+# vim: filetype=perl6:
diff --git a/src/Partcl/commands/main.pm b/src/Partcl/commands/main.pm
@@ -31,19 +31,6 @@ our sub apply(*@args) {
 our sub binary(*@args) {
 }
 
-##  "break" is special -- see "return"
-INIT {
-    GLOBAL::break := -> *@args {
-        if +@args {
-            error('wrong # args: should be "break"');
-        }
-        my $exception := pir::new__ps('Exception');
-        $exception<type> := 66; # TCL_BREAK / CONTROL_LOOP_LAST
-        pir::throw($exception);
-    }
-}
-
-
 our sub catch(*@args) {
     if +@args < 1 || +@args > 2 {
         error('wrong # args: should be "catch script ?resultVarName? ?optionVarName?"');
@@ -104,15 +91,6 @@ our sub concat(*@args) {
     $result;
 }
 
-##  "continue" is special -- see "return"
-INIT {
-    GLOBAL::continue := -> $message = '' {
-        my $exception := pir::new__ps('Exception');
-        $exception<type> := 65; # TCL_CONTINUE / CONTROL_LOOP_NEXT
-        pir::throw($exception);
-    }
-}
-
 our sub eof(*@args) {
     if +@args != 1 {
         error('wrong # args: should be "eof channelId"')
@@ -121,32 +99,6 @@ our sub eof(*@args) {
     return 0;
 }
 
-##  "error" is special -- see "return"
-INIT {
-    GLOBAL::error := -> *@args {
-        my $message := '';
-        if +@args < 1 || +@args > 3 {
-            $message := 'wrong # args: should be "error message ?errorInfo? ?errorCode?"';
-        } else {
-            $message := @args[0];
-        }
-
-        if +@args >= 2 {
-            our %GLOBALS;
-            %GLOBALS{'errorInfo'} := @args[1];
-            my $errorCode := @args[2] // 'NONE';
-            %GLOBALS{'errorCode'} := $errorCode;
-        }
-
-        my $exception := pir::new__ps('Exception');
-        # use EXCEPTION_SYNTAX_ERROR - just a generic type
-        $exception<type> := 56;
-        $exception<message> := $message;
-        pir::throw($exception);
-    }
-}
-
-
 our sub eval(*@args) {
     if +@args < 1 {
         error('wrong # args: should be "eval arg ?arg ...?"');
@@ -477,15 +429,6 @@ our sub rename(*@args) {
     }
 }
 
-##  "return" is special -- we want to be able to throw a
-##  CONTROL_RETURN exception without the sub itself catching
-##  it.  So we create a bare block for the return (bare blocks
-##  don't catch return exceptions) and bind it manually into
-##  the (global) namespace when loaded.
-INIT {
-    GLOBAL::return := -> $result = '' { return $result; }
-}
-
 our sub set(*@args) {
     if +@args < 1 || +@args > 2 {
         error('wrong # args: should be "set varName ?newValue?"');