use perl5:Code::Perl::Expr (":easy");
use Perl::Compiler::CodeGen::NameGen;
class Perl::Compiler::CodeGen::Perl5_Str
does Perl::Compiler::CodeGen {
my $INS = 'Perl6::Internals';
method generate (Perl::Compiler::PIL::PIL $tree is rw) {
my $ng = ::Perl::Compiler::CodeGen::NameGen.new(template => { "\$P_$_" });
say "{self} / $.WHAT()";
self.gen($tree, $ng);
}
method gen (Perl::Compiler::PIL::PIL $tree is rw, PIL::Compiler::CodeGen::NameGen $ng is rw) {
my $ret = do given $tree {
say "Processing $tree / $tree.WHAT()";
when ::Perl::Compiler::PIL::PILNil { "; # Nil\n" }
when ::Perl::Compiler::PIL::PILNoop { "; # Noop\n" }
when ::Perl::Compiler::PIL::PILLit { self.gen(.value, $ng) }
when ::Perl::Compiler::PIL::PILExp { self.gen(.value, $ng) }
when ::Perl::Compiler::PIL::PILPos { self.gen(.value, $ng) }
when ::Perl::Compiler::PIL::PILStmt { self.gen(.value, $ng.fork('expr')) ~ $ng.r('expr') }
when ::Perl::Compiler::PIL::PILThunk {
$ng.ret("$INS\::p5_make_thunk( sub () \{ { self.gen(.value) } } )"); ''
}
when ::Perl::Compiler::PIL::PILCode {
my $inner = self.gen(.statements);
$ng.ret("$INS\::p5_make_code( sub \{ {
(join "\n", map {
"my " ~ self.pad_var($_)
}, $tree.pads)
~ $inner
} } )"); ''
}
when ::Perl::Compiler::PIL::PILVal {
my sub box (String $class, $value) {
callm(string($class), "new", $value);
}
$ng.ret(do given .value {
when Str { box("P5::PIL::Run::Str" => string($_)) }
when Num { box("P5::PIL::Run::Number" => number($_)) }
when Bool { &?OUTER::BLOCK(+$_) }
when undef { box("P5::PIL::Run::Undef" => perl("undef")) }
when List { box("P5::PIL::Run::List" => list(map { &OUTER::BLOCK($_) }, @$_)) }
when Error { box("P5::PIL::Run::Error", string($_.first), list(@( $_.second ))) }
when Junc { die "no junctions yet"; box("P5::PIL::Run::Junction", ...) }
default { die "a value of type {.WHAT} cannot appear in PIL. Your compiler must be sick." }
}.perl); ''
}
when ::Perl::Compiler::PIL::PILVar {
# XXX shouldn't need $tree.pad.WHICH ; .pad.WHICH should do ($tree is topic)
my $pad = $tree.pad;
$ng.ret(self.pad_var($pad) ~ "->\{'{ $tree.value }'}"); ''
}
when ::Perl::Compiler::PIL::PILStmts {
self.gen(.head, $ng.fork) ~ '; ' ~ self.gen(.tail, $ng.fork);
}
when ::Perl::Compiler::PIL::PILApp {
my $str = join ' ',
self.gen(.code, $ng.fork('code')),
map { self.gen($^arg, $^gen) }, zip([.args], [map { $ng.fork("arg$_") }, 0 ..^ .args]);
$ng.ret(
$ng.r('code') ~ '->CALL('
~ join(', ', map { $ng.r("arg$_") }, 0 ..^ .args) ~ ')'
);
$str;
}
when ::Perl::Compiler::PIL::PILAssign {
my $str = self.gen(.right, $ng.fork('right')) ~ self.gen(.left, $ng.fork('left'));
$ng.ret(
$ng.r('left') ~ "->ASSIGN( $ng.r('right') )"
);
$str;
}
when ::Perl::Compiler::PIL::PILBind {
my $str = self.gen(.right, $ng.fork('right')) ~ self.gen(.left, $ng.fork('left'));
$ng.ret(
$ng.r('left') ~ "->BIND( $ng.r('right') )"
);
$str;
}
die "Unknown PIL node type: $tree.WHAT()";
};
say "RETVAL = $ret";
return $ret;
}
method pad_var(Perl::Compiler::PIL::Util::Pad $pad) {
"\$PAD_" ~ $pad.WHICH;
}
}
# vim: ft=perl6 :