From 3f872cb9b86492b28abfc3221567ac8cecfb2724 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Mon, 26 Jul 1999 08:06:39 +0000 Subject: [PATCH] patch for pp_foo -> Perl_pp_foo changes from Vishal Bhatia; add B::OP::name() method that returns just the op_name; convert Deparse et all to use that instead of B::OP::ppaddr(); add support for OP_SETSTATE in Deparse p4raw-id: //depot/perl@3761 --- ext/B/B.pm | 21 ++-- ext/B/B.xs | 10 +- ext/B/B/Bblock.pm | 10 +- ext/B/B/Bytecode.pm | 10 +- ext/B/B/C.pm | 6 +- ext/B/B/CC.pm | 6 +- ext/B/B/Deparse.pm | 271 ++++++++++++++++++++++++++-------------------------- ext/B/B/Lint.pm | 47 +++++---- ext/B/B/Xref.pm | 13 +-- opcode.h | 2 +- opcode.pl | 2 +- 11 files changed, 206 insertions(+), 192 deletions(-) diff --git a/ext/B/B.pm b/ext/B/B.pm index b39659d..e4730cd 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -76,7 +76,7 @@ sub parents { \@parents } # For debugging sub peekop { my $op = shift; - return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr); + return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); } sub walkoptree_slow { @@ -130,26 +130,26 @@ sub walkoptree_exec { } savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); $op->$method($level); - $ppname = $op->ppaddr; + $ppname = $op->name; if ($ppname =~ - /^pp_(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/) + /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/) { print $prefix, uc($1), " => {\n"; walkoptree_exec($op->other, $method, $level + 1); print $prefix, "}\n"; - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($ppname eq "match" || $ppname eq "subst") { my $pmreplstart = $op->pmreplstart; if ($$pmreplstart) { print $prefix, "PMREPLSTART => {\n"; walkoptree_exec($pmreplstart, $method, $level + 1); print $prefix, "}\n"; } - } elsif ($ppname eq "pp_substcont") { + } elsif ($ppname eq "substcont") { print $prefix, "SUBSTCONT => {\n"; walkoptree_exec($op->other->pmreplstart, $method, $level + 1); print $prefix, "}\n"; $op = $op->other; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($ppname eq "enterloop") { print $prefix, "REDO => {\n"; walkoptree_exec($op->redoop, $method, $level + 1); print $prefix, "}\n", $prefix, "NEXT => {\n"; @@ -157,7 +157,7 @@ sub walkoptree_exec { print $prefix, "}\n", $prefix, "LAST => {\n"; walkoptree_exec($op->lastop, $method, $level + 1); print $prefix, "}\n"; - } elsif ($ppname eq "pp_subst") { + } elsif ($ppname eq "subst") { my $replstart = $op->pmreplstart; if ($$replstart) { print $prefix, "SUBST => {\n"; @@ -559,9 +559,14 @@ leading "class indication" prefix removed (op_). =item sibling +=item name + +This returns the op name as a string (e.g. "add", "rv2av"). + =item ppaddr -This returns the function name as a string (e.g. pp_add, pp_rv2av). +This returns the function name as a string (e.g. Perl_pp_add, +Perl_pp_rv2av). =item desc diff --git a/ext/B/B.xs b/ext/B/B.xs index 2c9a888..570b001 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -556,11 +556,19 @@ OP_sibling(o) B::OP o char * +OP_name(o) + B::OP o + CODE: + ST(0) = sv_newmortal(); + sv_setpv(ST(0), PL_op_name[o->op_type]); + + +char * OP_ppaddr(o) B::OP o CODE: ST(0) = sv_newmortal(); - sv_setpvn(ST(0), "pp_", 3); + sv_setpvn(ST(0), "Perl_pp_", 8); sv_catpv(ST(0), PL_op_name[o->op_type]); char * diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm index ae47cf9..d2ef78f 100644 --- a/ext/B/B/Bblock.pm +++ b/ext/B/B/Bblock.pm @@ -90,9 +90,9 @@ sub B::LOOP::mark_if_leader { sub B::LOGOP::mark_if_leader { my $op = shift; - my $ppaddr = $op->ppaddr; + my $opname = $op->name; mark_leader($op->next); - if ($ppaddr eq "pp_entertry") { + if ($opname eq "entertry") { mark_leader($op->other->next); } else { mark_leader($op->other); @@ -102,10 +102,10 @@ sub B::LOGOP::mark_if_leader { sub B::LISTOP::mark_if_leader { my $op = shift; my $first=$op->first; - $first=$first->next while ($first->ppaddr eq "pp_null"); + $first=$first->next while ($first->name eq "null"); mark_leader($op->first) unless (exists( $bblock->{$$first})); mark_leader($op->next); - if ($op->ppaddr eq "pp_sort" and $op->flags & OPf_SPECIAL + if ($op->name eq "sort" and $op->flags & OPf_SPECIAL and $op->flags & OPf_STACKED){ my $root=$op->first->sibling->first; my $leader=$root->first; @@ -115,7 +115,7 @@ sub B::LISTOP::mark_if_leader { sub B::PMOP::mark_if_leader { my $op = shift; - if ($op->ppaddr ne "pp_pushre") { + if ($op->name ne "pushre") { my $replroot = $op->pmreplroot; if ($$replroot) { mark_leader($replroot); diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index 1bf4368..a9e5d55 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -193,7 +193,7 @@ sub B::OP::bytecode { ldop($ix); print "op_next $nextix\n"; print "op_sibling $sibix\n" unless $strip_syntree; - printf "op_type %s\t# %d\n", $op->ppaddr, $type; + printf "op_type %s\t# %d\n", "pp_" . $op->name, $type; printf("op_seq %d\n", $op->seq) unless $omit_seq; if ($type || !$compress_nullops) { printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", @@ -243,7 +243,7 @@ sub B::PVOP::bytecode { # This would be easy except that OP_TRANS uses a PVOP to store an # endian-dependent array of 256 shorts instead of a plain string. # - if ($op->ppaddr eq "pp_trans") { + if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness print "op_pv_tr ", join(",", @shorts), "\n"; } else { @@ -310,7 +310,7 @@ sub B::PMOP::bytecode { my $replroot = $op->pmreplroot; my $replrootix = $replroot->objix; my $replstartix = $op->pmreplstart->objix; - my $ppaddr = $op->ppaddr; + my $opname = $op->name; # pmnext is corrupt in some PMOPs (see misc.t for example) #my $pmnextix = $op->pmnext->objix; @@ -318,14 +318,14 @@ sub B::PMOP::bytecode { # OP_PUSHRE (a mutated version of OP_MATCH for the regexp # argument to a split) stores a GV in op_pmreplroot instead # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { + if ($opname eq "pushre") { $replroot->bytecode; } else { walkoptree($replroot, "bytecode"); } } $op->B::LISTOP::bytecode; - if ($ppaddr eq "pp_pushre") { + if ($opname eq "pushre") { printf "op_pmreplrootgv $replrootix\n"; } else { print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index c7b9d2a..dd4db03 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -319,7 +319,7 @@ sub B::PMOP::save { # OP_PUSHRE (a mutated version of OP_MATCH for the regexp # argument to a split) stores a GV in op_pmreplroot instead # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { + if ($op->name eq "pushre") { $gvsym = $replroot->save; # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug $replrootfield = 0; @@ -1031,8 +1031,8 @@ sub output_boilerplate { #include "perl.h" /* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef pp_mapstart -#define pp_mapstart pp_grepstart +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader EXTERN_C void boot_DynaLoader (CV* cv); diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index f912c41..4affda0 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -95,7 +95,7 @@ sub init_hash { map { $_ => 1 } @_ } %need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile pp_entertry pp_enterloop pp_enteriter pp_entersub - pp_enter); + pp_enter pp_method); sub debug { if ($debug_runtime) { @@ -1428,7 +1428,7 @@ sub pp_substcont { sub default_pp { my $op = shift; - my $ppname = $op->ppaddr; + my $ppname = "pp_" . $op->name; if ($curcop and $need_curcop{$ppname}){ $curcop->write_back; } @@ -1445,7 +1445,7 @@ sub default_pp { sub compile_op { my $op = shift; - my $ppname = $op->ppaddr; + my $ppname = "pp_" . $op->name; if (exists $ignore_op{$ppname}) { return $op->next; } diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 0eb319e..b983d12 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -243,15 +243,15 @@ sub walk_sub { return if !$op or null $op; walk_tree($op, sub { my $op = shift; - if ($op->ppaddr eq "pp_gv") { - if ($op->next->ppaddr eq "pp_entersub") { + if ($op->name eq "gv") { + if ($op->next->name eq "entersub") { next if $self->{'subs_done'}{$ {$op->gv}}++; next if class($op->gv->CV) eq "SPECIAL"; $self->todo($op->gv, $op->gv->CV, 0); $self->walk_sub($op->gv->CV); - } elsif ($op->next->ppaddr eq "pp_enterwrite" - or ($op->next->ppaddr eq "pp_rv2gv" - and $op->next->next->ppaddr eq "pp_enterwrite")) { + } elsif ($op->next->name eq "enterwrite" + or ($op->next->name eq "rv2gv" + and $op->next->next->name eq "enterwrite")) { next if $self->{'forms_done'}{$ {$op->gv}}++; next if class($op->gv->FORM) eq "SPECIAL"; $self->todo($op->gv, $op->gv->FORM, 1); @@ -384,8 +384,8 @@ sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; -# return $self->$ {\$op->ppaddr}($op, $cx); - my $meth = $op->ppaddr; +# return $self->$ {\("pp_" . $op->name)}($op, $cx); + my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); } @@ -461,36 +461,36 @@ sub deparse_format { sub is_scope { my $op = shift; - return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope" - || $op->ppaddr eq "pp_lineseq" - || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP" - && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter")); + return $op->name eq "leave" || $op->name eq "scope" + || $op->name eq "lineseq" + || ($op->name eq "null" && class($op) eq "UNOP" + && (is_scope($op->first) || $op->first->name eq "enter")); } sub is_state { - my $name = $_[0]->ppaddr; - return $name eq "pp_nextstate" || $name eq "pp_dbstate"; + my $name = $_[0]->name; + return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; } sub is_miniwhile { # check for one-line loop (`foo() while $y--') my $op = shift; return (!null($op) and null($op->sibling) - and $op->ppaddr eq "pp_null" and class($op) eq "UNOP" - and (($op->first->ppaddr =~ /^pp_(and|or)$/ - and $op->first->first->sibling->ppaddr eq "pp_lineseq") - or ($op->first->ppaddr eq "pp_lineseq" + and $op->name eq "null" and class($op) eq "UNOP" + and (($op->first->name =~ /^(and|or)$/ + and $op->first->first->sibling->name eq "lineseq") + or ($op->first->name eq "lineseq" and not null $op->first->first->sibling - and $op->first->first->sibling->ppaddr eq "pp_unstack") + and $op->first->first->sibling->name eq "unstack") )); } sub is_scalar { my $op = shift; - return ($op->ppaddr eq "pp_rv2sv" or - $op->ppaddr eq "pp_padsv" or - $op->ppaddr eq "pp_gv" or # only in array/hash constructs + return ($op->name eq "rv2sv" or + $op->name eq "padsv" or + $op->name eq "gv" or # only in array/hash constructs $op->flags & OPf_KIDS && !null($op->first) - && $op->first->ppaddr eq "pp_gvsv"); + && $op->first->name eq "gvsv"); } sub maybe_parens { @@ -661,10 +661,10 @@ sub pp_leave { $kid = $op->first->sibling; # skip enter if (is_miniwhile($kid)) { my $top = $kid->first; - my $name = $top->ppaddr; - if ($name eq "pp_and") { + my $name = $top->name; + if ($name eq "and") { $name = "while"; - } elsif ($name eq "pp_or") { + } elsif ($name eq "or") { $name = "until"; } else { # no conditional -> while 1 or until 0 return $self->deparse($top->first, 1) . " while 1"; @@ -764,6 +764,7 @@ sub pp_nextstate { } sub pp_dbstate { pp_nextstate(@_) } +sub pp_setstate { pp_nextstate(@_) } sub pp_unstack { return "" } # see also leaveloop @@ -823,7 +824,7 @@ sub pp_complement { pfixop(@_, "~", 21) } sub pp_negate { my $self = shift; my($op, $cx) = @_; - if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) { + if ($op->first->name =~ /^(i_)?negate$/) { # avoid --$x $self->pfixop($op, $cx, "-", 21.5); } else { @@ -960,7 +961,7 @@ sub pp_delete { sub pp_require { my $self = shift; my($op, $cx) = @_; - if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const" + if (class($op) eq "UNOP" and $op->first->name eq "const" and $op->first->private & OPpCONST_BARE) { my $name = $op->first->sv->PV; @@ -994,11 +995,11 @@ sub pp_refgen { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - if ($kid->ppaddr eq "pp_null") { + if ($kid->name eq "null") { $kid = $kid->first; - if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") { - my($pre, $post) = @{{"pp_anonlist" => ["[","]"], - "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}}; + if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { + my($pre, $post) = @{{"anonlist" => ["[","]"], + "anonhash" => ["{","}"]}->{$kid->name}}; my($expr, @exprs); $kid = $kid->first->sibling; # skip pushmark for (; !null($kid); $kid = $kid->sibling) { @@ -1007,18 +1008,18 @@ sub pp_refgen { } return $pre . join(", ", @exprs) . $post; } elsif (!null($kid->sibling) and - $kid->sibling->ppaddr eq "pp_anoncode") { + $kid->sibling->name eq "anoncode") { return "sub " . $self->deparse_sub($self->padval($kid->sibling->targ)); - } elsif ($kid->ppaddr eq "pp_pushmark") { - my $sib_ppaddr = $kid->sibling->ppaddr; - if ($sib_ppaddr =~ /^pp_(pad|rv2)[ah]v$/ + } elsif ($kid->name eq "pushmark") { + my $sib_name = $kid->sibling->name; + if ($sib_name =~ /^(pad|rv2)[ah]v$/ and not $kid->sibling->flags & OPf_REF) { # The @a in \(@a) isn't in ref context, but only when the # parens are there. return "\\(" . $self->deparse($kid->sibling, 1) . ")"; - } elsif ($sib_ppaddr eq 'pp_entersub') { + } elsif ($sib_name eq 'entersub') { my $text = $self->deparse($kid->sibling, 1); # Always show parens for \(&func()), but only with -p otherwise $text = "($text)" if $self->{'parens'} @@ -1036,7 +1037,7 @@ sub pp_readline { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh> + $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> return "<" . $self->deparse($kid, 1) . ">"; } @@ -1132,13 +1133,13 @@ my(%left, %right); sub assoc_class { my $op = shift; - my $name = $op->ppaddr; - if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") { + my $name = $op->name; + if ($name eq "concat" and $op->first->name eq "concat") { # avoid spurious `=' -- see comment in pp_concat - return "pp_concat"; + return "concat"; } - if ($name eq "pp_null" and class($op) eq "UNOP" - and $op->first->ppaddr =~ /^pp_(and|x?or)$/ + if ($name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|x?or)$/ and null $op->first->sibling) { # Like all conditional constructs, OP_ANDs and OP_ORs are topped @@ -1155,18 +1156,18 @@ sub assoc_class { # $a + $b + $c is equivalent to ($a + $b) + $c BEGIN { - %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19, - 'pp_divide' => 19, 'pp_i_divide' => 19, - 'pp_modulo' => 19, 'pp_i_modulo' => 19, - 'pp_repeat' => 19, - 'pp_add' => 18, 'pp_i_add' => 18, - 'pp_subtract' => 18, 'pp_i_subtract' => 18, - 'pp_concat' => 18, - 'pp_left_shift' => 17, 'pp_right_shift' => 17, - 'pp_bit_and' => 13, - 'pp_bit_or' => 12, 'pp_bit_xor' => 12, - 'pp_and' => 3, - 'pp_or' => 2, 'pp_xor' => 2, + %left = ('multiply' => 19, 'i_multiply' => 19, + 'divide' => 19, 'i_divide' => 19, + 'modulo' => 19, 'i_modulo' => 19, + 'repeat' => 19, + 'add' => 18, 'i_add' => 18, + 'subtract' => 18, 'i_subtract' => 18, + 'concat' => 18, + 'left_shift' => 17, 'right_shift' => 17, + 'bit_and' => 13, + 'bit_or' => 12, 'bit_xor' => 12, + 'and' => 3, + 'or' => 2, 'xor' => 2, ); } @@ -1186,20 +1187,20 @@ sub deparse_binop_left { # $a = $b = $c is equivalent to $a = ($b = $c) BEGIN { - %right = ('pp_pow' => 22, - 'pp_sassign=' => 7, 'pp_aassign=' => 7, - 'pp_multiply=' => 7, 'pp_i_multiply=' => 7, - 'pp_divide=' => 7, 'pp_i_divide=' => 7, - 'pp_modulo=' => 7, 'pp_i_modulo=' => 7, - 'pp_repeat=' => 7, - 'pp_add=' => 7, 'pp_i_add=' => 7, - 'pp_subtract=' => 7, 'pp_i_subtract=' => 7, - 'pp_concat=' => 7, - 'pp_left_shift=' => 7, 'pp_right_shift=' => 7, - 'pp_bit_and=' => 7, - 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7, - 'pp_andassign' => 7, - 'pp_orassign' => 7, + %right = ('pow' => 22, + 'sassign=' => 7, 'aassign=' => 7, + 'multiply=' => 7, 'i_multiply=' => 7, + 'divide=' => 7, 'i_divide=' => 7, + 'modulo=' => 7, 'i_modulo=' => 7, + 'repeat=' => 7, + 'add=' => 7, 'i_add=' => 7, + 'subtract=' => 7, 'i_subtract=' => 7, + 'concat=' => 7, + 'left_shift=' => 7, 'right_shift=' => 7, + 'bit_and=' => 7, + 'bit_or=' => 7, 'bit_xor=' => 7, + 'andassign' => 7, + 'orassign' => 7, ); } @@ -1287,7 +1288,7 @@ sub pp_concat { my $right = $op->last; my $eq = ""; my $prec = 18; - if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") { + if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { $eq = "="; $prec = 7; } @@ -1589,15 +1590,15 @@ sub pp_list { # This assumes that no other private flags equal 128, and that # OPs that store things other than flags in their op_private, # like OP_AELEMFAST, won't be immediate children of a list. - unless ($lop->private & OPpLVAL_INTRO or $lop->ppaddr eq "pp_undef") + unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef") { $local = ""; # or not last; } - if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my() + if ($lop->name =~ /^pad[ash]v$/) { # my() ($local = "", last) if $local eq "local"; $local = "my"; - } elsif ($lop->ppaddr ne "pp_undef") { # local() + } elsif ($lop->name ne "undef") { # local() ($local = "", last) if $local eq "my"; $local = "local"; } @@ -1606,7 +1607,7 @@ sub pp_list { return $self->deparse($kid, $cx) if null $kid->sibling and not $local; for (; !null($kid); $kid = $kid->sibling) { if ($local) { - if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") { + if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { $lop = $kid->first; } else { $lop = $kid; @@ -1641,10 +1642,10 @@ sub pp_cond_expr { } $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif + if ($false->name eq "lineseq") { # braces w/o scope => elsif my $head = "if ($cond) {\n\t$true\n\b}"; my @elsifs; - while (!null($false) and $false->ppaddr eq "pp_lineseq") { + while (!null($false) and $false->name eq "lineseq") { my $newop = $false->first->sibling->first; my $newcond = $newop->first; my $newtrue = $newcond->sibling; @@ -1673,13 +1674,13 @@ sub pp_leaveloop { local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; - if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop + if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) } else { $bare = 1; } - } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach + } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; if ($enter->flags & OPf_STACKED @@ -1704,20 +1705,20 @@ sub pp_leaveloop { $var = "my " . $var; } } - } elsif ($var->ppaddr eq "pp_rv2gv") { + } elsif ($var->name eq "rv2gv") { $var = $self->pp_rv2sv($var, 1); - } elsif ($var->ppaddr eq "pp_gv") { + } elsif ($var->name eq "gv") { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER - } elsif ($kid->ppaddr eq "pp_null") { # while/until + } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"pp_and" => "while", "pp_or" => "until"} - ->{$kid->ppaddr}; + my $name = {"and" => "while", "or" => "until"} + ->{$kid->name}; $head = "$name (" . $self->deparse($kid->first, 1) . ") "; $kid = $kid->first->sibling; - } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty + } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } # The third-to-last kid is the continue block if the pointer used @@ -1782,20 +1783,20 @@ sub pp_null { if (class($op) eq "OP") { # old value is lost return $self->{'ex_const'} if $op->targ == OP_CONST; - } elsif ($op->first->ppaddr eq "pp_pushmark") { + } elsif ($op->first->name eq "pushmark") { return $self->pp_list($op, $cx); - } elsif ($op->first->ppaddr eq "pp_enter") { + } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { return $self->dquote($op); } elsif (!null($op->first->sibling) and - $op->first->sibling->ppaddr eq "pp_readline" and + $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 7) . " = " . $self->deparse($op->first->sibling, 7), $cx, 7); } elsif (!null($op->first->sibling) and - $op->first->sibling->ppaddr eq "pp_trans" and + $op->first->sibling->name eq "trans" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " . $self->deparse($op->first->sibling, 20), @@ -1887,7 +1888,7 @@ sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } sub pp_av2arylen { my $self = shift; my($op, $cx) = @_; - if ($op->first->ppaddr eq "pp_padav") { + if ($op->first->name eq "padav") { return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); } else { return $self->maybe_local($op, $cx, @@ -1902,7 +1903,7 @@ sub pp_rv2av { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - if ($kid->ppaddr eq "pp_const") { # constant list + if ($kid->name eq "const") { # constant list my $av = $kid->sv; return "(" . join(", ", map(const($_), $av->ARRAY)) . ")"; } else { @@ -1915,10 +1916,10 @@ sub elem { my $self = shift; my ($op, $cx, $left, $right, $padname) = @_; my($array, $idx) = ($op->first, $op->first->sibling); - unless ($array->ppaddr eq $padname) { # Maybe this has been fixed + unless ($array->name eq $padname) { # Maybe this has been fixed $array = $array->first; # skip rv2av (or ex-rv2av in _53+) } - if ($array->ppaddr eq $padname) { + if ($array->name eq $padname) { $array = $self->padany($array); } elsif (is_scope($array)) { # ${expr}[0] $array = "{" . $self->deparse($array, 0) . "}"; @@ -1927,7 +1928,7 @@ sub elem { } else { # $x[20][3]{hi} or expr->[20] my $arrow; - $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/; + $arrow = "->" if $array->name !~ /^[ah]elem$/; return $self->deparse($array, 24) . $arrow . $left . $self->deparse($idx, 1) . $right; } @@ -1935,15 +1936,15 @@ sub elem { return "\$" . $array . $left . $idx . $right; } -sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) } -sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) } +sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } +sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } sub pp_gelem { my $self = shift; my($op, $cx) = @_; my($glob, $part) = ($op->first, $op->last); $glob = $glob->first; # skip rv2gv - $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug + $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug my $scope = is_scope($glob); $glob = $self->deparse($glob, 0); $part = $self->deparse($part, 1); @@ -1963,16 +1964,16 @@ sub slice { } $array = $last; $array = $array->first - if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null"; + if $array->name eq $regname or $array->name eq "null"; if (is_scope($array)) { $array = "{" . $self->deparse($array, 0) . "}"; - } elsif ($array->ppaddr eq $padname) { + } elsif ($array->name eq $padname) { $array = $self->padany($array); } else { $array = $self->deparse($array, 24); } $kid = $op->first->sibling; # skip pushmark - if ($kid->ppaddr eq "pp_list") { + if ($kid->name eq "list") { $kid = $kid->first->sibling; # skip list, pushmark for (; !null $kid; $kid = $kid->sibling) { push @elems, $self->deparse($kid, 6); @@ -1985,9 +1986,9 @@ sub slice { } sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", - "pp_rv2av", "pp_padav")) } + "rv2av", "padav")) } sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", - "pp_rv2hv", "pp_padhv")) } + "rv2hv", "padhv")) } sub pp_lslice { my $self = shift; @@ -2015,7 +2016,7 @@ sub method { my($op, $cx) = @_; my $kid = $op->first->sibling; # skip pushmark my($meth, $obj, @exprs); - if ($kid->ppaddr eq "pp_list" and want_list $kid) { + if ($kid->name eq "list" and want_list $kid) { # When an indirect object isn't a bareword but the args are in # parens, the parens aren't part of the method syntax (the LLAFR # doesn't apply), but they make a list with OPf_PARENS set that @@ -2043,7 +2044,7 @@ sub method { $meth = $kid->first; } $obj = $self->deparse($obj, 24); - if ($meth->ppaddr eq "pp_const") { + if ($meth->name eq "const") { $meth = $meth->sv->PV; # needs to be bare } else { $meth = $self->deparse($meth, 1); @@ -2087,17 +2088,17 @@ sub check_proto { return "&"; } } elsif ($chr eq "&") { - if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) { + if ($arg->name =~ /^(s?refgen|undef)$/) { push @reals, $self->deparse($arg, 6); } else { return "&"; } } elsif ($chr eq "*") { - if ($arg->ppaddr =~ /^pp_s?refgen$/ - and $arg->first->first->ppaddr eq "pp_rv2gv") + if ($arg->name =~ /^s?refgen$/ + and $arg->first->first->name eq "rv2gv") { $real = $arg->first->first; # skip refgen, null - if ($real->first->ppaddr eq "pp_gv") { + if ($real->first->name eq "gv") { push @reals, $self->deparse($real, 6); } else { push @reals, $self->deparse($real->first, 6); @@ -2107,19 +2108,19 @@ sub check_proto { } } elsif (substr($chr, 0, 1) eq "\\") { $chr = substr($chr, 1); - if ($arg->ppaddr =~ /^pp_s?refgen$/ and + if ($arg->name =~ /^s?refgen$/ and !null($real = $arg->first) and ($chr eq "\$" && is_scalar($real->first) or ($chr eq "\@" - && $real->first->sibling->ppaddr - =~ /^pp_(rv2|pad)av$/) + && $real->first->sibling->name + =~ /^(rv2|pad)av$/) or ($chr eq "%" - && $real->first->sibling->ppaddr - =~ /^pp_(rv2|pad)hv$/) + && $real->first->sibling->name + =~ /^(rv2|pad)hv$/) #or ($chr eq "&" # This doesn't work - # && $real->first->ppaddr eq "pp_rv2cv") + # && $real->first->name eq "rv2cv") or ($chr eq "*" - && $real->first->ppaddr eq "pp_rv2gv"))) + && $real->first->name eq "rv2gv"))) { push @reals, $self->deparse($real, 6); } else { @@ -2155,7 +2156,7 @@ sub pp_entersub { if (is_scope($kid)) { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; - } elsif ($kid->first->ppaddr eq "pp_gv") { + } elsif ($kid->first->name eq "gv") { my $gv = $kid->first->gv; if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; @@ -2312,22 +2313,22 @@ sub pp_const { sub dq { my $self = shift; my $op = shift; - my $type = $op->ppaddr; - if ($type eq "pp_const") { + my $type = $op->name; + if ($type eq "const") { return uninterp(escape_str(unback($op->sv->PV))); - } elsif ($type eq "pp_concat") { + } elsif ($type eq "concat") { return $self->dq($op->first) . $self->dq($op->last); - } elsif ($type eq "pp_uc") { + } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_lc") { + } elsif ($type eq "lc") { return '\L' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_ucfirst") { + } elsif ($type eq "ucfirst") { return '\u' . $self->dq($op->first->sibling); - } elsif ($type eq "pp_lcfirst") { + } elsif ($type eq "lcfirst") { return '\l' . $self->dq($op->first->sibling); - } elsif ($type eq "pp_quotemeta") { + } elsif ($type eq "quotemeta") { return '\Q' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_join") { + } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); @@ -2600,22 +2601,22 @@ sub pp_trans { sub re_dq { my $self = shift; my $op = shift; - my $type = $op->ppaddr; - if ($type eq "pp_const") { + my $type = $op->name; + if ($type eq "const") { return uninterp($op->sv->PV); - } elsif ($type eq "pp_concat") { + } elsif ($type eq "concat") { return $self->re_dq($op->first) . $self->re_dq($op->last); - } elsif ($type eq "pp_uc") { + } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_lc") { + } elsif ($type eq "lc") { return '\L' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_ucfirst") { + } elsif ($type eq "ucfirst") { return '\u' . $self->re_dq($op->first->sibling); - } elsif ($type eq "pp_lcfirst") { + } elsif ($type eq "lcfirst") { return '\l' . $self->re_dq($op->first->sibling); - } elsif ($type eq "pp_quotemeta") { + } elsif ($type eq "quotemeta") { return '\Q' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_join") { + } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); @@ -2626,8 +2627,8 @@ sub pp_regcomp { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe"; - $kid = $kid->first if $kid->ppaddr eq "pp_regcreset"; + $kid = $kid->first if $kid->name eq "regcmaybe"; + $kid = $kid->first if $kid->name eq "regcreset"; return $self->re_dq($kid); } @@ -2725,7 +2726,7 @@ sub pp_subst { $kid = $kid->sibling; } else { $repl = $op->pmreplroot->first; # skip substcont - while ($repl->ppaddr eq "pp_entereval") { + while ($repl->name eq "entereval") { $repl = $repl->first; $flags .= "e"; } diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm index 9d3b80a..67abe3d 100644 --- a/ext/B/B/Lint.pm +++ b/ext/B/B/Lint.pm @@ -129,8 +129,8 @@ my %check; my %implies_ok_context; BEGIN { map($implies_ok_context{$_}++, - qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice - pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete)); + qw(scalar av2arylen aelem aslice helem hslice + keys values hslice defined undef delete)); } # Lint checks turned on by default @@ -171,7 +171,7 @@ sub B::OP::lint {} sub B::COP::lint { my $op = shift; - if ($op->ppaddr eq "pp_nextstate") { + if ($op->name eq "nextstate") { $file = $op->filegv->SV->PV; $line = $op->line; $curstash = $op->stash->NAME; @@ -180,24 +180,24 @@ sub B::COP::lint { sub B::UNOP::lint { my $op = shift; - my $ppaddr = $op->ppaddr; - if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) { + my $opname = $op->name; + if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { my $parent = parents->[0]; - my $pname = $parent->ppaddr; + my $pname = $parent->name; return if gimme($op) || $implies_ok_context{$pname}; # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" # null out the parent so we have to check for a parent of pp_null and # a grandparent of pp_enteriter or pp_delete - if ($pname eq "pp_null") { - my $gpname = parents->[1]->ppaddr; - return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete"; + if ($pname eq "null") { + my $gpname = parents->[1]->name; + return if $gpname eq "enteriter" || $gpname eq "delete"; } warning("Implicit scalar context for %s in %s", - $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc); + $opname eq "rv2av" ? "array" : "hash", $parent->desc); } - if ($check{private_names} && $ppaddr eq "pp_method") { + if ($check{private_names} && $opname eq "method") { my $methop = $op->first; - if ($methop->ppaddr eq "pp_const") { + if ($methop->name eq "const") { my $method = $methop->sv->PV; if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { warning("Illegal reference to private method name $method"); @@ -209,14 +209,12 @@ sub B::UNOP::lint { sub B::PMOP::lint { my $op = shift; if ($check{implicit_read}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) { + if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { warning('Implicit match on $_'); } } if ($check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) { + if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { warning('Implicit substitution on $_'); } } @@ -225,10 +223,9 @@ sub B::PMOP::lint { sub B::LOOP::lint { my $op = shift; if ($check{implicit_read} || $check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_enteriter") { + if ($op->name eq "enteriter") { my $last = $op->last; - if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") { + if ($last->name eq "gv" && $last->gv->NAME eq "_") { warning('Implicit use of $_ in foreach'); } } @@ -237,22 +234,24 @@ sub B::LOOP::lint { sub B::GVOP::lint { my $op = shift; - if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv" + if ($check{dollar_underscore} && $op->name eq "gvsv" && $op->gv->NAME eq "_") { warning('Use of $_'); } if ($check{private_names}) { - my $ppaddr = $op->ppaddr; + my $opname = $op->name; my $gv = $op->gv; - if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv") + if (($opname eq "gv" || $opname eq "gvsv") && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { warning('Illegal reference to private name %s', $gv->NAME); } } if ($check{undefined_subs}) { - if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") { + if ($op->name eq "gv" + && $op->next->name eq "entersub") + { my $gv = $op->gv; my $subname = $gv->STASH->NAME . "::" . $gv->NAME; no strict 'refs'; @@ -262,7 +261,7 @@ sub B::GVOP::lint { } } } - if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") { + if ($check{regexp_variables} && $op->name eq "gvsv") { my $name = $op->gv->NAME; if ($name =~ /^[&'`]$/) { warning('Use of regexp variable $%s', $name); diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm index 16f25ff..06159a4 100644 --- a/ext/B/B/Xref.pm +++ b/ext/B/B/Xref.pm @@ -153,23 +153,24 @@ sub xref { last if $done{$$op}++; warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; warn peekop($op), "\n" if $debug_op; - my $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|range|cond_expr)$/) { + my $opname = $op->name; + if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { xref($op->other); - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($opname eq "match" || $opname eq "subst") { xref($op->pmreplstart); - } elsif ($ppname eq "pp_substcont") { + } elsif ($opname eq "substcont") { xref($op->other->pmreplstart); $op = $op->other; redo; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($opname eq "enterloop") { xref($op->redoop); xref($op->nextop); xref($op->lastop); - } elsif ($ppname eq "pp_subst") { + } elsif ($opname eq "subst") { xref($op->pmreplstart); } else { no strict 'refs'; + my $ppname = "pp_$opname"; &$ppname($op) if defined(&$ppname); } } diff --git a/opcode.h b/opcode.h index da4a8fe..01a36a0 100644 --- a/opcode.h +++ b/opcode.h @@ -2147,7 +2147,7 @@ EXT U32 PL_opargs[] = { 0x0004281d, /* syscall */ 0x00003604, /* lock */ 0x00000044, /* threadsv */ - 0x00000000, /* setstate */ + 0x00001404, /* setstate */ }; #endif diff --git a/opcode.pl b/opcode.pl index 4804554..f2b876d 100755 --- a/opcode.pl +++ b/opcode.pl @@ -780,4 +780,4 @@ lock lock ck_rfun s% S threadsv per-thread variable ck_null ds0 # Control (contd.) -setstate set statement info ck_null 0 +setstate set statement info ck_null s; -- 2.7.4