diff --git a/build/Makefile.in b/build/Makefile.in index 68595dc..b631167 100644 --- 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 index bc8a071..6e683f0 100644 --- 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 new file mode 100644 index 0000000..ac4ecaa --- /dev/null +++ b/src/Partcl/commands/control.pm @@ -0,0 +1,54 @@ +## these commands are special -- we want to be able to throw a +## CONTROL_ 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 := 66; # TCL_BREAK / CONTROL_LOOP_LAST + pir::throw($exception); + } +} + +INIT { + GLOBAL::continue := -> $message = '' { + my $exception := pir::new__ps('Exception'); + $exception := 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 := 56; + $exception := $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 index 8994d77..595b918 100644 --- 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 := 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 := 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 := 56; - $exception := $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?"');