From 5768bc248bc60a6a9cd014a1a0ca16ec501dee1a Mon Sep 17 00:00:00 2001 From: Coke Date: Sun, 18 Jul 2010 00:18:24 -0400 Subject: [PATCH] Have a single file for each tcl builtin. (splits up control.pm, list.pm, and main.pm in the commands dir) --- build/Makefile.in | 56 ++++- src/Partcl.pir | 58 ++++- src/Partcl/commands/after.pm | 7 + src/Partcl/commands/append.pm | 30 +++ src/Partcl/commands/apply.pm | 6 + src/Partcl/commands/binary.pm | 23 ++ src/Partcl/commands/break.pm | 14 ++ src/Partcl/commands/catch.pm | 36 +++ src/Partcl/commands/cd.pm | 14 ++ src/Partcl/commands/concat.pm | 7 + src/Partcl/commands/continue.pm | 11 + src/Partcl/commands/control.pm | 54 ----- src/Partcl/commands/eof.pm | 7 + src/Partcl/commands/error.pm | 27 +++ src/Partcl/commands/eval.pm | 13 ++ src/Partcl/commands/exit.pm | 7 + src/Partcl/commands/expr.pm | 23 ++ src/Partcl/commands/fileevent.pm | 11 + src/Partcl/commands/flush.pm | 10 + src/Partcl/commands/for.pm | 24 ++ src/Partcl/commands/foreach.pm | 55 +++++ src/Partcl/commands/format.pm | 7 + src/Partcl/commands/gets.pm | 24 ++ src/Partcl/commands/glob.pm | 22 ++ src/Partcl/commands/global.pm | 11 + src/Partcl/commands/if.pm | 25 +++ src/Partcl/commands/incr.pm | 17 ++ src/Partcl/commands/join.pm | 7 + src/Partcl/commands/lappend.pm | 22 ++ src/Partcl/commands/lassign.pm | 19 ++ src/Partcl/commands/lindex.pm | 30 +++ src/Partcl/commands/linsert.pm | 21 ++ src/Partcl/commands/list.pm | 361 ------------------------------- src/Partcl/commands/llength.pm | 9 + src/Partcl/commands/lrange.pm | 21 ++ src/Partcl/commands/lrepeat.pm | 19 ++ src/Partcl/commands/lreplace.pm | 33 +++ src/Partcl/commands/lreverse.pm | 8 + src/Partcl/commands/lset.pm | 46 ++++ src/Partcl/commands/lsort.pm | 66 ++++++ src/Partcl/commands/proc.pm | 61 ++++++ src/Partcl/commands/puts.pm | 21 ++ src/Partcl/commands/pwd.pm | 3 + src/Partcl/commands/regexp.pm | 20 ++ src/Partcl/commands/rename.pm | 12 + src/Partcl/commands/return.pm | 7 + src/Partcl/commands/set.pm | 60 +++++ src/Partcl/commands/socket.pm | 3 + src/Partcl/commands/source.pm | 3 + src/Partcl/commands/split.pm | 38 ++++ src/Partcl/commands/subst.pm | 3 + src/Partcl/commands/switch.pm | 50 +++++ src/Partcl/commands/time.pm | 30 +++ src/Partcl/commands/unset.pm | 22 ++ src/Partcl/commands/uplevel.pm | 19 ++ src/Partcl/commands/upvar.pm | 39 ++++ src/Partcl/commands/variable.pm | 5 + src/Partcl/commands/vwait.pm | 6 + src/Partcl/commands/while.pm | 10 + src/init.pm | 20 ++ 60 files changed, 1275 insertions(+), 418 deletions(-) create mode 100644 src/Partcl/commands/after.pm create mode 100644 src/Partcl/commands/append.pm create mode 100644 src/Partcl/commands/apply.pm create mode 100644 src/Partcl/commands/binary.pm create mode 100644 src/Partcl/commands/break.pm create mode 100644 src/Partcl/commands/catch.pm create mode 100644 src/Partcl/commands/cd.pm create mode 100644 src/Partcl/commands/concat.pm create mode 100644 src/Partcl/commands/continue.pm delete mode 100644 src/Partcl/commands/control.pm create mode 100644 src/Partcl/commands/eof.pm create mode 100644 src/Partcl/commands/error.pm create mode 100644 src/Partcl/commands/eval.pm create mode 100644 src/Partcl/commands/exit.pm create mode 100644 src/Partcl/commands/expr.pm create mode 100644 src/Partcl/commands/fileevent.pm create mode 100644 src/Partcl/commands/flush.pm create mode 100644 src/Partcl/commands/for.pm create mode 100644 src/Partcl/commands/foreach.pm create mode 100644 src/Partcl/commands/format.pm create mode 100644 src/Partcl/commands/gets.pm create mode 100644 src/Partcl/commands/glob.pm create mode 100644 src/Partcl/commands/global.pm create mode 100644 src/Partcl/commands/if.pm create mode 100644 src/Partcl/commands/incr.pm create mode 100644 src/Partcl/commands/join.pm create mode 100644 src/Partcl/commands/lappend.pm create mode 100644 src/Partcl/commands/lassign.pm create mode 100644 src/Partcl/commands/lindex.pm create mode 100644 src/Partcl/commands/linsert.pm create mode 100644 src/Partcl/commands/llength.pm create mode 100644 src/Partcl/commands/lrange.pm create mode 100644 src/Partcl/commands/lrepeat.pm create mode 100644 src/Partcl/commands/lreplace.pm create mode 100644 src/Partcl/commands/lreverse.pm create mode 100644 src/Partcl/commands/lset.pm create mode 100644 src/Partcl/commands/lsort.pm create mode 100644 src/Partcl/commands/proc.pm create mode 100644 src/Partcl/commands/puts.pm create mode 100644 src/Partcl/commands/pwd.pm create mode 100644 src/Partcl/commands/regexp.pm create mode 100644 src/Partcl/commands/rename.pm create mode 100644 src/Partcl/commands/return.pm create mode 100644 src/Partcl/commands/set.pm create mode 100644 src/Partcl/commands/socket.pm create mode 100644 src/Partcl/commands/source.pm create mode 100644 src/Partcl/commands/split.pm create mode 100644 src/Partcl/commands/subst.pm create mode 100644 src/Partcl/commands/switch.pm create mode 100644 src/Partcl/commands/time.pm create mode 100644 src/Partcl/commands/unset.pm create mode 100644 src/Partcl/commands/uplevel.pm create mode 100644 src/Partcl/commands/upvar.pm create mode 100644 src/Partcl/commands/variable.pm create mode 100644 src/Partcl/commands/vwait.pm create mode 100644 src/Partcl/commands/while.pm diff --git a/build/Makefile.in b/build/Makefile.in index 973b2c8..77f9499 100644 --- a/build/Makefile.in +++ b/build/Makefile.in @@ -27,18 +27,72 @@ GEN_SOURCES = \ src/Partcl/Compiler.pir \ src/Partcl/Grammar.pir \ src/Partcl/Operators.pir \ + src/Partcl/commands/after.pir \ + src/Partcl/commands/append.pir \ + src/Partcl/commands/apply.pir \ src/Partcl/commands/array.pir \ - src/Partcl/commands/control.pir \ + src/Partcl/commands/binary.pir \ + src/Partcl/commands/break.pir \ + src/Partcl/commands/catch.pir \ + src/Partcl/commands/cd.pir \ + src/Partcl/commands/concat.pir \ + src/Partcl/commands/continue.pir \ src/Partcl/commands/dict.pir \ + src/Partcl/commands/eof.pir \ + src/Partcl/commands/error.pir \ + src/Partcl/commands/eval.pir \ + src/Partcl/commands/exit.pir \ + src/Partcl/commands/expr.pir \ + src/Partcl/commands/fileevent.pir \ src/Partcl/commands/file.pir \ + src/Partcl/commands/flush.pir \ + src/Partcl/commands/foreach.pir \ + src/Partcl/commands/format.pir \ + src/Partcl/commands/for.pir \ + src/Partcl/commands/gets.pir \ + src/Partcl/commands/global.pir \ + src/Partcl/commands/glob.pir \ + src/Partcl/commands/if.pir \ + src/Partcl/commands/incr.pir \ src/Partcl/commands/info.pir \ src/Partcl/commands/interp.pir \ + src/Partcl/commands/join.pir \ + src/Partcl/commands/lappend.pir \ + src/Partcl/commands/lassign.pir \ + src/Partcl/commands/lindex.pir \ + src/Partcl/commands/linsert.pir \ src/Partcl/commands/list.pir \ + src/Partcl/commands/llength.pir \ + src/Partcl/commands/lrange.pir \ + src/Partcl/commands/lrepeat.pir \ + src/Partcl/commands/lreplace.pir \ + src/Partcl/commands/lreverse.pir \ + src/Partcl/commands/lset.pir \ + src/Partcl/commands/lsort.pir \ src/Partcl/commands/main.pir \ src/Partcl/commands/namespace.pir \ src/Partcl/commands/package.pir \ + src/Partcl/commands/proc.pir \ + src/Partcl/commands/puts.pir \ + src/Partcl/commands/pwd.pir \ + src/Partcl/commands/regexp.pir \ + src/Partcl/commands/rename.pir \ + src/Partcl/commands/return.pir \ + src/Partcl/commands/set.pir \ + src/Partcl/commands/socket.pir \ + src/Partcl/commands/source.pir \ + src/Partcl/commands/split.pir \ src/Partcl/commands/string.pir \ + src/Partcl/commands/subst.pir \ + src/Partcl/commands/switch.pir \ + src/Partcl/commands/time.pir \ src/Partcl/commands/trace.pir \ + src/Partcl/commands/unset.pir \ + src/Partcl/commands/uplevel.pir \ + src/Partcl/commands/upvar.pir \ + src/Partcl/commands/variable.pir \ + src/Partcl/commands/vwait.pir \ + src/Partcl/commands/while.pir \ src/TclArray.pir \ src/TclLexPad.pir \ src/TclList.pir \ diff --git a/src/Partcl.pir b/src/Partcl.pir index 788afe7..9e4baad 100644 --- a/src/Partcl.pir +++ b/src/Partcl.pir @@ -40,18 +40,72 @@ .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/after.pir' +.include 'src/Partcl/commands/append.pir' +.include 'src/Partcl/commands/apply.pir' .include 'src/Partcl/commands/array.pir' +.include 'src/Partcl/commands/binary.pir' +.include 'src/Partcl/commands/break.pir' +.include 'src/Partcl/commands/catch.pir' +.include 'src/Partcl/commands/cd.pir' +.include 'src/Partcl/commands/concat.pir' +.include 'src/Partcl/commands/continue.pir' .include 'src/Partcl/commands/dict.pir' +.include 'src/Partcl/commands/eof.pir' +.include 'src/Partcl/commands/error.pir' +.include 'src/Partcl/commands/eval.pir' +.include 'src/Partcl/commands/exit.pir' +.include 'src/Partcl/commands/expr.pir' +.include 'src/Partcl/commands/fileevent.pir' .include 'src/Partcl/commands/file.pir' +.include 'src/Partcl/commands/flush.pir' +.include 'src/Partcl/commands/foreach.pir' +.include 'src/Partcl/commands/format.pir' +.include 'src/Partcl/commands/for.pir' +.include 'src/Partcl/commands/gets.pir' +.include 'src/Partcl/commands/global.pir' +.include 'src/Partcl/commands/glob.pir' +.include 'src/Partcl/commands/if.pir' +.include 'src/Partcl/commands/incr.pir' .include 'src/Partcl/commands/info.pir' .include 'src/Partcl/commands/interp.pir' +.include 'src/Partcl/commands/join.pir' +.include 'src/Partcl/commands/lappend.pir' +.include 'src/Partcl/commands/lassign.pir' +.include 'src/Partcl/commands/lindex.pir' +.include 'src/Partcl/commands/linsert.pir' .include 'src/Partcl/commands/list.pir' +.include 'src/Partcl/commands/llength.pir' +.include 'src/Partcl/commands/lrange.pir' +.include 'src/Partcl/commands/lrepeat.pir' +.include 'src/Partcl/commands/lreplace.pir' +.include 'src/Partcl/commands/lreverse.pir' +.include 'src/Partcl/commands/lset.pir' +.include 'src/Partcl/commands/lsort.pir' +.include 'src/Partcl/commands/main.pir' .include 'src/Partcl/commands/namespace.pir' .include 'src/Partcl/commands/package.pir' +.include 'src/Partcl/commands/proc.pir' +.include 'src/Partcl/commands/puts.pir' +.include 'src/Partcl/commands/pwd.pir' +.include 'src/Partcl/commands/regexp.pir' +.include 'src/Partcl/commands/rename.pir' +.include 'src/Partcl/commands/return.pir' +.include 'src/Partcl/commands/set.pir' +.include 'src/Partcl/commands/socket.pir' +.include 'src/Partcl/commands/source.pir' +.include 'src/Partcl/commands/split.pir' .include 'src/Partcl/commands/string.pir' +.include 'src/Partcl/commands/subst.pir' +.include 'src/Partcl/commands/switch.pir' +.include 'src/Partcl/commands/time.pir' .include 'src/Partcl/commands/trace.pir' +.include 'src/Partcl/commands/unset.pir' +.include 'src/Partcl/commands/uplevel.pir' +.include 'src/Partcl/commands/upvar.pir' +.include 'src/Partcl/commands/variable.pir' +.include 'src/Partcl/commands/vwait.pir' +.include 'src/Partcl/commands/while.pir' .include 'src/TclArray.pir' .include 'src/TclLexPad.pir' .include 'src/TclList.pir' diff --git a/src/Partcl/commands/after.pm b/src/Partcl/commands/after.pm new file mode 100644 index 0000000..5c3de97 --- /dev/null +++ b/src/Partcl/commands/after.pm @@ -0,0 +1,7 @@ +our sub after(*@args) { + if +@args < 1 { + error('wrong # args: should be "after option ?arg arg ...?"') + } + pir::sleep__vN(+@args[0] / 1000); + ''; +} diff --git a/src/Partcl/commands/append.pm b/src/Partcl/commands/append.pm new file mode 100644 index 0000000..170d8d9 --- /dev/null +++ b/src/Partcl/commands/append.pm @@ -0,0 +1,30 @@ +our sub append(*@args) { + if +@args < 1 { + error('wrong # args: should be "append varName ?value value ...?"'); + } + + my $varName := @args.shift; + + my $var; + + # XXX bug compatibility - tcl errors if the var doesn't exist and there + # is nothing to append. See test file for ticket #. + + if !+@args { + $var := set($varName); + } else { + $var := Q:PIR { + .local pmc varname, lexpad + varname = find_lex '$varName' + lexpad = find_dynamic_lex '%LEXPAD' + %r = vivify lexpad, varname, ['TclString'] + }; + } + + my $result := set($varName); + while @args { + $result := ~$result ~ @args.shift; + } + + set($varName, $result); +} diff --git a/src/Partcl/commands/apply.pm b/src/Partcl/commands/apply.pm new file mode 100644 index 0000000..fd26d06 --- /dev/null +++ b/src/Partcl/commands/apply.pm @@ -0,0 +1,6 @@ +our sub apply(*@args) { + if +@args == 0 { + error('wrong # args: should be "apply lambdaExpr ?arg1 arg2 ...?"'); + } + ''; +} diff --git a/src/Partcl/commands/binary.pm b/src/Partcl/commands/binary.pm new file mode 100644 index 0000000..d13de8a --- /dev/null +++ b/src/Partcl/commands/binary.pm @@ -0,0 +1,23 @@ +our sub binary(*@args) { + error('wrong # args: should be "binary option ?arg arg ...?"') + if !+@args; + + my $subcommand := @args.shift(); + if $subcommand eq 'format' { + if +@args < 1 { + error('wrong # args: should be "binary format formatString ?arg arg ...?"'); + } + } elsif $subcommand eq 'scan' { + if +@args < 2 { + error('wrong # args: should be "binary scan value formatString ?varName varName ...?"'); + } + my $value := @args.shift(); + my $formatString := @args.shift(); + for @args -> $varName { + set($varName, ''); # XXX placeholder + } + } else { + error("bad option \"$subcommand\": must be format or scan"); + } + ''; +} diff --git a/src/Partcl/commands/break.pm b/src/Partcl/commands/break.pm new file mode 100644 index 0000000..aaccb0f --- /dev/null +++ b/src/Partcl/commands/break.pm @@ -0,0 +1,14 @@ +## use bare block to avoid catching control exceptions + +INIT { + GLOBAL::break := -> *@args { + if +@args { + error('wrong # args: should be "break"'); + } + my $exception := pir::new__ps('Exception'); + $exception := 65; # TCL_BREAK / CONTROL_LOOP_LAST + pir::throw($exception); + } +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/catch.pm b/src/Partcl/commands/catch.pm new file mode 100644 index 0000000..7cbb1ac --- /dev/null +++ b/src/Partcl/commands/catch.pm @@ -0,0 +1,36 @@ +our sub catch(*@args) { + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "catch script ?resultVarName? ?optionVarName?"'); + } + my $code := @args[0]; + + my $retval := 0; # TCL_OK + my $result; + try { + $result := Partcl::Compiler.eval($code); + CATCH { + $retval := 1; # TCL_ERROR + $result := $!; + } + CONTROL { + my $parrot_type := $!; + + # XXX using numeric type ids is fragile. + if $parrot_type == 57 { # CONTROL_RETURN + $retval := 2; # TCL_RETURN + } elsif $parrot_type == 65 { # CONTROL_LOOP_LAST + $retval := 3; # TCL_BREAK + } elsif $parrot_type == 64 { # CONTROL_LOOP_NEXT + $retval := 4; # TCL_CONTINUE + } else { + # This isn't a standard tcl control type. Give up. + pir::rethrow($!); + } + $result := $!; + } + }; + if +@args == 2 { + set(@args[1], $result); + } + $retval; +} diff --git a/src/Partcl/commands/cd.pm b/src/Partcl/commands/cd.pm new file mode 100644 index 0000000..bd6db8c --- /dev/null +++ b/src/Partcl/commands/cd.pm @@ -0,0 +1,14 @@ +# TODO: implement ~user syntax +our sub cd(*@args) { + if +@args > 1 { + error('wrong # args: should be "cd ?dirName?"'); + } + my $dir; + if @args == 1 { + $dir := @args[0]; + } else { + $dir := pir::new__ps('Env'); + } + my $OS := pir::new__ps('OS'); + $OS.chdir($dir); +} diff --git a/src/Partcl/commands/concat.pm b/src/Partcl/commands/concat.pm new file mode 100644 index 0000000..3916d5f --- /dev/null +++ b/src/Partcl/commands/concat.pm @@ -0,0 +1,7 @@ +our sub concat(*@args) { + my $result := @args ?? String::trim(@args.shift) !! ''; + while @args { + $result := $result ~ ' ' ~ String::trim(@args.shift); + } + $result; +} diff --git a/src/Partcl/commands/continue.pm b/src/Partcl/commands/continue.pm new file mode 100644 index 0000000..d7697cf --- /dev/null +++ b/src/Partcl/commands/continue.pm @@ -0,0 +1,11 @@ +## use bare block to avoid catching control exceptions + +INIT { + GLOBAL::continue := -> $message = '' { + my $exception := pir::new__ps('Exception'); + $exception := 64; # TCL_CONTINUE / CONTROL_LOOP_NEXT + pir::throw($exception); + } +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/control.pm b/src/Partcl/commands/control.pm deleted file mode 100644 index dde18bd..0000000 --- a/src/Partcl/commands/control.pm +++ /dev/null @@ -1,54 +0,0 @@ -## 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 := 65; # TCL_BREAK / CONTROL_LOOP_LAST - pir::throw($exception); - } -} - -INIT { - GLOBAL::continue := -> $message = '' { - my $exception := pir::new__ps('Exception'); - $exception := 64; # 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 := @args[1]; - my $errorCode := @args[2] // 'NONE'; - %GLOBALS := $errorCode; - } - - my $exception := pir::new__ps('Exception'); - # use EXCEPTION_SYNTAX_ERROR - just a generic type - $exception := 55; - $exception := $message; - pir::throw($exception); - } -} - -INIT { - GLOBAL::return := -> $result = '' { return $result; } -} - -# vim: filetype=perl6: diff --git a/src/Partcl/commands/eof.pm b/src/Partcl/commands/eof.pm new file mode 100644 index 0000000..4238e12 --- /dev/null +++ b/src/Partcl/commands/eof.pm @@ -0,0 +1,7 @@ +our sub eof(*@args) { + if +@args != 1 { + error('wrong # args: should be "eof channelId"') + } + my $chan := _getChannel(@args[0]); + 0; +} diff --git a/src/Partcl/commands/error.pm b/src/Partcl/commands/error.pm new file mode 100644 index 0000000..b833bf1 --- /dev/null +++ b/src/Partcl/commands/error.pm @@ -0,0 +1,27 @@ +## use bare block to avoid catching control exceptions + +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 := @args[1]; + my $errorCode := @args[2] // 'NONE'; + %GLOBALS := $errorCode; + } + + my $exception := pir::new__ps('Exception'); + # use EXCEPTION_SYNTAX_ERROR - just a generic type + $exception := 55; + $exception := $message; + pir::throw($exception); + } +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/eval.pm b/src/Partcl/commands/eval.pm new file mode 100644 index 0000000..81fc7d3 --- /dev/null +++ b/src/Partcl/commands/eval.pm @@ -0,0 +1,13 @@ +our sub eval(*@args) { + if +@args < 1 { + error('wrong # args: should be "eval arg ?arg ...?"'); + } + my $code := concat(|@args); + our %EVALCACHE; + my &sub := %EVALCACHE{$code}; + unless pir::defined__IP(&sub) { + &sub := Partcl::Compiler.compile($code); + %EVALCACHE{$code} := ⊂ + } + &sub(); +} diff --git a/src/Partcl/commands/exit.pm b/src/Partcl/commands/exit.pm new file mode 100644 index 0000000..aa5918c --- /dev/null +++ b/src/Partcl/commands/exit.pm @@ -0,0 +1,7 @@ +our sub exit(*@args) { + if +@args > 1 { + error('wrong # args: should be "exit ?returnCode?"'); + } + my $code := @args[0] // 0; + pir::exit__vi($code); +} diff --git a/src/Partcl/commands/expr.pm b/src/Partcl/commands/expr.pm new file mode 100644 index 0000000..935a8cf --- /dev/null +++ b/src/Partcl/commands/expr.pm @@ -0,0 +1,23 @@ +our sub expr(*@args) { + my $code := pir::join(' ', @args); + error("empty expression\nin expression \"\"") + if $code eq ''; + + our %EXPRCACHE; + my &sub := %EXPRCACHE{$code}; + unless pir::defined__IP(&sub) { + my $parse := + Partcl::Grammar.parse( + $code, + :rule('TOP_expr'), + :actions(Partcl::Actions) + ); + if $parse { + &sub := PAST::Compiler.compile($parse.ast); + %EXPRCACHE{$code} := ⊂ + } else { + error("Invalid expression"); + } + } + &sub(); +} diff --git a/src/Partcl/commands/fileevent.pm b/src/Partcl/commands/fileevent.pm new file mode 100644 index 0000000..ed7008e --- /dev/null +++ b/src/Partcl/commands/fileevent.pm @@ -0,0 +1,11 @@ +our sub fileevent(*@args) { + if +@args < 2 || +@args > 3 { + error('wrong # args: should be "fileevent channelId event ?script?"'); + } + my $channelId := @args.shift; + my $event := @args.shift; + if $event ne 'readable' || $event ne 'writable' { + error("bad event name \"$event\": must be readable or writable"); + } + ''; +} diff --git a/src/Partcl/commands/flush.pm b/src/Partcl/commands/flush.pm new file mode 100644 index 0000000..f72212f --- /dev/null +++ b/src/Partcl/commands/flush.pm @@ -0,0 +1,10 @@ +our sub flush(*@args) { + if +@args != 1 { + error('wrong # args: should be "flush channelId"'); + } + my $ioObj := _getChannel(@args[0]); + if pir::can__ips($ioObj, 'flush') { + $ioObj.flush(); + } + ''; +} diff --git a/src/Partcl/commands/for.pm b/src/Partcl/commands/for.pm new file mode 100644 index 0000000..b781ace --- /dev/null +++ b/src/Partcl/commands/for.pm @@ -0,0 +1,24 @@ +our sub for(*@args) { + if +@args != 4 { + error('wrong # args: should be "for start test next command"'); + } + my $init := @args[0]; + my $cond := @args[1]; + my $incr := @args[2]; + my $body := @args[3]; + + eval($init); + my $loop := 1; + while $loop && expr($cond) { + eval($body); + eval($incr); + CONTROL { + if $! == 64 { # CONTROL_LOOP_NEXT + eval($incr); + } elsif $! == 65 { # CONTROL_LOOP_LAST + $loop := 0; + } + } + } + ''; +} diff --git a/src/Partcl/commands/foreach.pm b/src/Partcl/commands/foreach.pm new file mode 100644 index 0000000..e1317b5 --- /dev/null +++ b/src/Partcl/commands/foreach.pm @@ -0,0 +1,55 @@ +our sub foreach(*@args) { + if +@args < 2 || +@args % 2 == 0 { + error('wrong # args: should be "foreach varList list ?varList list ...? command"'); + } + + my @varlists; + my @lists; + my $iterations := 0; + + my $body := @args.pop(); + my @varlist; + my @list; + for @args -> @varlist, @list { + @varlist := @varlist.getList(); + @list := @list.getList(); + + error('foreach varlist is empty') unless +@varlist; + + @varlists.push(@varlist); + @lists.push(@list); + + # elements in list are spread over varlist. make sure we're + # going to iterate only enough to cover. + my $count := pir::ceil__in(+@list / +@varlist); + $iterations := $count if $count > $iterations; + } + + my $iteration := 0; + while $iteration < $iterations { + $iteration++; + my $counter := 0; + while $counter < +@varlists { + my @varlist := @varlists[$counter]; + my @list := @lists[$counter]; + $counter++; + + my $I0 := 0; + while $I0 < +@varlist { + my $varname := @varlist[$I0++]; + + if +@list { + set($varname,pir::clone__pp(@list.shift())); + } else { + set($varname,''); + } + } + } + + my $result := 0; + + # let break and continue propagate to our surrounding while. + eval($body); + } + ''; +} diff --git a/src/Partcl/commands/format.pm b/src/Partcl/commands/format.pm new file mode 100644 index 0000000..2a0a1ad --- /dev/null +++ b/src/Partcl/commands/format.pm @@ -0,0 +1,7 @@ +our sub format(*@args) { + unless +@args { + error('wrong # args: should be "format formatString ?arg arg ...?"'); + } + + pir::sprintf__ssp(@args.shift(), @args) +} diff --git a/src/Partcl/commands/gets.pm b/src/Partcl/commands/gets.pm new file mode 100644 index 0000000..eb81440 --- /dev/null +++ b/src/Partcl/commands/gets.pm @@ -0,0 +1,24 @@ +our sub gets(*@args) { + our %CHANNELS; + + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "gets channelId ?varName?"'); + } + + my $channelId := @args[0]; + my $chanObj := %CHANNELS{$channelId}; + if (! pir::defined($chanObj) ) { + error("can not find channel named \"$channelId\""); + } + + my $result := pir::readline__sp($chanObj); + if pir::length__is($result) >0 && pir::substr__ssi($result, -1) eq "\n" { + $result := pir::chopn__ssi($result,1); + } + if +@args == 2 { + set(@args[1], $result); + return pir::length__is($result); + } else { + return $result; + } +} diff --git a/src/Partcl/commands/glob.pm b/src/Partcl/commands/glob.pm new file mode 100644 index 0000000..9ea1cfc --- /dev/null +++ b/src/Partcl/commands/glob.pm @@ -0,0 +1,22 @@ +our sub glob(*@args) { + my $dir := "."; + while @args[0] ne '--' && pir::substr(@args[0],0,1) eq '-' { + my $opt := @args.shift; + $dir := @args.shift if $opt eq '-directory'; + } + my @files := pir::new__ps('OS').readdir($dir); + my @globs; + for @args -> $pat { + @globs.push( FileGlob::Compiler.compile($pat) ); + } + + my @retval := pir::new__ps('TclList'); + for @files -> $f { + my $matched := 0; + for @globs -> $g { + $matched := 1 if ?Regex::Cursor.parse($f, :rule($g), :c(0)); + } + @retval.push($f) if $matched; + } + @retval; +} diff --git a/src/Partcl/commands/global.pm b/src/Partcl/commands/global.pm new file mode 100644 index 0000000..7359c0b --- /dev/null +++ b/src/Partcl/commands/global.pm @@ -0,0 +1,11 @@ +our sub global (*@args) { + our %GLOBALS; + + ## my %CUR_LEXPAD := DYNAMIC::<%LEXPAD> + my %CUR_LEXPAD := pir::find_dynamic_lex__Ps('%LEXPAD'); + + for @args { + %CUR_LEXPAD{$_} := %GLOBALS{$_}; + } + ''; +} diff --git a/src/Partcl/commands/if.pm b/src/Partcl/commands/if.pm new file mode 100644 index 0000000..b9d00be --- /dev/null +++ b/src/Partcl/commands/if.pm @@ -0,0 +1,25 @@ +our sub if(*@args) { + while @args { + my $expr := @args.shift; + my $body; + error('wrong # args: no script following "' ~ $expr ~ '" argument') + if !+@args; + + $body := @args.shift; + if $body eq 'then' { + error('wrong # args: no script following "then" argument') + if !+@args; + + $body := @args.shift; + } + if expr($expr) { return eval($body); } + if @args { + my $else := @args.shift; + if $else ne 'elseif' { + $else := @args.shift if $else eq 'else'; + return eval($else); + } + } + } + ''; +} diff --git a/src/Partcl/commands/incr.pm b/src/Partcl/commands/incr.pm new file mode 100644 index 0000000..0ea7fc8 --- /dev/null +++ b/src/Partcl/commands/incr.pm @@ -0,0 +1,17 @@ +our sub incr (*@args) { + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "incr varName ?increment?"'); + } + + my $var := @args[0]; + my $val := @args[1]; + + # incr auto-vivifies + try { + set($var); + CATCH { + set($var,0); + } + } + return set($var, pir::add__Iii(set($var), $val // 1)); +} diff --git a/src/Partcl/commands/join.pm b/src/Partcl/commands/join.pm new file mode 100644 index 0000000..3a776e3 --- /dev/null +++ b/src/Partcl/commands/join.pm @@ -0,0 +1,7 @@ +our sub join(*@args) { + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "join list ?joinString?"'); + } + + pir::join(@args[1] // " ", @args[0].getList()); +} diff --git a/src/Partcl/commands/lappend.pm b/src/Partcl/commands/lappend.pm new file mode 100644 index 0000000..d3abfcf --- /dev/null +++ b/src/Partcl/commands/lappend.pm @@ -0,0 +1,22 @@ +our sub lappend(*@args) { + if +@args < 1 { + error('wrong # args: should be "lappend varName ?value value ...?"'); + } + my $var := @args.shift(); + my @list; + # lappend auto-vivifies + try { + @list := set($var); + CATCH { + @list := set($var, pir::new__ps('TclList')); + } + } + @list := @list.getList(); + + for @args -> $elem { + @list.push($elem); + } + return set($var,@list); +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lassign.pm b/src/Partcl/commands/lassign.pm new file mode 100644 index 0000000..e71465d --- /dev/null +++ b/src/Partcl/commands/lassign.pm @@ -0,0 +1,19 @@ +our sub lassign(*@args) { + if +@args < 2 { + error('wrong # args: should be "lassign list varName ?varName ...?"'); + } + my @list := @args.shift().getList(); + my $listLen := +@list; + my $pos := 0; + for @args -> $var { + if $pos < $listLen { + set($var, @list.shift()); + } else { + set($var,''); + } + $pos++; + } + return @list; +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lindex.pm b/src/Partcl/commands/lindex.pm new file mode 100644 index 0000000..d3048e9 --- /dev/null +++ b/src/Partcl/commands/lindex.pm @@ -0,0 +1,30 @@ +our sub lindex(*@args) { + if +@args < 1 { + error('wrong # args: should be "lindex list ?index...?"'); + } + my $list := @args.shift(); + + my @indices; + if +@args == 0 { + return $list; + } elsif +@args == 1 { + @indices := @args[0].getList(); + } else { + @indices := @args; + } + + my $result := $list; + while (@indices) { + $result := $result.getList(); + my $index := $result.getIndex(@indices.shift()); # not a TclList? + my $size := +$result; + if $index < 0 || $index >= $size { + $result := ''; + } else { + $result := $result[$index]; + } + } + return $result; +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/linsert.pm b/src/Partcl/commands/linsert.pm new file mode 100644 index 0000000..14cf51b --- /dev/null +++ b/src/Partcl/commands/linsert.pm @@ -0,0 +1,21 @@ +our sub linsert(*@args) { + if +@args < 2 { + error('wrong # args: should be "linsert list index element ?element ...?"') + } + my @list := @args.shift().getList(); + + #if user says 'end', make sure we use the end (imagine one element list) + my $oIndex := @args.shift(); + my $index := @list.getIndex($oIndex); + if pir::substr__ssii($oIndex,0,3) eq 'end' { + $index++; + } else { + if $index > +@list { $index := +@list; } + if $index < 0 { $index := 0;} + } + + pir::splice__vppii(@list, @args, $index, 0); + return @list; +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/list.pm b/src/Partcl/commands/list.pm index ddf43de..c482413 100644 --- a/src/Partcl/commands/list.pm +++ b/src/Partcl/commands/list.pm @@ -1,366 +1,5 @@ -# all list-related commands - -our sub lappend(*@args) { - if +@args < 1 { - error('wrong # args: should be "lappend varName ?value value ...?"'); - } - my $var := @args.shift(); - my @list; - # lappend auto-vivifies - try { - @list := set($var); - CATCH { - @list := set($var, pir::new__ps('TclList')); - } - } - @list := @list.getList(); - - for @args -> $elem { - @list.push($elem); - } - return set($var,@list); -} - -our sub lassign(*@args) { - if +@args < 2 { - error('wrong # args: should be "lassign list varName ?varName ...?"'); - } - my @list := @args.shift().getList(); - my $listLen := +@list; - my $pos := 0; - for @args -> $var { - if $pos < $listLen { - set($var, @list.shift()); - } else { - set($var,''); - } - $pos++; - } - return @list; -} - -our sub linsert(*@args) { - if +@args < 2 { - error('wrong # args: should be "linsert list index element ?element ...?"') - } - my @list := @args.shift().getList(); - - #if user says 'end', make sure we use the end (imagine one element list) - my $oIndex := @args.shift(); - my $index := @list.getIndex($oIndex); - if pir::substr__ssii($oIndex,0,3) eq 'end' { - $index++; - } else { - if $index > +@list { $index := +@list; } - if $index < 0 { $index := 0;} - } - - pir::splice__vppii(@list, @args, $index, 0); - return @list; -} - our sub list(*@args) { return @args; } -our sub lindex(*@args) { - if +@args < 1 { - error('wrong # args: should be "lindex list ?index...?"'); - } - my $list := @args.shift(); - - my @indices; - if +@args == 0 { - return $list; - } elsif +@args == 1 { - @indices := @args[0].getList(); - } else { - @indices := @args; - } - - my $result := $list; - while (@indices) { - $result := $result.getList(); - my $index := $result.getIndex(@indices.shift()); # not a TclList? - my $size := +$result; - if $index < 0 || $index >= $size { - $result := ''; - } else { - $result := $result[$index]; - } - } - return $result; -} - -our sub llength(*@args) { - if +@args != 1 { - error('wrong # args: should be "llength list"') - } - - +@args[0].getList(); -} - -our sub lrange(*@args) { - if +@args != 3 { - error('wrong # args: should be "lrange list first last"') - } - my @list := @args[0].getList(); - my $from := @list.getIndex(@args[1]); - my $to := @list.getIndex(@args[2]); - - if $from < 0 { $from := 0} - my $listLen := +@list; - if $to > $listLen { $to := $listLen - 1 } - - my @retval := pir::new__ps('TclList'); - while $from <= $to { - @retval.push(@list[$from]); - $from++; - } - return @retval; -} - - -our sub lrepeat(*@args) { - if +@args < 2 { - error('wrong # args: should be "lrepeat positiveCount value ?value ...?"'); - } - my $count := @args.shift.getInteger(); - if $count < 1 { - error('must have a count of at least 1'); - } - my @result := pir::new__ps('TclList'); - while $count { - for @args -> $elem { - @result.push($elem); - } - $count--; - } - return @result; -} - -our sub lreplace(*@args) { - if +@args < 3 { - error('wrong # args: should be "lreplace list first last ?element element ...?"'); - } - - my @list := pir::clone__pp(@args.shift().getList()); - - my $first := @list.getIndex(@args.shift()); - my $last := @list.getIndex(@args.shift()); - - if +@list == 0 { - pir::splice__vppii(@list, @args, 0, 0); - return @list; - } - - $last := +@list -1 if $last >= +@list; - $first := 0 if $first < 0; - - if $first >= +@list { - error("list doesn't contain element $first"); - } - - my $count := $last - $first + 1; - if $count >= 0 { - pir::splice__vppii(@list, @args, $first, $count); - return @list; - } - - pir::splice__vppii(@list, @args, $first, 0); - return @list; -} - -our sub lreverse(*@args) { - if +@args != 1 { - error('wrong # args: should be "lreverse list"'); - } - return @args[0].getList().reverse(); -} - -our sub lset(*@args) { - if +@args < 2 { - error('wrong # args: should be "lset listVar index ?index...? value"'); - } - - my $name := @args.shift; - my $value := @args.pop; - - my $original_list := set($name); # Error if $name not found - don't viv - - if @args == 0 - || (@args == 1 && @args[0].getList == 0) { - set($name, $value); - } - else { - if pir::isa__ips($original_list, 'String') { - $original_list := pir::box__ps($original_list); - } - - my @result := pir::clone__pp($original_list).getList; - my @sublist := @result; - my @previous; - my $index; - - for @args -> $arg { - @previous := @sublist; - - $index := @previous.getIndex: $arg; - - if $index < 0 || $index >= @previous { - error('list index out of range'); - } - - if pir::typeof__sp(@previous[$index]) eq 'String' { - @previous[$index] := pir::box__ps(@previous[$index]); - } - - @previous[$index] := @sublist := @previous[$index].getList; - } - - @previous[$index] := $value; - set($name, @result); - } -} - -our sub lsort(*@args) { - - error('wrong # args: should be "lsort ?options? list"') - unless +@args; - - # Set defaults - my $compare := sort_ascii; - my $decr := 0; - my $unique := 0; - - my @list := @args.pop().getList(); - - for @args -> $key { - if $key eq '-decreasing' { - $decr := 1; - } elsif $key eq '-increasing' { - $decr := 0; - } elsif $key eq '-unique' { - $unique := 1; - } elsif $key eq '-integer' { - $compare := sort_integer; - } elsif $key eq '-real' { - $compare := sort_real; - } elsif $key eq '-dictionary' { - $compare := sort_dictionary; - } elsif $key eq '-command' { - $compare := error("NYI"); - } else { - error("bad option \"$key\": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique"); - } - } - - # XXX need the assigns? - @list.sort($compare); - - if $unique { - my @uniqued := pir::new__ps('TclList'); - my $last; - for @list -> $element { - if !+@uniqued || $element ne $last { - @uniqued.push($element); - } - $last := $element; - } - @list := @uniqued; - } - - @list.'reverse'() if $decr; - - @list; -} - -my sub sort_ascii($a, $b) { - pir::cmp__iss($a, $b); -} - -my sub sort_integer($a, $b) { - # XXX defensively avoid changing the string value of these pmcs. - pir::cmp__iii(pir::clone($a), pir::clone($b)); -} - -my sub sort_real($a, $b) { - pir::cmp__inn(pir::clone($a), pir::clone($b)); -} - -=begin fromPartcl - -.sub 'dictionary' - .param string s1 - .param string s2 - - .include 'cclass.pasm' - - .local int len1, len2, pos1, pos2 - len1 = length s1 - len2 = length s2 - pos1 = 0 - pos2 = 0 -loop: - if pos1 >= len1 goto end1 - if pos2 >= len2 goto greater - - $I0 = is_cclass .CCLASS_NUMERIC, s1, pos1 - if $I0 goto numeric - $I0 = is_cclass .CCLASS_NUMERIC, s2, pos2 - if $I0 goto numeric - - .local string char1, char2, sortchar1, sortchar2 - char1 = substr s1, pos1, 1 - char2 = substr s2, pos2, 1 - sortchar1 = downcase char1 - sortchar2 = downcase char2 - if sortchar1 != sortchar2 goto got_chars - sortchar1 = char1 - sortchar2 = char2 - -got_chars: - $I1 = ord sortchar1 - $I2 = ord sortchar2 - - inc pos1 - inc pos2 - goto compare - -numeric: - $I3 = find_not_cclass .CCLASS_NUMERIC, s1, pos1, len1 - if $I3 == pos1 goto greater - - $I4 = find_not_cclass .CCLASS_NUMERIC, s2, pos2, len2 - if $I4 == pos2 goto less - - $I5 = $I3 - pos1 - $I6 = $I4 - pos2 - $S1 = substr s1, pos1, $I5 - $S2 = substr s2, pos2, $I6 - pos1 = $I3 - pos2 = $I4 - $I1 = $S1 - $I2 = $S2 - -compare: - if $I1 < $I2 goto less - if $I1 > $I2 goto greater - goto loop - -end1: - if len1 == len2 goto equal - -less: - .return(-1) - -equal: - .return(0) - -greater: - .return(1) -.end - -=end fromPartcl - # vim: filetype=perl6: diff --git a/src/Partcl/commands/llength.pm b/src/Partcl/commands/llength.pm new file mode 100644 index 0000000..1ea4b34 --- /dev/null +++ b/src/Partcl/commands/llength.pm @@ -0,0 +1,9 @@ +our sub llength(*@args) { + if +@args != 1 { + error('wrong # args: should be "llength list"') + } + + +@args[0].getList(); +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lrange.pm b/src/Partcl/commands/lrange.pm new file mode 100644 index 0000000..66d25d5 --- /dev/null +++ b/src/Partcl/commands/lrange.pm @@ -0,0 +1,21 @@ +our sub lrange(*@args) { + if +@args != 3 { + error('wrong # args: should be "lrange list first last"') + } + my @list := @args[0].getList(); + my $from := @list.getIndex(@args[1]); + my $to := @list.getIndex(@args[2]); + + if $from < 0 { $from := 0} + my $listLen := +@list; + if $to > $listLen { $to := $listLen - 1 } + + my @retval := pir::new__ps('TclList'); + while $from <= $to { + @retval.push(@list[$from]); + $from++; + } + return @retval; +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lrepeat.pm b/src/Partcl/commands/lrepeat.pm new file mode 100644 index 0000000..5cfae93 --- /dev/null +++ b/src/Partcl/commands/lrepeat.pm @@ -0,0 +1,19 @@ +our sub lrepeat(*@args) { + if +@args < 2 { + error('wrong # args: should be "lrepeat positiveCount value ?value ...?"'); + } + my $count := @args.shift.getInteger(); + if $count < 1 { + error('must have a count of at least 1'); + } + my @result := pir::new__ps('TclList'); + while $count { + for @args -> $elem { + @result.push($elem); + } + $count--; + } + return @result; +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lreplace.pm b/src/Partcl/commands/lreplace.pm new file mode 100644 index 0000000..9efba87 --- /dev/null +++ b/src/Partcl/commands/lreplace.pm @@ -0,0 +1,33 @@ +our sub lreplace(*@args) { + if +@args < 3 { + error('wrong # args: should be "lreplace list first last ?element element ...?"'); + } + + my @list := pir::clone__pp(@args.shift().getList()); + + my $first := @list.getIndex(@args.shift()); + my $last := @list.getIndex(@args.shift()); + + if +@list == 0 { + pir::splice__vppii(@list, @args, 0, 0); + return @list; + } + + $last := +@list -1 if $last >= +@list; + $first := 0 if $first < 0; + + if $first >= +@list { + error("list doesn't contain element $first"); + } + + my $count := $last - $first + 1; + if $count >= 0 { + pir::splice__vppii(@list, @args, $first, $count); + return @list; + } + + pir::splice__vppii(@list, @args, $first, 0); + return @list; +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lreverse.pm b/src/Partcl/commands/lreverse.pm new file mode 100644 index 0000000..8369144 --- /dev/null +++ b/src/Partcl/commands/lreverse.pm @@ -0,0 +1,8 @@ +our sub lreverse(*@args) { + if +@args != 1 { + error('wrong # args: should be "lreverse list"'); + } + return @args[0].getList().reverse(); +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lset.pm b/src/Partcl/commands/lset.pm new file mode 100644 index 0000000..aee2243 --- /dev/null +++ b/src/Partcl/commands/lset.pm @@ -0,0 +1,46 @@ +our sub lset(*@args) { + if +@args < 2 { + error('wrong # args: should be "lset listVar index ?index...? value"'); + } + + my $name := @args.shift; + my $value := @args.pop; + + my $original_list := set($name); # Error if $name not found - don't viv + + if @args == 0 + || (@args == 1 && @args[0].getList == 0) { + set($name, $value); + } + else { + if pir::isa__ips($original_list, 'String') { + $original_list := pir::box__ps($original_list); + } + + my @result := pir::clone__pp($original_list).getList; + my @sublist := @result; + my @previous; + my $index; + + for @args -> $arg { + @previous := @sublist; + + $index := @previous.getIndex: $arg; + + if $index < 0 || $index >= @previous { + error('list index out of range'); + } + + if pir::typeof__sp(@previous[$index]) eq 'String' { + @previous[$index] := pir::box__ps(@previous[$index]); + } + + @previous[$index] := @sublist := @previous[$index].getList; + } + + @previous[$index] := $value; + set($name, @result); + } +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/lsort.pm b/src/Partcl/commands/lsort.pm new file mode 100644 index 0000000..355ffd5 --- /dev/null +++ b/src/Partcl/commands/lsort.pm @@ -0,0 +1,66 @@ +our sub lsort(*@args) { + + error('wrong # args: should be "lsort ?options? list"') + unless +@args; + + # Set defaults + my $compare := sort_ascii; + my $decr := 0; + my $unique := 0; + + my @list := @args.pop().getList(); + + for @args -> $key { + if $key eq '-decreasing' { + $decr := 1; + } elsif $key eq '-increasing' { + $decr := 0; + } elsif $key eq '-unique' { + $unique := 1; + } elsif $key eq '-integer' { + $compare := sort_integer; + } elsif $key eq '-real' { + $compare := sort_real; + } elsif $key eq '-dictionary' { + $compare := sort_dictionary; + } elsif $key eq '-command' { + $compare := error("NYI"); + } else { + error("bad option \"$key\": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique"); + } + } + + # XXX need the assigns? + @list.sort($compare); + + if $unique { + my @uniqued := pir::new__ps('TclList'); + my $last; + for @list -> $element { + if !+@uniqued || $element ne $last { + @uniqued.push($element); + } + $last := $element; + } + @list := @uniqued; + } + + @list.'reverse'() if $decr; + + @list; +} + +my sub sort_ascii($a, $b) { + pir::cmp__iss($a, $b); +} + +my sub sort_integer($a, $b) { + # XXX defensively avoid changing the string value of these pmcs. + pir::cmp__iii(pir::clone($a), pir::clone($b)); +} + +my sub sort_real($a, $b) { + pir::cmp__inn(pir::clone($a), pir::clone($b)); +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/proc.pm b/src/Partcl/commands/proc.pm new file mode 100644 index 0000000..2425a88 --- /dev/null +++ b/src/Partcl/commands/proc.pm @@ -0,0 +1,61 @@ +our sub proc(*@args) { + if +@args != 3 { + error('wrong # args: should be "proc name args body"'); + } + + my $name := @args[0]; + my $args := @args[1]; + my $body := @args[2]; + + my $parse := + Partcl::Grammar.parse( $body, :rule, :actions(Partcl::Actions) ); + my $block := $parse.ast; + my @params := $args.getList(); + my @argsInfo := pir::new__Ps('TclList'); + my %defaults := pir::new__Ps('TclArray'); + + for @params { + my @argument := $_.getList(); + + if +@argument == 1 { + $block[0].push( + PAST::Op.new( :pasttype, + PAST::Var.new( :scope, + PAST::Var.new( :name('lexpad'), :scope ), + $_ + ), + PAST::Var.new( :scope ) + ) + ); + @argsInfo.push($_); + %defaults{$_} := pir::new__Ps('Undef'); + } elsif +@argument == 2 { + $block[0].push( + PAST::Op.new( :pasttype, + PAST::Var.new( :scope, + PAST::Var.new( :name('lexpad'), :scope ), + @argument[0] + ), + PAST::Var.new( + :scope, + :viviself(PAST::Val.new( :value(@argument[1]) )) + ) + ) + ); + @argsInfo.push(@argument[0]); + %defaults{@argument[0]} := @argument[1]; + } else { + error("too many fields in argument specifier \"$_\""); + } + + + } + $block.name($name); + $block.control('return_pir'); + PAST::Compiler.compile($block); + my $thing := pir::get_hll_global__PS($name); + pir::setprop($thing, 'args', @argsInfo); + pir::setprop($thing, 'defaults', %defaults); + pir::setprop($thing, 'body', $body); + ''; +} diff --git a/src/Partcl/commands/puts.pm b/src/Partcl/commands/puts.pm new file mode 100644 index 0000000..59a1676 --- /dev/null +++ b/src/Partcl/commands/puts.pm @@ -0,0 +1,21 @@ +our sub puts(*@args) { + our %CHANNELS; + + my $nl := 1; + if @args[0] eq '-nonewline' { + @args.shift; $nl := 0; + } + my $channelId; + if +@args == 1 { + $channelId := 'stdout'; + } else { + $channelId := @args.shift; + } + my $chanObj := %CHANNELS{$channelId}; + if (! pir::defined($chanObj) ) { + error("can not find channel named \"$channelId\""); + } + pir::print__vps($chanObj, @args[0]); + pir::print__vps($chanObj, "\n") if $nl; + ''; +} diff --git a/src/Partcl/commands/pwd.pm b/src/Partcl/commands/pwd.pm new file mode 100644 index 0000000..f75cb92 --- /dev/null +++ b/src/Partcl/commands/pwd.pm @@ -0,0 +1,3 @@ +our sub pwd () { + pir::new__ps('OS').'cwd'(); +} diff --git a/src/Partcl/commands/regexp.pm b/src/Partcl/commands/regexp.pm new file mode 100644 index 0000000..3186094 --- /dev/null +++ b/src/Partcl/commands/regexp.pm @@ -0,0 +1,20 @@ +our sub regexp(*@args) { + error('wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"') + if +@args < 2; + + my $exp := @args.shift(); + my $string := @args.shift(); + + my $regex := ARE::Compiler.compile($exp); + my $match := Regex::Cursor.parse($string, :rule($regex), :c(0)); + + # XXX Set ALL the sub match strings to the main string + for @args -> $varname { + set($varname, $match.Str()); + } + + ## my &dumper := Q:PIR { %r = get_root_global ['parrot'], '_dumper' }; + ## &dumper(ARE::Compiler.compile($exp, :target)); + + ?$match; +} diff --git a/src/Partcl/commands/rename.pm b/src/Partcl/commands/rename.pm new file mode 100644 index 0000000..b6c9ec5 --- /dev/null +++ b/src/Partcl/commands/rename.pm @@ -0,0 +1,12 @@ +our sub rename(*@args) { + if +@args != 2 { + error('wrong # args: should be "rename oldName newName"'); + } + if @args[1] eq "" { + # delete sub. + my $ns := pir::get_hll_namespace__P(); + pir::delete__vQs($ns, @args[0]); + } else { + # XXX actually rename + } +} diff --git a/src/Partcl/commands/return.pm b/src/Partcl/commands/return.pm new file mode 100644 index 0000000..5caec30 --- /dev/null +++ b/src/Partcl/commands/return.pm @@ -0,0 +1,7 @@ +## use bare block to avoid catching control exceptions + +INIT { + GLOBAL::return := -> $result = '' { return $result; } +} + +# vim: filetype=perl6: diff --git a/src/Partcl/commands/set.pm b/src/Partcl/commands/set.pm new file mode 100644 index 0000000..d0886d8 --- /dev/null +++ b/src/Partcl/commands/set.pm @@ -0,0 +1,60 @@ +our sub set(*@args) { + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "set varName ?newValue?"'); + } + my $varname := @args[0]; + my $value := @args[1]; + + # Does it look like foo(bar) ? + # XXX Can we use the variable term in the grammar for this? + my $result; + if pir::ord__isi($varname, -1) == 41 && pir::index__iss($varname, '(' ) != -1 { + # find the variable name and key name + my $left_paren := pir::index__iss($varname, '('); + my $right_paren := pir::index__iss($varname, ')'); + my $keyname := pir::substr__ssii($varname, $left_paren+1, $right_paren-$left_paren-1); + my $arrayname := pir::substr__ssii($varname, 0, $left_paren); + + if +@args == 2 { # set + my $var := Q:PIR { + .local pmc varname, lexpad + varname = find_lex '$arrayname' + lexpad = find_dynamic_lex '%LEXPAD' + %r = vivify lexpad, varname, ['TclArray'] + }; + if !pir::isa($var, 'TclArray') { + error("can't set \"$varname\": variable isn't array"); + } + $var{$keyname} := $value; + $result := $var{$keyname}; + } else { # get + my $lexpad := pir::find_dynamic_lex('%LEXPAD'); + my $var := $lexpad{$arrayname}; + if pir::isnull($var) { + error("can't read \"$varname\": no such variable"); + } elsif !pir::isa($var, 'TclArray') { + error("can't read \"$varname\": variable isn't array"); + } elsif pir::isnull($var{$keyname}) { + error("can't read \"$varname($keyname)\": no such element in array"); + } else { + $result := $var{$keyname}; + } + } + } else { + # scalar + $result := Q:PIR { + .local pmc varname, lexpad + varname = find_lex '$varname' + lexpad = find_dynamic_lex '%LEXPAD' + %r = vivify lexpad, varname, ['Undef'] + }; + if pir::isa($result, 'TclArray') { + error("can't set \"$varname\": variable is array"); + } elsif pir::defined($value) { + pir::copy__0PP($result, $value) + } elsif ! pir::defined($result) { + error("can't read \"$varname\": no such variable"); + } + } + $result; +} diff --git a/src/Partcl/commands/socket.pm b/src/Partcl/commands/socket.pm new file mode 100644 index 0000000..2fc04a4 --- /dev/null +++ b/src/Partcl/commands/socket.pm @@ -0,0 +1,3 @@ +our sub socket(*@args) { + ''; +} diff --git a/src/Partcl/commands/source.pm b/src/Partcl/commands/source.pm new file mode 100644 index 0000000..c2599f0 --- /dev/null +++ b/src/Partcl/commands/source.pm @@ -0,0 +1,3 @@ +our sub source($filename) { + Partcl::Compiler.evalfiles($filename); +} diff --git a/src/Partcl/commands/split.pm b/src/Partcl/commands/split.pm new file mode 100644 index 0000000..96e4ce4 --- /dev/null +++ b/src/Partcl/commands/split.pm @@ -0,0 +1,38 @@ +our sub split(*@args) { + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "split string ?splitChars?"') + } + + my $string := ~@args[0]; + my $splitChars := @args[1] // " \r\n\t"; + + if $string eq '' { + return list(); + } + + if $splitChars eq '' { + return pir::split__Pss('',$string); + } + + my @result; + my $element := ''; + for $string -> $char { + my $active := 1; + for $splitChars -> $sc { + if $active { + if $char eq $sc { + @result.push($element); + $element := ''; + $active := 0; + } + } + } + if $active { + $element := $element ~ $char; + } + }; + @result.push($element); + + @result := list(|@result); # convert to a TclList + @result; +} diff --git a/src/Partcl/commands/subst.pm b/src/Partcl/commands/subst.pm new file mode 100644 index 0000000..f6060b5 --- /dev/null +++ b/src/Partcl/commands/subst.pm @@ -0,0 +1,3 @@ +our sub subst(*@args) { + ''; +} diff --git a/src/Partcl/commands/switch.pm b/src/Partcl/commands/switch.pm new file mode 100644 index 0000000..f1ff7b2 --- /dev/null +++ b/src/Partcl/commands/switch.pm @@ -0,0 +1,50 @@ +our sub switch(*@args) { + if +@args < 2 { + error('wrong # args: should be "switch ?switches? string pattern body ... ?default body?"'); + } + + my $regex := 0; + my $glob := 0; + my $nocase := 0; + if +@args != 2 { + while @args[0] ne '--' && pir::substr(@args[0],0,1) eq '-' { + my $opt := @args.shift; + $regex := 1 if $opt eq '-regex'; + $glob := 1 if $opt eq '-glob'; + $nocase := 1 if $opt eq '-nocase'; + } + @args.shift if @args[0] eq '--'; + } + # else, only 2 options, must be 2nd variant. + + my $string := @args.shift(); + if +@args == 1 { + # list form; expand the list. + @args := @args[0].getList(); + error('wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"') + unless +@args; + } + if +@args % 2 == 1 { + error('extra switch pattern with no body'); + } + while @args { + my $pat := @args.shift; + my $body := @args.shift; + if $nocase { + $pat := pir::downcase($pat); + $string := pir::downcase($string); + } + my $cmp := $string eq $pat; + if $regex { + my $re := ARE::Compiler.compile($pat); + $cmp := ?Regex::Cursor.parse($string, :rule($re), :c(0)); + } + if $glob { + my $globber := StringGlob::Compiler.compile($pat); + $cmp := ?Regex::Cursor.parse($string, :rule($globber), :c(0)); + } + if $cmp || (+@args == 0 && $pat eq 'default') { + return eval($body); + } + } +} diff --git a/src/Partcl/commands/time.pm b/src/Partcl/commands/time.pm new file mode 100644 index 0000000..90f46d4 --- /dev/null +++ b/src/Partcl/commands/time.pm @@ -0,0 +1,30 @@ +our sub time(*@args) { + if +@args < 1 || +@args > 2 { + error('wrong # args: should be "time command ?count?"'); + } + + my $command := @args[0]; + my $count; + if +@args == 2 { + $count := pir::set__iP(@args[1]); + } else { + $count := 1; + } + + if $count == 0 { + return '0 microseconds per iteration'; + } + + my $start := pir::time__N(); + + my $loop := pir::set__IP($count); + while $loop { + eval($command); + $loop--; + } + my $end := pir::time__N(); + + my $ms_per := pir::set__IP(($end-$start)*1000000 / $count); + + $ms_per ~ ' microseconds per iteration'; +} diff --git a/src/Partcl/commands/unset.pm b/src/Partcl/commands/unset.pm new file mode 100644 index 0000000..fcbf246 --- /dev/null +++ b/src/Partcl/commands/unset.pm @@ -0,0 +1,22 @@ +our sub unset(*@args) { + my $lexpad := pir::find_dynamic_lex('%LEXPAD'); + my $quiet := 0; + if +@args && @args[0] eq '-nocomplain' { + $quiet := 1; + @args.shift(); + } + for @args -> $varname { + my $var := $lexpad{$varname}; + if !pir::defined($var) { + error("can't unset \"$varname\": no such variable") + unless $quiet; + } else { + Q:PIR { + $P1 = find_lex '$lexpad' + $P2 = find_lex '$varname' + delete $P1[$P2] + } + } + } + ''; +} diff --git a/src/Partcl/commands/uplevel.pm b/src/Partcl/commands/uplevel.pm new file mode 100644 index 0000000..75dade2 --- /dev/null +++ b/src/Partcl/commands/uplevel.pm @@ -0,0 +1,19 @@ +our sub uplevel($level, *@args) { + ## my %LEXPAD := DYNAMIC::<%LEXPAD> + my %LEXPAD := pir::find_dynamic_lex__Ps('%LEXPAD'); + + ## 0x23 == '#' + if pir::ord($level) == 0x23 { + $level := %LEXPAD.depth - pir::substr($level, 1); + } + + ## walk up the chain of outer contexts + while $level > 0 { + %LEXPAD := %LEXPAD.outer; + $level := $level - 1; + } + + ## now evaluate @args in the current context + my $code := concat(|@args); + Partcl::Compiler.eval($code); +} diff --git a/src/Partcl/commands/upvar.pm b/src/Partcl/commands/upvar.pm new file mode 100644 index 0000000..c4dc15d --- /dev/null +++ b/src/Partcl/commands/upvar.pm @@ -0,0 +1,39 @@ +our sub upvar(*@args) { + my $usage := 'wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"'; + error($usage) unless +@args > 1; + + my %LEXPAD := pir::find_dynamic_lex__Ps('%LEXPAD'); + + my $peekLevel := @args[0]; + my $level := 1; + + ## 0x23 == '#' + if pir::ord($peekLevel) == 0x23 { + $level := %LEXPAD.depth - pir::substr($level, 1); + @args.shift(); + } elsif ~+$peekLevel eq $peekLevel { + # XXX need real isInt check.. + $level := $peekLevel; + @args.shift(); + } + + # Rest of the arguments must be paired up. + error($usage) if +@args % 2; + + my %curLEXPAD := %LEXPAD; + + # Walk up chain. + while $level > 0 { + %LEXPAD := %LEXPAD.outer; + $level := $level - 1; + } + + for @args -> $old_var, $new_var { + if pir::exists__iQs(%curLEXPAD, $new_var) { + error("variable \"$new_var\" already exists"); + } + %curLEXPAD{$new_var} := %LEXPAD{$old_var}; + } + + ''; +} diff --git a/src/Partcl/commands/variable.pm b/src/Partcl/commands/variable.pm new file mode 100644 index 0000000..07ae81e --- /dev/null +++ b/src/Partcl/commands/variable.pm @@ -0,0 +1,5 @@ +our sub variable(*@args) { + error('wrong # args: should be "variable ?name value...? name ?value?"') + unless +@args; + ''; +} diff --git a/src/Partcl/commands/vwait.pm b/src/Partcl/commands/vwait.pm new file mode 100644 index 0000000..f3b52bf --- /dev/null +++ b/src/Partcl/commands/vwait.pm @@ -0,0 +1,6 @@ +our sub vwait(*@args) { + if +@args != 1 { + error('wrong # args: should be "vwait name"'); + } + ''; +} diff --git a/src/Partcl/commands/while.pm b/src/Partcl/commands/while.pm new file mode 100644 index 0000000..19b7a00 --- /dev/null +++ b/src/Partcl/commands/while.pm @@ -0,0 +1,10 @@ +our sub while (*@args) { + if +@args != 2 { + error('wrong # args: should be "while test command"'); + } + my $cond := @args[0]; + my $body := @args[1]; + while expr($cond) { + eval($body); + } +} diff --git a/src/init.pm b/src/init.pm index 5786cb3..96e1b93 100644 --- a/src/init.pm +++ b/src/init.pm @@ -56,4 +56,24 @@ sub P6metaclass() { }; } +## EXPAND is a helper sub for {*} argument expansion; it probably +## doesn't belong in the global namespace but this is a convenient +## place to test it for now. It takes a string and splits it up +## into a list of elements, honoring braces and backslash +## expansion (similar to the Tcl_SplitList function). The actual +## parsing and expansion is handled by the token in +## Partcl::Grammar . + +our sub EXPAND($args) { + $args.getList(); +} + +sub dumper($what, $label = 'VAR1') { + pir::load_bytecode('dumper.pbc'); + my &dumper := Q:PIR { + %r = get_root_global ['parrot'], '_dumper' + }; + &dumper($what, $label); +} + # vim: filetype=perl6: