summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B/Deparse.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Deparse.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Deparse.pm346
1 files changed, 209 insertions, 137 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index d7dc060fc6d..7bf1cd51c36 100644
--- a/Master/tlpkg/tlperl/lib/B/Deparse.pm
+++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm
@@ -52,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
MDEREF_SHIFT
);
-$VERSION = '1.49';
+$VERSION = '1.54';
use strict;
our $AUTOLOAD;
use warnings ();
@@ -271,7 +271,7 @@ BEGIN {
BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
- kvaslice kvhslice padsv
+ kvaslice kvhslice padsv argcheck
nextstate dbstate rv2av rv2hv helem custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
@@ -279,6 +279,8 @@ BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
# _pessimise_walk(): recursively walk the optree of a sub,
# possibly undoing optimisations along the way.
+sub DEBUG { 0 }
+
sub _pessimise_walk {
my ($self, $startop) = @_;
@@ -1176,42 +1178,68 @@ sub pad_subs {
# or altered. In this case we return "()" and fall back to general
# deparsing of the individual sigelems as 'my $x = $_[N]' etc.
#
-# We're only called if the first two ops are nextstate and argcheck.
+# We're only called if the top is an ex-argcheck, which is a placeholder
+# indicating a signature subtree.
+#
+# Return a signature string, or an empty list if no deparseable as a
+# signature
sub deparse_argops {
- my ($self, $firstop, $cv) = @_;
+ my ($self, $topop, $cv) = @_;
my @sig;
- my $o = $firstop;
- return if $o->label; #first nextstate;
+
+
+ $topop = $topop->first;
+ return unless $$topop and $topop->name eq 'lineseq';
+
+
+ # last op should be nextstate
+ my $last = $topop->last;
+ return unless $$last
+ and ( _op_is_or_was($last, OP_NEXTSTATE)
+ or _op_is_or_was($last, OP_DBSTATE));
+
+ # first OP_NEXTSTATE
+
+ my $o = $topop->first;
+ return unless $$o;
+ return if $o->label;
# OP_ARGCHECK
$o = $o->sibling;
+ return unless $$o and $o->name eq 'argcheck';
+
my ($params, $opt_params, $slurpy) = $o->aux_list($cv);
my $mandatory = $params - $opt_params;
my $seen_slurpy = 0;
my $last_ix = -1;
- # keep looking for valid nextstate + argelem pairs
+ # keep looking for valid nextstate + argelem pairs, terminated
+ # by a final nextstate
while (1) {
- # OP_NEXTSTATE
$o = $o->sibling;
- last unless $$o;
- last unless $o->name =~ /^(next|db)state$/;
- last if $o->label;
+ return unless $$o;
+
+ # skip trailing nextstate
+ last if $$o == $$last;
+
+ # OP_NEXTSTATE
+ return unless $o->name =~ /^(next|db)state$/;
+ return if $o->label;
# OP_ARGELEM
- my $o2 = $o->sibling;
- last unless $$o2;
+ $o = $o->sibling;
+ last unless $$o;
- if ($o2->name eq 'argelem') {
- my $ix = $o2->string($cv);
+ if ($o->name eq 'argelem') {
+ my $ix = $o->string($cv);
while (++$last_ix < $ix) {
push @sig, $last_ix < $mandatory ? '$' : '$=';
}
- my $var = $self->padname($o2->targ);
+ my $var = $self->padname($o->targ);
if ($var =~ /^[@%]/) {
return if $seen_slurpy;
$seen_slurpy = 1;
@@ -1221,8 +1249,8 @@ sub deparse_argops {
else {
return if $ix >= $params;
}
- if ($o2->flags & OPf_KIDS) {
- my $kid = $o2->first;
+ if ($o->flags & OPf_KIDS) {
+ my $kid = $o->first;
return unless $$kid and $kid->name eq 'argdefelem';
my $def = $self->deparse($kid->first, 7);
$def = "($def)" if $kid->first->flags & OPf_PARENS;
@@ -1230,13 +1258,13 @@ sub deparse_argops {
}
push @sig, $var;
}
- elsif ($o2->name eq 'null'
- and ($o2->flags & OPf_KIDS)
- and $o2->first->name eq 'argdefelem')
+ elsif ($o->name eq 'null'
+ and ($o->flags & OPf_KIDS)
+ and $o->first->name eq 'argdefelem')
{
# special case - a void context default expression: $ = expr
- my $defop = $o2->first;
+ my $defop = $o->first;
my $ix = $defop->targ;
while (++$last_ix < $ix) {
push @sig, $last_ix < $mandatory ? '$' : '$=';
@@ -1248,10 +1276,9 @@ sub deparse_argops {
push @sig, '$ = ' . $def;
}
else {
- last;
+ return;
}
- $o = $o2;
}
while (++$last_ix < $params) {
@@ -1259,9 +1286,10 @@ sub deparse_argops {
}
push @sig, $slurpy if $slurpy and !$seen_slurpy;
- return ($o, join(', ', @sig));
+ return (join(', ', @sig));
}
+
# Deparse a sub. Returns everything except the 'sub foo',
# e.g. ($$) : method { ...; }
# or : prototype($$) lvalue ($a, $b) { ...; };
@@ -1304,27 +1332,26 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
$self->pad_subs($cv);
$self->pessimise($root, $cv->START);
my $lineseq = $root->first;
- if ($lineseq->name eq "lineseq") {
- my $firstop = $lineseq->first;
-
- if ($has_sig) {
- my $o2;
- # try to deparse first few ops as a signature if possible
- if ( $$firstop
- and $firstop->name =~ /^(next|db)state$/
- and (($o2 = $firstop->sibling))
- and $$o2)
- {
- if ($o2->name eq 'argcheck') {
- my ($nexto, $mysig) = $self->deparse_argops($firstop, $cv);
- if (defined $nexto) {
- $firstop = $nexto;
- $sig = $mysig;
- }
- }
- }
+
+ # stub sub may have single op rather than list of ops
+ my $is_list = ($lineseq->name eq "lineseq");
+ my $firstop = $is_list ? $lineseq->first : $lineseq;
+
+ # Try to deparse first subtree as a signature if possible.
+ # Top of signature subtree has an ex-argcheck as a placeholder
+ if ( $has_sig
+ and $$firstop
+ and $firstop->name eq 'null'
+ and $firstop->targ == OP_ARGCHECK
+ ) {
+ my ($mysig) = $self->deparse_argops($firstop, $cv);
+ if (defined $mysig) {
+ $sig = $mysig;
+ $firstop = $is_list ? $firstop->sibling : undef;
}
+ }
+ if ($is_list && $firstop) {
my @ops;
for (my $o = $firstop; $$o; $o=$o->sibling) {
push @ops, $o;
@@ -1341,9 +1368,12 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
$body .= ";\n$subs" if length($subs);
}
}
- else {
+ elsif ($firstop) {
$body = $self->deparse($root->first, 0);
}
+ else {
+ $body = ';'; # stub sub
+ }
my $l = '';
if ($self->{'linenums'}) {
@@ -2184,6 +2214,7 @@ my %ignored_hints = (
'strict/refs' => 1,
'strict/subs' => 1,
'strict/vars' => 1,
+ 'feature/bits' => 1,
);
my %rev_feature;
@@ -2304,7 +2335,7 @@ sub keyword {
}
# This sub may be called for a program that has no nextstate ops. In
# that case we may have a lexical sub named no/use/sub in scope but
- # but $self->lex_in_scope will return false because it depends on the
+ # $self->lex_in_scope will return false because it depends on the
# current nextstate op. So we need this alternate method if there is
# no current cop.
if (!$self->{'curcop'}) {
@@ -3029,6 +3060,8 @@ sub pp_sge { binop(@_, "ge", 15) }
sub pp_sle { binop(@_, "le", 15) }
sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
+sub pp_isa { binop(@_, "isa", 15) }
+
sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
@@ -3167,6 +3200,64 @@ sub pp_andassign { logassignop(@_, "&&=") }
sub pp_orassign { logassignop(@_, "||=") }
sub pp_dorassign { logassignop(@_, "//=") }
+my %cmpchain_cmpops = (
+ eq => ["==", 14],
+ i_eq => ["==", 14],
+ ne => ["!=", 14],
+ i_ne => ["!=", 14],
+ seq => ["eq", 14],
+ sne => ["ne", 14],
+ lt => ["<", 15],
+ i_lt => ["<", 15],
+ gt => [">", 15],
+ i_gt => [">", 15],
+ le => ["<=", 15],
+ i_le => ["<=", 15],
+ ge => [">=", 15],
+ i_ge => [">=", 15],
+ slt => ["lt", 15],
+ sgt => ["gt", 15],
+ sle => ["le", 15],
+ sge => ["ge", 15],
+);
+sub pp_cmpchain_and {
+ my($self, $op, $cx) = @_;
+ my($prec, $dep);
+ while(1) {
+ my($thiscmp, $rightcond);
+ if($op->name eq "cmpchain_and") {
+ $thiscmp = $op->first;
+ $rightcond = $thiscmp->sibling;
+ } else {
+ $thiscmp = $op;
+ }
+ my $thiscmptype = $cmpchain_cmpops{$thiscmp->name} // (return "XXX");
+ if(defined $prec) {
+ $thiscmptype->[1] == $prec or return "XXX";
+ $thiscmp->first->name eq "null" &&
+ !($thiscmp->first->flags & OPf_KIDS)
+ or return "XXX";
+ } else {
+ $prec = $thiscmptype->[1];
+ $dep = $self->deparse($thiscmp->first, $prec);
+ }
+ $dep .= " ".$thiscmptype->[0]." ";
+ my $operand = $thiscmp->last;
+ if(defined $rightcond) {
+ $operand->name eq "cmpchain_dup" or return "XXX";
+ $operand = $operand->first;
+ }
+ $dep .= $self->deparse($operand, $prec);
+ last unless defined $rightcond;
+ if($rightcond->name eq "null" && ($rightcond->flags & OPf_KIDS) &&
+ $rightcond->first->name eq "cmpchain_and") {
+ $rightcond = $rightcond->first;
+ }
+ $op = $rightcond;
+ }
+ return $self->maybe_parens($dep, $cx, $prec);
+}
+
sub rv2gv_or_string {
my($self,$op) = @_;
if ($op->name eq "gv") { # could be open("open") or open("###")
@@ -3360,7 +3451,7 @@ sub pp_glob {
my $kid = $op->first->sibling; # skip pushmark
my $keyword =
$op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
- my $text = $self->deparse($kid);
+ my $text = $self->deparse($kid, $cx);
return $cx >= 5 || $self->{'parens'}
? "$keyword($text)"
: "$keyword $text";
@@ -5685,100 +5776,81 @@ sub tr_chr {
}
}
-# XXX This doesn't yet handle all cases correctly either
+sub tr_invmap {
+ my ($invlist_ref, $map_ref) = @_;
-sub tr_decode_utf8 {
- my($swash_hv, $flags) = @_;
- my %swash = $swash_hv->ARRAY;
- my $final = undef;
- $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
- my $none = $swash{"NONE"}->IV;
- my $extra = $none + 1;
- my(@from, @delfrom, @to);
- my $line;
- foreach $line (split /\n/, $swash{'LIST'}->PV) {
- my($min, $max, $result) = split(/\t/, $line);
- $min = hex $min;
- if (length $max) {
- $max = hex $max;
- } else {
- $max = $min;
- }
- $result = hex $result;
- if ($result == $extra) {
- push @delfrom, [$min, $max];
- } else {
- push @from, [$min, $max];
- push @to, [$result, $result + $max - $min];
- }
- }
- for my $i (0 .. $#from) {
- if ($from[$i][0] == ord '-') {
- unshift @from, splice(@from, $i, 1);
- unshift @to, splice(@to, $i, 1);
- last;
- } elsif ($from[$i][1] == ord '-') {
- $from[$i][1]--;
- $to[$i][1]--;
- unshift @from, ord '-';
- unshift @to, ord '-';
- last;
- }
- }
- for my $i (0 .. $#delfrom) {
- if ($delfrom[$i][0] == ord '-') {
- push @delfrom, splice(@delfrom, $i, 1);
- last;
- } elsif ($delfrom[$i][1] == ord '-') {
- $delfrom[$i][1]--;
- push @delfrom, ord '-';
- last;
- }
+ my $infinity = ~0 >> 1; # IV_MAX
+ my $from = "";
+ my $to = "";
+
+ for my $i (0.. @$invlist_ref - 1) {
+ my $this_from = $invlist_ref->[$i];
+ my $map = $map_ref->[$i];
+ my $upper = ($i < @$invlist_ref - 1)
+ ? $invlist_ref->[$i+1]
+ : $infinity;
+ my $range = $upper - $this_from - 1;
+ if (DEBUG) {
+ print STDERR "i=$i, from=$this_from, upper=$upper, range=$range\n";
+ }
+ next if $map == ~0;
+ next if $map == ~0 - 1;
+ $from .= tr_chr($this_from);
+ $to .= tr_chr($map);
+ next if $range == 0; # Single code point
+ if ($range == 1) { # Adjacent code points
+ $from .= tr_chr($this_from + 1);
+ $to .= tr_chr($map + 1);
+ }
+ elsif ($upper != $infinity) {
+ $from .= "-" . tr_chr($this_from + $range);
+ $to .= "-" . tr_chr($map + $range);
+ }
+ else {
+ $from .= "-INFTY";
+ $to .= "-INFTY";
+ }
}
- if (defined $final and $to[$#to][1] != $final) {
- push @to, [$final, $final];
+
+ return ($from, $to);
+}
+
+sub tr_decode_utf8 {
+ my($tr_av, $flags) = @_;
+ printf STDERR "flags=0x%x\n", $flags if DEBUG;
+ my $invlist = $tr_av->ARRAYelt(0);
+ my @invlist = unpack("J*", $invlist->PV);
+ my @map = unpack("J*", $tr_av->ARRAYelt(1)->PV);
+
+ if (DEBUG) {
+ for my $i (0 .. @invlist - 1) {
+ printf STDERR "[%d]\t%x\t", $i, $invlist[$i];
+ my $map = $map[$i];
+ if ($map == ~0) {
+ print STDERR "TR_UNMAPPED\n";
+ }
+ elsif ($map == ~0 - 1) {
+ print STDERR "TR_SPECIAL\n";
+ }
+ else {
+ printf STDERR "%x\n", $map;
+ }
+ }
}
- push @from, @delfrom;
+
+ my ($from, $to) = tr_invmap(\@invlist, \@map);
+
if ($flags & OPpTRANS_COMPLEMENT) {
- my @newfrom;
- my $next = 0;
- for my $i (0 .. $#from) {
- push @newfrom, [$next, $from[$i][0] - 1];
- $next = $from[$i][1] + 1;
- }
- @from = ();
- for my $range (@newfrom) {
- if ($range->[0] <= $range->[1]) {
- push @from, $range;
- }
- }
+ shift @map;
+ pop @invlist;
+ my $throw_away;
+ ($from, $throw_away) = tr_invmap(\@invlist, \@map);
}
- my($from, $to, $diff);
- for my $chunk (@from) {
- $diff = $chunk->[1] - $chunk->[0];
- if ($diff > 1) {
- $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
- } elsif ($diff == 1) {
- $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
- } else {
- $from .= tr_chr($chunk->[0]);
- }
- }
- for my $chunk (@to) {
- $diff = $chunk->[1] - $chunk->[0];
- if ($diff > 1) {
- $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
- } elsif ($diff == 1) {
- $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
- } else {
- $to .= tr_chr($chunk->[0]);
- }
+
+ if (DEBUG) {
+ print STDERR "Returning ", escape_str($from), "/",
+ escape_str($to), "\n";
}
- #$final = sprintf("%04x", $final) if defined $final;
- #$none = sprintf("%04x", $none) if defined $none;
- #$extra = sprintf("%04x", $extra) if defined $extra;
- #print STDERR "final: $final\n none: $none\nextra: $extra\n";
- #print STDERR $swash{'LIST'}->PV;
return (escape_str($from), escape_str($to));
}
@@ -5792,9 +5864,9 @@ sub pp_trans {
($from, $to) = tr_decode_byte($op->pv, $priv_flags);
} elsif ($class eq "PADOP") {
($from, $to)
- = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
+ = tr_decode_utf8($self->padval($op->padix), $priv_flags);
} else { # class($op) eq "SVOP"
- ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
+ ($from, $to) = tr_decode_utf8($op->sv, $priv_flags);
}
my $flags = "";
$flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;