package JE::Code;
use strict;
use warnings; no warnings qw 'utf8 parenthesis';
use constant 1.03 our $_const = do {
my $x = 0;
+{ map +($_ => $x++),
'cx_stm', # statement
'cx_void', # statement; retval ignored
# expression contexts
'cx_void_expr',
'cx_any', # includes lvalue
'cx_rv', # rvalue
'cx_lv', # lvalue
'cx_bool', # plain boolean, not necessarily a JE::Boolean
'cx_str', # Perl scalar in UTF-16 (with surrogates)
'cx_num', # Perl scalar
'ret_void', # no retval
'ret_maybe', # might have a retval (which could be an lval)
'ret_break', # break or continue
'ret_any', # includes lvalue
'ret_lv',
'ret_rv',
'ret_str',
'ret_num',
'ret_bool',
}
};
BEGIN { no strict; delete @{__PACKAGE__."::"}{_const => keys %$_const} }
=begin notes
The cx_stm constant for statement-level context applies to a context in
which any return type (including an lvalue) is expected, but an lvalue has
to have ->get called on it before it is returned.
The to_perl methods take 1 argument, a cx_ constant, and return 2 or 3:
0. ret_ constant indicating possible return types
1. string of Perl code
( 2. alternate string of Perl code that can be used only in some
contexts, such as "..." for JE::String->new(...) )
The reason we have all those return values is most easily demonstrated by
example:
For the + operator, we have two completely different behaviours, depending
on the types of the operands. If an operand can only be a string, we get:
ret_str, 'JE::String->new($global, "...")', '"..."'
If we see one of those, we can stringify the other operand, returning code
like this:
"..." . [other operand]->to_string->value16
We need to_perl’s second retval, for cases like - :
[str operand]->to_number->value - [num operand]
=end notes
=cut
sub _esc_str($) {
my $str = shift;
$str =~ s/(['\\])/\\$1/g;
"'$str'";
}
our %labels;
our %loop_labels;
our $cache_indx;
our $code;
no warnings 'redefine';
sub optimise {
my $self = shift;
local %labels; local %loop_labels; local $cache_indx;
local $code = $self;
my $global = $self->{global};
$self->set_global(undef);
$self->{psrc} = 'no warnings"utf8","exiting";'
. $self->{tree}->to_perl(cx_stm);
$self->{tree}=[$self->{tree}[0]];
$self->set_global($global);
}
use Scalar::Util 'refaddr';
sub JE::Code::Statement::to_perl {
my $stm = shift;
my $cx = shift;
my $type = $$stm[1];
$type eq 'empty' and return ret_void, '';
if($type eq 'function' ) {
(my $new_code_obj = bless {
map+($_=>$code->{$_}),qw/global source file line/
}, 'JE::Code')
->{tree} = $$_[4];
$new_code_obj->{vars} = $$_[5];
$new_code_obj->optimise;
$$stm[4] = $new_code_obj;
return ret_void, '';
}
my $pos = $$stm[0][0];
if ($type eq 'labelled') {
my @labels = @$stm[2..$#$stm-1];
my $is_loop =
$$stm[-1][1] =~ /^(?:do|while|for|switch)\z/;
# We have to alias the labels to a single label, because
# Perl does not support multiple labels on a sin-
# gle statement. Nor can we stack them up with
# blocks, ( foo:{bar:{...}} ) because that won’t work
# for loop-control constructs (next foo). We have
# to rename them, since JS idents can have $ in them.
my $alias_to = refaddr $stm->[-1];
local @labels{@labels} = ($alias_to)x@labels;
# ‘continue’ statements only look in this hash:
local @loop_labels{@labels} = ($alias_to)x@labels
if $is_loop;
my($rettype,$code) = $$stm[-1]->to_perl($cx);
return
$rettype,
# loops add their own label, since some have to put
# something before it
$is_loop ? $code :
"JE_Code_$alias_to:" . (
$$stm[-1][1] =~ /^{/
? $code
: length $code ? "{$code}" : '{;}'
); # Without the ; it’s a hash.
}
if ($type eq 'statements') {
# At run time, the statements are executed one by one, and
# the return value of the last statement that actually
# returned one is returned. To avoid passing cx_stm context
# when cx_void will do, we work backwards.
# ~~~ This logic is currently flawed. It needs to account
# for a ‘break’ or similar in between two ret_any stms.
# And also ‘return’ satetments.
my @code; my $last_rettype;
for (@$stm[reverse 2..$#$stm]) {
my($rettype,$code) = $_->to_perl($cx);
$last_rettype = $rettype;
push @code, $code;
if($rettype != ret_void && $rettype != ret_maybe) {
$cx = cx_void
}
}
my $code = join '', reverse @code;
# $rettype will be undefined if this is an empty block
return defined $last_rettype?$last_rettype:ret_void, $code;
}
if ($type eq 'var') {
# The Perl code looks like this:
# $scope->find_var("foo")->set( ...expr... );
my $stm_code = '';
for (@$stm[2..$#$stm]) { if (@$_ == 2) {
my($rettype,$code) = _term_to_perl($$_[1],cx_rv);
$stm_code .=
'$scope->find_var(' . _esc_str($$_[0]) .')->set('
. $code . ");";
}}
return ret_void, $stm_code;
}
if ($type eq 'if') {
# 2 3 4
# we have: expr statement statement?
my($rettype,$code) = $$stm[2]->to_perl(cx_bool);
my $stm_code = "if($code){";
($rettype,$code) = $$stm[3]->to_perl($cx);
$stm_code .= "$code}";
my $rettype2;
if(exists $$stm[4]) {
($rettype2,$code) = $$stm[4]->to_perl($cx);
$stm_code .= "else{$code}"
}
return $cx == cx_void ? ret_void
: (defined $rettype2 ? $rettype2 == ret_void : 1)
&& $rettype == ret_void
? ret_void
: ret_maybe,
$stm_code
}
if ($type =~ /^(?:do|while|for|switch)\z/) {
# We have one of the following:
#
# 1 2 3 4 5
# 'do' statement expression
# 'while' expression statement
# 'for' expression 'in' expression statement
# 'for' var_decl 'in' expression statement
# 'for' expression expression expression statement
# 'for' var_decl expression expression statement
#
# In those last two cases, expression may be 'empty'.
# (See further down for 'switch').
my $label = refaddr $stm;
my $stm_code = "JE_Code_$label:";
# Alias for simple break/continue statements with-
# out a label:
local $labels{''} = local $loop_labels{''} = $label;
if ($type eq 'do') {
# For a do statement we need two loop labels:
# outer: {
# do { inner: {
#
# }} while foo
# }
# continue statements use the inner label.
# In case there are aliases to the existing label:
my @js_labels = grep $labels{$_} == $label =>=>
keys %loop_labels;
local @loop_labels{'',@js_labels} =
($label.'c')x(@js_labels+1);
my($rettype,$code) = $$stm[2]->to_perl($cx);
my(undef,$boolcode)
= $$stm[3]->to_perl(cx_bool);
return $rettype,
"$stm_code\{do{JE_Code_${label}c:{" .
(length $code ? $code : ';') # foo:{} is a hash
."}}while "
. "$boolcode}";
}
elsif ($type eq 'while') {
my(undef,$boolcode)
= $$stm[2]->to_perl(cx_bool);
my($rettype,$code) = $$stm[3]->to_perl($cx);
return $rettype,
"${stm_code}while($boolcode){$code}";
}
elsif ($type eq 'for' and $$stm[3] eq 'in') {
# for(var i = 3 in ...) {
# break;
# }
# translates into
# $scope->find_var('i')->set(3);
# JE_Code_loop: for((my $o = ...)->keys) {
# next if not defined $o->prop($_);
# # in which case it's been deleted
# $scope->find_var('i')->set($_);
# last JE_Code_loop;
# }
# (except that the arguments to ->set() have to be
# expressions returning JE::(Number|String)). For
# statements without the ‘var’, we don’t evaluate
# the lhs before the loop, but only in the loop. It
# takes the place of $scope->find_var.
my $left_side = $$stm[2];
if ($left_side->[1] eq 'var') {
substr $stm_code,0,0 =>=
($left_side->to_perl(cx_void))[1];
$left_side = _esc_str($left_side->[2][0]);
# now contains the identifier within a
# Perl string
}
(undef,my $obj_code) = $$stm[4]->to_perl(cx_rv);
$stm_code .=
"for((my\$o=$obj_code)->keys){" .
'next if!defined prop$o $_;' .
( ref $left_side
? ( $left_side->to_perl(cx_lv) )[1]
: "\$scope->find_var($left_side)" ) .
'->set(_new JE\'String $global,$_);';
my($rettype, $code) = $$stm[5]->to_perl($cx);
return $rettype, "$stm_code$code}";
}
elsif ($type eq 'for') { # for(;;)
$stm_code .= 'for(';
if(ref $$stm[2]) {
my $code = ($$stm[2]->to_perl(cx_void))[1];
length $code and $stm_code .=
"do{$code}" # We need the do
} # because to_perl
$stm_code .= ';'; # returns whole
if(ref $$stm[3]) { # statements
my(undef,$code) =
$$stm[3]->to_perl(cx_bool);
$stm_code .= $code;
}
$stm_code .= ';';
ref $$stm[4] and $stm_code .=
( $$stm[4]->to_perl(cx_void_expr) )[1];
my($rettype, $code) = $$stm[5]->to_perl($cx);
return $rettype, "$stm_code){$code}";
}
else { # switch
# $stm->[2] is the parenthesized
# expression.
# Each pair of elements thereafter
# represents one case clause, an expr
# followed by statements, except for
# the default clause, which has the
# string 'default' for its first elem
# We need to turn something like
# switch(3) {
# case 5: a();
# default: f();
# case 3636:
# case 838: break;
# case 3: h();
# }
# into
# JE_Code_loop: for(3) {
# $_->id eq 5->id and goto JE_Code_case1;
# $_->id eq 3636->id and goto JE_Code_case2;
# $_->id eq 838->id and goto JE_Code_case3;
# $_->id eq 3->id and goto JE_Code_case4;
# goto JE_Code_default;
# JE_Code_case1: $scope->find_var('a')->call;
# JE_Code_default: $scope->find_var('f')->call;
# JE_Code_case2: ;
# JE_Code_case3: last JE_Code_loop;
# JE_Code_case4: $scope->find_var('f')->call;
# }
# (except that the expressions are more complex).
# header
$stm_code .= 'for(' .
( $$stm[2]->to_perl(cx_rv) )[1] . '){';
# Go through the case clauses and add goto state-
# ments to $stm_code while also creating the state-
# ments that go further down.
my $more_statements = '';
my($n, $there_is_a_default) = 1;
while (($n+=2) < @$stm) {
if($$stm[$n] eq 'default') {
$more_statements .=
'JE_Code_default:';
++ $there_is_a_default
}
else {
$stm_code .= 'id$_ eq ' .
($$stm[$n]->to_perl(cx_rv))[1] .
"->id&&goto JE_Code_case$n;";
$more_statements.="JE_Code_case$n:"
}
my $stm = ( $$stm[$n+1]->to_perl($cx) )[1];
$more_statements .= length $stm?$stm:';' ;
} ;
return $cx==ret_void ? ret_void : ret_maybe, # ~~~ need to do some detecting
# for the rettype
$stm_code . (
$there_is_a_default
? 'goto JE_Code_default' : 'last'
) . ";$more_statements}"
} # switch
}
if ($type eq 'continue') {
my $label = exists $$stm[2] ? $$stm[2] : '';
return ret_break, exists $loop_labels{$label}
? "next JE_Code_$loop_labels{$label};"
: "die q[continue $label: label '$label' not found];"
}
if ($type eq 'break') {
my $label = exists $$stm[2] ? $$stm[2] : '';
return ret_break, exists $labels{$label}
? "last JE_Code_$labels{$label};"
: "die q[break $label: label '$label' not found];"
}
if ($type eq 'return') {
return ret_any, '$return=' . ( exists $$stm[2]
? ($$stm[2]->to_perl(cx_rv))[1]
: 'undef'
) . ';last RETURN;' ;
}
if ($type eq 'with') {
my($rettype, $code) = $$stm[3]->to_perl($cx);
return $rettype,
'{local$scope=bless[@$scope,'
. ($$stm[2]->to_perl(cx_rv))[1]
. "->to_object],'JE::Scope';$code}";
}
if ($type eq 'throw') {
return ret_void,'die '.($$stm[2]->to_perl(cx_rv))[1]. ';' ;
}
if ($type eq 'try') {
# We have one of the following:
# 1 2 3 4 5
# 'try' block ident block (catch)
# 'try' block block (finally)
# 'try' block ident block block (catch & finally)
# For a try-catch, we can simply use eval{...;1}||do{...}.
# With finally, it’s a lot more complicated. We can’t use
# Scope::Guard, because a destructor can’t affect execution
# flow. So we have to set up a complicated net to catch
# every return/break/continue in addition to exceptions.
# For every unique value in %labels, we need a separate
# block. What we end up with is something like this:
# ~~~(The inner do{} is actually redundant. Maybe I should
# refactor it a bit.)
# { # lexical scope for all these variables:
# my $l; #label
# my $e; #exception
# my $c; #continue
# eval {
# JE_Code_labels: {
# RETURN: {
# JE_Code_1: for(0,1){ $_ and ++$c, last;
# JE_Code_2: for(0,1){ $_ and ++$c, last;
# JE_Code_3: for(0,1){ $_ and ++$c, last;
# my $r = $return;
# eval { ... try ...; last JE_Code_labels };
# ... catch ...;
# last JE_Code_labels;
# } $l = 3, last JE_Code_labels
# } $l = 2, last JE_Code_labels
# } $l = 1, last JE_Code_labels
# } $l = 'r'
# }
# 1
# } or $e=$@;
# my $r = $return;
# ... finally ...
# defined $e && die $e;
# $return = $r;
# $l and $l == 'r' ? last RETURN :
# $c ? next "JE_Code_$l" : last "JE_Code_$l"
# }
# A catch’s do-block (this is not in a do when there is a
# finally) is as follows:
# do {
# $return = $r;
# ref $@ or $@ = _objectify_error($@);
# (my $o = new JE::Object $global)
# ->prop({
# name => 'e',
# value => $@,
# dontdel => 1,
# });
# local $scope = bless [
# @$scope, $o
# ], 'JE::Scope';
# ...code...
# };
# Got that?
my $finally = $#$stm == 3 || $#$stm == 5;
# try and catch
my $inner_code = '';
# We don’t want try{3; throw...} to return 3, so we save
# the previous value of $return before entering the eval.
my $we_can_catch = !ref $$stm[3];
$inner_code .= 'my$r=$return;eval{' if $we_can_catch;
my($rettype,$code) = $$stm[2]->to_perl($cx); # try
$inner_code .= $code;
$inner_code .= 'last JE_Code_labels;' if $finally;
if($we_can_catch) {
$inner_code .= ($finally ? '};' : '1}||do{')
. '$return=$r;' # prevent { 3; throw ... }
# from returning 3
# Turn miscellaneous errors into
# Error objects
.q"ref$@or$@=_objectify_error($@);"
.q"(my$o=new JE'Object $global)->prop({"
. 'name=>' . _esc_str($$stm[3]) . ','
. 'value=>$@,'
. 'dontdel=>1'
.'});'
.'local$scope='
. 'bless[@$scope,$o],"JE::Scope";';
my($rettype, $code) = $$stm[4]->to_perl($cx);
$inner_code .= $code
. ($finally ? ';last JE_Code_labels' : '}');
}
if ($finally) {
# get a list of labels
my @labels; my %seen;
for(values %labels, values %loop_labels) {
push @labels, $_ unless $seen{$_}++
}
my $stm_code =
'{'
. 'my($l,$e,$c);'
. 'eval{'
. 'JE_Code_labels:{'
. 'RETURN:{';
$stm_code .=
"JE_Code_$_:for(0,1){\$_ and++\$c,last;",
for @labels;
$stm_code .= $inner_code;
$stm_code .=
'}$l='._esc_str($_).",last JE_Code_labels"
for reverse @labels;
$stm_code .=
'}$l="r"'
. '}'
. '1'
. '}or$e=$@;'
. 'my$r=$return;'
. ( $$stm[-1]->to_perl(cx_void) )[1]
. 'defined$e&&die$e;'
. '$return=$r;'
. '$l and$l eq"r"?last RETURN:'
. '$c?eval"next JE_Code_$l"'
. ':eval"last JE_Code_$l"'
.'}';
return $cx==ret_void ? ret_void : ret_maybe,
$stm_code;
}
else {
return $cx==ret_void ? ret_void : ret_maybe,
$we_can_catch ? "{$inner_code}" :
$inner_code;
}
# ~~~ need to do some detecting for the rettype
}
}
=begin for-me
Types of expressions:
'new' term args?
'member/call' term ( subscript | args) *
'postfix' term op
'hash' term*
'array' term? (comma term?)*
'prefix' op+ term
'lassoc' term (op term)*
'assign' term (op term)* (term term)?
(the last two terms are the 2nd and 3rd terms of ? :
'expr' term*
(commas are omitted from the array)
'function' ident? params statements
=end for-me
=cut
# Note: each expression object is an array ref. The elems are:
# [0] - an array ref containing
# [0] - the starting position in the source code and
# [1] - the ending position
# [1] - the type of expression
# [2..$#] - the various terms/tokens that make up the expr
sub JE::Code::Expression::to_perl {
#ret_rv, "hooha()" . ';' x ($_[1] == cx_stm || $_[1] == cx_void)
# ~~~ ++ $ops>$counting and last JE_Code_OP if $counting;
my $expr = shift;
my $cx = shift;
my $type = $$expr[1];
# ~~~ $pos = $$expr[0][0];
if ($type eq 'expr') {
my $sc = '';
$cx == cx_stm
? ($sc = ';', $cx = cx_any) :
$cx == cx_void && ($sc = ';', $cx = cx_void_expr);
if(@$expr == 3) { # no comma
my($rettype,$code) =
_term_to_perl($$expr[-1], $cx);
if($rettype == ret_lv && $sc) {
$code =
"{my\$v=$code;\$v->get;\$return=\$v}";
}elsif($rettype==ret_any && $sc){
$code = "{my\$v=$code;"
. 'ref$v eq"JE::LValue"&&$v->get'
. ';$return=$v'
.'}';
}
elsif($sc) {
$code = "\$return=$code;"
}
return $rettype, $code;
}
else { # comma op
my $result = join ',', map+
(_term_to_perl($_, cx_void_expr))[1],
@$expr[2..$#$expr-1];
$result .= ',';
my($rettype,$code) =
_term_to_perl($$expr[-1], ret_rv);
$result .= $code;
if($sc) {
$result = "\$return=($result);";
}
else {
$result = "scalar($result)";
}
return $cx == cx_void_expr ? ret_void : $rettype,
$result;
}
}
if ($type eq 'assign') {
my @copy = @$expr[2..$#$expr];
# Evaluation is done left-first in JS, unlike in
# Perl, so a = b = c is evaluated in this order:
# - evaluate a
# - evaluate b
# - evaluate c
# - assign c to b
# - assign b to a
# Check first to see whether we have the terms
# of a ? : at the end:
my @qc_terms = @copy >= 3 && (
ref $copy[-2] # avoid stringification
|| $copy[-2] =~ /^(?:[tfu]\z|[si0-9])/
)
? (pop @copy, pop @copy) : ();
# @qc_terms is now in reverse order
# Rough sketch of what we want to accomplish:
# a += b += c += d
#
# do {
# my $l = a;
# $l->set($l->get + do{
# my $l = b;
# $l->set($l->get + do {
# my $l = c;
# $l->set($l->get + d)
# })
# })
# }
# a = b
#
# a->set(b->get)
# a += b = c
#
# do {
# my $l = a;
# $l->set($l->get + b->set(my $v = c))
# }
# Get the first rhs ready:
my $perl_expr = pop @copy;
# Now apply ? : if it's there
if(@qc_terms) {
$perl_expr = (_term_to_perl($perl_expr,cx_bool))[1]
. '?' . (_term_to_perl($qc_terms[1],cx_rv))[1]
. ':' . (_term_to_perl($qc_terms[0],cx_rv))[1]
}
else {
$perl_expr = (_term_to_perl($perl_expr,cx_rv))[1];
}
# short-circuit if we only have ? : and no assignment
# ~~~ check return types from both legs
return ret_rv, $perl_expr unless @copy;
# Iterate through the ops, wrapping each previous expr with
# the current one.
while(@copy) {
my ($op, $term) = (pop @copy, pop @copy);
if(length $op > 1) {
$perl_expr = 'do{my$l='
. (_term_to_perl($term,cx_lv))[1] . ';'
. '$l->set('
. "'JE::Code::Expression::in".substr $op,0,-1,
. "'->(\$l->get,$perl_expr))}"
}
else {
$perl_expr =
(_term_to_perl($term,cx_lv))[1]
. "->set($perl_expr)"
}
}
# ~~~ T and tainted $taint and $val->can('taint')
# and $val = taint $val $taint;
return ret_rv, $perl_expr;
}
if($type eq 'lassoc') { # left-associative
my @copy = @$expr[2..$#$expr];
my $result = (_term_to_perl(shift @copy, cx_rv))[1];
while(@copy) {
# We have to deal with || && specially for the sake
# of short-circuiting
my $op = $copy[0];
if ($op =~ m&^(?:\&\&|\|\|)\z&) {
$result =
"$result$op "
.(_term_to_perl($copy[1],cx_rv))[1]
}
else {
$result = "'JE::Code::Expression::in$op'->"
. "($result,"
.(_term_to_perl($copy[1],cx_rv))[1]
.')'
}
splice @copy, 0, 2; # double shift
}
return ret_rv,$result;
}
if ($type eq 'prefix') {
# ~~~ taintedness
# $$expr[1] -- 'prefix'
# @$expr[2..-2] -- prefix ops
# $$expr[-1] -- operand
my $term = (
_term_to_perl( $$expr[-1],
$$expr[-2] =~ m-^(?:\+\+|\-\-)\z- ? cx_lv :
$$expr[-2] =~ m e^(?:typ\eof|d\el\et\e)\ze ? cx_any :
cx_rv
)
)[1];
$term = "'JE::Code::Expression::pre$_'->($term)"
for reverse @$expr[2..@$expr-2];
return ret_rv, $term;
}
if ($type eq 'postfix') {
# ~~~ taintedness
# ~~~ These are supposed to use the same rules
# as the + and - infix ops for the actual
# addition part. Verify that they do this.
# This will need to be made more efficient:
# do{
# my $l = ...; $l->set(
# "JE::Code::Expression::in+"->(
# $l->get,
# JE::Number->new($global, 1)
# )
# );
# $v
# }
return ret_rv, 'do{'
. 'my$l=' . (_term_to_perl($$expr[2], cx_lv))[1] . ';'
. '$l->set('
. '"JE::Code::Expression::in+"->('
. 'my$v=$l->get->to_number,'
. _cached('JE\'Number->new($global,'
. (-1,1)[$$expr[3] eq '++']. ')')
. ')'
. ')'
. ';$v' x ($cx != cx_void_expr)
.'}'
}
if ($type eq 'new') {
# ~~~ ? T && tainted $taint
#~~~ ? map $_->can('taint') ?taint $_ $taint:$_,
return ret_rv, (_term_to_perl($$expr[2],cx_rv))[1]
.'->construct'
. ( @$expr == 4
? '(' . $$expr[-1]->to_perl . ')'
: '' )
}
if($type eq 'member/call') {
my($type, $obj) = _term_to_perl( $$expr[2],
exists $$expr[3]
? ref $$expr[3]eq 'JE::Code::Subscript'
? cx_rv
: cx_any
: $cx
);
# ~~~ We can probably optimise this not to create LValue objects for calls,
# but use the ‘apply’ method directly.
for (3..$#$expr) {
my $cx = exists $$expr[$_+1]
? ref $$expr[$_+1]eq 'JE::Code::Subscript'
? cx_rv
: cx_any
: $cx;
if(ref $$expr[$_] eq 'JE::Code::Subscript') {
if($cx != cx_lv && $cx != cx_any) {
$obj .= '->prop('
. $$expr[$_]->to_perl
.')';
if($cx == cx_void_expr) {
$type = ret_void
} else {
$obj = "do{my\$v=$obj;"
. 'defined$v?$v:$global->undefined}';
$type = ret_rv;
}
}
else {
$obj = "JE'LValue->new($obj,"
. $$expr[$_]->to_perl . ')';
$type = ret_lv
}
}
else {
# ~~~ taintedness for calls
if($cx != cx_lv && $cx != cx_any) {
$obj = 'do{'
. "my\$v=$obj->call("
. $$expr[$_]->to_perl
. ');'
. 'ref$v eq"JE::LValue"' . (
$cx==cx_void_expr
?'&&$v->get'
:'?$v->get:$v'
)
.'}';
$type = ret_rv;
}
else {
$obj = "$obj->call("
. $$expr[$_]->to_perl
.')';
$type = ret_any
}
# If $obj is an lvalue,
# JE::LValue::call will make
# the lvalue's base object the 'this'
# value. Otherwise,
# JE::Object::Function::call
# will make the
# global object the 'this' value.
}
# ~~~ need some error-checking
}
return $type, $obj; # which may be an lvalue
}
if($type eq 'array') {
if($#$expr < 2) {
return ret_rv, "JE'Object'Array->new(\$global)"
}
my @ary;
for (2..$#$expr) {
if(ref $$expr[$_] eq 'comma') {
ref $$expr[$_-1] eq 'comma' || $_ == 2
and push @ary, 'undef';
}
else {
push @ary,
(_term_to_perl( $$expr[$_], cx_rv ))[1];
}
}
return ret_rv, 'do{my$a=new JE\'Object\'Array $global;'
. '$$$a{array}=[' . join(',',@ary) . '];$a}'
# sticking it in like that
# makes 'undef' elements non-
# existent, rather
# than undefined
}
if($type eq 'hash') {
local @_ = @$expr[2..$#$expr];
if(!@_) { return ret_rv, "JE'Object->new(\$global)"; }
my $obj = 'do{my$o=new JE\'Object $global;';
my ($key, $value);
while(@_) { # I have to loop through them to keep
# the order.
$key = _esc_str(shift);
$value = (_term_to_perl( shift, cx_rv ))[1];
$obj .= "\$o->prop($key,$value);";
}
return ret_rv, $obj . '$o}';
}
if ($type eq 'func') {
# format: [[...], function=> 'name',
# [ params ], $statements_obj, \@vars]
# or: [[...], function =>
# [ params ], $statements_obj, \@vars]
# The code we need to produce will be like this:
# e.g.: function(foo){ bar }
# JE'Object'Function->new({
# scope=>$scope,
# argnames=>['foo'],
# function=>$$cache[0],
# })
# If there is a name (function x (){}), it’s a little
# more complex:
# do{
# my $f = JE'Object'Function->new({
# name => 'x',
# scope =>[@$scope, my $o = new JE::Object $global],
# ... argnames and function ...
# });
# $o->prop({ name => 'x', value => $f,
# readonly => 1, dontdel => 1 });
# $f
# }
# The code object has to be created beforehand and placed
# in the cache.
# ~~~ When we merge this with JE::Parser, the entire code
# for the code object can be placed in a
# $$cache[0]||=....
my($name,$params,$statements) = ref $$expr[2] ?
(undef, @$expr[2,3]) : @$expr[2..4];
my $ret; my $scope;
if($name) {
$name = _esc_str($name);
$ret = 'do{my$f=';
# ~~~ I should be able to remove this ‘bless’. See
# the comment in jE::Object::Function::New
$scope = 'bless('
. '[@$scope,my$o=new JE\'Object $global]'
. ',"JE::Scope")'
}
my $c = $code->{cache}->[my $indx = $cache_indx++] = bless{
map+($_,$code->{$_}),qw/global source file line/
}, "JE::Code";
$c->{tree} = $statements;
$c->{vars} = $$expr[-1];
$c->optimise;
$ret .=
"JE'Object'Function->new({"
. 'scope=>' . ($scope||'$scope') . ','
. (defined $name ? ("name=>$name,") : '')
. 'argnames=>[' . join(',',map _esc_str($_),@$params).'],'
. "function=>\$\$cache[$indx]"
.'})';
if($name) {
$ret .=
';$o->prop({'
. "name=>$name,"
. 'value=>$f,'
. 'readonly=>1,'
. 'dontdel=>1'
.'})}'
}
return ret_rv,$ret;
}
}
sub _cached($) {
my $code_str = shift;
my $indx = $cache_indx++;
return "(\$\$cache[$indx]||=$code_str)";
}
use constant nan => sin 9**9**9;
use constant inf => 9**9**9;
sub _term_to_perl {
my $term = $_[0];
my $cx = $_[1];
# For booleans, we just use the expression itself, since the over-
# loaded booleanness is much faster than ->to_boolean, which has to
# create an object.
# For strings and numbers, ->to_string->value16 is only slightly
# faster than "" for objects, but the latter is 4x the speed for
# strings and about 5% faster for strings (fewer method calls).
# The converse holds true (exact speed differences aside) for
# ->to_number->value vs 0+ (actually, in 5.8.8 the 0+ overload-
# ing for JE::Number is slower than two method calls, but it’s
# faster in 5.10). If we might have an object, we must
# string-/numbify it immediately so that toString and
# valueOf are called at the right time.
# ~~~ Having said all that, we can’t use "..." because it will Uni-
# codify the string (un-UTF-16-ify it). We probably need some
# new method added to JE::Types and all the classes.
if(ref $term eq 'JE::Code::Expression') {
my($rettype,$code,$alt) = $term->to_perl($cx);
return $rettype,
$cx == cx_str ?
defined $alt ? $alt : "$code->to_string->value16" :
$cx == cx_num ?
defined $alt ? $alt : "(0+$code)" :
$cx == cx_bool ?
defined $alt ? $alt : $code :
$code
}
elsif(ref $term) { # ’better be’n array
my $code = _cached("scalar(require JE'Object'RegExp,"
. "JE'Object'RegExp->new(\$global,"
. _esc_str($$term[0])
. (defined $$term[1]?',' . _esc_str($$term[1]):'')
. '))');
return ret_rv,
$cx == cx_str ?
"$code->to_string->value16" :
$cx == cx_num ?
"(0+$code)" :
$code
}
if($term =~ /^i/) {
my $find = "\$scope->find_var("
. _esc_str(substr $term,1)
. ")";
return
$cx == cx_lv || $cx == cx_any ? ( ret_lv, $find ) :
$cx==cx_str ?( ret_str, "$find->get->to_string->value16") :
$cx==cx_bool?( ret_bool,"$find->get" ) :
$cx==cx_num ?( ret_num, "(0+$find->get)" ) :
( ret_rv, "$find->get" )
}
return (ret_void,'0') if $cx == cx_void;
return ret_rv,'die(new JE\'Object\'Error\'ReferenceError $global,'
.'add_line_number"Cannot assign to a non-lvalue")'
if $cx == cx_lv;
$term eq'this'?
$cx == cx_str ? (ret_str, "\$this->to_string->value16") :
$cx == cx_bool ? (ret_bool, '$this') :
$cx == cx_num ? (ret_num, '(0+$this)') :
( ret_rv, '$this', 0)
:
$term =~ /^s/ ? do {
my $esc = _esc_str(my $str = substr $term,1);
$cx == cx_str ? (ret_str, $esc) :
$cx == cx_bool ? (ret_bool, 0+(length $term > 1)) :
$cx == cx_num ? (ret_num,
# ~~~ JE::Number probably needs a function for
# this, as it is a repeat of code found else- # where (in JE::String)
$str =~ /^[\p{Zs}\s\ck]*
(
[+-]?
(?:
(?=[0-9]|\.[0-9]) [0-9]* (?:\.[0-9]*)?
(?:[Ee][+-]?[0-9]+)?
|
Infinity
)
[\p{Zs}\s\ck]*
)?
\z
/ox ? defined $1 ? $1 eq 'Infinity' ? 9**9**9 : $1 : 0 :
$str =~ /^ [\p{Zs}\s\ck]* 0[Xx] ([A-Fa-f0-9]+)
[\p{Zs}\s\ck]*\z/ox
? hex $1 : nan
) : (
ret_str, _cached "_new JE'String \$global,$esc",
$esc
)
} :
$term eq 't' ?
$cx == cx_str ? (ret_str, '"true"') :
$cx == cx_bool ? (ret_bool, 1) :
$cx == cx_num ? (ret_num, 1) :
( ret_bool, '$global->true', 1)
:
$term eq 'f' ?
$cx == cx_str ? (ret_str, '"false"') :
$cx == cx_bool ? (ret_bool, 0) :
$cx == cx_num ? (ret_num, 0) :
( ret_bool, '$global->false', 0)
:
$term eq 'n' ?
$cx == cx_str ? (ret_str, '"null"') :
$cx == cx_bool ? (ret_bool, 0) :
$cx == cx_num ? (ret_num, 0) :
( ret_rv, '$global->null')
:
$cx == cx_str ? (ret_str,
$term == inf ? '"Infinity"' :
$term ==-+inf ? '"-Infinity"':
$term == $term? $term :
'"NaN"'
) :
$cx == cx_bool ? (ret_bool, 0+($term && $term == $term)) :
$cx == cx_num ? (ret_num, $term ) :
( ret_rv, _cached "JE'Number->new(\$global," . (
$term == inf ? '"inf"' : $term == -+inf ? '"-inf"':
$term == $term ? $term : '"nan"'
) . ')', $term )
}
sub JE::Code::Subscript::to_perl {
my $val = (my $self = shift)->[1];
ref $val ? $val->to_perl(cx_str) : _esc_str($val);
}
sub JE::Code::Arguments::to_perl {
my $self = shift;
join ',', map +(_term_to_perl($_,cx_rv))[1], @$self[1..$#$self];
}
1