Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: b2512a4129
Fetching contributors…

Cannot retrieve contributors at this time

executable file 697 lines (620 sloc) 22.063 kb
use v5;
use Perlito5::AST;
package Perlito5::Perl6;
{
sub tab {
my $level = shift;
"\t" x $level
}
my %safe_char = (
'$' => 1,
'%' => 1,
'@' => 1,
'&' => 1,
'_' => 1,
',' => 1,
'.' => 1,
':' => 1,
';' => 1,
'-' => 1,
'+' => 1,
'*' => 1,
' ' => 1,
'(' => 1,
')' => 1,
'<' => 1,
'=' => 1,
'>' => 1,
'[' => 1,
']' => 1,
'{' => 1,
'|' => 1,
'}' => 1,
);
sub escape_string {
my $s = shift;
my @out;
my $tmp = '';
return "''" if $s eq '';
for my $i (0 .. length($s) - 1) {
my $c = substr($s, $i, 1);
if ( ($c ge 'a' && $c le 'z')
|| ($c ge 'A' && $c le 'Z')
|| ($c ge '0' && $c le '9')
|| exists( $safe_char{$c} )
)
{
$tmp = $tmp . $c;
}
else {
push @out, "'$tmp'" if $tmp ne '';
push @out, "chr(" . ord($c) . ")";
$tmp = '';
}
}
push @out, "'$tmp'" if $tmp ne '';
return join(' ~ ', @out);
}
sub to_str {
my $cond = shift;
if ($cond->isa( 'Perlito5::AST::Val::Buf' )) {
return $cond->emit_perl6;
}
else {
return '(' . $cond->emit_perl6 . ')'; # XXX change if needed
}
}
sub to_num {
my $cond = shift;
if ($cond->isa( 'Perlito5::AST::Val::Int' ) || $cond->isa( 'Perlito5::AST::Val::Num' )) {
return $cond->emit_perl6;
}
else {
return '(' . $cond->emit_perl6 . ')'; # XXX change if needed
}
}
sub to_bool {
my $cond = shift;
if ( ($cond->isa( 'Perlito5::AST::Val::Int' ))
|| ($cond->isa( 'Perlito5::AST::Val::Num' ))
|| ($cond->isa( 'Perlito5::AST::Apply' ) && $cond->code eq 'infix:<||>')
|| ($cond->isa( 'Perlito5::AST::Apply' ) && $cond->code eq 'infix:<&&>')
|| ($cond->isa( 'Perlito5::AST::Apply' ) && $cond->code eq 'prefix:<!>')
)
{
return $cond->emit_perl6;
}
else {
return '(' . $cond->emit_perl6 . ')'; # XXX change if needed
}
}
}
package Perlito5::Perl6::LexicalBlock;
{
sub new { my $class = shift; bless {@_}, $class }
sub block { $_[0]->{block} }
sub needs_return { $_[0]->{needs_return} }
sub top_level { $_[0]->{top_level} }
sub emit_perl6 {
my $self = shift;
my $level = shift;
if ($self->{top_level}) {
my $block = Perlito5::Perl6::LexicalBlock->new( block => $self->block, needs_return => $self->needs_return, top_level => 0 );
return $block->emit_perl6( $level + 1 ) . ';' . "\n"
}
my @block;
for (@{$self->{block}}) {
if (defined($_)) {
push @block, $_
}
}
if (!@block) {
return Perlito5::Perl6::tab($level) . ';';
}
my @str;
for my $decl ( @block ) {
if ($decl->isa( 'Perlito5::AST::Decl' ) && $decl->decl eq 'my') {
push @str, Perlito5::Perl6::tab($level) . $decl->emit_perl6_init;
}
if ($decl->isa( 'Perlito5::AST::Apply' ) && $decl->code eq 'infix:<=>') {
my $var = $decl->arguments[0];
if ($var->isa( 'Perlito5::AST::Decl' ) && $var->decl eq 'my') {
push @str, Perlito5::Perl6::tab($level) . $var->emit_perl6_init;
}
}
}
for my $decl ( @block ) {
if (!( $decl->isa( 'Perlito5::AST::Decl' ) && $decl->decl eq 'my' )) {
push @str, $decl->emit_perl6($level) . ';';
}
}
return join("\n", @str) . ';';
}
}
package Perlito5::AST::CompUnit;
{
sub emit_perl6 {
my $self = $_[0];
my $level = $_[1];
# process 'package' statements
my @body;
my $i = 0;
while ( $i <= scalar @{$self->{body}} ) {
my $stmt = $self->{body}->[$i];
if ( ref($stmt) eq 'Perlito5::AST::Apply' && $stmt->code eq 'package' ) {
# found an inner package
my $name = $stmt->namespace;
my @stmts;
$i++;
while ( $i <= scalar( @{$self->{body}} )
&& !( ref($self->{body}->[$i]) eq 'Perlito5::AST::Apply' && $self->{body}->[$i]->code eq 'package' )
)
{
push @stmts, $self->{body}->[$i];
$i++;
}
push @body, Perlito5::AST::CompUnit->new( name => $name, body => \@stmts );
}
else {
push @body, $stmt
if defined $stmt; # TODO find where undefined stmts come from
$i++;
}
}
my $class_name = $self->{name};
my $str = 'package ' . $class_name . '{' . "\n";
for my $decl ( @body ) {
if ($decl->isa( 'Perlito5::AST::Decl' ) && ( $decl->decl eq 'my' )) {
$str = $str . ' ' . $decl->emit_perl6_init;
}
if ($decl->isa( 'Perlito5::AST::Apply' ) && $decl->code eq 'infix:<=>') {
my $var = $decl->arguments[0];
if ($var->isa( 'Perlito5::AST::Decl' ) && $var->decl eq 'my') {
$str = $str . ' ' . $var->emit_perl6_init;
}
}
}
for my $decl ( @body ) {
if ($decl->isa( 'Perlito5::AST::Sub' )) {
$str = $str . ($decl)->emit_perl6( $level + 1 ) . ";\n";
}
}
for my $decl ( @body ) {
if ( defined( $decl )
&& (!( $decl->isa( 'Perlito5::AST::Decl' ) && $decl->decl eq 'my' ))
&& (!( $decl->isa( 'Perlito5::AST::Sub')))
)
{
$str = $str . ($decl)->emit_perl6( $level + 1 ) . ";\n";
}
}
$str . "}\n";
}
sub emit_perl6_program {
my $comp_units = shift;
my $str = '';
# $str .= "use Perlito5::Perl6::Runtime;\n";
for my $comp_unit ( @$comp_units ) {
$str = $str . $comp_unit->emit_perl6() . "\n";
}
return $str;
}
}
package Perlito5::AST::Val::Int;
{
sub emit_perl6 {
my $self = shift;
my $level = shift; Perlito5::Perl6::tab($level) . $self->{int} }
}
package Perlito5::AST::Val::Num;
{
sub emit_perl6 {
my $self = shift;
my $level = shift; Perlito5::Perl6::tab($level) . $self->{num} }
}
package Perlito5::AST::Val::Buf;
{
sub emit_perl6 {
my $self = shift;
my $level = shift; Perlito5::Perl6::tab($level) . Perlito5::Perl6::escape_string($self->{buf}) }
}
package Perlito5::AST::Lit::Block;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $sig = '$_';
if ($self->{sig}) {
$sig = $self->{sig}->emit_perl6( $level + 1 );
}
return
Perlito5::Perl6::tab($level) . "(function ($sig) \{\n"
. (Perlito5::Perl6::LexicalBlock->new( block => $self->{stmts}, needs_return => 1 ))->emit_perl6( $level + 1 ) . "\n"
. Perlito5::Perl6::tab($level) . '})'
}
}
package Perlito5::AST::Index;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
if ( $self->{obj}->isa('Perlito5::AST::Var')
&& $self->{obj}->sigil eq '$'
)
{
my $v = Perlito5::AST::Var->new( sigil => '@', namespace => $self->{obj}->namespace, name => $self->{obj}->name );
return $v->emit_perl6($level) . '[' . $self->{index_exp}->emit_perl6() . ']';
}
Perlito5::Perl6::tab($level) . $self->{obj}->emit_perl6() . '[' . $self->{index_exp}->emit_perl6() . ']';
}
}
package Perlito5::AST::Lookup;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
if ( $self->{obj}->isa('Perlito5::AST::Var')
&& $self->{obj}->sigil eq '$'
)
{
my $v = Perlito5::AST::Var->new( sigil => '%', namespace => $self->{obj}->namespace, name => $self->{obj}->name );
return $v->emit_perl6($level) . '{' . $self->{index_exp}->emit_perl6() . '}';
}
return $self->{obj}->emit_perl6($level) . '{' . $self->{index_exp}->emit_perl6() . '}';
}
}
package Perlito5::AST::Var;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
if ( $self->{sigil} eq '*' ) {
my $ns = 'PKG';
if ($self->{namespace}) {
$ns = 'NAMESPACE["' . $self->{namespace} . '"]';
}
return $ns . '::' . $self->{name};
}
my $ns = '';
if ($self->{namespace}) {
$ns = $self->{namespace} . '::';
}
$ns . $self->{sigil} . $self->{name}
}
}
package Perlito5::AST::Proto;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
Perlito5::Perl6::tab($level) . $self->{name}
}
}
package Perlito5::AST::Call;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $invocant = $self->{invocant}->emit_perl6;
my $meth = $self->{method};
if ( $meth eq 'postcircumfix:<[ ]>' ) {
return Perlito5::Perl6::tab($level) . $invocant . '[' . $self->{arguments}->emit_perl6() . ']'
}
if ( $meth eq 'postcircumfix:<{ }>' ) {
return Perlito5::Perl6::tab($level) . $invocant . '{' . $self->{arguments}->emit_perl6() . '}'
}
if ($meth eq 'postcircumfix:<( )>') {
my @args = ();
push @args, $_->emit_perl6
for @{$self->{arguments}};
return Perlito5::Perl6::tab($level) . '(' . $invocant . ')(' . join(',', @args) . ')';
}
# try to call a method on the class; if that fails, then call a 'native js' method
my @args = ($invocant);
push @args, $_->emit_perl6
for @{$self->{arguments}};
return Perlito5::Perl6::tab($level) . $invocant . '.' . $meth . '(' . join(',', @args) . ')'
}
}
package Perlito5::AST::Apply;
{
my %op_infix_js = (
'infix:<->' => ' - ',
'infix:<*>' => ' * ',
'infix:<x>' => ' x ',
'infix:<+>' => ' + ',
'infix:<.>' => ' ~ ',
'infix:</>' => ' / ',
'infix:<>>' => ' > ',
'infix:<<>' => ' < ',
'infix:<>=>' => ' >= ',
'infix:<<=>' => ' <= ',
'infix:<eq>' => ' eq ',
'infix:<ne>' => ' ne ',
'infix:<le>' => ' le ',
'infix:<ge>' => ' ge ',
'infix:<==>' => ' == ',
'infix:<!=>' => ' != ',
'infix:<..>' => ' .. ',
'infix:<&&>' => ' && ',
'infix:<||>' => ' || ',
'infix:<and>' => ' and ',
'infix:<or>' => ' or ',
'infix:<//>' => ' // ',
);
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $apply = $self->op_assign();
if ($apply) {
return $apply->emit_perl6( $level );
}
my $code = $self->{code};
if (ref $code ne '') {
my @args = ();
push @args, $_->emit_perl6
for @{$self->{arguments}};
return Perlito5::Perl6::tab($level) . '(' . $self->{code}->emit_perl6() . ')(' . join(',', @args) . ')';
}
if ($code eq 'infix:<=>>') {
return Perlito5::Perl6::tab($level) . join(', ', map( $_->emit_perl6, @{$self->{arguments}} ))
}
if (exists $op_infix_js{$code}) {
return Perlito5::Perl6::tab($level) . '('
. join( $op_infix_js{$code}, map( $_->emit_perl6, @{$self->{arguments}} ))
. ')'
}
if ($code eq 'eval') {
return
'eval(perl5_to_js('
. Perlito5::Perl6::to_str($self->{arguments}->[0])
. '))'
}
if ($code eq 'undef') { return Perlito5::Perl6::tab($level) . 'Any' }
if ($code eq 'shift') {
if (!( $self->{arguments} && @{$self->{arguments}} )) {
return 'shift(@_)'
}
}
if ($code eq 'map') {
my $fun = $self->{arguments}->[0];
my $list = $self->{arguments}->[1];
return
'(function (a_) { '
. 'var out = []; '
. 'if ( a_ == null ) { return out; }; '
. 'for(var i = 0; i < a_.length; i++) { '
. 'my $_ = a_[i]; '
. 'out.push(' . $fun->emit_perl6 . ')'
. '}; '
. 'return out;'
. ' })(' . $list->emit_perl6() . ')'
}
if ( $code eq 'bless'
|| $code eq 'ref'
)
{
return 'Perlito5::Perl6::Runtime::' . $code . '( '
. join( ', ', map( $_->emit_perl6, @{ $self->{arguments} } ) )
. ')';
}
if ( $code eq 'prefix:<!>' ) {
return '!( ' . Perlito5::Perl6::to_bool( $self->{arguments}->[0] ) . ')';
}
if ( $code eq 'prefix:<$>' ) {
my $arg = $self->{arguments}->[0];
return '$(' . $arg->emit_perl6 . ')';
}
if ( $code eq 'prefix:<@>' ) {
return '@(' . join( ' ', map( $_->emit_perl6, @{ $self->{arguments} } ) ) . ')';
}
if ( $code eq 'prefix:<%>' ) {
my $arg = $self->{arguments}->[0];
return '%(' . $arg->emit_perl6 . ')';
}
if ( $code eq 'circumfix:<[ ]>' ) {
return '[' . join( ', ', map( $_->emit_perl6, @{ $self->{arguments} } ) ) . ']';
}
if ( $code eq 'circumfix:<{ }>' ) {
return '{' . join( ', ', map( $_->emit_perl6, @{ $self->{arguments} } ) ) . '}';
}
if ( $code eq 'prefix:<\\>' ) {
my $arg = $self->{arguments}->[0];
if ( $arg->isa('Perlito5::AST::Var') ) {
if ( $arg->sigil eq '@' ) {
# XXX not implemented
return $arg->emit_perl6;
}
if ( $arg->sigil eq '%' ) {
return '(HashRef.new(' . $arg->emit_perl6 . '))';
}
}
# XXX \&x should return a CODE ref
return '(ScalarRef.new(' . $arg->emit_perl6 . '))';
}
if ($code eq 'postfix:<++>') { return '(' . join(' ', map( $_->emit_perl6, @{$self->{arguments}} )) . ')++' }
if ($code eq 'postfix:<-->') { return '(' . join(' ', map( $_->emit_perl6, @{$self->{arguments}} )) . ')--' }
if ($code eq 'prefix:<++>') { return '++(' . join(' ', map( $_->emit_perl6, @{$self->{arguments}} )) . ')' }
if ($code eq 'prefix:<-->') { return '--(' . join(' ', map( $_->emit_perl6, @{$self->{arguments}} )) . ')' }
if ($code eq 'prefix:<+>') { return '+(' . $self->{arguments}->[0]->emit_perl6() . ')' }
if ($code eq 'list:<.>')
{
return '('
. join( ' ~ ',
map( Perlito5::Perl6::to_str($_), @{$self->{arguments}} )
)
. ')'
}
if ($code eq 'ternary:<? :>') {
return Perlito5::Perl6::tab($level)
. '( ' . Perlito5::Perl6::to_bool( $self->{arguments}->[0] )
. ' ?? ' . ($self->{arguments}->[1])->emit_perl6()
. ' !! ' . ($self->{arguments}->[2])->emit_perl6()
. ')'
}
if ($code eq 'circumfix:<( )>') {
return Perlito5::Perl6::tab($level) . '(' . join(', ', map( $_->emit_perl6, @{$self->{arguments}} )) . ')';
}
if ($code eq 'infix:<=>') {
return emit_perl6_bind( $self->{arguments}->[0], $self->{arguments}->[1], $level );
}
if ($code eq 'return') {
return Perlito5::Perl6::tab($level) . 'return('
. ( $self->{arguments} && @{$self->{arguments}}
? $self->{arguments}->[0]->emit_perl6()
: ''
)
. ')'
}
if ($self->{namespace}) {
if ( $self->{namespace} eq 'Perl6'
&& $code eq 'inline'
)
{
if ( $self->{arguments}->[0]->isa('Perlito5::AST::Val::Buf') ) {
# Perlito5::Perl6::inline('$x = 123')
return $self->{arguments}[0]{buf};
}
else {
die "Perl6::inline needs a string constant";
}
}
$code = $self->{namespace} . '::' . ( $code );
}
my @args = ();
push @args, $_->emit_perl6
for @{$self->{arguments}};
Perlito5::Perl6::tab($level) . $code . '(' . join(', ', @args) . ')';
}
sub emit_perl6_bind {
my $parameters = shift;
my $arguments = shift;
my $level = shift;
Perlito5::Perl6::tab($level) . '(' . $parameters->emit_perl6() . ' = ' . $arguments->emit_perl6() . ')';
}
}
package Perlito5::AST::If;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $cond = $self->{cond};
if ( $cond->isa( 'Perlito5::AST::Var' )
&& $cond->sigil eq '@'
)
{
$cond = Perlito5::AST::Apply->new( code => 'prefix:<@>', arguments => [ $cond ] );
}
my $body = Perlito5::Perl6::LexicalBlock->new( block => $self->{body}->stmts, needs_return => 0 );
my $s = Perlito5::Perl6::tab($level) . 'if ( ' . Perlito5::Perl6::to_bool( $cond ) . ' ) {' . "\n"
. $body->emit_perl6( $level + 1 ) . "\n"
. Perlito5::Perl6::tab($level) . '}';
if ( @{ $self->{otherwise}->stmts } ) {
my $otherwise = Perlito5::Perl6::LexicalBlock->new( block => $self->{otherwise}->stmts, needs_return => 0 );
$s = $s
. "\n"
. Perlito5::Perl6::tab($level) . 'else {' . "\n"
. $otherwise->emit_perl6( $level + 1 ) . "\n"
. Perlito5::Perl6::tab($level) . '}';
}
return $s;
}
}
package Perlito5::AST::While;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $body = Perlito5::Perl6::LexicalBlock->new( block => $self->{body}->stmts, needs_return => 0 );
return
Perlito5::Perl6::tab($level) . 'loop ( '
. ( $self->{init} ? $self->{init}->emit_perl6() . '; ' : '; ' )
. ( $self->{cond} ? Perlito5::Perl6::to_bool( $self->{cond} ) . '; ' : '; ' )
. ( $self->{continue} ? $self->{continue}->emit_perl6() . ' ' : ' ' )
. ') {' . "\n"
. $body->emit_perl6( $level + 1 )
. ' }'
}
}
package Perlito5::AST::For;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $cond = $self->{cond};
my $body = Perlito5::Perl6::LexicalBlock->new( block => $self->{body}->stmts, needs_return => 0 );
my $sig = '$_';
if ($self->{body}->sig()) {
$sig = $self->{body}->sig->emit_perl6( $level + 1 );
}
Perlito5::Perl6::tab($level) . 'for ' . $cond->emit_perl6() . ' -> ' . $sig . ' { '
. $body->emit_perl6( $level + 1 )
. '}' . "\n"
}
}
package Perlito5::AST::Decl;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
Perlito5::Perl6::tab($level) . $self->{var}->emit_perl6;
}
sub emit_perl6_init {
my $self = shift;
$self->{decl} . ' ' . ($self->{var})->emit_perl6() . ';';
}
}
package Perlito5::AST::Sub;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
Perlito5::Perl6::tab($level)
. "sub "
. ( $self->{name}
? $self->{name}
: ''
)
. '(*@_) {' . "\n"
. (Perlito5::Perl6::LexicalBlock->new( block => $self->{block}, needs_return => 1, top_level => 1 ))->emit_perl6( $level + 1 ) . "\n"
. Perlito5::Perl6::tab($level) . '}';
}
}
package Perlito5::AST::Do;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $block = $self->simplify->block;
return
Perlito5::Perl6::tab($level) . '(do {' . "\n"
. (Perlito5::Perl6::LexicalBlock->new( block => $block, needs_return => 1 ))->emit_perl6( $level + 1 ) . "\n"
. Perlito5::Perl6::tab($level) . '})'
}
}
package Perlito5::AST::Use;
{
sub emit_perl6 {
my $self = shift;
my $level = shift;
my $mod = $self->{mod};
return "\n"
. Perlito5::Perl6::tab($level) . '# use ' . $self->{mod} . ";"
}
}
=begin
=head1 NAME
Perlito5::Perl6::Emit - Code generator for Perlito Perl5-in-Perl6
=head1 SYNOPSIS
$program->emit_perl6() # generated Perl5 code
=head1 DESCRIPTION
This module generates Perl6 code for the Perlito Perl 5 compiler.
=head1 AUTHORS
Flavio Soibelmann Glock <fglock@gmail.com>.
The Pugs Team E<lt>perl6-compiler@perl.orgE<gt>.
=head1 COPYRIGHT
Copyright 2006, 2009, 2011, 2012 by Flavio Soibelmann Glock, Audrey Tang 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>
=end
Jump to Line
Something went wrong with that request. Please try again.