package Pugs::Emitter::Perl6::Perl5;
$Pugs::Emitter::Perl6::Perl5::VERSION = '0.01';
use 5.006;
# p6-ast to perl5 emitter
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 1;
use Pugs::Emitter::Rule::Perl5::Ratchet;
use Pugs::Runtime::Common;
use Digest::MD5 'md5_hex';
use Pugs::Runtime::Perl6;
use Pugs::Emitter::Perl6::Perl5::Value;
use Pugs::Emitter::Perl6::Perl5::Native;
use Pugs::Emitter::Perl6::Perl5::Expression;
use Pugs::Emitter::Perl6::Perl5::Perl5Range;
use Pugs::Emitter::Perl6::Perl5::Perl5Array;
use Pugs::Emitter::Perl6::Perl5::Perl5Hash;
use Pugs::Emitter::Perl6::Perl5::Array;
use Pugs::Emitter::Perl6::Perl5::Hash;
use Pugs::Emitter::Perl6::Perl5::Scalar;
# TODO - finish localizing %_V6_ENV at each block
our %_V6_ENV;
our $id = int( 1000 + rand(9000) );
our $_V6_SELF = '$_V6_SELF';
sub _var_get {
my $n = $_[0];
my $s;
for ( qw( scalar array hash ) ) {
next unless exists $n->{$_};
$s = $n->{$_};
# $s =~ s/^\@/\$_V6_Array_/;
# $s =~ s/^\%/\$_V6_Hash_/;
}
#print "get: $s\n";
if ( defined $s
&& $s =~ /\$\? .* POSITION $/x
) {
# $?CALLER::CALLER::CALLER::POSITION
my $code = $s;
$code =~ s/\$/\&/;
return _emit_code( $code );
}
if ( ! $s ) {
if ( exists $n->{bare_block} ) {
my $block = _emit( $n );
# TODO - check if it is a comma-delimited list
#print "block: [$block]\n";
return $block
if $block =~ / \# \s* hash \s* \n \s* }? \s* $/xs;
#print "sub: [$block]\n";
return ' sub ' . $block;
}
return _emit( $n );
}
return $_V6_ENV{$s}{get}
if exists $_V6_ENV{$s} &&
exists $_V6_ENV{$s}{get};
#if ( ref $s eq 'HASH' ) {
# my $v = $s->{match_variable};
# $v = _emit( $v ) if ref( $v );
# return Pugs::Runtime::Common::mangle_var( '$/' ) . '->{' . $v . '}';
#}
# default
return "\$_V6_SELF->{'" . substr($s,2) . "'}"
if substr($s,1,1) eq '.';
return Pugs::Runtime::Common::mangle_var( $s );
}
sub _var_set {
my $s = $_[0];
#warn "emit: set $s - ", Dumper %_V6_ENV;
return $_V6_ENV{$s}{set}
if exists $_V6_ENV{$s}{set};
# default
return sub { Pugs::Runtime::Common::mangle_var( $s ) . " = " . $_[0] };
}
sub _not_implemented {
my ( $n, $what ) = @_;
return "die q(not implemented $what: " . Dumper( $n ) . ")";
}
# modified from http://www.stonehenge.com/merlyn/UnixReview/col30.html
sub deep_copy {
my $this = shift;
if (ref $this eq '') {
$this;
} elsif (ref $this eq "ARRAY") {
[map deep_copy($_), @$this];
} elsif (ref $this eq "HASH") {
+{map { $_ => deep_copy($this->{$_}) } keys %$this};
} else {
#print "deep_copy: ", ref($this), "\n";
$this;
}
}
sub emit {
# <audreyt> %Namespace:: = (); # clear stash
my %old_env = %{ deep_copy( \%_V6_ENV ) };
local %_V6_ENV = %old_env;
my ($grammar, $ast) = @_;
# runtime parameters: $grammar, $string, $state, $arg_list
# rule parameters: see Runtime::Rule.pm
warn Pugs::Runtime::Perl6::Scalar::perl( $ast )
if $ENV{V6DUMPAST};
return _emit( $ast );
#"do{\n" .
#_emit( $ast, ' ' ) . "\n" .
#"}";
}
sub _emit_code {
my $code = $_[0];
if (substr($code, 1,1) eq '?') {
my $caller_level = 0;
while ($code =~ s/^&\?CALLER::/&?/) {
++$caller_level;
}
my $name = substr($code, 2);
# special!
if ($name eq 'ROUTINE') {
return "Pugs::Runtime::Perl6::Routine->new(Devel::Caller::caller_cv($caller_level))";
}
elsif ($name eq 'POSITION') {
if ($caller_level == 0) {
return "join(' line ', __FILE__, __LINE__)";
}
return "join(' line ', (caller(".($caller_level-1)."))[1,2])";
}
die 'unhandled magic variable';
}
return "Pugs::Runtime::Perl6::Routine->new(\\$code)";
}
sub _emit_double_quoted {
my $n = $_[0];
# special case for $POSITION
my @strings = map { $_ =~ s/\$(\?.*POSITION)/&$1/; $_ } (split /([&\$][*?][:\w.]+\w)/, $n);
return '""' unless @strings;
return join('.', map { /^\$\*/ ? Pugs::Runtime::Common::mangle_var($_)
: /^.\?/ ? 'do { '.Pugs::Compiler::Perl6->compile($_)->{perl5}.' }'
: '"'.$_.'"' }
grep { length $_ } @strings);
}
sub _emit_angle_quoted {
my $n = $_[0];
return "qw($n)" unless $n =~ /[()]/;
return "qw!$n!" unless $n =~ /[!]/;
return "qw^$n^" unless $n =~ /[\^]/;
die "can't quote string [$n]";
}
sub _emit_pair {
my ( $k, $v ) = ( _emit( $_[0] ), _emit( $_[1] ) );
return Pugs::Emitter::Perl6::Perl5::node->node( 'pair', [ $k, $v ] )
if Scalar::Util::blessed $k
&& Scalar::Util::blessed $v;
return "{ $k => $v }";
}
sub _emit {
my $n = $_[0];
#die "_emit: ", Dumper( $n );
#warn "_emit: ", Dumper( $n );
# 'undef' example: parameter list, in a sub call without parameters
return ''
unless defined $n;
die "unknown node: ", Dumper( $n )
unless ref( $n ) eq 'HASH';
# Native
return Pugs::Emitter::Perl6::Perl5::node->node( 'int', $n->{int} )
if exists $n->{int};
return Pugs::Emitter::Perl6::Perl5::node->node( 'num', $n->{num} )
if exists $n->{num};
return Pugs::Emitter::Perl6::Perl5::node->node( 'str', $n->{single_quoted} )
if exists $n->{single_quoted};
# Containers with sigil
return Pugs::Emitter::Perl6::Perl5::node->node( 'Perl5Scalar', $n->{scalar} )
if exists $n->{scalar};
return Pugs::Emitter::Perl6::Perl5::node->node( 'Perl5Array', $n->{array} )
if exists $n->{array};
return Pugs::Emitter::Perl6::Perl5::node->node( 'Perl5Hash', $n->{hash} )
if exists $n->{hash};
# ---
if (exists $n->{statements}) {
my $statements = join ( ";\n",
map { defined $_ ? _emit( $_ ) : "" }
@{$n->{statements}}, undef
);
return length $statements ? $statements : " # empty block\n";
}
return Pugs::Runtime::Common::mangle_ident( $n->{bareword} )
if exists $n->{bareword};
return Pugs::Runtime::Common::mangle_ident( $n->{dot_bareword} )
if exists $n->{dot_bareword};
return _emit_code($n->{code})
if exists $n->{code};
return _emit_pair( $n->{pair}{key}, $n->{pair}{value} )
if exists $n->{pair};
return _emit_double_quoted( $n->{double_quoted} )
if exists $n->{double_quoted};
return _emit_angle_quoted( $n->{angle_quoted} )
if exists $n->{angle_quoted};
return $n->{perl5source}
if exists $n->{perl5source};
return assoc_list( $n )
if exists $n->{assoc} && $n->{assoc} eq 'list';
return assoc_chain( $n )
if exists $n->{assoc} && $n->{assoc} eq 'chain';
return reduce( $n )
if exists $n->{reduce};
return emit_block( $n )
if exists $n->{bare_block};
if ( exists $n->{fixity} ) {
return infix( $n )
if $n->{fixity} eq 'infix';
return prefix( $n )
if $n->{fixity} eq 'prefix';
return postfix( $n )
if $n->{fixity} eq 'postfix';
return circumfix( $n )
if $n->{fixity} eq 'circumfix';
return postcircumfix( $n )
if $n->{fixity} eq 'postcircumfix';
return ternary( $n )
if $n->{fixity} eq 'ternary';
}
return statement( $n )
if exists $n->{statement};
return variable_declarator( $n )
if exists $n->{variable_declarator};
return term( $n )
if exists $n->{term};
return default( $n );
}
sub reduce {
my $n = $_[0];
#print "reduce emit_rule: ", Dumper( $n );
return
"( List::Util::reduce { \$a " .
$n->{op}{op} . " \$b } " . _emit( $n->{param} ) .
" ) ";
}
sub assoc_list {
my $n = $_[0];
# print "list emit_rule: ", Dumper( $n );
my @list = map { exists $_->{null}
? ()
: _emit( $_ )
} @{$n->{list}};
if ( ! grep { ! ref( $_ ) } @list ) {
#my $seq = Pugs::Emitter::Perl6::Perl5::node->node( 'Seq', \@list );
#print "Creating Seq $seq - @{[ $seq->WHAT ]}\n";
return Pugs::Emitter::Perl6::Perl5::node->node( 'Seq', \@list )
}
if ( $n->{op1} eq ';' ||
$n->{op1} eq ',' ) {
return join ( ",\n", @list );
}
return _not_implemented( $n->{op1}, "list-op" );
}
sub assoc_chain {
my $n = $_[0];
my @chain = @{$n->{chain}};
#print "chain emit_rule: ", Dumper( @chain );
if ( @chain == 3 ) {
my $exp1 = _emit( $chain[0] );
my $op = $chain[1];
my $exp2 = _emit( $chain[2] );
return "$exp1 $op $exp2"
}
my @e;
for ( my $i = 0; $i < @chain; $i += 2 ) {
push @e, emit_parenthesis( $chain[$i] );
}
my $id1 = $id++;
my $s = 'do { $_V6_PAD{'.$id1.'} = [' . join(",", @e) . "]; ";
@e = ();
for ( my $i = 1; $i < @chain; $i += 2 ) {
push @e,
'$_V6_PAD{'.$id1.'}[' . int($i/2) . "] $chain[$i] " .
'$_V6_PAD{'.$id1.'}[' . (int($i/2)+1) . "]";
}
return $s . join(" && ", @e) . " }";
}
sub _emit_parameter_signature {
my $n = $_[0] or return '';
return '' unless @$n;
# { var => '$self', invocant => 1 },
# { var => '$title' },
# { var => '$subtitle', optional => 1 },
# { var => '$case', named_only => 1 },
# { var => '$justify', named_only => 1, required => 1});
return join(",\n ", map { _emit_data_bind_param_spec($_) } @$n );
}
sub _emit_data_bind_param_spec {
my %param = %{$_[0]};
# XXX: translate other attributes
$param{var} = delete $param{name};
$param{var} = delete $param{code} if $param{code};
$param{optional} = 1 if delete $param{default};
my $dumped = Dumper(\%param);
$dumped =~ s/^\$VAR1 = //g;
$dumped =~ s/;$//;
$dumped =~ s/\n//mg;
return $dumped;
}
sub _emit_parameter_binding {
my $n = $_[0];
# no parameters
return ''
unless defined $n;
#warn "parameter list: ",Dumper $n;
# 'name' => '$desc', $v
# 'optional' => 1, $v?
# 'named_only' => 1, :$v
# 'type' => 'Str' Str $v
# 'is_slurpy' => 1, *$v
# 'attribute' => \@attr $v is rw
my @params = @$n or return '';
my $defaults = '';
my $param = join( ',' ,
map { _emit( {%$_, scalar => $_->{name}} ) } grep { substr($_->{name}, 0, 1) ne '&' } @params
);
for (grep { $_->{default} } @params) {
my $var = $_->{default}{code} ? '\\'. $_->{default}{code} : _emit( $_->{default} );
if ( substr($_->{name}, 0, 1) eq '&' ) {
my $name = substr($_->{name}, 1);
my $var = $_->{default}{code} ? '\\'. $_->{default}{code} : _emit( $_->{default} );
$defaults .= "local *$name = $var unless *$name;\n"; # XXX: WRONG
}
else {
my $name = _emit( {%$_, scalar => $_->{name}} );
$defaults .= "$name = $var unless defined $name;\n";
}
}
return((length($param) ? " my ($param);\n" : '').
" Data::Bind->arg_bind(\\\@_);\n $defaults;\n");
}
sub _emit_parameter_capture {
my $n = $_[0];
return '' unless $n;
# XXX: gah i am lazy
if ( exists $n->{fixity} && $n->{fixity} eq 'circumfix') {
$n = $n->{exp1} or return '';
}
$n = { list => [$n] }
if !($n->{assoc} && $n->{assoc} eq 'list');
my ($positional, @named) = ("\\(");
for (@{$n->{list}}) {
if (my $pair = $_->{pair}) {
push @named, $pair->{key}{single_quoted}.' => \\'.emit_parenthesis($pair->{value});
}
elsif ($_->{fixity} && $_->{fixity} eq 'infix' && $_->{op1} eq '=>') {
push @named, _emit($_->{exp1}).' => \\'.emit_parenthesis($_->{exp2});
}
else {
# \($scalar, 123, ), \@array, \($orz)
if (exists $_->{array} || exists $_->{hash}) {
$positional .= "), \\"._emit($_).", \\(";
}
else {
$positional .= (exists $_->{bare_block} ? 'sub ' : '')._emit($_).', ';
}
}
}
$positional .= ')';
return "[$positional], {".join(',', @named).'}';
}
sub runtime_method {
my $n = $_[0];
# runtime decision - method or lib call
my $self = _emit( $n->{self} );
if ( $self eq $_V6_SELF ) {
# '$_V6_SELF' is known to be an object
return $self . '->' . _emit( $n->{method} ) . emit_parenthesis( $n->{param} );
}
return
'do { my @_V6_TMP = ' . $self . "; " .
'( @_V6_TMP == 1 && Scalar::Util::blessed $_V6_TMP[0] ' .
" ? " .
'$_V6_TMP[0]->' .
_emit( $n->{method} ) . emit_parenthesis( $n->{param} ) .
" : " .
" Pugs::Runtime::Perl6::Scalar::" . _emit( $n->{method}, ' ' ) .
'( @_V6_TMP, ' . _emit( $n->{param} ) . ")" .
" ) }";
}
sub emit_parenthesis {
my $n = $_[0];
#print "paren: ", Dumper($n);
return emit_parenthesis( $n->{exp1} )
if ref( $n )
&& exists $n->{'fixity'}
&& $n->{'fixity'} eq 'circumfix'
&& $n->{'op1'} eq '('
&& $n->{'op2'} eq ')';
return '(' . ( defined $n ? _emit($n) : '' ) . ')';
}
sub closure_is_hash {
my $n = $_[0];
# not delimited by {...}
return 0
if $n && !$n->{bare_block};
#<audreyt> If the closure
#<audreyt> appears to delimit nothing but a comma-separated list starting with
#<audreyt> a pair (counting a single pair as a list of one element), the closure
#<audreyt> will be immediately executed as a hash composer.
#<audreyt> also, {} is a hash
#print "block: ",Dumper $n;
if ( exists $n->{bare_block}{statements} ) {
# {}
if ( @{$n->{bare_block}{statements}} == 0 ) {
return 1;
}
# { pair }
if (
@{$n->{bare_block}{statements}} == 1 &&
exists $n->{bare_block}{statements}[0]{op1} &&
$n->{bare_block}{statements}[0]{op1} eq '=>'
) {
return 1;
}
# { pair,pair, }
if (
@{$n->{bare_block}{statements}} == 1 &&
exists $n->{bare_block}{statements}[0]{op1} &&
( $n->{bare_block}{statements}[0]{op1} eq ','
|| ( ref $n->{bare_block}{statements}[0]{op1} eq 'HASH'
&& $n->{bare_block}{statements}[0]{op1} eq '=>'
)
)
# TODO - && is it a pair?
) {
return 1;
}
}
return 0;
}
sub emit_block_nobraces {
my $n = $_[0];
$n = { bare_block => $n }
if $n && !$n->{bare_block};
#print "block: ",Dumper $n;
if ( exists $n->{bare_block}{statements} ) {
if ( @{$n->{bare_block}{statements}} == 0 ) {
return " # hash\n";
}
if ( closure_is_hash( $n ) ) {
return _emit( $n->{bare_block}{statements}[0] ) . " # hash\n";
}
}
return _emit( $n->{bare_block} );
}
sub emit_block {
my $n = $_[0];
$n = { bare_block => $n }
if $n && !$n->{bare_block};
my $s = emit_block_nobraces( $n );
if ( exists $n->{trait} ) {
# BEGIN/END
return $n->{trait} . " { $s } ";
}
return " { $s } ";
}
sub _emit_closure {
my ($signature, $block) = @_;
return " Data::Bind->sub_signature( sub {" .
" my %_V6_PAD;\n" .
_emit_parameter_binding( $signature ) .
emit_block_nobraces( $block ) .
"\n }, "._emit_parameter_signature( $signature ).")\n";
}
sub default {
my $n = $_[0];
#warn "emit: ", Dumper( $n );
if ( exists $n->{pointy_block} ) {
# XXX: no signature yet
return _emit_closure($n->{signature}, $n->{pointy_block});
return "sub {\n" . _emit( $n->{pointy_block} ) . "\n }\n";
}
if ( exists $n->{op1} && $n->{op1} eq 'call' ) {
# warn "call: ",Dumper $n;
if ($n->{sub}{scalar} || $n->{sub}{exp1} || $n->{sub}{statement}) {
return _emit($n->{sub}). '->(' .
_emit_parameter_capture( $n->{param} ) . ')';
}
if ( $n->{sub}{bareword} eq 'call' ) {
# call;
#warn "super call: ",Dumper $n;
return "super"; # param list?
}
if ( $n->{sub}{bareword} eq 'hash' ) {
return ' %{{ ' . _emit( $n->{param} ) . ' }} ';
}
if ( $n->{sub}{bareword} eq 'use'
|| $n->{sub}{bareword} eq 'require'
) {
# use v6-alpha
if ( exists $n->{param}{cpan_bareword} ) {
if ( $n->{param}{cpan_bareword} =~ /^v6-/ ) {
return " # use v6-alpha\n";
}
}
#warn "call: ",Dumper $n;
if ( $n->{param}{sub}{bareword} =~ /^v5/ ) {
return "warn 'use v5 - not implemented'";
}
if ( $n->{param}{sub}{bareword} eq 'v6' ) {
return " # use v6\n";
}
# use perl5:module::name 'param'
if ( $n->{param}{sub}{lang} &&
$n->{param}{sub}{lang} eq 'perl5' ) {
return
"{ " .
# restore PERL5LIB - see 'perldoc lib'
'local @INC = @lib::ORIG_INC; ' .
"use " . _emit( $n->{param}{sub} ) . ' ' .
(exists $n->{param}{param} ? _emit($n->{param}{param}) : '' ) .
"; } ";
}
# use module::name 'param'
return "use " . _emit( $n->{param}{sub} ) . ' ' .
(exists $n->{param}{param}
? _emit($n->{param}{param})
: '' );
}
if ( $n->{sub}{bareword} eq 'enum' ) {
# enum name list;
if ( exists $n->{param}{sub} ) {
my $name = _emit( $n->{param}{sub} );
my @param = eval _emit( $n->{param}{param} );
return
"do { " .
"{ package ${name}; require Exporter; " .
" our \@ISA = qw(Exporter);" .
" our \@EXPORT = (" . ( join ",", map {
"'$_'"
} @param ) . "); " .
( join "\n", map {
" sub $param[$_] { $_ } ";
} 0 .. $#param ) .
"}" .
" ${name}->import(); " .
"1 } "; # /do -- t/oo/enums.t depends on enum returning true
}
}
return " " . $n->{sub}{bareword} . " '', " . _emit( $n->{param} )
if $n->{sub}{bareword} eq 'print' ||
$n->{sub}{bareword} eq 'warn';
return " ( print '', " . emit_parenthesis( $n->{param} ) . "," . '"\n" ) '
if $n->{sub}{bareword} eq 'say';
# XXX: handle args
return "Pugs::Runtime::Perl6::Routine->new(Devel::Caller::caller_cv(1))"
if $n->{sub}{bareword} eq 'caller';
# ???
$n->{sub}{bareword} = 'die'
if $n->{sub}{bareword} eq 'fail';
if ( $n->{sub}{bareword} eq 'each' ) {
# special case: each ( @a; @b );
# works like 'Y'
if ( exists $n->{param}{exp1}
&& exists $n->{param}{exp1}{list}
) {
my @param = map { _emit( $_ ) }
@{ $n->{param}{exp1}{list} };
my @param2 = map { '$' . substr($_,1) }
@param;
return
"do { " .
" my \$n = $param[0] > $param[1] ? $param[0] : $param[1]; " .
" map { ( ".$param2[0]."[\$_], ".$param2[1]."[\$_] ) } 0..\$n-1" .
"}"
}
}
# TODO - other builtins
my $subname = $n->{sub}{bareword};
if ( $subname ) {
if ($subname eq 'defined') {
my $param = _emit( $n->{param} );
# when testing defined-ness of $!, it is testing the emptiness of $@ in perl5.
return " length(\$@) " if $param eq '$::_V6_ERR_';
return " (defined $param )";
}
if ($subname eq 'substr' || $subname eq 'split' || $subname eq 'die' || $subname eq 'return' || $subname eq 'push' || $subname eq 'shift' || $subname eq 'join' || $subname eq 'index' || $subname eq 'undef' || $subname eq 'rand' || $subname eq 'int' || $subname eq 'splice' || $subname eq 'keys' || $subname eq 'values' || $subname eq 'sort' || $subname eq 'chomp' || $subname eq 'lc') {
return $subname . emit_parenthesis( $n->{param} );
}
# XXX: !(0) is not correctly parsed. workaround here.
if ($subname eq '!' || $subname eq 'not') {
return $subname.' '._emit($n->{param});
}
if ($subname eq 'WHAT') {
# WHAT was .ref
# WHICH was .id was .SKID
# HOW (class) was .META
return 'Pugs::Runtime::Perl6::Scalar::ref( \\'. _emit( $n->{param} ) . ')';
}
# runtime thunked builtins
if ($subname eq 'eval') {
return
'sub {
my $_eval_string = Pugs::Runtime::Perl6::eval_preprocess('. _emit_parameter_capture( $n->{param} ) . ');
local $@;
no warnings;
my @result;
if (wantarray) {
@result = eval $_eval_string;
}
else {
$result[0] = eval $_eval_string;
}
$::_V6_ERR_ = $@;
#warn $::_V6_ERR_ if $::_V6_ERR_;
wantarray ? @result : $result[0];' .
"\n}->()";
}
if ($subname eq 'open') {
return 'Perl6::Internals::open('. _emit_parameter_capture( $n->{param} ) . ')';
}
my $sub_name = Pugs::Runtime::Common::mangle_ident( $n->{sub}{bareword} );
$sub_name = "\&{'$sub_name'}"
if $sub_name =~ /^v6::/; # avoid perl5 syntax error
return ' ' . $sub_name .
(exists $n->{param} ? '(' . _emit_parameter_capture( $n->{param} ) . ')' : '()');
}
}
if ( exists $n->{op1} && $n->{op1} eq 'method_call' ) {
#print "method_call: ", Dumper( $n );
my $self = _emit( $n->{self} );
#print "self: ", Dumper( $self );
# self is Compile-time object
if ( Scalar::Util::blessed $self ) {
# XXX encode $method to longname & ASCII
my $method = $n->{method}{dot_bareword};
# eval is needed to enable method dispatch
my $code = eval '$self->' . $method . '( _emit( $n->{param} ) )';
die $@ if $@;
return $code;
}
if ($n->{method}{dot_bareword} eq 'map') {
my $param = $n->{param}{fixity} eq 'circumfix' ? $n->{param}{exp1} : undef;
my $code = $param->{bare_block} ? 'sub { '._emit($param).' }' : _emit($param);
return _emit( $n->{self} ) . '->' . 'map( '.$code.' )';
# return 'Pugs::Runtime::Perl6::Array::map([\('.$code.', '. _emit( $n->{self} ).')], {})';
}
if ( $n->{method}{dot_bareword} eq 'print' ||
$n->{method}{dot_bareword} eq 'warn' ) {
my $s = _emit( $n->{self} );
if ( $s eq Pugs::Runtime::Common::mangle_var('$*ERR') ) {
return " print STDERR '', " . _emit( $n->{param} );
}
return " print '', $s";
}
if ( $n->{method}{dot_bareword} eq 'say' ) {
my $s = _emit( $n->{self} );
if ( $s eq Pugs::Runtime::Common::mangle_var('$*ERR') ) {
return " print STDERR '', " . _emit( $n->{param} ) . ', "\n"';
}
return " print '', $s" . ', "\n"';
}
if ( $n->{method}{dot_bareword} eq 'perl' ) {
return 'Pugs::Runtime::Perl6::Scalar::perl' . emit_parenthesis( $n->{self} );
}
if ( $n->{method}{dot_bareword} eq 'yaml' ) {
return 'Pugs::Runtime::Perl6::Scalar::yaml' . emit_parenthesis( $n->{self} );
}
# TODO: other builtins
if ( $n->{method}{dot_bareword} eq 'defined' ) {
return '(defined ' . _emit( $n->{self} ) . ")\n";
}
#warn "method_call: ", Dumper( $n );
# constructor
if ( exists $n->{self}{bareword} ) {
# Str.new;
return
" '" . _emit( $n->{self} ) . "'->" . _emit( $n->{method} ) .
emit_parenthesis( $n->{param} );
}
# "autobox"
if ( exists $n->{self}{code} ) {
if ( $n->{method}{dot_bareword} eq 'goto' ) {
# &code.goto;
return
" \@_ = (" . _emit_parameter_capture( $n->{param} ) . ");\n" .
" " . _emit( $n->{method} ) . "( " .
_emit( $n->{self} ) . "->code )";
}
# &?ROUTINE.name;
return
_emit( $n->{self} ) . "->" .
_emit( $n->{method} ) . emit_parenthesis( $n->{param} )
}
#warn "method: ", Dumper( $n );
if ( exists $n->{self}{scalar} ) {
# $.scalar.method(@param)
return " " . _emit( $n->{self} ) . '->' .
_emit( $n->{method} ) .
emit_parenthesis( $n->{param} )
if $n->{self}{scalar} =~ /^\$\./;
# $scalar.++;
return 'ref' . emit_parenthesis( $n->{self} )
if $n->{method}{dot_bareword} eq 'WHAT'; # "ref"
# runtime decision - method or lib call
return runtime_method( $n );
}
if ( exists $n->{self}{op1}
|| exists $n->{self}{term}
) {
# %var<item>.++;
return runtime_method( $n );
}
# normal methods or subs
if ( exists $n->{sub}{bareword} ) {
return " " . Pugs::Runtime::Common::mangle_ident( $n->{sub}{bareword} ) .
'(' .
join ( ";\n", # XXX
map { _emit( $_ ) } @{$n->{param}}
) .
')';
}
}
if ( exists $n->{substitution}) {
return 'XXXX';
}
if ( exists $n->{rx} ) {
return 'qr{'.$n->{rx}{rx}.'}' if $n->{rx}{options}{perl5};
}
return _not_implemented( $n, "syntax" );
}
sub statement {
my $n = $_[0];
#warn "statement: ", Dumper( $n );
if ( # XXX: obsoleted, fix unless to use new structure
$n->{statement} eq 'unless' ) {
return " " . $n->{statement} .
emit_parenthesis( $n->{exp1} ) .
emit_block( $n->{exp2} ) . "\n" .
( $n->{exp3} ? " else" . emit_block( $n->{exp3} ) : '' );
}
if ( $n->{statement} eq 'if' ) {
my $ret = $n->{statement} .
emit_parenthesis( $n->{exp1} ) .
emit_block( $n->{exp2} ) . "\n";
for (@{$n->{exp3} || []}) {
if (ref($_) eq 'ARRAY') {
$ret .= 'elsif '.emit_parenthesis( $_->[0] ) .
emit_block( $_->[1] ) . "\n";
}
else {
$ret .= 'else '. emit_block( $_ ) . "\n";
}
}
return $ret;
}
if ( $n->{statement} eq 'do' ) {
return 'do ' . emit_block( $n->{exp1} );
}
if ( $n->{statement} eq 'given' ) {
return 'for (1) { local $_ = ' . _emit( $n->{exp1} ) . '; ' .
emit_block_nobraces( $n->{exp2} ) . ' } ';
}
if ( $n->{statement} eq 'when' ) {
return
'if (' .
_emit(
{
exp1 => { scalar => '$_' },
exp2 => $n->{exp1},
op1 => '~~',
fixity => 'infix',
}
) . ') {' . emit_block_nobraces( $n->{exp2} ) . '; last; V6_CONTINUE: ; } ';
}
if ( $n->{statement} eq 'default' ) {
return
'{' . emit_block_nobraces( $n->{exp1} ) . '; last; V6_CONTINUE: ; } ';
}
if ( $n->{statement} eq 'continue' ) {
return
'goto V6_CONTINUE';
}
if ( $n->{statement} eq 'break' ) {
return
'next';
}
if ( $n->{statement} eq 'for' ||
$n->{statement} eq 'while' ||
$n->{statement} eq 'until' ) {
#warn "for: ",Dumper $n;
if ( exists $n->{exp2}{pointy_block} ) {
if ($n->{statement} eq 'for'
&& $n->{exp2}{signature}
&& @{$n->{exp2}{signature}} > 1) {
return 'Pugs::Runtime::Perl6::Array::map([\\'._emit($n->{exp2}).', ['._emit($n->{exp1}).']], {})';
}
my @sigs = map { { scalar => $_->{name} } } @{$n->{exp2}{signature}};
my $sig = $n->{exp2}{signature} ? ' my ' . _emit( @sigs ) : '';
my $head = $n->{statement} eq 'for'
? $n->{statement} .
$sig .
emit_parenthesis( $n->{exp1} )
: $n->{statement} . ' ( '.
( $sig ? $sig . ' = ' : ''
) . _emit( $n->{exp1} ) . ' )';
return $head .
" { " . _emit( $n->{exp2}{pointy_block} ) . " }";
}
#die 'for/while/until should contain a block' unless $n->{exp2}{bare_block};
return " " . $n->{statement} .
emit_parenthesis( $n->{exp1} ) .
emit_block( $n->{exp2} );
}
if ( $n->{statement} eq 'loop' ) {
if ( ! exists $n->{exp1} ) {
return " while (1) " . emit_block( $n->{content} );
}
return " for ( ".
join(';', map { $_->{null} ? ' ' : _emit($_) } @{$n}{qw/exp1 exp2 exp3/}).
")\n" . emit_block( $n->{content} );
}
return _not_implemented( $n, "statement" );
}
sub emit_sub_name {
my $n = $_[0];
#print "sub name: ", Dumper( $n );
my $name = Pugs::Runtime::Common::mangle_ident( $n->{name} );
return $name
unless $n->{category};
return _emit( $n->{name} );
}
sub term {
my $n = $_[0];
#print "term: ", Dumper( $n );
if ( $n->{term} eq 'self' ) {
return $_V6_SELF;
}
if ( $n->{term} eq 'yada' ) {
return '( die "not implemented" )';
}
if ( $n->{term} eq 'undef' ) {
return ' undef ';
}
if ( $n->{term} eq 'grammar' ||
$n->{term} eq 'class' ||
$n->{term} eq 'package' ||
$n->{term} eq 'module' ||
$n->{term} eq 'role' ) {
# Moose: package xxx; use Moose;
# class Point;
# print Dumper($n);
my %old_env = %{ deep_copy( \%_V6_ENV ) };
local %_V6_ENV = %old_env;
my $id;
# TODO - anonymous class
# TODO - attributes
$id = ref( $n->{name} )
? $n->{name}{cpan_bareword}
: $n->{name};
my @a = split "-", $id;
my $version = ( @a > 1 && $a[-1] =~ /^[0-9]/ ? $a[-1] : '' );
my $namespace = $a[0]
? Pugs::Runtime::Common::mangle_ident( $a[0] )
: '';
my $attributes = '';
for my $attr ( @{$n->{attribute}} ) {
if ( $attr->[0]{bareword} eq 'is' &&
$attr->[1]{bareword} ne 'export' ) {
$attributes .= "push \@ISA, '" . Pugs::Runtime::Common::mangle_ident( $attr->[1]{bareword} ) . "';";
}
if ( $attr->[0]{bareword} eq 'does' ) {
# TODO
# $attributes .= "with '" . Pugs::Runtime::Common::mangle_ident( $attr->[1]{bareword} ) . "';";
$attributes .= "use base '" . Pugs::Runtime::Common::mangle_ident( $attr->[1]{bareword} ) . "';";
}
}
my $decl = "package $namespace" .
( $version
? ";
\$".$namespace."::VERSION = '$version'"
: "" ) .
( $n->{term} eq 'grammar'
? ";
use Pugs::Compiler::Rule;
use Moose;
use base 'Pugs::Grammar::Base';
no strict 'refs'"
: "" ) .
( $n->{term} eq 'class'
? ";
use Moose;
Pugs::Runtime::Perl6->setup_class;
no strict 'refs'"
: "" ) .
( $n->{term} eq 'role'
? ";
# use Moose::Role; XXX - need '\$object does role'
use Moose;
Pugs::Runtime::Perl6->setup_class;
no strict 'refs'"
: "" ) .
";
use Exporter 'import';
push our \@ISA, 'Exporter';
our \@EXPORT;
bool->import(); # True, False
$attributes ";
return ref( $n->{block} ) && exists $n->{block}{bare_block}
? "{ $decl; ".(@{$n->{block}{bare_block}{statements}}
? _emit($n->{block}) : '')."}"
: $decl;
}
if ( $n->{term} eq 'sub' ||
$n->{term} eq 'submethod' ||
$n->{term} eq 'method' ) {
#warn "sub: ",Dumper $n;
my %old_env = %{ deep_copy( \%_V6_ENV ) };
local %_V6_ENV = %old_env;
my $name = emit_sub_name( $n );
my $export = '';
for my $attr ( @{$n->{attribute}} ) {
if ( $attr->[0]{bareword} eq 'is' &&
$attr->[1]{bareword} eq 'export' ) {
$export = "push \@EXPORT, '$name';";
}
}
if (length $name) {
my $wrapper_name = $name;
my $multi_sub = '';
my $sigs = _emit_parameter_signature ( $n->{signature} ) ;
if ($n->{multi}) {
$name .= '_'.md5_hex($sigs);
$multi_sub = "BEGIN { Sub::Multi->add_multi('$wrapper_name', \\&$name) }\n";
}
# XXX: check incompatible attributes
return "$name = "._emit_closure($n->{signature}, $n->{block})
if $n->{category};
#print "Term: ", Dumper( $n );
return "local *$name = "._emit_closure($n->{signature}, $n->{block})
if $n->{my};
return $export . " sub " . $name .
" {\n" .
" my %_V6_PAD;\n" .
(
$n->{term} =~ /method/
? " my \$_V6_SELF = shift; " # default invocant
: ""
) .
_emit_parameter_binding( $n->{signature} ) .
emit_block_nobraces( $n->{block} ) .
"\n };\n" . # ; required when assigning to local
"## Signature for $name\n" .
" Data::Bind->sub_signature\n".
" (\\&$name, $sigs);\n$multi_sub";
}
else {
return _emit_closure($n->{signature}, $n->{block});
}
}
if ( $n->{term} eq 'rule' ||
$n->{term} eq 'token' ||
$n->{term} eq 'regex' ) {
#warn "rule: ",Dumper $n;
my $name = emit_sub_name( $n );
my $export = '';
for my $attr ( @{$n->{attribute}} ) {
if ( $attr->[0]{bareword} eq 'is' &&
$attr->[1]{bareword} eq 'export' ) {
$export = "push \@EXPORT, '$name';";
}
}
my $perl5;
for my $attr ( @{$n->{attribute}} ) {
if ( $attr->[0]{bareword} eq ':P5' ) {
die "TODO: regex :P5 {...}";
}
}
if ( $n->{term} eq 'regex' ) {
$perl5 = Pugs::Emitter::Rule::Perl5::emit(
'Pugs::Grammar::Base',
$n->{block},
{}, # options
);
}
elsif ( $n->{term} eq 'rule' ) {
$perl5 = Pugs::Emitter::Rule::Perl5::Ratchet::emit(
'Pugs::Grammar::Base',
$n->{block},
{ sigspace => 1 }, # options
);
}
else {
$perl5 = Pugs::Emitter::Rule::Perl5::Ratchet::emit(
'Pugs::Grammar::Base',
$n->{block},
{}, # options
);
}
if ( $n->{category} ) {
# XXX - signature, exports are currently disabled, need more work
$perl5 =~ s/
my \s+ \$grammar \s+ = .*? ; \s+
my \s+ \$s \s+ = .*? ;
/
my \$s = \$_[0] || '';
my \$grammar = \$_[1] || __PACKAGE__;
/sx;
return "$name = $perl5";
}
elsif ( $name ) {
$perl5 =~ s/
(my \s+ \$grammar)
/
\$_[3] = \$_[2];
\$_[2] = undef;
$1
/sx;
$perl5 = "*$name = $perl5";
}
else {
$perl5 =~ s/
my \s+ \$grammar \s+ = .*? ; \s+
my \s+ \$s \s+ = .*? ;
/
my \$s = \$_[0] || '';
my \$grammar = \$_[1] || __PACKAGE__;
\$_[3] = \$_[2];
\$_[2] = undef;
/sx;
return $perl5;
}
# TODO - _emit_parameter_binding( $n->{signature} ) .
return $export .
$perl5 . ";" .
"## Signature for $name\n" .
" Data::Bind->sub_signature\n".
" (\\&$name, ". _emit_parameter_signature ( $n->{signature} ) . ");\n";
}
return _not_implemented( $n, "term" );
}
sub infix {
my $n = $_[0];
#print "infix: ", Dumper( $n );
if ( $n->{op1} eq '..' ) {
my $v1 = _emit( $n->{exp1} );
my $v2 = _emit( $n->{exp2} );
return Pugs::Emitter::Perl6::Perl5::node->node( 'Perl5Range', [ $v1, $v2 ] )
if Scalar::Util::blessed $v1
&& Scalar::Util::blessed $v2;
}
if ( $n->{op1} eq 'xx' ) {
return
'do { my @_V6_TMP1 = ' . _emit( $n->{exp1} ) . '; ' .
' my @_V6_TMP2; push @_V6_TMP2, @_V6_TMP1 for 1..' .
_emit( $n->{exp2} ) . '; @_V6_TMP2 } ';
}
if ( $n->{op1} eq 'xx=' ) {
return
'(' .
_emit( $n->{exp1} ) . ' = ' .
'do { my @_V6_TMP1 = ' . _emit( $n->{exp1} ) . '; ' .
' my @_V6_TMP2; push @_V6_TMP2, @_V6_TMP1 for 1..' .
_emit( $n->{exp2} ) . '; @_V6_TMP2 } ' .
')';
}
if ( $n->{op1} eq '~' ) {
return _emit( $n->{exp1} ) . ' . ' . _emit( $n->{exp2} );
}
if ( $n->{op1} eq '=>' ) {
return _emit_pair( $n->{exp1}, $n->{exp2} );
}
if ( $n->{op1} eq '~=' ) {
return _emit( $n->{exp1} ) . ' .= ' . _emit( $n->{exp2} );
}
if ( $n->{op1} eq '//' ||
$n->{op1} eq 'err' ) {
# ( !defined ($::TMP=( my $x = $v )) ? $y : $::TMP )
my $id1 = $id++;
return
' ( !defined ( $_V6_PAD{'.$id1.'} = ( ' . _emit( $n->{exp1} ) . ' )) ' .
' ? ( ' . _emit( $n->{exp2} ) . ' ) ' .
' : $_V6_PAD{'.$id1.'} ) ';
}
if ( $n->{op1} eq 'does' ) {
# XXX - fix this when Moose implements '$object does'
#print Dumper( $n->{exp2} );
return "'" . $n->{exp2}{sub}{bareword} . "'" .
'->new( ' . _emit( $n->{exp1} ) . ' )'
}
if ( $n->{op1} eq '=:=' ) {
# XXX: Data::Bind needs to provide an API. we are now
# actually with different address using the magic proxying in D::B.
return 'Scalar::Util::refaddr(\\'._emit($n->{exp1}).
') == Scalar::Util::refaddr(\\'._emit($n->{exp2}).')';
}
if ( $n->{op1} eq ':=' ) {
# experimenting with Lexical::Alias
#return ' Lexical::Alias::alias( ' . _emit($n->{exp1}) . ', ' . _emit($n->{exp2}) . ' )';
#warn "bind: ", Dumper( $n );
# The hassle here is that we can't use \(@x) or \(my @x)
my $_emit_value = sub { exists $_[0]->{array} ||
(exists $_[0]->{fixity} && $_[0]->{fixity} eq 'prefix' &&
exists $_[0]->{op1} &&
$_[0]->{op1} eq 'my' && exists $_[0]->{exp1}{array})
? '\\' . _emit($_[0])
: '\\'. emit_parenthesis($_[0])
};
return " Data::Bind::bind_op2( " . $_emit_value->( $n->{exp1} ) . ','
. 'scalar '.$_emit_value->( $n->{exp2} ). ' )';
}
if ( $n->{op1} eq '~~' ) {
#print "infix:<~~> \n";
if ( my $subs = $n->{exp2}{substitution} ) {
# XXX: use Pugs::Compiler::RegexPerl5
# XXX: escape
my $p5options = join('', map { $subs->{options}{$_} ? $_ : '' } qw(s m g e));
return _emit( $n->{exp1} ) . ' =~ s{' . $subs->{substitution}[0]. '}{'. $subs->{substitution}->[1] .'}' . $p5options
if $subs->{options}{p5};
return _not_implemented( $n, "rule" );
}
if ( my $rx = $n->{exp2}{rx} ) {
if ( !$rx->{options}{perl5} ) {
my $regex = $rx->{rx};
my %options = %{$rx->{options}};
#print "Options: @{[ %options ]} \n";
my $opt = '';
if ( exists $options{'g'} ) {
$opt .= 'continue => 1, p => ( $_V6_M ? (
$_V6_M->to
) : undef )';
# XXX: hack for /$pattern/
$regex = 'q{'.$regex.'}' unless $regex =~ m/^\$[\w\d]+/;
return
'do {
undef $::_V6_MATCH_;
my @_V6_TMP;
my $_V6_RX = Pugs::Compiler::Regex->compile( '.$regex.', { grammar => __PACKAGE__ } );
my $_V6_M;
while (
$_V6_M = $_V6_RX->match('._emit($n->{exp1}).', { '.$opt.' } )
) {
#print "Match: $_V6_M \n";
push @_V6_TMP, $_V6_M
}
@_V6_TMP;
}';
}
if ( exists $options{'c'} ) {
$opt .= 'continue => 1, p => ( $::_V6_MATCH_ ? (
$::_V6_MATCH_->to
) : undef )';
}
# XXX: hack for /$pattern/
$regex = 'q{'.$regex.'}' unless $regex =~ m/^\$[\w\d]+/;
return '$::_V6_MATCH_ = Pugs::Compiler::Regex->compile( '.$regex.', { grammar => __PACKAGE__ } )->match('._emit($n->{exp1}).', { '.$opt.' } )';
}
}
return _emit( $n->{exp1} ) . ' =~ (ref' . emit_parenthesis( $n->{exp2} ).' eq "Regexp" '.
' ? '._emit($n->{exp2}).
' : quotemeta'.emit_parenthesis($n->{exp2}).
')';
}
if ( $n->{op1} eq '=' ) {
#print "{'='}: ", Dumper( $n );
if ( exists $n->{exp1}{variable_declarator}
&& exists $n->{exp1}{exp1}{scalar}
|| exists $n->{exp1}{scalar}
) {
#print "set $n->{exp1}{exp1}{scalar}";
#print "{'='}: set scalar ",Dumper($n->{exp2});
my $v = _emit( $n->{exp2} );
# XXX uncomment when Data::Bind accepts refs
return _emit( $n->{exp1} ) . ' = ' . $v->scalar
if Scalar::Util::blessed $v;
if ( exists $n->{exp2}{'bare_block'}
) {
if ( closure_is_hash( $n->{exp2} ) ) {
return _emit( $n->{exp1} ) . ' = ' .
"bless " . _emit( $n->{exp2} ) . ", 'Pugs::Runtime::Perl5Container::Hash' ";
}
return _emit( $n->{exp1} ) . ' = ' .
"bless sub " . _emit( $n->{exp2} ) . ", 'Pugs::Runtime::Perl5Container::Code' ";
}
return _emit( $n->{exp1} ) . ' = ' . _emit( $n->{exp2} );
#return _var_set( $n->{exp1}{scalar} )->( _var_get( $n->{exp2} ) );
}
if ( exists $n->{exp1}{hash} ) {
my $exp2 = $n->{exp2};
$exp2 = $exp2->{exp1}
if exists $exp2->{'fixity'}
&& $exp2->{'fixity'} eq 'circumfix'
&& $exp2->{'op1'} eq '(';
#print "{'='}: set hash ",Dumper($exp2);
# Note - the AST is changed in-place here
if ( exists $exp2->{'list'} ) {
$exp2->{'list'} = [
map {
exists ( $_->{pair} )
? ( $_->{pair}{key},
$_->{pair}{value}
)
: $_
}
@{ $exp2->{'list'} }
];
}
return _emit( $n->{exp1} ) .
" = " . emit_parenthesis( $exp2 );
}
if ( exists $n->{exp1}{op1} && ref $n->{exp1}{op1} &&
$n->{exp1}{op1} eq 'has' ) {
#print "{'='}: ", Dumper( $n );
# XXX - changes the AST
push @{ $n->{exp1}{attribute} },
[ { bareword => 'default' },
$n->{exp2}
];
#print "{'='}: ", Dumper( $n );
return _emit( $n->{exp1} );
}
return _emit( $n->{exp1} ) .
" = " . _var_get( $n->{exp2} );
}
if ( $n->{op1} eq '+=' ) {
#print "{'='}: ", Dumper( $n );
if ( exists $n->{exp1}{scalar} ) {
#warn "set $n->{exp1}{scalar}";
return _var_set( $n->{exp1}{scalar} )->(
_emit(
{
fixity => 'infix',
op1 => '+',
exp1 => $n->{exp1},
exp2 => $n->{exp2},
}
)
);
}
return _emit( $n->{exp1} ) .
" = " . _emit( $n->{exp2} );
}
if ( exists $n->{exp2}{bare_block} ) {
# $a = { 42 }
return " " . _emit( $n->{exp1} ) . ' ' .
$n->{op1} . ' ' . "sub " . _emit( $n->{exp2} );
}
return '(' . _emit( $n->{exp1} ) . ' ' .
$n->{op1} . ' ' . _emit( $n->{exp2} ) . ')';
}
sub circumfix {
my $n = $_[0];
#print "circumfix: ", Dumper( $n );
if ( $n->{op1} eq '(' &&
$n->{op2} eq ')' ) {
my $v = _emit( $n->{exp1} );
return $v
if Scalar::Util::blessed( $v );
return emit_parenthesis( $n->{exp1} );
}
if ( $n->{op1} eq '[' &&
$n->{op2} eq ']' ) {
return '[]'
unless defined $n->{exp1};
my $v = _emit( $n->{exp1} );
#print "List ", ref($v), " = ", $v, "\n";
#print "Array ", ref($v->array), " = ", $v->array, "\n";
#print "Scalar ", ref($v->array->scalar), " = ", $v->array->scalar, "\n";
return $v->list->scalar
if Scalar::Util::blessed( $v );
return '[' . $v . ']';
}
return _not_implemented( $n, "circumfix" );
}
sub postcircumfix {
my $n = $_[0];
#warn "postcircumfix: ", Dumper( $n );
if ( $n->{op1} eq '(' &&
$n->{op2} eq ')' ) {
# warn "postcircumfix:<( )> ", Dumper( $n );
# $.scalar(@param)
return " " . _emit( $n->{exp1} ) .
'->' . emit_parenthesis( $n->{exp2} )
if exists $n->{exp1}{scalar} &&
$n->{exp1}{scalar} =~ /^\$\./;
}
if ( $n->{op1} eq '[' &&
$n->{op2} eq ']' ) {
if ( ! exists $n->{exp2} ) {
# $array[]
# TODO - bless
return '@{ ' . _emit( $n->{exp1} ) . ' }';
}
if ( exists $n->{exp1}{array} # @array
|| exists $n->{exp1}{op1} # (1,2,3)
&& $n->{exp1}{op1} eq '('
&& exists $n->{exp1}{exp1}{op1}
&& $n->{exp1}{exp1}{op1} eq ','
) {
#print ".[] = " . Dumper( $n->{exp2} );
my $name = _emit( $n->{exp1} );
# the extra parenthesis avoid p5 warning - "@a[1] better written as $a[1]"
return $name . '[(' . _emit( $n->{exp2} ) . ')]';
}
return '@{' . _emit( $n->{exp1} ) . '}[(' . _emit( $n->{exp2} ) . ')]';
#return _emit( $n->{exp1} ) . '->[' . _emit( $n->{exp2} ) . ']';
}
if ( $n->{op1} eq '<' &&
$n->{op2} eq '>' ) {
my $name = _emit( $n->{exp1} );
#$name =~ s/^\%/\$/;
# $/<x>
return " " . _emit( $n->{exp1} ) .
'->{ ' . _emit_angle_quoted( $n->{exp2}{angle_quoted} ) . ' }'
if exists $n->{exp1}{scalar};
# looks like a hash slice
$name =~ s/^(?: \% | \$ ) / \@ /x;
return $name . '{ ' . _emit_angle_quoted( $n->{exp2}{angle_quoted} ) . ' }';
}
if ( $n->{op1} eq '{' &&
$n->{op2} eq '}' ) {
my $name = _emit( $n->{exp1} );
# $/{'x'}
return " " . _emit( $n->{exp1} ) .
'->{' . _emit( $n->{exp2}{statements}[0] ) . '}'
if exists $n->{exp1}{scalar};
# die "trying to emit ${name}{exp}" unless $name =~ m/^\%/;
#print "postcircumfix{} ",Dumper( $n->{exp2}{statements} );
if ( exists $n->{exp2}{statements}[0]{list}
)
{
# looks like a hash slice
$name =~ s/^(?: \% | \$ ) / \@ /x;
}
else {
$name =~ s/^\%/\$/;
}
return $name .
'{ ' .
join('}{',
map {
_emit($_)
} @{$n->{exp2}{statements}} ) .
' }';
}
return _not_implemented( $n, "postcircumfix" );
}
sub prefix {
my $n = $_[0];
# print "prefix: ", Dumper( $n );
my $v = _emit( $n->{exp1} );
#-- coercions
if ( $n->{op1} eq 'str'
|| $n->{op1} eq '~'
) {
return $v->str
if Scalar::Util::blessed $v;
#print Dumper( $n );
return ' "' . _emit( $n->{exp1} ) . '"'
if exists $n->{exp1}{op1}
&& $n->{exp1}{op1} eq '[';
return ' "" . ' . _emit( $n->{exp1} );
}
if ( $n->{op1} eq 'num'
|| $n->{op1} eq '+'
) {
return $v->num
if Scalar::Util::blessed $v;
return '(0+('._emit($n->{exp1}).'))';
}
if ( $n->{op1} eq 'int' ) {
return $v->int
if Scalar::Util::blessed $v;
return 'int('._emit($n->{exp1}).')';
}
if ( $n->{op1} eq 'true'
|| $n->{op1} eq '?'
) {
return $v->true
if Scalar::Util::blessed $v;
return '('._emit($n->{exp1}).' ? 1 : 0 )';
}
if ( $n->{op1} eq 'not'
|| $n->{op1} eq '!'
) {
return _emit( $n->{exp1} ) . ' ? 0 : 1 ';
}
if ( $n->{op1} eq 'scalar'
|| $n->{op1} eq '$'
) {
return $v->scalar
if Scalar::Util::blessed $v;
return '${' . _emit( $n->{exp1} ) . '}';
}
if ( $n->{op1} eq 'hash'
|| $n->{op1} eq '%'
) {
return $v->hash
if Scalar::Util::blessed $v;
}
if ( $n->{op1} eq 'array' # XXX list ?
|| $n->{op1} eq '@'
) {
return $v->list
if Scalar::Util::blessed $v;
}
#-- /coercions
if ( $n->{op1} eq 'do' ) {
return $n->{op1} . ' ' . _emit( $n->{exp1} );
}
if ( $n->{op1} eq 'try' ) {
#warn "try: ", Dumper( $n );
#if ( exists $n->{trait} ) {
# # CATCH/CONTROL
# return $n->{trait} . " {\n" . _emit( $n->{bare_block} ) . "\n }";
#}
my $id1 = $id++;
#return 'do { $_V6_PAD{'.$id1.'} = [ eval ' . _emit( $n->{exp1} ) . " ]; " .
# Pugs::Runtime::Common::mangle_var( '$!' ) . ' = $@; @{$_V6_PAD{'.$id1.'}} }';
return
'sub {
local $@;
no warnings;
my @result;
if (wantarray) {
@result = eval ' . _emit( $n->{exp1} ) . ';
}
else {
$result[0] = eval ' . _emit( $n->{exp1} ) . ';
}
$::_V6_ERR_ = $@;
#warn $::_V6_ERR_ if $::_V6_ERR_;
wantarray ? @result : $result[0];' .
"\n}->()";
}
if ( $n->{op1} eq '++' ||
$n->{op1} eq '--' ||
$n->{op1} eq '+' ||
$n->{op1} eq '-' ) {
return $n->{op1} . _emit( $n->{exp1} );
}
if ($n->{op1} eq '=') { # iterate
return _emit($n->{exp1}).'->getline';
}
return _not_implemented( $n, "prefix" );
}
sub postfix {
my $n = $_[0];
# print "postfix: ", Dumper( $n );
if ( $n->{op1} eq '++' ||
$n->{op1} eq '--' ) {
return _emit( $n->{exp1} ) . $n->{op1};
}
return _not_implemented( $n, "postfix" );
}
sub ternary {
my $n = $_[0];
# print "ternary: ", Dumper( $n );
my $v = _emit( $n->{exp1} );
if ( $n->{op1} eq '??' ||
$n->{op2} eq '!!' ) {
return $v->true .
' ? ' . _emit( $n->{exp2} ) .
' : ' . _emit( $n->{exp3} )
if Scalar::Util::blessed $v;
return _emit( $n->{exp1} ) .
' ? ' . _emit( $n->{exp2} ) .
' : ' . _emit( $n->{exp3} ) ;
}
return _not_implemented( $n, "ternary" );
}
sub variable_declarator {
my $n = $_[0];
if ( $n->{'variable_declarator'} eq 'my' ||
$n->{'variable_declarator'} eq 'our' ) {
#die "not implemented 'attribute'",Dumper $n
# if @{$n->{attribute}};
if ( ref $n->{exp1}
&& exists $n->{exp1}{term}
) {
$n->{exp1}{my} = $n->{'variable_declarator'};
return _emit( $n->{exp1} );
}
return $n->{'variable_declarator'} . ' ' . _emit( $n->{exp1} );
}
if ( $n->{'variable_declarator'} eq 'constant' ) {
my $name;
for (qw( scalar hash array )) {
$name = $n->{exp1}{$_} if exists $n->{exp1}{$_}
}
$name = _emit( $n->{exp1} ) unless $name;
my $no_sigil = substr( $name, 1 );
$_V6_ENV{$name}{get} = $_V6_ENV{$name}{set} = $no_sigil;
return "use constant $no_sigil "; # TODO - set initial value
}
if ( $n->{'variable_declarator'} eq 'state' ) {
$id++;
#print "State: $id $name ", Dumper( $n->{exp1} );
my $name;
for (qw( scalar hash array )) {
$name = $n->{exp1}{$_} if exists $n->{exp1}{$_}
}
$name = _emit( $n->{exp1} ) unless $name;
my $sigil = substr( $name, 0, 1 );
$_V6_ENV{$name}{get} = $_V6_ENV{$name}{set} =
$sigil . '{$_V6_STATE{'.$id.'}}';
return _emit( $n->{exp1} );
}
if ( $n->{'variable_declarator'} eq 'has' ) {
# Moose: has 'xxx';
# has $x;
#warn "has: ",Dumper $n;
my $name = _emit( $n->{exp1} );
#my $name = _emit( $n->{exp1} );
$name =~ s/^\$//; # remove sigil
my $raw_name;
$raw_name = $n->{exp1}{scalar} if exists $n->{exp1}{scalar};
$_V6_ENV{$raw_name}{set} = sub {
"\$_V6_SELF->" . substr($raw_name,2) . "(" . $_[0] . ")"
};
# is rw?
#warn Dumper @{$n->{attribute}};
my $is_rw = grep { $_->[0]{bareword} eq 'is' &&
$_->[1]{bareword} eq 'rw' } @{$n->{attribute}};
if ( $is_rw ) {
$_V6_ENV{$raw_name}{set} = sub {
"\$_V6_SELF->{'" . substr($raw_name,2) . "'} = " . $_[0]
}
}
my $attr = join( ', ',
map {
join( ' => ', map { "'" . _emit($_) . "'" } @$_ )
} @{$n->{attribute}}
);
return $n->{'variable_declarator'} . " '" . substr($raw_name,2) . "' => ( $attr )";
}
}
1;
__END__
=head1 NAME
Pugs::Emitter::Perl6::Perl5 - Code generator for the Perl6-to-Perl5 compiler
=head1 SYNOPSIS
# TODO
=head1 DESCRIPTION
This module provides the Perl5 code generator for the C<v6.pm> Perl6 compiler.
=head1 AUTHORS
The Pugs Team C<< <perl6-compiler@perl.org> >>.
Please join us on irc.freenode.net #perl6 if you'd like to participate.
=head1 SEE ALSO
The Perl 6 Spec: L<http://dev.perl.org>
=head1 COPYRIGHT
Copyright 2006 by Flavio Soibelmann Glock and others.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut