package Seis::Compiler; use strict; use warnings; use utf8; use 5.010_001; use Perl6::PVIP 0.07; use Carp (); use Data::Dumper (); use Encode (); use Seis::Runtime; use constant { G_VOID => 1, G_SCALAR => 2, G_ARRAY => 3, }; # `no warnings 'misc'` suppress `"our" variable $x redeclared` message # in `our $x; { my $x; { our $x}}` our $HEADER = <<'...'; package # Hide from PAUSE Main; use strict; use 5.018_000; use utf8; no warnings "experimental::smartmatch"; no warnings "experimental::lexical_subs"; use feature "lexical_subs"; use Seis::Autobox; use List::Util qw(min max); use Seis::Runtime; use POSIX qw(floor); no warnings 'misc', 'void'; BEGIN { *gcd = *Seis::BuiltinFunctions::gcd; *Int = *Seis::Runtime::Int; *Mu = *Seis::Runtime::Mu; *Array = *Seis::Runtime::Array; *True = *Bool::True; } ... sub new { my $class = shift; return bless {}, $class; } sub compile { my ($self, $src, $filename) = @_; $filename //= '-e'; local $self->{filename} = $filename; local $self->{line_number} = 0; my $parser = Perl6::PVIP->new(); my $node = $parser->parse_string($src) or Seis::Exception::ParsingError->throw("Can't parse $filename:\n" . $parser->errstr); return join('', $HEADER, qq{#line 1 "$filename"\n}, $self->do_compile($node) ); } sub do_compile { my ($self, $node, $gimme) = @_; $gimme //= G_SCALAR; Carp::confess "Invalid node" unless ref $node; my $v = $node->value; my $type = $node->type; if ($type == PVIP_NODE_STATEMENTS) { my $ret; for (my $i=0; $i<@$v; $i++) { next if $v->[$i]->type == PVIP_NODE_NOP; # $ret .= sprintf("# NODE:%d SELF:%d\n", $v->[$i]->line_number, $self->{line_number}); while ($self->{line_number} < $v->[$i]->line_number) { $ret .= "\n"; $self->{line_number}++; } my $stmt = $self->do_compile($v->[$i], $i==@$v-1 ? G_SCALAR : G_VOID); if ($stmt =~ /\n\z/ && $i!=@$v-1) { $ret .= $stmt; } else { $ret .= "$stmt;\n"; $self->{line_number}++; } } $ret; } elsif ($type == PVIP_NODE_UNDEF) { undef; } elsif ($type == PVIP_NODE_RANGE) { if ($gimme == G_ARRAY) { $self->do_compile($v->[0]) . '..' . $self->do_compile($v->[1]); } else { '[' . $self->do_compile($v->[0]) . '..' . $self->do_compile($v->[1]) .']'; } } elsif ($type == PVIP_NODE_REDUCE) { my $body; if ($v->[0]->value =~ /[a-z]/) { $body = sprintf '$seis_reduce_ret = %s($seis_reduce_ret, $seis_reduce_stuff)', $v->[0]->value; } else { $body = sprintf '$seis_reduce_ret %s= $seis_reduce_stuff', $v->[0]->value; } # XXX I should care the other cases? my $initial = $v->[0]->value eq '*' ? 1 : 0; sprintf('do { my @seis_reduce_ary = %s; my $seis_reduce_ret = @seis_reduce_ary==0 ? %s : shift @seis_reduce_ary; for my $seis_reduce_stuff (@seis_reduce_ary) { %s } $seis_reduce_ret; }', $self->do_compile($v->[1], G_ARRAY), $initial, $body); } elsif ($type == PVIP_NODE_INT) { $node->value; } elsif ($type == PVIP_NODE_NUMBER) { $node->value; } elsif ($type == PVIP_NODE_DIV) { '(' . $self->do_compile($v->[0]) . ')/(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_MUL) { '(' . $self->do_compile($v->[0]) . ')*(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_ADD) { '(' . $self->do_compile($v->[0]) . ')+(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_SUB) { '(' . $self->do_compile($v->[0]) . ')-(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_IDENT) { if ($v eq '::Array') { 'Seis::Class->_new(name => "Array")' } elsif ($v eq 'self') { '$self' } elsif ($v eq '::Hash') { 'Seis::Class->_new(name => "Hash")' } elsif ($v eq 'Buf') { 'Buf::' } elsif ($v eq 'Exception') { 'Seis::Class->_new(name => "Exception")' } elsif ($v eq 'Real') { 'Seis::Real::' } elsif ($v eq 'Duration') { 'Seis::Duration::' } elsif ($v eq 'Pair') { 'Pair::' } elsif ($v eq 'Instant') { 'Seis::Instant::' } elsif ($v eq 'IO::Handle') { 'IO::Handle::' } elsif ($v eq 'Bool::False') { 'Bool::False()' } elsif ($v eq 'Bool::True') { 'Bool::True()' } elsif ($v eq 'True') { 'Bool::True()' } elsif ($v eq 'False') { 'Bool::False()' } elsif ($v eq 'IO::Path::Cygwin') { 'IO::Path::Cygwin::' } else { $v; } } elsif ($type == PVIP_NODE_FUNCALL) { if ($v->[0]->type == PVIP_NODE_IDENT) { # builtin functions if ($v->[0]->value eq 'shift' || $v->[0]->value eq 'pop') { # shift(@array) local $self->{args_list} = 1; sprintf('%s(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'elems') { # TODO You may optimize this function... elems(3) can be caluculate while compilation time. sprintf('Seis::Runtime::builtin_elems(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'eval') { my $is_perl5 = do { my @args = @{$v->[1]->value}; if (@args==2) { my $pair = $args[1]; if ( $pair->type == PVIP_NODE_PAIR && $pair->value->[0]->value eq 'lang' && $pair->value->[1]->value eq 'perl5' ) { 1; } } else { 0; } }; if ($is_perl5) { sprintf('CORE::eval(%s)', $self->do_compile($v->[1]->value->[0]), ); } else { join('', 'do {', 'my $__rg_compiler = Seis::Compiler->new();', 'my $__rg_compiled = $__rg_compiler->compile(', $self->do_compile($v->[1]), ');', 'my $__rg_ret = eval $__rg_compiled;', 'if ($@) {', 'Seis::Exception::CompilationFailed->throw("$@");', '}', '$__rg_ret;}', ); } } elsif ($v->[0]->value eq 'now') { 'Seis::BuiltinFunctions::now()'; } elsif ($v->[0]->value eq 'kv') { sprintf('(%s)->kv', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'list') { sprintf('List->new(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'copy') { sprintf('Seis::BuiltinFunctions::copy(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'reduce') { sprintf('Seis::BuiltinFunctions::reduce(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'gcd') { sprintf('Seis::BuiltinFunctions::gcd(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'chdir') { if (@{$v->[1]->value} == 0) { Seis::Exception::CompilationFailed->throw( 'You need pass 1 argument for chdir function' ); } sprintf('CORE::chdir(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'connect') { sprintf('Seis::BuiltinFunctions::connect(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'any') { sprintf('Seis::BuiltinFunctions::any(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'get') { sprintf('Seis::BuiltinFunctions::get(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'sign') { sprintf('(%s)->sign', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'ords') { sprintf('Seis::BuiltinFunctions::ords(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'is-prime') { sprintf('Seis::BuiltinFunctions::is_prime(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'open') { sprintf('Seis::BuiltinFunctions::open(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'end') { # TODO support the 'list' style. sprintf('Seis::BuiltinFunctions::end(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'lines') { sprintf('Str::lines(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'slurp') { sprintf('Seis::BuiltinFunctions::slurp(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'hash') { sprintf('+{%s}', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'push') { # (funcall (ident "push") (args (variable "@a") (string "e"))) if ( $v->[1]->type == PVIP_NODE_ARGS && @{$v->[1]->value}==2 && $v->[1]->value->[0]->type == PVIP_NODE_VARIABLE && $v->[1]->value->[0]->value =~ /\A\@/) { sprintf('CORE::push(%s,%s)', $self->do_compile($v->[1]->value->[0], G_ARRAY), $self->do_compile($v->[1]->value->[1]), ); } else { sprintf('CORE::push(%s)', $self->do_compile($v->[1]), ); } } elsif ($v->[0]->value eq 'values') { # (args (variable "@array")) if ( $v->[1]->type == PVIP_NODE_ARGS && @{$v->[1]->value}==1 && $v->[1]->value->[0]->type == PVIP_NODE_VARIABLE && $v->[1]->value->[0]->value =~ /\A\@/) { # values(@a) if ($gimme == G_ARRAY) { sprintf('CORE::values(%s)', $self->do_compile($v->[1]->value->[0], G_ARRAY), ); } else { sprintf('[CORE::values(%s)]', $self->do_compile($v->[1]->value->[0], G_ARRAY), ); } } else { sprintf('CORE::values(%s)', $self->do_compile($v->[1]), ); } } elsif ($v->[0]->value eq 'keys') { # (args (variable "@array")) if ( $v->[1]->type == PVIP_NODE_ARGS && @{$v->[1]->value}==1 && $v->[1]->value->[0]->type == PVIP_NODE_VARIABLE && $v->[1]->value->[0]->value =~ /\A\@/) { # keys(@a) if ($gimme == G_ARRAY) { sprintf('CORE::keys(%s)', $self->do_compile($v->[1]->value->[0], G_ARRAY), ); } else { sprintf('[CORE::keys(%s)]', $self->do_compile($v->[1]->value->[0], G_ARRAY), ); } } else { sprintf('CORE::keys(%s)', $self->do_compile($v->[1]), ); } } elsif ($v->[0]->value eq 'getc') { sprintf('Seis::BuiltinFunctions::getc(%s)', $self->do_compile($v->[1]), ); } elsif ($v->[0]->value eq 'close') { sprintf('Seis::BuiltinFunctions::close(%s)', $self->do_compile($v->[1]), ); } else { sprintf('%s(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } } else { sprintf('(%s)->(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } } elsif ($type == PVIP_NODE_ARGS) { my @args = map { if ($_->type == PVIP_NODE_IDENT && $_->value eq 'Hash') { 'Seis::Hash::' } elsif ($_->type == PVIP_NODE_IDENT && $_->value eq 'Array') { 'Array::' } elsif ($_->type == PVIP_NODE_IDENT && $_->value eq 'IO::Path') { 'IO::Path::' } elsif ($_->type == PVIP_NODE_IDENT && $_->value eq 'True') { 'Bool::True()' } elsif ($_->type == PVIP_NODE_IDENT && $_->value eq 'False') { 'Bool::False()' } elsif ($_->type == PVIP_NODE_IDENT) { my $v = $_->value; $v =~ s/\A:://; sprintf('Seis::Class->_new(name => %s)', $self->compile_string($v)); } elsif ($_->type == PVIP_NODE_VARIABLE && $_->value =~ /\A\@/) { my $v = $_->value; $v =~ s/−/ー/g; "\\$v"; } else { $self->do_compile($_) } } @$v; if ($self->{args_list}) { join(",", map { "$_" } @args); } else { join(",", map { "scalar($_)" } @args); } } elsif ($type == PVIP_NODE_STRING) { $self->compile_string($v); } elsif ($type == PVIP_NODE_MOD) { sprintf('(%s)%%(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_VARIABLE) { $v =~ s!-!ー!g; $v; } elsif ($type == PVIP_NODE_MY) { if (@$v==1) { # (my (list (variable "$a") (variable "$b") (variable "$c"))) if ($v->[0]->type == PVIP_NODE_LIST) { sprintf('my (%s)', join(',', map { $self->do_compile($_) } @{$v->[0]->value}) ); } else { die "NYI: (1)" . $node->as_sexp } } else { my ($type, $vars) = @$v; if ($vars->type == PVIP_NODE_VARIABLE) { # (my (nop) (variable "$i")) sprintf('my %s', $self->do_compile($vars) ); } elsif ($vars->type == PVIP_NODE_FUNC) { # (my (nop) (func (ident "vtest") (params (param (nop) (variable "$cmp") (nop)) (param (vargs (variable "@v")))) (nop) (block (statements (list_assignment (my (nop) (variable "$x")) (funcall (ident "shift") (args (variable "@v")))) (while (variable "@v") (block (statements (list_assignment (my (nop) (variable "$y")) (funcall (ident "shift") (args (variable "@v")))) (funcall (ident "is") (args (cmp (methodcall (ident "Version") (ident "new") (args (variable "$x"))) (methodcall (ident "Version") (ident "new") (args (variable "$y")))) (variable "$cmp") (string_concat (string_concat (string_concat (string_concat (string_concat (string "") (variable "$x")) (string " cmp ")) (variable "$y")) (string " is ")) (variable "$cmp")))) (list_assignment (variable "$x") (variable "$y"))))))))) sprintf('my %s', $self->do_compile($vars)); } elsif ($vars->type == PVIP_NODE_LIST) { # my ($a, $b); sprintf('my %s', $self->do_compile($vars, G_ARRAY)); } else { die "NYI: " . $node->as_sexp } } } elsif ($type == PVIP_NODE_OUR) { my @vars = map { $self->do_compile($_) } @$v; sprintf('our (%s)', join(',', map { "($_)" } @vars) ); } elsif ($type == PVIP_NODE_BIND) { # TODO: This may not compatible with Perl6. sprintf('%s=(%s)', $self->do_compile($v->[0], G_ARRAY), $self->do_compile($v->[1], G_ARRAY), ); } elsif ($type == PVIP_NODE_LIST_ASSIGNMENT) { sprintf('%s=(%s)', $self->do_compile($v->[0], G_ARRAY), $self->do_compile($v->[1], $self->is_list_lvalue($v->[0]) ? G_ARRAY : G_SCALAR ), ); } elsif ($type == PVIP_NODE_STRING_CONCAT) { sprintf('(%s).(%s)', $v->[0]->type == PVIP_NODE_STATEMENTS ? $self->do_compile($v->[0]->value->[0]) : $self->do_compile($v->[0]), $v->[1]->type == PVIP_NODE_STATEMENTS ? $self->do_compile($v->[1]->value->[0]) : $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_IF) { # (if (int 1) (statements (int 5)) (else (int 4))) my $ret = 'if (' . $self->do_compile($v->[0]) . ') {' . $self->do_compile($v->[1]) . '}'; shift @$v; shift @$v; while (@$v) { $ret .= $self->do_compile(shift @$v); } $ret; } elsif ($type == PVIP_NODE_EQV) { Seis::Exception::NotImplemented->throw("PVIP_NODE_EQV is not implemented") } elsif ($type == PVIP_NODE_ARRAY) { sprintf('[%s]', join(',', map { "($_)" } map { $self->do_compile($_, G_ARRAY) } @$v) ); } elsif ($type == PVIP_NODE_ATPOS) { my $invocant = $self->do_compile($v->[0]); my $pos = $self->do_compile($v->[1]); if ( ($v->[0]->type == PVIP_NODE_VARIABLE && $v->[0]->value =~ /\A@/) ) { # @a[0] sprintf('%s[(%s)]', $invocant, $pos, ); } else { # $a[0] sprintf('(%s)->[(%s)]', $invocant, $pos, ); } } elsif ($type == PVIP_NODE_METHODCALL) { my $invocant = $self->do_compile($v->[0]); if ($v->[0]->type != PVIP_NODE_IDENT) { $invocant = "($invocant)"; } my $method = $self->do_compile($v->[1]); my $params = defined($v->[2]) ? $self->do_compile($v->[2]) : ''; $method =~ s!-!ー!g; if ($v->[0]->type == PVIP_NODE_WHATEVER) { return sprintf('(sub { shift->%s(%s) })', $method, $params ); } if ($v->[1]->type == PVIP_NODE_STRING || $v->[1]->type == PVIP_NODE_STRING_CONCAT) { sprintf('%s->${\(%s)}(%s)', $invocant, $method, $params, ); } else { sprintf('%s->%s(%s)', $invocant, $method, $params, ); } } elsif ($type == PVIP_NODE_FUNC) { my $name = $self->do_compile($v->[0]); my $exportable = $v->[2]->type == PVIP_NODE_EXPORT; my $ret = ''; $ret .= "sub $name {"; $ret .= "\n"; $self->{line_number}++; $ret .= $self->do_compile($v->[1]); $ret .= $self->do_compile($v->[3]); $ret .= "}\n"; $self->{line_number}++; if ($exportable) { $ret .= sprintf("push \@__RG_EXPORT, %s;", $self->compile_string($name)); } $ret; } elsif ($type == PVIP_NODE_PARAMS) { # (params (param (nop) (variable "$n") (nop))) # (params (param (ident "Int") (variable "$n") (nop) (int 0))) my $ret = ''; my $is_vargs = 0; my $min_args = 0; my $max_args = 0; for my $param (@$v) { $ret .= $self->do_compile($param) . ";"; if ($param->value->[1]->type == PVIP_NODE_VARGS) { $is_vargs++; } else { if ($param->value->[2] == PVIP_NODE_NOP) { # no default value. $min_args++; $max_args++; } else { # has default value. $max_args++; } if ($param->value->[0]->type == PVIP_NODE_IDENT) { my $type = $self->compile_string($param->value->[0]->value); $ret .= sprintf('Seis::Exception::ArgumentType->throw("invalid argument type(expected %s)") unless %s->isa(%s);', $param->value->[0]->value, $param->value->[1]->value, $type); } } } unless ($is_vargs) { $ret .= sprintf('Seis::Exception::ArgumentCount->throw("Invalid argument count(Expected %d to %d but " . (0+@_) . ")") unless %d <= @_ && @_<=%d;', $min_args, $max_args, $min_args, $max_args); } $ret .= "undef;"; } elsif ($type == PVIP_NODE_PARAM) { # (params (param (nop) (variable "$n") (nop))) # (param (nop) (vargs (variable "@a")) (nop) (int 0)) if (@$v==4) { if ($v->[1]->type == PVIP_NODE_VARGS) { sprintf('%s;', $self->do_compile($v->[1])); } elsif ($v->[1]->value =~ /\A\@/) { # (param (ident "Int") (variable "$x") (nop)) sprintf('my %s=@_;', $self->do_compile($v->[1])); } else { sprintf('my %s=shift;', $self->do_compile($v->[1])); } } else { die "Should not reach here : " . $node->as_sexp; } } elsif ($type == PVIP_NODE_RETURN) { 'return (' . join(',', map { "($_)" } map {$self->do_compile($_)} @$v) . ')'; } elsif ($type == PVIP_NODE_ELSE) { 'else { ' . join(';', map { $self->do_compile($_) } @$v) . '}'; } elsif ($type == PVIP_NODE_WHILE) { sprintf("while (%s) %s", $self->do_compile($v->[0]), $self->maybe_block($v->[1])); } elsif ($type == PVIP_NODE_UNTIL) { sprintf("until (%s) %s", $self->do_compile($v->[0]), $self->maybe_block($v->[1])); } elsif ($type == PVIP_NODE_DIE) { sprintf('die (%s)', $self->do_compile($v->[0])); } elsif ($type == PVIP_NODE_ELSIF) { sprintf('elsif (%s) { %s }', $self->do_compile($v->[0]), $self->do_compile($v->[1])); } elsif ($type == PVIP_NODE_NOW) { 'Seis::BuiltinFunctions::now()' } elsif ($type == PVIP_NODE_RAND) { 'rand()' } elsif ($type == PVIP_NODE_TIME) { 'time()' } elsif ($type == PVIP_NODE_LIST) { if ($gimme == G_SCALAR) { # In scalar context, create arrayref automatically. sprintf('[%s]', join(',', map { "($_)" } map { $self->do_compile($_) } @$v) ); } else { sprintf('(%s)', join(',', map { "($_)" } map { $self->do_compile($_, G_ARRAY) } @$v) ); } } elsif ($type == PVIP_NODE_FOR) { my $iteratee = $self->do_compile($v->[0], G_ARRAY); if ($v->[1]->type == PVIP_NODE_LAMBDA) { # (for (list (int 1) (int 2) (int 3)) (lambda (params (param (nop) (variable "$x") (nop))) (statements (inplace_add (variable "$i") (variable "$x"))))) # (for (variable "@list") (lambda (params) (block (statements (funcall (ident "isnt") (args (variable "$_") (string "a") (string "$_ does not get set implicitly if a pointy is given"))))))) my $varname = $v->[1]->value->[0]->value->[0]->value->[1]->value; sprintf('for my %s (%s) %s', $varname, $iteratee, $self->maybe_block($v->[1]->value->[1]) ); } else { sprintf('for (%s) %s', $iteratee, $self->maybe_block($v->[1]) ); } } elsif ($type == PVIP_NODE_UNLESS) { my $ret = 'unless (' . $self->do_compile($v->[0]) . ') {' . $self->do_compile($v->[1]) . '}'; shift @$v; shift @$v; while (@$v) { $ret .= $self->do_compile(shift @$v); } $ret; } elsif ($type == PVIP_NODE_NOT) { if ($self->is_array_variable($v->[0])) { sprintf('!(0+%s)', $self->do_compile($v->[0]->value) ); } else { # I want to do this with PL_check hack. sprintf('Seis::Runtime::_not(%s)', $self->do_compile($v->[0]) ); } } elsif ($type == PVIP_NODE_CONDITIONAL) { sprintf('(%s)?(%s):(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), $self->do_compile($v->[2]), ); } elsif ($type == PVIP_NODE_NOP) { return "()"; } elsif ($type == PVIP_NODE_POW) { sprintf('(%s)**(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_CLARGS) { Seis::Exception::NotImplemented->throw("PVIP_NODE_CLARGS is not implemented") } elsif ($type == PVIP_NODE_HASH) { if ($gimme == G_ARRAY) { '(' . join(',', map { $self->do_compile($_, G_ARRAY) } @$v) . ')'; } else { '{' . join(',', map { $self->do_compile($_, G_ARRAY) } @$v) . '}'; } } elsif ($type == PVIP_NODE_PAIR) { if ($gimme == G_SCALAR) { sprintf('Pair->_new(scalar(%s),scalar(%s))', $v->[0]->type == PVIP_NODE_IDENT ? $self->compile_string($v->[0]) : $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } else { my $key = $v->[0]->type == PVIP_NODE_IDENT ? $self->compile_string($v->[0]->value) : $self->do_compile($v->[0]); sprintf('(%s)=>scalar(%s)', $key, $self->do_compile($v->[1]), ); } } elsif ($type == PVIP_NODE_ATKEY) { if ($v->[0]->type == PVIP_NODE_VARIABLE && $v->[0]->value =~ /\A%/) { my $target = $self->do_compile($v->[0]); $target =~ s/\A%/\$/; sprintf('%s{(%s)}', $target, $self->do_compile($v->[1]), ); } elsif ($v->[0]->type == PVIP_NODE_VARIABLE && $v->[0]->value =~ /\A\$/) { sprintf('(%s)->{(%s)}', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($v->[0]->type == PVIP_NODE_TW_ENV || ($v->[0]->type == PVIP_NODE_VARIABLE && $v->[0]->value =~ /\A$/)) { sprintf('(%s)->{(%s)}', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } else { sprintf('(%s){(%s)}', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } } elsif ($type == PVIP_NODE_LOGICAL_AND) { sprintf('(%s)&&(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_LOGICAL_OR) { sprintf('(%s)||(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_LOGICAL_XOR) { sprintf('do { my $a = (%s); my $b = (%s); if ($a) { $b ? !!0 : $a } else { $b ? $b : !!0 } }', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BIN_AND) { sprintf('(%s)&(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BIN_OR) { sprintf('(%s)|(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BIN_XOR) { sprintf('(%s)^(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BLOCK) { my $ret = ''; # $ret .= sprintf("# %d %d\n", $node->line_number, $self->{line_number}); if (@$v) { $ret .= '{' . $self->do_compile($v->[0]) . '}'; } else { $ret .= '{ }'; } $ret; } elsif ($type == PVIP_NODE_LAMBDA) { # (lambda (params (param (nop) (variable "$n") (nop))) (statements (mul (variable "$n") (int 2)))) # (lambda (block (statements (logical_or (chain (mod (variable "$_") (int 3)) (eq (int 0))) (chain (mod (variable "$_") (int 5)) (eq (int 0))))))) if (@$v==1) { if ($v->[0]->type == PVIP_NODE_BLOCK) { my $ret = 'sub '; $ret .= $self->do_compile($v->[0]); $ret; } elsif ($v->[0]->type == PVIP_NODE_HASH) { # (lambda (hash (pair (ident "out") (string "(IO)\n")))) my $ret = 'sub '; $ret .= $self->do_compile($v->[0]); $ret; } else { ... } } else { my $ret = 'sub {'; $ret .= $self->do_compile($v->[0]); $ret .= $self->do_compile($v->[1]); $ret .= "}"; $ret; } } elsif ($type == PVIP_NODE_USE) { if ($v->[0]->value eq 'v6') { $self->{line_number}++; "# use v6;\n"; } else { 'use ' . $self->do_compile($v->[0]); } } elsif ($type == PVIP_NODE_MODULE) { sprintf('package %s; our @__RG_EXPORT; use parent qw(Seis::Exporter);', $v->[0]->value); } elsif ($type == PVIP_NODE_CLASS) { # (class (ident "Foo7") (nop) (statements (method (ident "bar") (nop) (statements (int 5963))))) # (class (ident "Foo8") (list (is (ident "Foo7"))) (statements)) state $ANON_CLASS = 0; my $pkg = $v->[0]->type == PVIP_NODE_NOP ? "Seis::_AnonClass" . $ANON_CLASS++ : $self->do_compile($v->[0]); my $retval = $gimme == G_VOID ? '' : "Seis::Class->_new(name => '$pkg')"; my $body = $self->do_compile($v->[2]); if ($body eq '{ }') { $body = ''; } sprintf(q!do { package %s; BEGIN { our @ISA; unshift @ISA, "Seis::Object"; %s; } %s; %s }!, $pkg, join(";\n", map { $self->do_compile($_) } @{$v->[1]->value}), $body, $retval); } elsif ($type == PVIP_NODE_METHOD) { # (method (ident "bar") (nop) (statements)) # TODO: support arguments # (method (ident "bar") (params (param (nop) (variable "$n") (nop))) (statements (mul (variable "$n") (int 3)))) my $name = $self->do_compile($v->[0]); join('', 'sub ' . $name . ' {', 'my $self=shift;', $self->do_compile($v->[1]), ';undef;', $self->do_compile($v->[2]), ';}' ); } elsif ($type == PVIP_NODE_UNARY_PLUS) { if ($v->[0]->type == PVIP_NODE_LIST) { sprintf('0+@{[%s]}', $self->do_compile($v->[0], G_ARRAY)); } else { sprintf('(%s)->Int()', $self->do_compile($v->[0])); } } elsif ($type == PVIP_NODE_UNARY_MINUS) { sprintf('-(%s)', $self->do_compile($v->[0])); } elsif ($type == PVIP_NODE_IT_METHODCALL) { sprintf('$_->%s(%s)', $self->do_compile($v->[0]), defined($v->[1]) ? $self->do_compile($v->[1]) : '', ); } elsif ($type == PVIP_NODE_LAST) { 'last'; } elsif ($type == PVIP_NODE_NEXT) { 'next'; } elsif ($type == PVIP_NODE_REDO) { 'redo'; } elsif ($type == PVIP_NODE_POSTINC) { sprintf('(%s)++', $self->do_compile($v->[0]), ); } elsif ($type == PVIP_NODE_POSTDEC) { sprintf('(%s)--', $self->do_compile($v->[0]), ); } elsif ($type == PVIP_NODE_PREINC) { sprintf('++(%s)', $self->do_compile($v->[0]), ); } elsif ($type == PVIP_NODE_PREDEC) { sprintf('--(%s)', $self->do_compile($v->[0]), ); } elsif ($type == PVIP_NODE_UNARY_BITWISE_NEGATION) { sprintf('~(%s)', $self->do_compile($v->[0]), ); } elsif ($type == PVIP_NODE_BRSHIFT) { sprintf('(%s)>>(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BLSHIFT) { sprintf('(%s)<<(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_CHAIN) { my $compile = sub { my ($lhs, $type, $rhs) = @_; my $op = +{ PVIP_NODE_EQ() => '==', PVIP_NODE_NE() => '!=', PVIP_NODE_LT() => '<', PVIP_NODE_LE() => '<=', PVIP_NODE_GT() => '>', PVIP_NODE_GE() => '>=', PVIP_NODE_STREQ() => 'eq', PVIP_NODE_STRNE() => 'ne', PVIP_NODE_STRNE() => 'ne', PVIP_NODE_STRGT() => 'gt', PVIP_NODE_STRGE() => 'ge', PVIP_NODE_STRLT() => 'lt', PVIP_NODE_STRLE() => 'le', PVIP_NODE_EQV() => 'eq', # TODO PVIP_NODE_SMART_MATCH() => '~~', }->{$type}; if ($type == PVIP_NODE_NOT_SMART_MATCH) { # Perl5 does not support `!~~` operator! sprintf("(!((%s)~~(%s)))", $lhs, $rhs); } else { unless ($op) { Seis::Exception::NotImplemented->throw(sprintf "PVIP_NODE_%s is not implemented in chaning", $type) } sprintf("(%s)%s(%s)", $lhs, $op, $rhs); } }; if (@$v == 1) { return $self->do_compile($v->[0]); } elsif (@$v == 2) { # optimized for simple case $compile->( $self->do_compile($v->[0]), $v->[1]->type, $self->do_compile($v->[1]->value->[0]), ); } else { my $ret = 'do { my $_rg_chain_ret = 1; my $_rg_chain_rhs; my $_rg_chain_lhs = '; $ret .= $self->do_compile(shift @$v); $ret .= ';'; while (my $rhs_node = shift @$v) { $ret .= sprintf('$_rg_chain_rhs=%s;', $self->do_compile($rhs_node->value->[0])); $ret .= sprintf('unless (%s) { $_rg_chain_ret=0; goto _RG_CHAIN_END; }', $compile->('$_rg_chain_lhs', $rhs_node->type, '$_rg_chain_rhs')); $ret .= '$_rg_chain_lhs=$_rg_chain_rhs;'; } $ret .= '_RG_CHAIN_END: $_rg_chain_ret; }'; return $ret; } } elsif ($type == PVIP_NODE_INPLACE_ADD) { '(' . $self->do_compile($v->[0]) . ')+=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_SUB) { '(' . $self->do_compile($v->[0]) . ')-=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_MUL) { '(' . $self->do_compile($v->[0]) . ')*=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_DIV) { '(' . $self->do_compile($v->[0]) . ')/=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_POW) { '(' . $self->do_compile($v->[0]) . ')**=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_MOD) { '(' . $self->do_compile($v->[0]) . ')%=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_BIN_OR) { sprintf('(%s)|=(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_INPLACE_BIN_AND) { sprintf('(%s)&=(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_INPLACE_BIN_XOR) { sprintf('(%s)^=(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_INPLACE_BLSHIFT) { sprintf('(%s)<<=(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_INPLACE_BRSHIFT) { sprintf('(%s)>>=(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_INPLACE_CONCAT_S) { '(' . $self->do_compile($v->[0]) . ').=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_REPEAT_S) { '(' . $self->do_compile($v->[0]) . ')x(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_INPLACE_REPEAT_S) { '(' . $self->do_compile($v->[0]) . ')x=(' . $self->do_compile($v->[1]) . ')'; } elsif ($type == PVIP_NODE_STRINGIFY) { # STRINGIFY, stringification if ($self->is_array_variable($v->[0]) || $v->[0]->type == PVIP_NODE_LIST) { sprintf(q{join(' ', (%s))}, $self->do_compile($v->[0], G_ARRAY)); } else { sprintf(q{(%s)->Str()}, $self->do_compile($v->[0])); } } elsif ($type == PVIP_NODE_TRY) { "eval " . $self->do_compile($v->[0]); } elsif ($type == PVIP_NODE_REF) { sprintf(q{\(%s)}, $self->do_compile($v->[0])); } elsif ($type == PVIP_NODE_MULTI) { Seis::Exception::NotImplemented->throw("PVIP_NODE_MULTI is not implemented") } elsif ($type == PVIP_NODE_UNARY_BOOLEAN) { sprintf 'Seis::Runtime::boolean(%s)', $self->do_compile($v->[0]); } elsif ($type == PVIP_NODE_UNARY_UPTO) { Seis::Exception::NotImplemented->throw("PVIP_NODE_UNARY_UPTO is not implemented") } elsif ($type == PVIP_NODE_ARRAY_DEREF) { '@{' . $self->do_compile($v->[0]) . '}'; } elsif ($type == PVIP_NODE_STDOUT) { '*STDOUT' } elsif ($type == PVIP_NODE_STDERR) { '*STDERR' } elsif ($type == PVIP_NODE_SCALAR_DEREF) { '${' . $self->do_compile($v->[0]) . '}'; } elsif ($type == PVIP_NODE_TW_ENV) { '(\%ENV)' } elsif ($type == PVIP_NODE_TW_TMPDIR) { 'IO::Path->new(File::Spec->tmpdir())' } elsif ($type == PVIP_NODE_TW_INC) { if ($gimme == G_SCALAR) { '\\@Seis::INC'; } else { '@Seis::INC'; } } elsif ($type == PVIP_NODE_META_METHOD_CALL) { # (meta_method_call (class (nop) (nop) (statements)) (ident "methods") (nop)) sprintf('(%s)->meta()->%s(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), $self->do_compile($v->[2]), ); } elsif ($type == PVIP_NODE_REGEXP) { $self->compile_regexp($v); } elsif ($type == PVIP_NODE_SMART_MATCH) { Seis::Exception::NotImplemented->throw("PVIP_NODE_SMART_MATCH is not implemented") } elsif ($type == PVIP_NODE_NOT_SMART_MATCH) { Seis::Exception::NotImplemented->throw("PVIP_NODE_NOT_SMART_MATCH is not implemented") } elsif ($type == PVIP_NODE_PERL5_REGEXP) { sprintf('qr!%s!', $v); } elsif ($type == PVIP_NODE_FALSE) { '(Bool::false())' } elsif ($type == PVIP_NODE_TRUE) { '(Bool::True())' } elsif ($type == PVIP_NODE_TW_VM) { Seis::Exception::NotImplemented->throw("PVIP_NODE_TW_VM is not implemented") } elsif ($type == PVIP_NODE_HAS) { # (has (public_attribute "x")) # support private variable if ($v->[0]->type == PVIP_NODE_ATTRIBUTE_VARIABLE) { sprintf(q!__PACKAGE__->meta->add_attribute(%s)!, $self->compile_string($v->[0]->value)); } else { die "Should not reach here"; } } elsif ($type == PVIP_NODE_ATTRIBUTE_VARIABLE) { # (public_attribute "x") sprintf('$self->{%s}', $self->compile_string($v)); } elsif ($type == PVIP_NODE_FUNCREF) { sprintf('\&%s', $self->do_compile($v->[0])); } elsif ($type == PVIP_NODE_PATH) { sprintf('IO::Path->new(%s)', $self->compile_string($node) ); } elsif ($type == PVIP_NODE_TW_PACKAGE) { Seis::Exception::NotImplemented->throw("PVIP_NODE_TW_PACKAGE is not implemented") } elsif ($type == PVIP_NODE_TW_CLASS) { 'Seis::MetaClass->new(name => __PACKAGE__)' } elsif ($type == PVIP_NODE_TW_MODULE) { Seis::Exception::NotImplemented->throw("PVIP_NODE_TW_MODULE is not implemented") } elsif ($type == PVIP_NODE_TW_OS) { '($^O)'; } elsif ($type == PVIP_NODE_E) { '(exp(1))'; } elsif ($type == PVIP_NODE_TW_PID) { '($$)'; } elsif ($type == PVIP_NODE_TW_PERLVER) { '6' } elsif ($type == PVIP_NODE_TW_OSVER) { 'do {require Config; $Config::Config{osvers} }'; } elsif ($type == PVIP_NODE_TW_CWD) { '(IO::Path->new(Cwd::getcwd()))' } elsif ($type == PVIP_NODE_TW_EXECUTABLE_NAME) { '($0)' } elsif ($type == PVIP_NODE_TW_ROUTINE) { 'Sub->_new(__SUB__)'; } elsif ($type == PVIP_NODE_SLANGS) { Seis::Exception::NotImplemented->throw("PVIP_NODE_SLANGS is not implemented") } elsif ($type == PVIP_NODE_LOGICAL_ANDTHEN) { Seis::Exception::NotImplemented->throw("PVIP_NODE_LOGICAL_ANDTHEN is not implemented") } elsif ($type == PVIP_NODE_VALUE_IDENTITY) { Seis::Exception::NotImplemented->throw("PVIP_NODE_VALUE_IDENTITY is not implemented") } elsif ($type == PVIP_NODE_CMP) { sprintf('(%s)cmp(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_SPECIAL_VARIABLE_REGEXP_MATCH) { '@Seis::Runtime::REGEXP_MATCH' } elsif ($type == PVIP_NODE_SPECIAL_VARIABLE_EXCEPTIONS) { # Perl5's $@ contains "" if there is no errors. # It's incompatible with Perl6. '($@ ? $@ : undef)'; } elsif ($type == PVIP_NODE_ENUM) { Seis::Exception::NotImplemented->throw("PVIP_NODE_ENUM is not implemented") } elsif ($type == PVIP_NODE_NUM_CMP) { sprintf('(%s)<=>(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_UNARY_FLATTEN_OBJECT) { Seis::Exception::NotImplemented->throw("PVIP_NODE_UNARY_FLATTEN_OBJECT is not implemented") } elsif ($type == PVIP_NODE_COMPLEX) { sprintf('Seis::Complex->_new(%s)', $self->compile_string($v)); } elsif ($type == PVIP_NODE_ROLE) { Seis::Exception::NotImplemented->throw("PVIP_NODE_ROLE is not implemented") } elsif ($type == PVIP_NODE_IS) { # (is (ident "Foo7")) sprintf q!push @ISA, '%s'!, $self->do_compile($v->[0]); } elsif ($type == PVIP_NODE_DOES) { Seis::Exception::NotImplemented->throw("PVIP_NODE_DOES is not implemented") } elsif ($type == PVIP_NODE_JUNCTIVE_AND) { Seis::Exception::NotImplemented->throw("PVIP_NODE_JUNCTIVE_AND is not implemented") } elsif ($type == PVIP_NODE_JUNCTIVE_SAND) { Seis::Exception::NotImplemented->throw("PVIP_NODE_JUNCTIVE_SAND is not implemented") } elsif ($type == PVIP_NODE_JUNCTIVE_OR) { Seis::Exception::NotImplemented->throw("PVIP_NODE_JUNCTIVE_OR is not implemented") } elsif ($type == PVIP_NODE_UNICODE_CHAR) { sprintf(q!"\N{%s}"!, $v); } elsif ($type == PVIP_NODE_STUB) { '...'; } elsif ($type == PVIP_NODE_EXPORT) { Seis::Exception::NotImplemented->throw("PVIP_NODE_EXPORTABLE is not implemented") } elsif ($type == PVIP_NODE_BITWISE_OR) { Seis::Exception::NotImplemented->throw("PVIP_NODE_BITWISE_OR is not implemented") } elsif ($type == PVIP_NODE_BITWISE_AND) { sprintf('(%s)&(%s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BITWISE_XOR) { Seis::Exception::NotImplemented->throw("PVIP_NODE_BITWISE_XOR is not implemented") } elsif ($type == PVIP_NODE_VARGS) { # (vargs (variable "@a")) sprintf('my %s = @_;', $self->do_compile($v->[0])); } elsif ($type == PVIP_NODE_TW_A) { '($Seis::Runtime::TW_A)'; } elsif ($type == PVIP_NODE_TW_B) { '($Seis::Runtime::TW_B)'; } elsif ($type == PVIP_NODE_TW_C) { '($Seis::Runtime::TW_C)'; } elsif ($type == PVIP_NODE_WHATEVER) { '(Seis::Whatever->new())'; } elsif ($type == PVIP_NODE_NEED) { sprintf("BEGIN { require %s }", $self->do_compile($v->[0])); } elsif ($type == PVIP_NODE_END) { "END " . $self->do_compile($v->[0]); } elsif ($type == PVIP_NODE_GCD) { sprintf('Seis::BuiltinFunctions::gcd(%s, %s)', $self->do_compile($v->[0]), $self->do_compile($v->[1]), ); } elsif ($type == PVIP_NODE_BEGIN) { "BEGIN " . $self->do_compile($v->[0]); } elsif ($type == PVIP_NODE_PACKAGE) { sprintf('package %s %s', $self->do_compile($v->[0]), $self->do_compile($v->[1]) ); } else { Seis::Exception::UnknownNode->throw( ("Unknown node: PVIP_NODE_" . uc($node->name)) ); } } sub binop { my ($self, $op, $v) = @_; sprintf('(%s)%s(%s)', $self->do_compile($v->[0]), $op, $v, $self->do_compile($v->[1]), ); } sub maybe_block { my ($self, $node) = @_; if ($node->type == PVIP_NODE_BLOCK) { return $self->do_compile($node); } else { return '{' . $self->do_compile($node) . "}"; } } sub compile_string{ my ($self, $v) = @_; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 1; local $Data::Dumper::Purity = 1; local $Data::Dumper::Indent = 0; Data::Dumper::Dumper(Encode::decode_utf8($v)); } sub is_list_lvalue { my ($self, $node) = @_; my $is_list_var = sub { my $c = shift; return $c->type == PVIP_NODE_VARIABLE && $c->value =~ /\A[%@]/; }; if ($node->type == PVIP_NODE_MY) { # my, nop, list # my, nop, var if (@{$node->value}==2) { my $c = $node->value->[1]; if ($is_list_var->($c)) { # my @x = ... 1 } elsif ($c->type == PVIP_NODE_LIST) { # my ($x, $y) = ... 1 } elsif ($c->type == PVIP_NODE_TW_INC) { 1; # @*INC } else { # my $x = ... 0 } } elsif (@{$node->value}==1) { my $c = $node->value->[0]; if ($c->type == PVIP_NODE_LIST) { 1 } elsif ($c->type == PVIP_NODE_TW_INC) { 1; # @*INC } else { 0; } } else { 0; } } else { # @x = ... if ($is_list_var->($node)) { # my @x = ... 1 } elsif ($node->type == PVIP_NODE_TW_INC) { 1; # @*INC } else { # my $x = ... 0 } } } sub compile_regexp { my ($class, $regexp) = @_; my $ret = ''; while (length($regexp)) { if ($regexp =~ s/\A//) { $ret .= '\p{PosixAlpha}'; } elsif ($regexp =~ s/\A +//) { next; } elsif ($regexp =~ s/\A!//) { $ret .= '\!'; } elsif ($regexp =~ s/\A(.)//s) { $ret .= $1; } else { die "Should not reache here: " . Data::Dumper::Dumper($regexp); } } sprintf('qr!%s!sxp', $ret); } sub is_array_variable { my ($self, $node) = @_; return $node->type == PVIP_NODE_VARIABLE && $node->value =~ /\A\@/; } 1;