use warnings;
use strict;
# Real subroutines, blocks, thunks.
# Back on days 1 and 2 of PIL2JS, the eval()s were needed to emulate Perl's
# "the return value of a sub is the value of the last expression evaluated":
# (function () { 42 })() # undefined
# (function () { return eval "42" })() # 42
# Now PIL::PStmts wraps a return() around the last statement, but only if we're
# $PIL::IN_SUBLIKE. Easy, eh? :)
{
package PIL::PSub;
our @ISA = qw< PIL::PCode >;
sub prefix { "Sub" }
sub name :lvalue { $_[0]->{pSubName} }
sub type :lvalue { $_[0]->{pSubType} }
sub params :lvalue { $_[0]->{pSubParams} }
sub lvalue :lvalue { $_[0]->{pSubLValue} }
sub body :lvalue { $_[0]->{pSubBody} }
sub multi :lvalue { $_[0]->{pSubIsMulti} }
sub fixup {
die if ref $_[0]->name;
return $_[0]->SUPER::fixup;
}
sub magical_vars {
my $self = shift;
my ($js, @vars) = $self->SUPER::magical_vars;
my $jsvar = PIL::name_mangle $self->name;
my $name = PIL::doublequote $self->name;
$js .= "_26Main_3a_3a_3fBLOCK = $jsvar; pad['&?BLOCK'] = _26Main_3a_3a_3fBLOCK;\n"
if $PIL::IN_SUBLIKE >= PIL::SUBBLOCK;
$js .= "_26Main_3a_3a_3fSUB = $jsvar; pad['&?SUB'] = _26Main_3a_3a_3fSUB;\n"
if $PIL::IN_SUBLIKE >= PIL::SUBROUTINE;
$js .= "_24Main_3a_3a_3fSUBNAME = new PIL2JS.Box.Constant($name); pad['\$?SUBNAME'] = _24Main_3a_3a_3fSUBNAME;\n";
return ($js, @vars, qw< &?BLOCK &?SUB $?SUBNAME >);
}
sub callchain {
"PIL2JS_callchain.push(" . PIL::name_mangle($_[0]->name) . ");\n";
}
sub as_js {
my $self = shift;
local $_;
local $PIL::CUR_SUBNAME = $self->name;
#warn "Skipping &*END.\n" and return ""
return ""
if $self->name eq "&*END";
#warn "Skipping " . $self->name . ".\n" and return ""
return ""
if $self->name =~ /^__export_c.*import$/;
my $def = sprintf "new PIL2JS.Box(%s.FETCH())", $self->SUPER::as_js;
my $name = sprintf "%s.FETCH().pil2js_name = %s",
PIL::name_mangle($self->name),
PIL::doublequote(($self->name =~ /^&.*::(?:prefix:|postfix:|infix:|circumfix:|coerce:|self:|term:|postcircumfix:|rule_modifier:|trait_verb:|trait_auxiliary:|scope_declarator:|statement_control:|infix_postfix_meta_operator:|postfix_prefix_meta_operator:|prefix_postfix_meta_operator:|infix_circumfix_meta_operator:)?(.+)$/)[0] or $self->name);
# "or $self->name" needed for the /^__export/ and /^__init/ subs.
my $decl = $self->multi
? sprintf "if(!%s) var %s = new PIL2JS.Box(PIL2JS.new_multi());\n%s.FETCH().pil2js_multi.add_variant(%s, %d)",
PIL::name_mangle($self->name),
PIL::name_mangle($self->name),
PIL::name_mangle($self->name),
$def,
$self->arity
: sprintf "%s%s = %s;",
$PIL::IN_GLOBPIL ? "" : "var ",
PIL::name_mangle($self->name),
$def;
my $js = "$decl;\n$name;\n";
# Special magic for methods.
if($self->type->isa("PIL::SubMethod")) {
my $methname = $self->name;
$methname = ($methname =~ /^&.*::(.+)$/)[0] or
PIL::fail("Method names must be simple strings!");
# method foo (A|B|C $self:) {...}
my @classes =
$self->params->[0]->name =~ /^@/ ? (":Array") :
$self->params->[0]->name =~ /^%/ ? (":Hash") :
map { ":" . $_->as_string } $self->params->[0]->type->all_types;
$js .= sprintf
"PIL2JS.addmethod(%s, %s, %s);\n",
PIL::name_mangle($_),
PIL::doublequote($methname),
PIL::name_mangle($self->name) for @classes;
}
# Special magic for &*END_xyz subs.
if($self->name =~ /^&\*END_\d+/) {
$js .= sprintf
"_40Main_3a_3a_2aEND.FETCH().push(%s);\n",
PIL::name_mangle $self->name;
}
return $js;
}
sub unwrap { $_[0] }
}
{
package PIL::PCode;
sub prefix { "" }
sub name { "<anonymous@{[$PIL::CUR_SUBNAME ? ' in ' . $PIL::CUR_SUBNAME : '']}>" }
sub arity { $_[0]->params->arity }
sub type :lvalue { $_[0]->{pType} }
sub params :lvalue { $_[0]->{pParams} }
sub lvalue :lvalue { $_[0]->{pLValue} }
sub body :lvalue { $_[0]->{pBody} }
sub multi :lvalue { $_[0]->{pIsMulti} }
sub fixup {
my $self = shift;
die if ref $self->type;
die unless ref($self->params) eq "ARRAY";
bless $self->params => "PIL::Params";
$self->type = bless [] => "PIL::" . $self->type; # minor hack
local $PIL::IN_SUBLIKE = $self->type->as_constant;
local @PIL::IN_SUBLIKES = (@PIL::IN_SUBLIKES, $self->type->as_constant);
# &PIL::Params::fixup returns the fixed PIL::Params and the fixed
# $self->{pSubBody}.
my %params_and_body =
return bless {
$self->isa("PIL::PSub")
? (pSubName => $self->name)
: (),
"p" . $self->prefix . "Type" => $self->type,
"p" . $self->prefix . "LValue" => $self->lvalue,
"p" . $self->prefix . "IsMulti" => $self->multi,
$self->params->fixup(
$self->prefix,
$self->body eq "PNil"
? bless {} => "PIL::PNil"
: $self->body
),
} => ref $self;
}
sub magical_vars {
my $self = shift;
my $vars;
$vars .= $PIL::IN_SUBLIKE >= PIL::SUBROUTINE && !$self->isa("PIL::PSub")
? "_24Main_3a_3a_3fSUBNAME = new PIL2JS.Box.Constant('<anon>');\n"
: "";
$vars .= "_24Main_3a_3a_3fPOSITION = new PIL2JS.Box('<unknown>'); pad['\$?POSITION'] = _24Main_3a_3a_3fPOSITION;\n";
$vars .= "var _24Main_3a_3a_ = new PIL2JS.Box(undefined); pad['\$_'] = _24Main_3a_3a_;\n"
unless grep { $_->name eq '$_' } @{ $self->params };
# $?SUBNAME handled in PIL::PSub
# We've to exclude $! from the list of vars-to-backup for primitives,
# because else we can't implement &try in Perl.
return (
$vars,
'$?POSITION',
$PIL::IN_SUBLIKE == PIL::SUBPRIM ? () : '$!',
!$self->isa("PIL::PSub") ? '$?SUBNAME' : ()
);
}
sub callchain { "" }
sub corofix {
my ($self, $body) = @_;
# Cosmetical fix
chomp(my $ret = sprintf <<EOF, PIL::add_indent(1, $body), ($PIL::CORO_ID) x 3); ($ret, $PIL::CORO_ID++);
var initial_entrypoint = function () {
%s
};
if(!PIL2JS.coro_entrypoints[%d]) {
PIL2JS.coro_entrypoints[%d] = initial_entrypoint;
}
PIL2JS.coro_entrypoints[%d](__returncc);
EOF
}
sub as_js {
my $self = shift;
local $_;
local $PIL::IN_SUBLIKE = $self->type->as_constant;
local @PIL::IN_SUBLIKES = (@PIL::IN_SUBLIKES, $self->type->as_constant);
local $PIL::CUR_SUBNAME = $self->name;
my $callchain = $self->callchain;
my $new_pad = "var pad = {}; PIL2JS_subpads.push(pad)";
my $params = $self->params->as_js;
(my $magical_vars, local @PIL::VARS_TO_BACKUP) = $self->magical_vars;
my ($body, $coro_id) =
$PIL::IN_SUBLIKE == PIL::SUBCOROUTINE
? $self->corofix($self->body->as_js)
: $self->body->as_js;
my $ccsetup =
$PIL::IN_SUBLIKE == PIL::SUBCOROUTINE
? PIL::coro_cc $coro_id, $self->lvalue, @PIL::VARS_TO_BACKUP
: PIL::generic_cc PIL::cur_retcc, $self->lvalue, @PIL::VARS_TO_BACKUP;
my $backup = "var " . join ", ", map {
sprintf "backup_%s = %s", PIL::name_mangle($_), PIL::name_mangle($_);
} @PIL::VARS_TO_BACKUP;
my $bind = $self->params->as_js_bind;
my $wrappedbody = "$new_pad;\n$callchain$magical_vars\n$bind;\n\n$body";
my $jsbody = $self->multi
? "$params\nif(only_check_for_params) return;\n\n" . $self->params->autothread_wrapper($wrappedbody)
: $params . "\n" . $self->params->autothread_wrapper($wrappedbody);
return sprintf "PIL2JS.Box.constant_func(%d, function (args) {\n%s;\n%s%s;\n%s\n%s\n})",
$self->arity,
# Lexicalize PIL2JS and thus speed up PIL2JS
PIL::add_indent(1, "var PIL2JS = AlsoPIL2JS_SpeedupHack"),
$self->multi
? PIL::add_indent(1, "var only_check_for_params = args.only_check_for_params;\n")
: "",
PIL::add_indent(1, $backup),
PIL::add_indent(1, $ccsetup),
PIL::add_indent(1, $jsbody);
}
sub unwrap { $_[0] }
}
{
package PIL::PThunk;
sub fixup {
my $self = shift;
die unless keys %$self == 1;
return bless { (%$self)[0] => (%$self)[1]->fixup } => "PIL::PThunk";
}
sub as_js {
my $self = shift;
local $PIL::IN_SUBLIKE = PIL::SUBTHUNK;
local @PIL::IN_SUBLIKES = (@PIL::IN_SUBLIKES, PIL::SUBTHUNK);
local $PIL::CUR_SUBNAME = "<thunk@{[$PIL::CUR_SUBNAME ? ' in ' . $PIL::CUR_SUBNAME : '']}>";
no warnings "recursion";
my $body = PIL::possibly_ccify +(%$self)[1], PIL::RawJS->new("thunkreturncc");
my $ret = sprintf <<EOF, PIL::add_indent 1, $body;
PIL2JS.Box.constant_func(0, function (args) {
var cxt = args.shift();
var thunkreturncc = args.pop();
%s;
})
EOF
chomp $ret; # Cosmetical fix
return $ret;
}
sub unwrap { $_[0] }
}
1;