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.pm282
1 files changed, 187 insertions, 95 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index 7bf1cd51c36..67147f12ddf 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.54';
+$VERSION = '1.56';
use strict;
our $AUTOLOAD;
use warnings ();
@@ -280,6 +280,7 @@ BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
# possibly undoing optimisations along the way.
sub DEBUG { 0 }
+use if DEBUG, 'Data::Dumper';
sub _pessimise_walk {
my ($self, $startop) = @_;
@@ -2303,6 +2304,8 @@ my %feature_keywords = (
evalbytes=>'evalbytes',
__SUB__ => '__SUB__',
fc => 'fc',
+ try => 'try',
+ catch => 'try',
);
# keywords that are strong and also have a prototype
@@ -2471,7 +2474,7 @@ sub unop {
return $self->maybe_parens(
$self->keyword($name) . " $kid", $cx, 16
);
- }
+ }
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
return $self->maybe_parens(
@@ -2511,7 +2514,7 @@ sub pp_each { unop(@_, "each") }
sub pp_values { unop(@_, "values") }
sub pp_keys { unop(@_, "keys") }
{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
-sub pp_boolkeys {
+sub pp_boolkeys {
# no name because its an optimisation op that has no keyword
unop(@_,"");
}
@@ -4054,6 +4057,31 @@ sub pp_leavetry {
return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
}
+sub pp_leavetrycatch {
+ my $self = shift;
+ my ($op) = @_;
+
+ # Expect that the first three kids should be (entertrycatch, poptry, catch)
+ my $entertrycatch = $op->first;
+ $entertrycatch->name eq "entertrycatch" or die "Expected entertrycatch as first child of leavetrycatch";
+
+ my $tryblock = $entertrycatch->sibling;
+ $tryblock->name eq "poptry" or die "Expected poptry as second child of leavetrycatch";
+
+ my $catch = $tryblock->sibling;
+ $catch->name eq "catch" or die "Expected catch as third child of leavetrycatch";
+
+ my $catchblock = $catch->first->sibling;
+ $catchblock->name eq "scope" or die "Expected scope as second child of catch";
+
+ my $trycode = scopeop(0, $self, $tryblock);
+ my $catchvar = $self->padname($catch->targ);
+ my $catchcode = scopeop(0, $self, $catchblock);
+
+ return "try {\n\t$trycode\n\b}\n" .
+ "catch($catchvar) {\n\t$catchcode\n\b}\cK";
+}
+
sub _op_is_or_was {
my ($op, $expect_type) = @_;
my $type = $op->type;
@@ -5658,38 +5686,24 @@ sub double_delim {
# Escape a characrter.
# Only used by tr///, so backslashes hyphens
-sub pchr { # ASCII
+sub pchr {
my($n) = @_;
- if ($n == ord '\\') {
- return '\\\\';
- } elsif ($n == ord "-") {
- return "\\-";
- } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' '))
- and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~')))
- {
- # I'm presuming a regex is not ok here, otherwise we could have used
- # /[[:print:]]/a to get here
- return chr($n);
- } elsif ($n == ord "\a") {
- return '\\a';
- } elsif ($n == ord "\b") {
- return '\\b';
- } elsif ($n == ord "\t") {
- return '\\t';
- } elsif ($n == ord "\n") {
- return '\\n';
- } elsif ($n == ord "\e") {
- return '\\e';
- } elsif ($n == ord "\f") {
- return '\\f';
- } elsif ($n == ord "\r") {
- return '\\r';
- } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
- return '\\c' . $unctrl{chr $n};
- } else {
-# return '\x' . sprintf("%02x", $n);
- return '\\' . sprintf("%03o", $n);
- }
+ return sprintf("\\x{%X}", $n) if $n > 255;
+ return '\\\\' if $n == ord '\\';
+ return "\\-" if $n == ord "-";
+ # I'm presuming a regex is not ok here, otherwise we could have used
+ # /[[:print:]]/a to get here
+ return chr($n) if ( utf8::native_to_unicode($n)
+ >= utf8::native_to_unicode(ord(' '))
+ and utf8::native_to_unicode($n)
+ <= utf8::native_to_unicode(ord('~')));
+
+ my $mnemonic_pos = index("\a\b\e\f\n\r\t", chr($n));
+ return "\\" . substr("abefnrt", $mnemonic_pos, 1) if $mnemonic_pos >= 0;
+
+ return '\\c' . $unctrl{chr $n} if $n >= ord("\cA") and $n <= ord("\cZ");
+# return '\x' . sprintf("%02x", $n);
+ return '\\' . sprintf("%03o", $n);
}
# Convert a list of characters into a string suitable for tr/// search or
@@ -5765,92 +5779,170 @@ sub tr_decode_byte {
return ($from, $to);
}
-sub tr_chr {
- my $x = shift;
- if ($x == ord "-") {
- return "\\-";
- } elsif ($x == ord "\\") {
- return "\\\\";
- } else {
- return chr $x;
+my $infinity = ~0 >> 1; # IV_MAX
+
+sub tr_append_to_invlist {
+ my ($list_ref, $current, $next) = @_;
+
+ # Appends the range $current..$next-1 to the inversion list $list_ref
+
+ printf STDERR "%d: %d..%d %s", __LINE__, $current, $next, Dumper $list_ref if DEBUG;
+
+ if (@$list_ref && $list_ref->[-1] == $current) {
+
+ # The new range extends the current final one. If it is a finite
+ # rane, replace the current final by the new ending.
+ if (defined $next) {
+ $list_ref->[-1] = $next;
+ }
+ else {
+ # The new range extends to infinity, which means the current end
+ # of the inversion list is dangling. Removing it causes things to
+ # work.
+ pop @$list_ref;
+ }
}
+ else { # The new range starts after the current final one; add it as a
+ # new range
+ push @$list_ref, $current;
+ push @$list_ref, $next if defined $next;
+ }
+
+ print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG;
}
-sub tr_invmap {
- my ($invlist_ref, $map_ref) = @_;
+sub tr_invlist_to_string {
+ my ($list_ref, $to_complement) = @_;
- my $infinity = ~0 >> 1; # IV_MAX
- my $from = "";
- my $to = "";
+ # Stringify the inversion list $list_ref, possibly complementing it first.
+ # CAUTION: this can modify $list_ref.
- 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";
+ print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG;
+
+ if ($to_complement) {
+
+ # Complementing an inversion list is done by prepending a 0 if it
+ # doesn't have one there already; otherwise removing the leading 0.
+ if ($list_ref->[0] == 0) {
+ shift @$list_ref;
+ }
+ else {
+ unshift @$list_ref, 0;
}
- 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);
+
+ print STDERR __LINE__, ": ", Dumper $list_ref if DEBUG;
+ }
+
+ my $output = "";
+
+ # Every other element is in the list.
+ for (my $i = 0; $i < @$list_ref; $i += 2) {
+ my $base = $list_ref->[$i];
+ $output .= pchr($base);
+ last unless defined $list_ref->[$i+1];
+
+ # The beginning of the next element starts the range of items not in
+ # the list.
+ my $upper = $list_ref->[$i+1] - 1;
+ my $range = $upper - $base;
+ $output .= '-' if $range > 1; # Adjacent characters don't have a
+ # minus, though it would be legal to do
+ # so
+ $output .= pchr($upper) if $range > 0;
+ }
+
+ print STDERR __LINE__, ": tr_invlist_to_string() returning '$output'\n"
+ if DEBUG;
+ return $output;
+}
+
+my $unmapped = ~0;
+my $special_handling = ~0 - 1;
+
+sub dump_invmap {
+ my ($invlist_ref, $map_ref) = @_;
+
+ for my $i (0 .. @$invlist_ref - 1) {
+ printf STDERR "[%d]\t%x\t", $i, $invlist_ref->[$i];
+ my $map = $map_ref->[$i];
+ if ($map == $unmapped) {
+ print STDERR "TR_UNMAPPED\n";
}
- elsif ($upper != $infinity) {
- $from .= "-" . tr_chr($this_from + $range);
- $to .= "-" . tr_chr($map + $range);
+ elsif ($map == $special_handling) {
+ print STDERR "TR_SPECIAL\n";
}
else {
- $from .= "-INFTY";
- $to .= "-INFTY";
+ printf STDERR "%x\n", $map;
}
}
-
- return ($from, $to);
}
sub tr_decode_utf8 {
my($tr_av, $flags) = @_;
- printf STDERR "flags=0x%x\n", $flags if DEBUG;
+
+ printf STDERR "\n%s: %d: flags=0x%x\n", __FILE__, __LINE__, $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;
- }
+ dump_invmap(\@invlist, \@map) if DEBUG;
+
+ my @from;
+ my @to;
+
+ # Go through the whole map
+ for (my $i = 0; $i < @invlist; $i++) {
+ my $map = $map[$i];
+ printf STDERR "%d: i=%d, source=%x, map=%x\n",
+ __LINE__, $i, $invlist[$i], $map if DEBUG;
+
+ # Ignore any lines that are unmapped
+ next if $map == $unmapped;
+
+ # Calculate this component of the mapping; First the lhs
+ my $this_from = $invlist[$i];
+ my $next_from = $invlist[$i+1] if $i < @invlist - 1;
+
+ # The length of the rhs is the same as the lhs, except when special
+ my $next_map = $map - $this_from + $next_from
+ if $map != $special_handling && defined $next_from;
+
+ if (DEBUG) {
+ printf STDERR "%d: i=%d, from=%x, to=%x",
+ __LINE__, $i, $this_from, $map;
+ printf STDERR ", next_from=%x,", $next_from if defined $next_from;
+ printf STDERR ", next_map=%x", $next_map if defined $next_map;
+ print STDERR "\n";
}
- }
- my ($from, $to) = tr_invmap(\@invlist, \@map);
+ # Add the lhs.
+ tr_append_to_invlist(\@from, $this_from, $next_from);
- if ($flags & OPpTRANS_COMPLEMENT) {
- shift @map;
- pop @invlist;
- my $throw_away;
- ($from, $throw_away) = tr_invmap(\@invlist, \@map);
+ # And, the rhs; special handling doesn't get output as it really is an
+ # unmatched rhs
+ tr_append_to_invlist(\@to, $map, $next_map) if $map != $special_handling;
}
- if (DEBUG) {
- print STDERR "Returning ", escape_str($from), "/",
- escape_str($to), "\n";
+ # Done with the input.
+
+ my $to;
+ if (join("", @from) eq join("", @to)) {
+
+ # the rhs is suppressed if identical to the left. That's because
+ # tr/ABC/ABC/ can be written as tr/ABC//. (Do this comparison before
+ # any complementing)
+ $to = "";
}
+ else {
+ $to = tr_invlist_to_string(\@to, 0); # rhs not complemented
+ }
+
+ my $from = tr_invlist_to_string(\@from,
+ ($flags & OPpTRANS_COMPLEMENT) != 0);
+
+ print STDERR "Returning ", escape_str($from), "/",
+ escape_str($to), "\n" if DEBUG;
return (escape_str($from), escape_str($to));
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:48:46 +0000