This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove compiler files from their old lib/B locations. The compiler
authorMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Fri, 20 Feb 1998 18:23:47 +0000 (18:23 +0000)
committerMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Fri, 20 Feb 1998 18:23:47 +0000 (18:23 +0000)
now builds by default (without the byteperl executable so far) and
seems to work at least minimally.

p4raw-id: //depot/perl@565

22 files changed:
MANIFEST
bytecode.pl
lib/B.pm [deleted file]
lib/B/Asmdata.pm [deleted file]
lib/B/Assembler.pm [deleted file]
lib/B/Bblock.pm [deleted file]
lib/B/Bytecode.pm [deleted file]
lib/B/C.pm [deleted file]
lib/B/CC.pm [deleted file]
lib/B/Debug.pm [deleted file]
lib/B/Deparse.pm [deleted file]
lib/B/Disassembler.pm [deleted file]
lib/B/Lint.pm [deleted file]
lib/B/Showlex.pm [deleted file]
lib/B/Stackobj.pm [deleted file]
lib/B/Terse.pm [deleted file]
lib/B/Xref.pm [deleted file]
lib/B/assemble [deleted file]
lib/B/cc_harness [deleted file]
lib/B/disassemble [deleted file]
lib/B/makeliblinks [deleted file]
lib/O.pm [deleted file]

index 7d2920b..a0e0dd5 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -32,7 +32,9 @@ XSUB.h                        Include file for extension subroutines
 av.c                   Array value code
 av.h                   Array value header
 bytecode.h             Bytecode header for compiler
-bytecode.pl            Produces byterun.h, byterun.c and lib/B/Asmdata.pm
+bytecode.pl            Produces byterun.h, byterun.c and ext/B/Asmdata.pm
+byterun.c              Runtime support for compiler-generated bytecode
+byterun.h              Header for byterun.c
 cc_runtime.h           Macros need by runtime of compiler-generated code
 cflags.SH              A script that emits C compilation flags per file
 compat3.sym            List of symbols for binary-compatibility with 5.003
@@ -123,9 +125,29 @@ emacs/ptags                Creates smart TAGS file
 embed.h                        Maps symbols to safer names
 embed.pl               Produces embed.h
 embedvar.h             C namespace management
+ext/B/B.pm             Compiler backend support functions and methods
 ext/B/B.xs             Compiler backend external subroutines
+ext/B/B/Asmdata.pm     Compiler backend data for assembler
+ext/B/B/Assembler.pm   Compiler backend assembler support functions
+ext/B/B/Bblock.pm      Compiler basic block analysis support
+ext/B/B/Bytecode.pm    Compiler Bytecode backend
+ext/B/B/C.pm           Compiler C backend
+ext/B/B/CC.pm          Compiler CC backend
+ext/B/B/Debug.pm       Compiler Debug backend
+ext/B/B/Deparse.pm     Compiler Deparse backend
+ext/B/B/Disassembler.pm        Compiler Disassembler backend
+ext/B/B/Lint.pm                Compiler Lint backend
+ext/B/B/Showlex.pm     Compiler Showlex backend
+ext/B/B/Stackobj.pm    Compiler stack objects support functions
+ext/B/B/Terse.pm       Compiler Terse backend
+ext/B/B/Xref.pm                Compiler Xref backend
+ext/B/B/assemble       Assemble compiler bytecode
+ext/B/B/cc_harness     Simplistic wrapper for using -MO=CC compiler
+ext/B/B/disassemble    Disassemble compiler bytecode output
+ext/B/B/makeliblinks   Make a simplistic XSUB .so symlink tree for compiler
 ext/B/Makefile.PL      Compiler backend makefile writer
 ext/B/NOTES            Compiler backend notes
+ext/B/O.pm             Compiler front-end module (-MO=...)
 ext/B/README           Compiler backend README
 ext/B/TESTS            Compiler backend test data
 ext/B/Todo             Compiler backend Todo list
@@ -368,11 +390,6 @@ keywords.pl                Program to write keywords.h
 lib/AnyDBM_File.pm     Perl module to emulate dbmopen
 lib/AutoLoader.pm      Autoloader base class
 lib/AutoSplit.pm       Split up autoload functions
-lib/B.pm               Compiler backend support functions and methods
-lib/B/assemble         Assemble compiler bytecode
-lib/B/cc_harness       Simplistic wrapper for using -MO=CC compiler
-lib/B/disassemble      Disassemble compiler bytecode output
-lib/B/makeliblinks     Make a simplistic XSUB .so symlink tree for compiler
 lib/Benchmark.pm       Measure execution time
 lib/Bundle/CPAN.pm     The CPAN bundle
 lib/CGI.pm             Web server interface ("Common Gateway Interface")
@@ -433,7 +450,6 @@ lib/Net/hostent.pm  By-name interface to Perl's builtin gethost*
 lib/Net/netent.pm      By-name interface to Perl's builtin getnet*
 lib/Net/protoent.pm    By-name interface to Perl's builtin getproto*
 lib/Net/servent.pm     By-name interface to Perl's builtin getserv*
-lib/O.pm               Compiler front-end module (-MO=...)
 lib/Pod/Functions.pm   used by pod/splitpod
 lib/Pod/Html.pm                Convert POD data to HTML
 lib/Pod/Text.pm                Convert POD data to formatted ASCII text
index 7fa3fe4..8eadbdd 100644 (file)
@@ -34,12 +34,12 @@ EOT
 my $perl_header;
 ($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g;
 
-unlink "byterun.c", "byterun.h", "lib/B/Asmdata.pm";
+unlink "byterun.c", "byterun.h", "ext/B/Asmdata.pm";
 
 #
 # Start with boilerplate for Asmdata.pm
 #
-open(ASMDATA_PM, ">lib/B/Asmdata.pm") or die "Asmdata.pm: $!";
+open(ASMDATA_PM, ">ext/B/Asmdata.pm") or die "Asmdata.pm: $!";
 print ASMDATA_PM $perl_header, <<'EOT';
 package B::Asmdata;
 use Exporter;
diff --git a/lib/B.pm b/lib/B.pm
deleted file mode 100644 (file)
index 8545c5c..0000000
--- a/lib/B.pm
+++ /dev/null
@@ -1,271 +0,0 @@
-#      B.pm
-#
-#      Copyright (c) 1996, 1997 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
-package B;
-require DynaLoader;
-require Exporter;
-@ISA = qw(Exporter DynaLoader);
-@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
-               class peekop cast_I32 cstring cchar hash threadsv_names
-               main_root main_start main_cv svref_2object
-               walkoptree walkoptree_slow walkoptree_exec walksymtable
-               parents comppadlist sv_undef compile_stats timing_info);
-
-use strict;
-@B::SV::ISA = 'B::OBJECT';
-@B::NULL::ISA = 'B::SV';
-@B::PV::ISA = 'B::SV';
-@B::IV::ISA = 'B::SV';
-@B::NV::ISA = 'B::IV';
-@B::RV::ISA = 'B::SV';
-@B::PVIV::ISA = qw(B::PV B::IV);
-@B::PVNV::ISA = qw(B::PV B::NV);
-@B::PVMG::ISA = 'B::PVNV';
-@B::PVLV::ISA = 'B::PVMG';
-@B::BM::ISA = 'B::PVMG';
-@B::AV::ISA = 'B::PVMG';
-@B::GV::ISA = 'B::PVMG';
-@B::HV::ISA = 'B::PVMG';
-@B::CV::ISA = 'B::PVMG';
-@B::IO::ISA = 'B::CV';
-
-@B::OP::ISA = 'B::OBJECT';
-@B::UNOP::ISA = 'B::OP';
-@B::BINOP::ISA = 'B::UNOP';
-@B::LOGOP::ISA = 'B::UNOP';
-@B::CONDOP::ISA = 'B::UNOP';
-@B::LISTOP::ISA = 'B::BINOP';
-@B::SVOP::ISA = 'B::OP';
-@B::GVOP::ISA = 'B::OP';
-@B::PVOP::ISA = 'B::OP';
-@B::CVOP::ISA = 'B::OP';
-@B::LOOP::ISA = 'B::LISTOP';
-@B::PMOP::ISA = 'B::LISTOP';
-@B::COP::ISA = 'B::OP';
-
-@B::SPECIAL::ISA = 'B::OBJECT';
-
-{
-    # Stop "-w" from complaining about the lack of a real B::OBJECT class
-    package B::OBJECT;
-}
-
-my $debug;
-my $op_count = 0;
-my @parents = ();
-
-sub debug {
-    my ($class, $value) = @_;
-    $debug = $value;
-    walkoptree_debug($value);
-}
-
-# sub OPf_KIDS;
-# add to .xs for perl5.002
-sub OPf_KIDS () { 4 }
-
-sub class {
-    my $obj = shift;
-    my $name = ref $obj;
-    $name =~ s/^.*:://;
-    return $name;
-}
-
-sub parents { \@parents }
-
-# For debugging
-sub peekop {
-    my $op = shift;
-    return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
-}
-
-sub walkoptree_slow {
-    my($op, $method, $level) = @_;
-    $op_count++; # just for statistics
-    $level ||= 0;
-    warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
-    $op->$method($level);
-    if ($$op && ($op->flags & OPf_KIDS)) {
-       my $kid;
-       unshift(@parents, $op);
-       for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
-           walkoptree_slow($kid, $method, $level + 1);
-       }
-       shift @parents;
-    }
-}
-
-sub compile_stats {
-    return "Total number of OPs processed: $op_count\n";
-}
-
-sub timing_info {
-    my ($sec, $min, $hr) = localtime;
-    my ($user, $sys) = times;
-    sprintf("%02d:%02d:%02d user=$user sys=$sys",
-           $hr, $min, $sec, $user, $sys);
-}
-
-my %symtable;
-sub savesym {
-    my ($obj, $value) = @_;
-#    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
-    $symtable{sprintf("sym_%x", $$obj)} = $value;
-}
-
-sub objsym {
-    my $obj = shift;
-    return $symtable{sprintf("sym_%x", $$obj)};
-}
-
-sub walkoptree_exec {
-    my ($op, $method, $level) = @_;
-    my ($sym, $ppname);
-    my $prefix = "    " x $level;
-    for (; $$op; $op = $op->next) {
-       $sym = objsym($op);
-       if (defined($sym)) {
-           print $prefix, "goto $sym\n";
-           return;
-       }
-       savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
-       $op->$method($level);
-       $ppname = $op->ppaddr;
-       if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
-           print $prefix, uc($1), " => {\n";
-           walkoptree_exec($op->other, $method, $level + 1);
-           print $prefix, "}\n";
-       } elsif ($ppname eq "pp_match" || $ppname eq "pp_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") {
-           print $prefix, "SUBSTCONT => {\n";
-           walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
-           print $prefix, "}\n";
-           $op = $op->other;
-       } elsif ($ppname eq "pp_cond_expr") {
-           # pp_cond_expr never returns op_next
-           print $prefix, "TRUE => {\n";
-           walkoptree_exec($op->true, $method, $level + 1);
-           print $prefix, "}\n";
-           $op = $op->false;
-           redo;
-       } elsif ($ppname eq "pp_range") {
-           print $prefix, "TRUE => {\n";
-           walkoptree_exec($op->true, $method, $level + 1);
-           print $prefix, "}\n", $prefix, "FALSE => {\n";
-           walkoptree_exec($op->false, $method, $level + 1);
-           print $prefix, "}\n";
-       } elsif ($ppname eq "pp_enterloop") {
-           print $prefix, "REDO => {\n";
-           walkoptree_exec($op->redoop, $method, $level + 1);
-           print $prefix, "}\n", $prefix, "NEXT => {\n";
-           walkoptree_exec($op->nextop, $method, $level + 1);
-           print $prefix, "}\n", $prefix, "LAST => {\n";
-           walkoptree_exec($op->lastop,  $method, $level + 1);
-           print $prefix, "}\n";
-       } elsif ($ppname eq "pp_subst") {
-           my $replstart = $op->pmreplstart;
-           if ($$replstart) {
-               print $prefix, "SUBST => {\n";
-               walkoptree_exec($replstart, $method, $level + 1);
-               print $prefix, "}\n";
-           }
-       }
-    }
-}
-
-sub walksymtable {
-    my ($symref, $method, $recurse, $prefix) = @_;
-    my $sym;
-    no strict 'vars';
-    local(*glob);
-    while (($sym, *glob) = each %$symref) {
-       if ($sym =~ /::$/) {
-           $sym = $prefix . $sym;
-           if ($sym ne "main::" && &$recurse($sym)) {
-               walksymtable(\%glob, $method, $recurse, $sym);
-           }
-       } else {
-           svref_2object(\*glob)->EGV->$method();
-       }
-    }
-}
-
-{
-    package B::Section;
-    my $output_fh;
-    my %sections;
-    
-    sub new {
-       my ($class, $section, $symtable, $default) = @_;
-       $output_fh ||= FileHandle->new_tmpfile;
-       my $obj = bless [-1, $section, $symtable, $default], $class;
-       $sections{$section} = $obj;
-       return $obj;
-    }
-    
-    sub get {
-       my ($class, $section) = @_;
-       return $sections{$section};
-    }
-
-    sub add {
-       my $section = shift;
-       while (defined($_ = shift)) {
-           print $output_fh "$section->[1]\t$_\n";
-           $section->[0]++;
-       }
-    }
-
-    sub index {
-       my $section = shift;
-       return $section->[0];
-    }
-
-    sub name {
-       my $section = shift;
-       return $section->[1];
-    }
-
-    sub symtable {
-       my $section = shift;
-       return $section->[2];
-    }
-       
-    sub default {
-       my $section = shift;
-       return $section->[3];
-    }
-       
-    sub output {
-       my ($section, $fh, $format) = @_;
-       my $name = $section->name;
-       my $sym = $section->symtable || {};
-       my $default = $section->default;
-
-       seek($output_fh, 0, 0);
-       while (<$output_fh>) {
-           chomp;
-           s/^(.*?)\t//;
-           if ($1 eq $name) {
-               s{(s\\_[0-9a-f]+)} {
-                   exists($sym->{$1}) ? $sym->{$1} : $default;
-               }ge;
-               printf $fh $format, $_;
-           }
-       }
-    }
-}
-
-bootstrap B;
-
-1;
diff --git a/lib/B/Asmdata.pm b/lib/B/Asmdata.pm
deleted file mode 100644 (file)
index 3a3cf6d..0000000
+++ /dev/null
@@ -1,150 +0,0 @@
-#
-#      Copyright (c) 1996, 1997 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
-#
-#
-# This file is autogenerated from bytecode.pl. Changes made here will be lost.
-#
-package B::Asmdata;
-use Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
-use vars qw(%insn_data @insn_name @optype @specialsv_name);
-
-@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
-@specialsv_name = qw(Nullsv &sv_undef &sv_yes &sv_no);
-
-# XXX insn_data is initialised this way because with a large
-# %insn_data = (foo => [...], bar => [...], ...) initialiser
-# I get a hard-to-track-down stack underflow and segfault.
-$insn_data{comment} = [35, \&PUT_comment, "GET_comment"];
-$insn_data{nop} = [10, \&PUT_none, "GET_none"];
-$insn_data{ret} = [0, \&PUT_none, "GET_none"];
-$insn_data{ldsv} = [1, \&PUT_objindex, "GET_objindex"];
-$insn_data{ldop} = [2, \&PUT_objindex, "GET_objindex"];
-$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
-$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
-$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"];
-$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"];
-$insn_data{newop} = [7, \&PUT_U8, "GET_U8"];
-$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"];
-$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"];
-$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"];
-$insn_data{pv_free} = [12, \&PUT_none, "GET_none"];
-$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"];
-$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"];
-$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"];
-$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"];
-$insn_data{xrv} = [17, \&PUT_objindex, "GET_objindex"];
-$insn_data{xpv} = [18, \&PUT_none, "GET_none"];
-$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"];
-$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"];
-$insn_data{xnv} = [21, \&PUT_double, "GET_double"];
-$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"];
-$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"];
-$insn_data{xlv_targ} = [24, \&PUT_objindex, "GET_objindex"];
-$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"];
-$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"];
-$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"];
-$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"];
-$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"];
-$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"];
-$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"];
-$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"];
-$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"];
-$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{xio_top_gv} = [36, \&PUT_objindex, "GET_objindex"];
-$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{xio_fmt_gv} = [38, \&PUT_objindex, "GET_objindex"];
-$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{xio_bottom_gv} = [40, \&PUT_objindex, "GET_objindex"];
-$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"];
-$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"];
-$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"];
-$insn_data{xcv_stash} = [44, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_start} = [45, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_root} = [46, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_gv} = [47, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_filegv} = [48, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"];
-$insn_data{xcv_padlist} = [50, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_outside} = [51, \&PUT_objindex, "GET_objindex"];
-$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"];
-$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"];
-$insn_data{av_push} = [54, \&PUT_objindex, "GET_objindex"];
-$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"];
-$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"];
-$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"];
-$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"];
-$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{hv_store} = [60, \&PUT_objindex, "GET_objindex"];
-$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"];
-$insn_data{mg_obj} = [62, \&PUT_objindex, "GET_objindex"];
-$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"];
-$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"];
-$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{xmg_stash} = [66, \&PUT_objindex, "GET_objindex"];
-$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"];
-$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"];
-$insn_data{gp_sv} = [69, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"];
-$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"];
-$insn_data{gp_av} = [72, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_hv} = [73, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_cv} = [74, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_filegv} = [75, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_io} = [76, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_form} = [77, \&PUT_objindex, "GET_objindex"];
-$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"];
-$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"];
-$insn_data{gp_share} = [80, \&PUT_objindex, "GET_objindex"];
-$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"];
-$insn_data{op_next} = [82, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_sibling} = [83, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"];
-$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"];
-$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"];
-$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"];
-$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"];
-$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"];
-$insn_data{op_first} = [90, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_last} = [91, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_other} = [92, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_true} = [93, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_false} = [94, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"];
-$insn_data{op_pmreplroot} = [96, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_pmreplrootgv} = [97, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_pmreplstart} = [98, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_pmnext} = [99, \&PUT_objindex, "GET_objindex"];
-$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"];
-$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"];
-$insn_data{op_sv} = [103, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_gv} = [104, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"];
-$insn_data{op_redoop} = [107, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_nextop} = [108, \&PUT_objindex, "GET_objindex"];
-$insn_data{op_lastop} = [109, \&PUT_objindex, "GET_objindex"];
-$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{cop_stash} = [111, \&PUT_objindex, "GET_objindex"];
-$insn_data{cop_filegv} = [112, \&PUT_objindex, "GET_objindex"];
-$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"];
-$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"];
-$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"];
-$insn_data{main_start} = [116, \&PUT_objindex, "GET_objindex"];
-$insn_data{main_root} = [117, \&PUT_objindex, "GET_objindex"];
-$insn_data{curpad} = [118, \&PUT_objindex, "GET_objindex"];
-
-my ($insn_name, $insn_data);
-while (($insn_name, $insn_data) = each %insn_data) {
-    $insn_name[$insn_data->[0]] = $insn_name;
-}
-# Fill in any gaps
-@insn_name = map($_ || "unused", @insn_name);
-
-1;
diff --git a/lib/B/Assembler.pm b/lib/B/Assembler.pm
deleted file mode 100644 (file)
index 0729b90..0000000
+++ /dev/null
@@ -1,207 +0,0 @@
-#      Assembler.pm
-#
-#      Copyright (c) 1996 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-package B::Assembler;
-use Exporter;
-use B qw(ppname);
-use B::Asmdata qw(%insn_data @insn_name);
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
-               parse_statement uncstring);
-
-use strict;
-my %opnumber;
-my ($i, $opname);
-for ($i = 0; defined($opname = ppname($i)); $i++) {
-    $opnumber{$opname} = $i;
-}
-
-my ($linenum, $errors);
-
-sub error {
-    my $str = shift;
-    warn "$linenum: $str\n";
-    $errors++;
-}
-
-my $debug = 0;
-sub debug { $debug = shift }
-
-#
-# First define all the data conversion subs to which Asmdata will refer
-#
-
-sub B::Asmdata::PUT_U8 {
-    my $arg = shift;
-    my $c = uncstring($arg);
-    if (defined($c)) {
-       if (length($c) != 1) {
-           error "argument for U8 is too long: $c";
-           $c = substr($c, 0, 1);
-       }
-    } else {
-       $c = chr($arg);
-    }
-    return $c;
-}
-
-sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
-sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
-sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
-sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
-
-sub B::Asmdata::PUT_strconst {
-    my $arg = shift;
-    $arg = uncstring($arg);
-    if (!defined($arg)) {
-       error "bad string constant: $arg";
-       return "";
-    }
-    if ($arg =~ s/\0//g) {
-       error "string constant argument contains NUL: $arg";
-    }
-    return $arg . "\0";
-}
-
-sub B::Asmdata::PUT_pvcontents {
-    my $arg = shift;
-    error "extraneous argument: $arg" if defined $arg;
-    return "";
-}
-sub B::Asmdata::PUT_PV {
-    my $arg = shift;
-    $arg = uncstring($arg);
-    error "bad string argument: $arg" unless defined($arg);
-    return pack("N", length($arg)) . $arg;
-}
-sub B::Asmdata::PUT_comment {
-    my $arg = shift;
-    $arg = uncstring($arg);
-    error "bad string argument: $arg" unless defined($arg);
-    if ($arg =~ s/\n//g) {
-       error "comment argument contains linefeed: $arg";
-    }
-    return $arg . "\n";
-}
-sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
-sub B::Asmdata::PUT_none {
-    my $arg = shift;
-    error "extraneous argument: $arg" if defined $arg;
-    return "";
-}
-sub B::Asmdata::PUT_op_tr_array {
-    my $arg = shift;
-    my @ary = split(/\s*,\s*/, $arg);
-    if (@ary != 256) {
-       error "wrong number of arguments to op_tr_array";
-       @ary = (0) x 256;
-    }
-    return pack("n256", @ary);
-}
-# XXX Check this works
-sub B::Asmdata::PUT_IV64 {
-    my $arg = shift;
-    return pack("NN", $arg >> 32, $arg & 0xffffffff);
-}
-
-my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
-            b => "\b", f => "\f", v => "\013");
-
-sub uncstring {
-    my $s = shift;
-    $s =~ s/^"// and $s =~ s/"$// or return undef;
-    $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
-    return $s;
-}
-
-sub strip_comments {
-    my $stmt = shift;
-    # Comments only allowed in instructions which don't take string arguments
-    $stmt =~ s{
-       (?sx)   # Snazzy extended regexp coming up. Also, treat
-               # string as a single line so .* eats \n characters.
-       ^\s*    # Ignore leading whitespace
-       (
-         [^"]* # A double quote '"' indicates a string argument. If we
-               # find a double quote, the match fails and we strip nothing.
-       )
-       \s*\#   # Any amount of whitespace plus the comment marker...
-       .*$     # ...which carries on to end-of-string.
-    }{$1};     # Keep only the instruction and optional argument.
-    return $stmt;
-}
-
-sub parse_statement {
-    my $stmt = shift;
-    my ($insn, $arg) = $stmt =~ m{
-       (?sx)
-       ^\s*    # allow (but ignore) leading whitespace
-       (.*?)   # Instruction continues up until...
-       (?:     # ...an optional whitespace+argument group
-           \s+         # first whitespace.
-           (.*)        # The argument is all the rest (newlines included).
-       )?$     # anchor at end-of-line
-    }; 
-    if (defined($arg)) {
-       if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
-           $arg = hex($arg);
-       } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
-           $arg = oct($arg);
-       } elsif ($arg =~ /^pp_/) {
-           $arg =~ s/\s*$//; # strip trailing whitespace
-           my $opnum = $opnumber{$arg};
-           if (defined($opnum)) {
-               $arg = $opnum;
-           } else {
-               error qq(No such op type "$arg");
-               $arg = 0;
-           }
-       }
-    }
-    return ($insn, $arg);
-}
-
-sub assemble_insn {
-    my ($insn, $arg) = @_;
-    my $data = $insn_data{$insn};
-    if (defined($data)) {
-       my ($bytecode, $putsub) = @{$data}[0, 1];
-       my $argcode = &$putsub($arg);
-       return chr($bytecode).$argcode;
-    } else {
-       error qq(no such instruction "$insn");
-       return "";
-    }
-}
-
-sub assemble_fh {
-    my ($fh, $out) = @_;
-    my ($line, $insn, $arg);
-    $linenum = 0;
-    $errors = 0;
-    while ($line = <$fh>) {
-       $linenum++;
-       chomp $line;
-       if ($debug) {
-           my $quotedline = $line;
-           $quotedline =~ s/\\/\\\\/g;
-           $quotedline =~ s/"/\\"/g;
-           &$out(assemble_insn("comment", qq("$quotedline")));
-       }
-       $line = strip_comments($line) or next;
-       ($insn, $arg) = parse_statement($line);
-       &$out(assemble_insn($insn, $arg));
-       if ($debug) {
-           &$out(assemble_insn("nop", undef));
-       }
-    }
-    if ($errors) {
-       die "Assembly failed with $errors error(s)\n";
-    }
-}
-
-1;
diff --git a/lib/B/Bblock.pm b/lib/B/Bblock.pm
deleted file mode 100644 (file)
index 125c8a3..0000000
+++ /dev/null
@@ -1,142 +0,0 @@
-package B::Bblock;
-use Exporter ();
-@ISA = "Exporter";
-@EXPORT_OK = qw(find_leaders);
-
-use B qw(peekop walkoptree walkoptree_exec
-        main_root main_start svref_2object);
-use B::Terse;
-use strict;
-
-my $bblock;
-my @bblock_ends;
-
-sub mark_leader {
-    my $op = shift;
-    if ($$op) {
-       $bblock->{$$op} = $op;
-    }
-}
-
-sub find_leaders {
-    my ($root, $start) = @_;
-    $bblock = {};
-    mark_leader($start);
-    walkoptree($root, "mark_if_leader");
-    return $bblock;
-}
-
-# Debugging
-sub walk_bblocks {
-    my ($root, $start) = @_;
-    my ($op, $lastop, $leader, $bb);
-    $bblock = {};
-    mark_leader($start);
-    walkoptree($root, "mark_if_leader");
-    my @leaders = values %$bblock;
-    while ($leader = shift @leaders) {
-       $lastop = $leader;
-       $op = $leader->next;
-       while ($$op && !exists($bblock->{$$op})) {
-           $bblock->{$$op} = $leader;
-           $lastop = $op;
-           $op = $op->next;
-       }
-       push(@bblock_ends, [$leader, $lastop]);
-    }
-    foreach $bb (@bblock_ends) {
-       ($leader, $lastop) = @$bb;
-       printf "%s .. %s\n", peekop($leader), peekop($lastop);
-       for ($op = $leader; $$op != $$lastop; $op = $op->next) {
-           printf "    %s\n", peekop($op);
-       }
-       printf "    %s\n", peekop($lastop);
-    }
-    print "-------\n";
-    walkoptree_exec($start, "terse");
-}
-
-sub walk_bblocks_obj {
-    my $cvref = shift;
-    my $cv = svref_2object($cvref);
-    walk_bblocks($cv->ROOT, $cv->START);
-}
-
-sub B::OP::mark_if_leader {}
-
-sub B::COP::mark_if_leader {
-    my $op = shift;
-    if ($op->label) {
-       mark_leader($op);
-    }
-}
-
-sub B::LOOP::mark_if_leader {
-    my $op = shift;
-    mark_leader($op->next);
-    mark_leader($op->nextop);
-    mark_leader($op->redoop);
-    mark_leader($op->lastop->next);
-}
-
-sub B::LOGOP::mark_if_leader {
-    my $op = shift;
-    my $ppaddr = $op->ppaddr;
-    mark_leader($op->next);
-    if ($ppaddr eq "pp_entertry") {
-       mark_leader($op->other->next);
-    } else {
-       mark_leader($op->other);
-    }
-}
-
-sub B::CONDOP::mark_if_leader {
-    my $op = shift;
-    mark_leader($op->next);
-    mark_leader($op->true);
-    mark_leader($op->false);
-}
-
-sub B::PMOP::mark_if_leader {
-    my $op = shift;
-    if ($op->ppaddr ne "pp_pushre") {
-       my $replroot = $op->pmreplroot;
-       if ($$replroot) {
-           mark_leader($replroot);
-           mark_leader($op->next);
-           mark_leader($op->pmreplstart);
-       }
-    }
-}
-
-# PMOP stuff omitted
-
-sub compile {
-    my @options = @_;
-    if (@options) {
-       return sub {
-           my $objname;
-           foreach $objname (@options) {
-               $objname = "main::$objname" unless $objname =~ /::/;
-               eval "walk_bblocks_obj(\\&$objname)";
-               die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
-           }
-       }
-    } else {
-       return sub { walk_bblocks(main_root, main_start) };
-    }
-}
-
-# Basic block leaders:
-#     Any COP (pp_nextstate) with a non-NULL label
-#     [The op after a pp_enter] Omit
-#     [The op after a pp_entersub. Don't count this one.]
-#     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
-#     The ops pointed at by op_next and op_other of a LOGOP, except
-#     for pp_entertry which has op_next and op_other->op_next
-#     The ops pointed at by op_true and op_false of a CONDOP
-#     The op pointed at by op_pmreplstart of a PMOP
-#     The op pointed at by op_other->op_pmreplstart of pp_substcont?
-#     [The op after a pp_return] Omit
-
-1;
diff --git a/lib/B/Bytecode.pm b/lib/B/Bytecode.pm
deleted file mode 100644 (file)
index 447bd37..0000000
+++ /dev/null
@@ -1,778 +0,0 @@
-#      Bytecode.pm
-#
-#      Copyright (c) 1996-1998 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
-package B::Bytecode;
-use strict;
-use Carp;
-use IO::File;
-
-use B qw(minus_c main_cv main_root main_start comppadlist
-        class peekop walkoptree svref_2object cstring walksymtable);
-use B::Asmdata qw(@optype @specialsv_name);
-use B::Assembler qw(assemble_fh);
-
-my %optype_enum;
-my $i;
-for ($i = 0; $i < @optype; $i++) {
-    $optype_enum{$optype[$i]} = $i;
-}
-
-# Following is SVf_POK|SVp_POK
-# XXX Shouldn't be hardwired
-sub POK () { 0x04040000 }
-
-# Following is SVf_IOK|SVp_OK
-# XXX Shouldn't be hardwired
-sub IOK () { 0x01010000 }
-
-my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
-my $assembler_pid;
-
-# Optimisation options. On the command line, use hyphens instead of
-# underscores for compatibility with gcc-style options. We use
-# underscores here because they are OK in (strict) barewords.
-my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
-my %optimise = (strip_syntax_tree      => \$strip_syntree,
-               compress_nullops        => \$compress_nullops,
-               omit_sequence_numbers   => \$omit_seq,
-               bypass_nullops          => \$bypass_nullops);
-
-my $nextix = 0;
-my %symtable;  # maps object addresses to object indices.
-               # Filled in at allocation (newsv/newop) time.
-my %saved;     # maps object addresses (for SVish classes) to "saved yet?"
-               # flag. Set at FOO::bytecode time usually by SV::bytecode.
-               # Manipulated via saved(), mark_saved(), unmark_saved().
-
-my $svix = -1; # we keep track of when the sv register contains an element
-               # of the object table to avoid unnecessary repeated
-               # consecutive ldsv instructions.
-my $opix = -1; # Ditto for the op register.
-
-sub ldsv {
-    my $ix = shift;
-    if ($ix != $svix) {
-       print "ldsv $ix\n";
-       $svix = $ix;
-    }
-}
-
-sub stsv {
-    my $ix = shift;
-    print "stsv $ix\n";
-    $svix = $ix;
-}
-
-sub set_svix {
-    $svix = shift;
-}
-
-sub ldop {
-    my $ix = shift;
-    if ($ix != $opix) {
-       print "ldop $ix\n";
-       $opix = $ix;
-    }
-}
-
-sub stop {
-    my $ix = shift;
-    print "stop $ix\n";
-    $opix = $ix;
-}
-
-sub set_opix {
-    $opix = shift;
-}
-
-sub pvstring {
-    my $str = shift;
-    if (defined($str)) {
-       return cstring($str . "\0");
-    } else {
-       return '""';
-    }
-}
-
-sub saved { $saved{${$_[0]}} }
-sub mark_saved { $saved{${$_[0]}} = 1 }
-sub unmark_saved { $saved{${$_[0]}} = 0 }
-
-sub debug { $debug_bc = shift }
-
-sub B::OBJECT::nyi {
-    my $obj = shift;
-    warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
-                class($obj), $$obj);
-}
-
-#
-# objix may stomp on the op register (for op objects)
-# or the sv register (for SV objects)
-#
-sub B::OBJECT::objix {
-    my $obj = shift;
-    my $ix = $symtable{$$obj};
-    if (defined($ix)) {
-       return $ix;
-    } else {
-       $obj->newix($nextix);
-       return $symtable{$$obj} = $nextix++;
-    }
-}
-
-sub B::SV::newix {
-    my ($sv, $ix) = @_;
-    printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
-    stsv($ix);    
-}
-
-sub B::GV::newix {
-    my ($gv, $ix) = @_;
-    my $gvname = $gv->NAME;
-    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
-    print "gv_fetchpv $name\n";
-    stsv($ix);
-}
-
-sub B::HV::newix {
-    my ($hv, $ix) = @_;
-    my $name = $hv->NAME;
-    if ($name) {
-       # It's a stash
-       printf "gv_stashpv %s\n", cstring($name);
-       stsv($ix);
-    } else {
-       # It's an ordinary HV. Fall back to ordinary newix method
-       $hv->B::SV::newix($ix);
-    }
-}
-
-sub B::SPECIAL::newix {
-    my ($sv, $ix) = @_;
-    # Special case. $$sv is not the address of the SV but an
-    # index into svspecialsv_list.
-    printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
-    stsv($ix);
-}
-
-sub B::OP::newix {
-    my ($op, $ix) = @_;
-    my $class = class($op);
-    my $typenum = $optype_enum{$class};
-    croak "OP::newix: can't understand class $class" unless defined($typenum);
-    print "newop $typenum\t# $class\n";
-    stop($ix);
-}
-
-sub B::OP::walkoptree_debug {
-    my $op = shift;
-    warn(sprintf("walkoptree: %s\n", peekop($op)));
-}
-
-sub B::OP::bytecode {
-    my $op = shift;
-    my $next = $op->next;
-    my $nextix;
-    my $sibix = $op->sibling->objix;
-    my $ix = $op->objix;
-    my $type = $op->type;
-
-    if ($bypass_nullops) {
-       $next = $next->next while $$next && $next->type == 0;
-    }
-    $nextix = $next->objix;
-
-    printf "# %s\n", peekop($op) if $debug_bc;
-    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_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",
-           $op->targ, $op->flags, $op->private;
-    }
-}
-
-sub B::UNOP::bytecode {
-    my $op = shift;
-    my $firstix = $op->first->objix;
-    $op->B::OP::bytecode;
-    if (($op->type || !$compress_nullops) && !$strip_syntree) {
-       print "op_first $firstix\n";
-    }
-}
-
-sub B::LOGOP::bytecode {
-    my $op = shift;
-    my $otherix = $op->other->objix;
-    $op->B::UNOP::bytecode;
-    print "op_other $otherix\n";
-}
-
-sub B::SVOP::bytecode {
-    my $op = shift;
-    my $sv = $op->sv;
-    my $svix = $sv->objix;
-    $op->B::OP::bytecode;
-    print "op_sv $svix\n";
-    $sv->bytecode;
-}
-
-sub B::GVOP::bytecode {
-    my $op = shift;
-    my $gv = $op->gv;
-    my $gvix = $gv->objix;
-    $op->B::OP::bytecode;
-    print "op_gv $gvix\n";
-    $gv->bytecode;
-}
-
-sub B::PVOP::bytecode {
-    my $op = shift;
-    my $pv = $op->pv;
-    $op->B::OP::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") {
-       my @shorts = unpack("s256", $pv); # assembler handles endianness
-       print "op_pv_tr ", join(",", @shorts), "\n";
-    } else {
-       printf "newpv %s\nop_pv\n", pvstring($pv);
-    }
-}
-
-sub B::BINOP::bytecode {
-    my $op = shift;
-    my $lastix = $op->last->objix;
-    $op->B::UNOP::bytecode;
-    if (($op->type || !$compress_nullops) && !$strip_syntree) {
-       print "op_last $lastix\n";
-    }
-}
-
-sub B::CONDOP::bytecode {
-    my $op = shift;
-    my $trueix = $op->true->objix;
-    my $falseix = $op->false->objix;
-    $op->B::UNOP::bytecode;
-    print "op_true $trueix\nop_false $falseix\n";
-}
-
-sub B::LISTOP::bytecode {
-    my $op = shift;
-    my $children = $op->children;
-    $op->B::BINOP::bytecode;
-    if (($op->type || !$compress_nullops) && !$strip_syntree) {
-       print "op_children $children\n";
-    }
-}
-
-sub B::LOOP::bytecode {
-    my $op = shift;
-    my $redoopix = $op->redoop->objix;
-    my $nextopix = $op->nextop->objix;
-    my $lastopix = $op->lastop->objix;
-    $op->B::LISTOP::bytecode;
-    print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
-}
-
-sub B::COP::bytecode {
-    my $op = shift;
-    my $stash = $op->stash;
-    my $stashix = $stash->objix;
-    my $filegv = $op->filegv;
-    my $filegvix = $filegv->objix;
-    my $line = $op->line;
-    if ($debug_bc) {
-       printf "# line %s:%d\n", $filegv->SV->PV, $line;
-    }
-    $op->B::OP::bytecode;
-    printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
-newpv %s
-cop_label
-cop_stash $stashix
-cop_seq %d
-cop_filegv $filegvix
-cop_arybase %d
-cop_line $line
-EOT
-    $filegv->bytecode;
-    $stash->bytecode;
-}
-
-sub B::PMOP::bytecode {
-    my $op = shift;
-    my $replroot = $op->pmreplroot;
-    my $replrootix = $replroot->objix;
-    my $replstartix = $op->pmreplstart->objix;
-    my $ppaddr = $op->ppaddr;
-    # pmnext is corrupt in some PMOPs (see misc.t for example)
-    #my $pmnextix = $op->pmnext->objix;
-
-    if ($$replroot) {
-       # 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") {
-           $replroot->bytecode;
-       } else {
-           walkoptree($replroot, "bytecode");
-       }
-    }
-    $op->B::LISTOP::bytecode;
-    if ($ppaddr eq "pp_pushre") {
-       printf "op_pmreplrootgv $replrootix\n";
-    } else {
-       print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
-    }
-    my $re = pvstring($op->precomp);
-    # op_pmnext omitted since a perl bug means it's sometime corrupt
-    printf <<"EOT", $op->pmflags, $op->pmpermflags;
-op_pmflags 0x%x
-op_pmpermflags 0x%x
-newpv $re
-pregcomp
-EOT
-}
-
-sub B::SV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $ix = $sv->objix;
-    my $refcnt = $sv->REFCNT;
-    my $flags = sprintf("0x%x", $sv->FLAGS);
-    ldsv($ix);
-    print "sv_refcnt $refcnt\nsv_flags $flags\n";
-    mark_saved($sv);
-}
-
-sub B::PV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    $sv->B::SV::bytecode;
-    printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
-}
-
-sub B::IV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $iv = $sv->IVX;
-    $sv->B::SV::bytecode;
-    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
-}
-
-sub B::NV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    $sv->B::SV::bytecode;
-    printf "xnv %s\n", $sv->NVX;
-}
-
-sub B::RV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $rv = $sv->RV;
-    my $rvix = $rv->objix;
-    $rv->bytecode;
-    $sv->B::SV::bytecode;
-    print "xrv $rvix\n";
-}
-
-sub B::PVIV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $iv = $sv->IVX;
-    $sv->B::PV::bytecode;
-    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
-}
-
-sub B::PVNV::bytecode {
-    my ($sv, $flag) = @_;
-    # The $flag argument is passed through PVMG::bytecode by BM::bytecode
-    # and AV::bytecode and indicates special handling. $flag = 1 is used by
-    # BM::bytecode and means that we should ensure we save the whole B-M
-    # table. It consists of 257 bytes (256 char array plus a final \0)
-    # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
-    # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
-    # call SV::bytecode instead of saving PV and calling NV::bytecode since
-    # PV/NV/IV stuff is different for AVs.
-    return if saved($sv);
-    if ($flag == 2) {
-       $sv->B::SV::bytecode;
-    } else {
-       my $pv = $sv->PV;
-       $sv->B::IV::bytecode;
-       printf "xnv %s\n", $sv->NVX;
-       if ($flag == 1) {
-           $pv .= "\0" . $sv->TABLE;
-           printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
-       } else {
-           printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
-       }
-    }
-}
-
-sub B::PVMG::bytecode {
-    my ($sv, $flag) = @_;
-    # See B::PVNV::bytecode for an explanation of $flag.
-    return if saved($sv);
-    # XXX We assume SvSTASH is already saved and don't save it later ourselves
-    my $stashix = $sv->SvSTASH->objix;
-    my @mgchain = $sv->MAGIC;
-    my (@mgobjix, $mg);
-    #
-    # We need to traverse the magic chain and get objix for each OBJ
-    # field *before* we do B::PVNV::bytecode since objix overwrites
-    # the sv register. However, we need to write the magic-saving
-    # bytecode *after* B::PVNV::bytecode since sv isn't initialised
-    # to refer to $sv until then.
-    #
-    @mgobjix = map($_->OBJ->objix, @mgchain);
-    $sv->B::PVNV::bytecode($flag);
-    print "xmg_stash $stashix\n";
-    foreach $mg (@mgchain) {
-       printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
-           cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
-    }
-}
-
-sub B::PVLV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    $sv->B::PVMG::bytecode;
-    printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
-xlv_targoff %d
-xlv_targlen %d
-xlv_type %s
-EOT
-}
-
-sub B::BM::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    # See PVNV::bytecode for an explanation of what the argument does
-    $sv->B::PVMG::bytecode(1);
-    printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
-       $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
-}
-
-sub B::GV::bytecode {
-    my $gv = shift;
-    return if saved($gv);
-    my $ix = $gv->objix;
-    mark_saved($gv);
-    my $gvname = $gv->NAME;
-    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
-    my $egv = $gv->EGV;
-    my $egvix = $egv->objix;
-    ldsv($ix);
-    printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
-sv_flags 0x%x
-xgv_flags 0x%x
-gp_line %d
-EOT
-    my $refcnt = $gv->REFCNT;
-    printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
-    my $gvrefcnt = $gv->GvREFCNT;
-    printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
-    if ($gvrefcnt > 1 &&  $ix != $egvix) {
-       print "gp_share $egvix\n";
-    } else {
-       if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
-           my $i;
-           my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
-           my @subfields = map($gv->$_(), @subfield_names);
-           my @ixes = map($_->objix, @subfields);
-           # Reset sv register for $gv
-           ldsv($ix);
-           for ($i = 0; $i < @ixes; $i++) {
-               printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
-           }
-           # Now save all the subfields
-           my $sv;
-           foreach $sv (@subfields) {
-               $sv->bytecode;
-           }
-       }
-    }
-}
-
-sub B::HV::bytecode {
-    my $hv = shift;
-    return if saved($hv);
-    mark_saved($hv);
-    my $name = $hv->NAME;
-    my $ix = $hv->objix;
-    if (!$name) {
-       # It's an ordinary HV. Stashes have NAME set and need no further
-       # saving beyond the gv_stashpv that $hv->objix already ensures.
-       my @contents = $hv->ARRAY;
-       my ($i, @ixes);
-       for ($i = 1; $i < @contents; $i += 2) {
-           push(@ixes, $contents[$i]->objix);
-       }
-       for ($i = 1; $i < @contents; $i += 2) {
-           $contents[$i]->bytecode;
-       }
-       ldsv($ix);
-       for ($i = 0; $i < @contents; $i += 2) {
-           printf("newpv %s\nhv_store %d\n",
-                  pvstring($contents[$i]), $ixes[$i / 2]);
-       }
-       printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
-    }
-}
-
-sub B::AV::bytecode {
-    my $av = shift;
-    return if saved($av);
-    my $ix = $av->objix;
-    my $fill = $av->FILL;
-    my $max = $av->MAX;
-    my (@array, @ixes);
-    if ($fill > -1) {
-       @array = $av->ARRAY;
-       @ixes = map($_->objix, @array);
-       my $sv;
-       foreach $sv (@array) {
-           $sv->bytecode;
-       }
-    }
-    # See PVNV::bytecode for the meaning of the flag argument of 2.
-    $av->B::PVMG::bytecode(2);
-    # Recover sv register and set AvMAX and AvFILL to -1 (since we
-    # create an AV with NEWSV and SvUPGRADE rather than doing newAV
-    # which is what sets AvMAX and AvFILL.
-    ldsv($ix);
-    printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
-    if ($fill > -1) {
-       my $elix;
-       foreach $elix (@ixes) {
-           print "av_push $elix\n";
-       }
-    } else {
-       if ($max > -1) {
-           print "av_extend $max\n";
-       }
-    }
-}
-
-sub B::CV::bytecode {
-    my $cv = shift;
-    return if saved($cv);
-    my $ix = $cv->objix;
-    $cv->B::PVMG::bytecode;
-    my $i;
-    my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
-    my @subfields = map($cv->$_(), @subfield_names);
-    my @ixes = map($_->objix, @subfields);
-    # Save OP tree from CvROOT (first element of @subfields)
-    my $root = shift @subfields;
-    if ($$root) {
-       walkoptree($root, "bytecode");
-    }
-    # Reset sv register for $cv (since above ->objix calls stomped on it)
-    ldsv($ix);
-    for ($i = 0; $i < @ixes; $i++) {
-       printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
-    }
-    printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
-    # Now save all the subfields (except for CvROOT which was handled
-    # above) and CvSTART (now the initial element of @subfields).
-    shift @subfields; # bye-bye CvSTART
-    my $sv;
-    foreach $sv (@subfields) {
-       $sv->bytecode;
-    }
-}
-
-sub B::IO::bytecode {
-    my $io = shift;
-    return if saved($io);
-    my $ix = $io->objix;
-    my $top_gv = $io->TOP_GV;
-    my $top_gvix = $top_gv->objix;
-    my $fmt_gv = $io->FMT_GV;
-    my $fmt_gvix = $fmt_gv->objix;
-    my $bottom_gv = $io->BOTTOM_GV;
-    my $bottom_gvix = $bottom_gv->objix;
-
-    $io->B::PVMG::bytecode;
-    ldsv($ix);
-    print "xio_top_gv $top_gvix\n";
-    print "xio_fmt_gv $fmt_gvix\n";
-    print "xio_bottom_gv $bottom_gvix\n";
-    my $field;
-    foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
-       printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
-    }
-    foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
-       printf "xio_%s %d\n", lc($field), $io->$field();
-    }
-    printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
-    $top_gv->bytecode;
-    $fmt_gv->bytecode;
-    $bottom_gv->bytecode;
-}
-
-sub B::SPECIAL::bytecode {
-    # nothing extra needs doing
-}
-
-sub bytecompile_object {
-    my $sv;
-    foreach $sv (@_) {
-       svref_2object($sv)->bytecode;
-    }
-}
-
-sub B::GV::bytecodecv {
-    my $gv = shift;
-    my $cv = $gv->CV;
-    if ($$cv && !saved($cv)) {
-       if ($debug_cv) {
-           warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
-                        $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
-       }
-       $gv->bytecode;
-    }
-}
-
-sub bytecompile_main {
-    my $curpad = (comppadlist->ARRAY)[1];
-    my $curpadix = $curpad->objix;
-    $curpad->bytecode;
-    walkoptree(main_root, "bytecode");
-    warn "done main program, now walking symbol table\n" if $debug_bc;
-    my ($pack, %exclude);
-    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
-                     FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
-                     SelectSaver blib Cwd))
-    {
-       $exclude{$pack."::"} = 1;
-    }
-    no strict qw(vars refs);
-    walksymtable(\%{"main::"}, "bytecodecv", sub {
-       warn "considering $_[0]\n" if $debug_bc;
-       return !defined($exclude{$_[0]});
-    });
-    if (!$module_only) {
-       printf "main_root %d\n", main_root->objix;
-       printf "main_start %d\n", main_start->objix;
-       printf "curpad $curpadix\n";
-       # XXX Do min_intro_pending and max_intro_pending matter?
-    }
-}
-
-sub prepare_assemble {
-    my $newfh = IO::File->new_tmpfile;
-    select($newfh);
-    binmode $newfh;
-    return $newfh;
-}
-
-sub do_assemble {
-    my $fh = shift;
-    seek($fh, 0, 0); # rewind the temporary file
-    assemble_fh($fh, sub { print OUT @_ });
-}
-
-sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-    open(OUT, ">&STDOUT");
-    binmode OUT;
-    select(OUT);
-  OPTION:
-    while ($option = shift @options) {
-       if ($option =~ /^-(.)(.*)/) {
-           $opt = $1;
-           $arg = $2;
-       } else {
-           unshift @options, $option;
-           last OPTION;
-       }
-       if ($opt eq "-" && $arg eq "-") {
-           shift @options;
-           last OPTION;
-       } elsif ($opt eq "o") {
-           $arg ||= shift @options;
-           open(OUT, ">$arg") or return "$arg: $!\n";
-           binmode OUT;
-       } elsif ($opt eq "D") {
-           $arg ||= shift @options;
-           foreach $arg (split(//, $arg)) {
-               if ($arg eq "b") {
-                   $| = 1;
-                   debug(1);
-               } elsif ($arg eq "o") {
-                   B->debug(1);
-               } elsif ($arg eq "a") {
-                   B::Assembler::debug(1);
-               } elsif ($arg eq "C") {
-                   $debug_cv = 1;
-               }
-           }
-       } elsif ($opt eq "v") {
-           $verbose = 1;
-       } elsif ($opt eq "m") {
-           $module_only = 1;
-       } elsif ($opt eq "S") {
-           $no_assemble = 1;
-       } elsif ($opt eq "f") {
-           $arg ||= shift @options;
-           my $value = $arg !~ s/^no-//;
-           $arg =~ s/-/_/g;
-           my $ref = $optimise{$arg};
-           if (defined($ref)) {
-               $$ref = $value;
-           } else {
-               warn qq(ignoring unknown optimisation option "$arg"\n);
-           }
-       } elsif ($opt eq "O") {
-           $arg = 1 if $arg eq "";
-           my $ref;
-           foreach $ref (values %optimise) {
-               $$ref = 0;
-           }
-           if ($arg >= 6) {
-               $strip_syntree = 1;
-           }
-           if ($arg >= 2) {
-               $bypass_nullops = 1;
-           }
-           if ($arg >= 1) {
-               $compress_nullops = 1;
-               $omit_seq = 1;
-           }
-       }
-    }
-    if (@options) {
-       return sub {
-           my $objname;
-           my $newfh; 
-           $newfh = prepare_assemble() unless $no_assemble;
-           foreach $objname (@options) {
-               eval "bytecompile_object(\\$objname)";
-           }
-           do_assemble($newfh) unless $no_assemble;
-       }
-    } else {
-       return sub {
-           my $newfh; 
-           $newfh = prepare_assemble() unless $no_assemble;
-           bytecompile_main();
-           do_assemble($newfh) unless $no_assemble;
-       }
-    }
-}
-
-1;
diff --git a/lib/B/C.pm b/lib/B/C.pm
deleted file mode 100644 (file)
index 4158bc4..0000000
+++ /dev/null
@@ -1,1201 +0,0 @@
-#      C.pm
-#
-#      Copyright (c) 1996, 1997 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
-package B::C;
-use Exporter ();
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(output_all output_boilerplate output_main
-               init_sections set_callback save_unused_subs objsym);
-
-use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
-        class cstring cchar svref_2object compile_stats comppadlist hash
-        threadsv_names);
-use B::Asmdata qw(@specialsv_name);
-
-use FileHandle;
-use Carp;
-use strict;
-
-my $hv_index = 0;
-my $gv_index = 0;
-my $re_index = 0;
-my $pv_index = 0;
-my $anonsub_index = 0;
-
-my %symtable;
-my $warn_undefined_syms;
-my $verbose;
-my @unused_sub_packages;
-my $nullop_count;
-my $pv_copy_on_grow;
-my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
-
-my @threadsv_names;
-BEGIN {
-    @threadsv_names = threadsv_names();
-}
-
-# Code sections
-my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
-    $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
-    $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
-    $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
-    $xrvsect, $xpvbmsect, $xpviosect);
-
-sub walk_and_save_optree;
-my $saveoptree_callback = \&walk_and_save_optree;
-sub set_callback { $saveoptree_callback = shift }
-sub saveoptree { &$saveoptree_callback(@_) }
-
-sub walk_and_save_optree {
-    my ($name, $root, $start) = @_;
-    walkoptree($root, "save");
-    return objsym($start);
-}
-
-# Current workaround/fix for op_free() trying to free statically
-# defined OPs is to set op_seq = -1 and check for that in op_free().
-# Instead of hardwiring -1 in place of $op->seq, we use $op_seq
-# so that it can be changed back easily if necessary. In fact, to
-# stop compilers from moaning about a U16 being initialised with an
-# uncast -1 (the printf format is %d so we can't tweak it), we have
-# to "know" that op_seq is a U16 and use 65535. Ugh.
-my $op_seq = 65535;
-
-sub AVf_REAL () { 1 }
-
-# XXX This shouldn't really be hardcoded here but it saves
-# looking up the name of every BASEOP in B::OP
-sub OP_THREADSV () { 345 }
-
-sub savesym {
-    my ($obj, $value) = @_;
-    my $sym = sprintf("s\\_%x", $$obj);
-    $symtable{$sym} = $value;
-}
-
-sub objsym {
-    my $obj = shift;
-    return $symtable{sprintf("s\\_%x", $$obj)};
-}
-
-sub getsym {
-    my $sym = shift;
-    my $value;
-
-    return 0 if $sym eq "sym_0";       # special case
-    $value = $symtable{$sym};
-    if (defined($value)) {
-       return $value;
-    } else {
-       warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
-       return "UNUSED";
-    }
-}
-
-sub savepv {
-    my $pv = shift;
-    my $pvsym = 0;
-    my $pvmax = 0;
-    if ($pv_copy_on_grow) {
-       my $cstring = cstring($pv);
-       if ($cstring ne "0") { # sic
-           $pvsym = sprintf("pv%d", $pv_index++);
-           $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
-       }
-    } else {
-       $pvmax = length($pv) + 1;
-    }
-    return ($pvsym, $pvmax);
-}
-
-sub B::OP::save {
-    my ($op, $level) = @_;
-    my $type = $op->type;
-    $nullop_count++ unless $type;
-    if ($type == OP_THREADSV) {
-       # saves looking up ppaddr but it's a bit naughty to hard code this
-       $init->add(sprintf("(void)find_threadsv(%s);",
-                          cstring($threadsv_names[$op->targ])));
-    }
-    $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
-                        ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
-                        $type, $op_seq, $op->flags, $op->private));
-    savesym($op, sprintf("&op_list[%d]", $opsect->index));
-}
-
-sub B::FAKEOP::new {
-    my ($class, %objdata) = @_;
-    bless \%objdata, $class;
-}
-
-sub B::FAKEOP::save {
-    my ($op, $level) = @_;
-    $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
-                        $op->next, $op->sibling, $op->ppaddr, $op->targ,
-                        $op->type, $op_seq, $op->flags, $op->private));
-    return sprintf("&op_list[%d]", $opsect->index);
-}
-
-sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
-sub B::FAKEOP::type { $_[0]->{type} || 0}
-sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
-sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
-sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
-sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
-sub B::FAKEOP::private { $_[0]->{private} || 0 }
-
-sub B::UNOP::save {
-    my ($op, $level) = @_;
-    $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
-                          ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                          $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private, ${$op->first}));
-    savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
-}
-
-sub B::BINOP::save {
-    my ($op, $level) = @_;
-    $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
-                           ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                           $op->targ, $op->type, $op_seq, $op->flags,
-                           $op->private, ${$op->first}, ${$op->last}));
-    savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
-}
-
-sub B::LISTOP::save {
-    my ($op, $level) = @_;
-    $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
-                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                            $op->targ, $op->type, $op_seq, $op->flags,
-                            $op->private, ${$op->first}, ${$op->last},
-                            $op->children));
-    savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
-}
-
-sub B::LOGOP::save {
-    my ($op, $level) = @_;
-    $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
-                           ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                           $op->targ, $op->type, $op_seq, $op->flags,
-                           $op->private, ${$op->first}, ${$op->other}));
-    savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
-}
-
-sub B::CONDOP::save {
-    my ($op, $level) = @_;
-    $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
-                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                            $op->targ, $op->type, $op_seq, $op->flags,
-                            $op->private, ${$op->first}, ${$op->true},
-                            ${$op->false}));
-    savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
-}
-
-sub B::LOOP::save {
-    my ($op, $level) = @_;
-    #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
-    #           peekop($op->redoop), peekop($op->nextop),
-    #           peekop($op->lastop)); # debug
-    $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
-                          ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                          $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private, ${$op->first}, ${$op->last},
-                          $op->children, ${$op->redoop}, ${$op->nextop},
-                          ${$op->lastop}));
-    savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
-}
-
-sub B::PVOP::save {
-    my ($op, $level) = @_;
-    $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
-                          ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                          $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private, cstring($op->pv)));
-    savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
-}
-
-sub B::SVOP::save {
-    my ($op, $level) = @_;
-    my $svsym = $op->sv->save;
-    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
-                          ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                          $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private, "(SV*)$svsym"));
-    savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
-}
-
-sub B::GVOP::save {
-    my ($op, $level) = @_;
-    my $gvsym = $op->gv->save;
-    $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
-                          ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                          $op->targ, $op->type, $op_seq, $op->flags,
-                          $op->private));
-    $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
-    savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
-}
-
-sub B::COP::save {
-    my ($op, $level) = @_;
-    my $gvsym = $op->filegv->save;
-    my $stashsym = $op->stash->save;
-    warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
-       if $debug_cops;
-    $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
-                         ${$op->next}, ${$op->sibling}, $op->ppaddr,
-                         $op->targ, $op->type, $op_seq, $op->flags,
-                         $op->private, cstring($op->label), $op->cop_seq,
-                         $op->arybase, $op->line));
-    my $copix = $copsect->index;
-    $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
-              sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
-    savesym($op, "(OP*)&cop_list[$copix]");
-}
-
-sub B::PMOP::save {
-    my ($op, $level) = @_;
-    my $replroot = $op->pmreplroot;
-    my $replstart = $op->pmreplstart;
-    my $replrootfield = sprintf("s\\_%x", $$replroot);
-    my $replstartfield = sprintf("s\\_%x", $$replstart);
-    my $gvsym;
-    my $ppaddr = $op->ppaddr;
-    if ($$replroot) {
-       # 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") {
-           $gvsym = $replroot->save;
-#          warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
-           $replrootfield = 0;
-       } else {
-           $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
-       }
-    }
-    # pmnext handling is broken in perl itself, I think. Bad op_pmnext
-    # fields aren't noticed in perl's runtime (unless you try reset) but we
-    # segfault when trying to dereference it to find op->op_pmnext->op_type
-    $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
-                          ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
-                          $op->type, $op_seq, $op->flags, $op->private,
-                          ${$op->first}, ${$op->last}, $op->children,
-                          $replrootfield, $replstartfield,
-                          $op->pmflags, $op->pmpermflags,));
-    my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
-    my $re = $op->precomp;
-    if (defined($re)) {
-       my $resym = sprintf("re%d", $re_index++);
-       $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
-       $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
-                          length($re)));
-    }
-    if ($gvsym) {
-       $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
-    }
-    savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
-}
-
-sub B::SPECIAL::save {
-    my ($sv) = @_;
-    # special case: $$sv is not the address but an index into specialsv_list
-#   warn "SPECIAL::save specialsv $$sv\n"; # debug
-    my $sym = $specialsv_name[$$sv];
-    if (!defined($sym)) {
-       confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
-    }
-    return $sym;
-}
-
-sub B::OBJECT::save {}
-
-sub B::NULL::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-#   warn "Saving SVt_NULL SV\n"; # debug
-    # debug
-    #if ($$sv == 0) {
-    #  warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
-    #}
-    $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::IV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
-    $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
-                        $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::NV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
-    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
-                        $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVLV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    my $pv = $sv->PV;
-    my $len = length($pv);
-    my ($pvsym, $pvmax) = savepv($pv);
-    my ($lvtarg, $lvtarg_sym);
-    $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
-                           $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, 
-                           $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
-    $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
-                        $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
-       $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
-                          $xpvlvsect->index, cstring($pv), $len));
-    }
-    $sv->save_magic;
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVIV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    my $pv = $sv->PV;
-    my $len = length($pv);
-    my ($pvsym, $pvmax) = savepv($pv);
-    $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
-    $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
-                        $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
-       $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
-                          $xpvivsect->index, cstring($pv), $len));
-    }
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVNV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    my $pv = $sv->PV;
-    my $len = length($pv);
-    my ($pvsym, $pvmax) = savepv($pv);
-    $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
-                           $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
-    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
-                        $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
-       $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
-                          $xpvnvsect->index, cstring($pv), $len));
-    }
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::BM::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    my $pv = $sv->PV . "\0" . $sv->TABLE;
-    my $len = length($pv);
-    $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
-                           $len, $len + 258, $sv->IVX, $sv->NVX,
-                           $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
-    $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
-                        $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    $sv->save_magic;
-    $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
-                      $xpvbmsect->index, cstring($pv), $len),
-              sprintf("xpvbm_list[%d].xpv_cur = %u;",
-                      $xpvbmsect->index, $len - 257));
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    my $pv = $sv->PV;
-    my $len = length($pv);
-    my ($pvsym, $pvmax) = savepv($pv);
-    $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
-    $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
-                        $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
-       $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
-                          $xpvsect->index, cstring($pv), $len));
-    }
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVMG::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    my $pv = $sv->PV;
-    my $len = length($pv);
-    my ($pvsym, $pvmax) = savepv($pv);
-    $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
-                           $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
-    $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
-                        $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
-       $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
-                          $xpvmgsect->index, cstring($pv), $len));
-    }
-    $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-    $sv->save_magic;
-    return $sym;
-}
-
-sub B::PVMG::save_magic {
-    my ($sv) = @_;
-    #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
-    my $stash = $sv->SvSTASH;
-    if ($$stash) {
-       warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
-           if $debug_mg;
-       # XXX Hope stash is already going to be saved.
-       $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
-    }
-    my @mgchain = $sv->MAGIC;
-    my ($mg, $type, $obj, $ptr);
-    foreach $mg (@mgchain) {
-       $type = $mg->TYPE;
-       $obj = $mg->OBJ;
-       $ptr = $mg->PTR;
-       my $len = defined($ptr) ? length($ptr) : 0;
-       if ($debug_mg) {
-           warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
-                        class($sv), $$sv, class($obj), $$obj,
-                        cchar($type), cstring($ptr));
-       }
-       $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
-                          $$sv, $$obj, cchar($type),cstring($ptr),$len));
-    }
-}
-
-sub B::RV::save {
-    my ($sv) = @_;
-    my $sym = objsym($sv);
-    return $sym if defined $sym;
-    $xrvsect->add($sv->RV->save);
-    $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
-                        $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
-    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub try_autoload {
-    my ($cvstashname, $cvname) = @_;
-    warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
-    # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
-    # use should be handled by the class itself.
-    no strict 'refs';
-    my $isa = \@{"$cvstashname\::ISA"};
-    if (grep($_ eq "AutoLoader", @$isa)) {
-       warn "Forcing immediate load of sub derived from AutoLoader\n";
-       # Tweaked version of AutoLoader::AUTOLOAD
-       my $dir = $cvstashname;
-       $dir =~ s(::)(/)g;
-       eval { require "auto/$dir/$cvname.al" };
-       if ($@) {
-           warn qq(failed require "auto/$dir/$cvname.al": $@\n);
-           return 0;
-       } else {
-           return 1;
-       }
-    }
-}
-
-sub B::CV::save {
-    my ($cv) = @_;
-    my $sym = objsym($cv);
-    if (defined($sym)) {
-#      warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
-       return $sym;
-    }
-    # Reserve a place in svsect and xpvcvsect and record indices
-    my $sv_ix = $svsect->index + 1;
-    $svsect->add("svix$sv_ix");
-    my $xpvcv_ix = $xpvcvsect->index + 1;
-    $xpvcvsect->add("xpvcvix$xpvcv_ix");
-    # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
-    $sym = savesym($cv, "&sv_list[$sv_ix]");
-    warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
-    my $gv = $cv->GV;
-    my $cvstashname = $gv->STASH->NAME;
-    my $cvname = $gv->NAME;
-    my $root = $cv->ROOT;
-    my $cvxsub = $cv->XSUB;
-    if (!$$root && !$cvxsub) {
-       if (try_autoload($cvstashname, $cvname)) {
-           # Recalculate root and xsub
-           $root = $cv->ROOT;
-           $cvxsub = $cv->XSUB;
-           if ($$root || $cvxsub) {
-               warn "Successful forced autoload\n";
-           }
-       }
-    }
-    my $startfield = 0;
-    my $padlist = $cv->PADLIST;
-    my $pv = $cv->PV;
-    my $xsub = 0;
-    my $xsubany = "Nullany";
-    if ($$root) {
-       warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
-                    $$cv, $$root) if $debug_cv;
-       my $ppname = "";
-       if ($$gv) {
-           my $stashname = $gv->STASH->NAME;
-           my $gvname = $gv->NAME;
-           if ($gvname ne "__ANON__") {
-               $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
-               $ppname .= ($stashname eq "main") ?
-                           $gvname : "$stashname\::$gvname";
-               $ppname =~ s/::/__/g;
-           }
-       }
-       if (!$ppname) {
-           $ppname = "pp_anonsub_$anonsub_index";
-           $anonsub_index++;
-       }
-       $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
-       warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
-                    $$cv, $ppname, $$root) if $debug_cv;
-       if ($$padlist) {
-           warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
-                        $$padlist, $$cv) if $debug_cv;
-           $padlist->save;
-           warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
-                        $$padlist, $$cv) if $debug_cv;
-       }
-    }
-    elsif ($cvxsub) {
-       $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
-       # Try to find out canonical name of XSUB function from EGV.
-       # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
-       # calls newXS() manually with weird arguments).
-       my $egv = $gv->EGV;
-       my $stashname = $egv->STASH->NAME;
-       $stashname =~ s/::/__/g;
-       $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
-       $decl->add("void $xsub _((CV*));");
-    }
-    else {
-       warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
-                    $cvstashname, $cvname); # debug
-    }
-    $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0",
-                         $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
-                         $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
-                         $$padlist, ${$cv->OUTSIDE}));
-    if ($$gv) {
-       $gv->save;
-       $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
-       warn sprintf("done saving GV 0x%x for CV 0x%x\n",
-                    $$gv, $$cv) if $debug_cv;
-    }
-    my $filegv = $cv->FILEGV;
-    if ($$filegv) {
-       $filegv->save;
-       $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
-       warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
-                    $$filegv, $$cv) if $debug_cv;
-    }
-    my $stash = $cv->STASH;
-    if ($$stash) {
-       $stash->save;
-       $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
-       warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
-                    $$stash, $$cv) if $debug_cv;
-    }
-    $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
-                         $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
-    return $sym;
-}
-
-sub B::GV::save {
-    my ($gv) = @_;
-    my $sym = objsym($gv);
-    if (defined($sym)) {
-       #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
-       return $sym;
-    } else {
-       my $ix = $gv_index++;
-       $sym = savesym($gv, "gv_list[$ix]");
-       #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
-    }
-    my $gvname = $gv->NAME;
-    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
-    #warn "GV name is $name\n"; # debug
-    my $egv = $gv->EGV;
-    my $egvsym;
-    if ($$gv != $$egv) {
-       #warn(sprintf("EGV name is %s, saving it now\n",
-       #            $egv->STASH->NAME . "::" . $egv->NAME)); # debug
-       $egvsym = $egv->save;
-    }
-    $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
-              sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
-              sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
-              sprintf("GvLINE($sym) = %u;", $gv->LINE));
-    # Shouldn't need to do save_magic since gv_fetchpv handles that
-    #$gv->save_magic;
-    my $refcnt = $gv->REFCNT + 1;
-    $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
-    my $gvrefcnt = $gv->GvREFCNT;
-    if ($gvrefcnt > 1) {
-       $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
-    }
-    if (defined($egvsym)) {
-       # Shared glob *foo = *bar
-       $init->add("gp_free($sym);",
-                  "GvGP($sym) = GvGP($egvsym);");
-    } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
-       # Don't save subfields of special GVs (*_, *1, *# and so on)
-#      warn "GV::save saving subfields\n"; # debug
-       my $gvsv = $gv->SV;
-       if ($$gvsv) {
-           $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
-#          warn "GV::save \$$name\n"; # debug
-           $gvsv->save;
-       }
-       my $gvav = $gv->AV;
-       if ($$gvav) {
-           $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
-#          warn "GV::save \@$name\n"; # debug
-           $gvav->save;
-       }
-       my $gvhv = $gv->HV;
-       if ($$gvhv) {
-           $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
-#          warn "GV::save \%$name\n"; # debug
-           $gvhv->save;
-       }
-       my $gvcv = $gv->CV;
-       if ($$gvcv) {
-           $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
-#          warn "GV::save &$name\n"; # debug
-           $gvcv->save;
-       }
-       my $gvfilegv = $gv->FILEGV;
-       if ($$gvfilegv) {
-           $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv));
-#          warn "GV::save GvFILEGV(*$name)\n"; # debug
-           $gvfilegv->save;
-       }
-       my $gvform = $gv->FORM;
-       if ($$gvform) {
-           $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
-#          warn "GV::save GvFORM(*$name)\n"; # debug
-           $gvform->save;
-       }
-       my $gvio = $gv->IO;
-       if ($$gvio) {
-           $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
-#          warn "GV::save GvIO(*$name)\n"; # debug
-           $gvio->save;
-       }
-    }
-    return $sym;
-}
-sub B::AV::save {
-    my ($av) = @_;
-    my $sym = objsym($av);
-    return $sym if defined $sym;
-    my $avflags = $av->AvFLAGS;
-    $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
-                           $avflags));
-    $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
-                        $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
-    my $sv_list_index = $svsect->index;
-    my $fill = $av->FILL;
-    $av->save_magic;
-    warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
-       if $debug_av;
-    # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
-    #if ($fill > -1 && ($avflags & AVf_REAL)) {
-    if ($fill > -1) {
-       my @array = $av->ARRAY;
-       if ($debug_av) {
-           my $el;
-           my $i = 0;
-           foreach $el (@array) {
-               warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
-                            $$av, $i++, class($el), $$el);
-           }
-       }
-       my @names = map($_->save, @array);
-       # XXX Better ways to write loop?
-       # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
-       # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
-       $init->add("{",
-                  "\tSV **svp;",
-                  "\tAV *av = (AV*)&sv_list[$sv_list_index];",
-                  "\tav_extend(av, $fill);",
-                  "\tsvp = AvARRAY(av);",
-              map("\t*svp++ = (SV*)$_;", @names),
-                  "\tAvFILLp(av) = $fill;",
-                  "}");
-    } else {
-       my $max = $av->MAX;
-       $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
-           if $max > -1;
-    }
-    return savesym($av, "(AV*)&sv_list[$sv_list_index]");
-}
-
-sub B::HV::save {
-    my ($hv) = @_;
-    my $sym = objsym($hv);
-    return $sym if defined $sym;
-    my $name = $hv->NAME;
-    if ($name) {
-       # It's a stash
-
-       # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
-       # the only symptom is that sv_reset tries to reset the PMf_USED flag of
-       # a trashed op but we look at the trashed op_type and segfault.
-       #my $adpmroot = ${$hv->PMROOT};
-       my $adpmroot = 0;
-       $decl->add("static HV *hv$hv_index;");
-       # XXX Beware of weird package names containing double-quotes, \n, ...?
-       $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
-       if ($adpmroot) {
-           $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
-                              $adpmroot));
-       }
-       $sym = savesym($hv, "hv$hv_index");
-       $hv_index++;
-       return $sym;
-    }
-    # It's just an ordinary HV
-    $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
-                           $hv->MAX, $hv->RITER));
-    $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
-                        $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
-    my $sv_list_index = $svsect->index;
-    my @contents = $hv->ARRAY;
-    if (@contents) {
-       my $i;
-       for ($i = 1; $i < @contents; $i += 2) {
-           $contents[$i] = $contents[$i]->save;
-       }
-       $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
-       while (@contents) {
-           my ($key, $value) = splice(@contents, 0, 2);
-           $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
-                              cstring($key),length($key),$value, hash($key)));
-       }
-       $init->add("}");
-    }
-    return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
-}
-
-sub B::IO::save {
-    my ($io) = @_;
-    my $sym = objsym($io);
-    return $sym if defined $sym;
-    my $pv = $io->PV;
-    my $len = length($pv);
-    $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
-                           $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
-                           $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
-                           cstring($io->TOP_NAME), cstring($io->FMT_NAME), 
-                           cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
-                           cchar($io->IoTYPE), $io->IoFLAGS));
-    $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
-                        $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
-    $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
-    my ($field, $fsym);
-    foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
-       $fsym = $io->$field();
-       if ($$fsym) {
-           $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
-           $fsym->save;
-       }
-    }
-    $io->save_magic;
-    return $sym;
-}
-
-sub B::SV::save {
-    my $sv = shift;
-    # This is where we catch an honest-to-goodness Nullsv (which gets
-    # blessed into B::SV explicitly) and any stray erroneous SVs.
-    return 0 unless $$sv;
-    confess sprintf("cannot save that type of SV: %s (0x%x)\n",
-                   class($sv), $$sv);
-}
-
-sub output_all {
-    my $init_name = shift;
-    my $section;
-    my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
-                   $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
-                   $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
-                   $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
-                   $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
-    $symsect->output(\*STDOUT, "#define %s\n");
-    print "\n";
-    output_declarations();
-    foreach $section (@sections) {
-       my $lines = $section->index + 1;
-       if ($lines) {
-           my $name = $section->name;
-           my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
-           print "Static $typename ${name}_list[$lines];\n";
-       }
-    }
-    $decl->output(\*STDOUT, "%s\n");
-    print "\n";
-    foreach $section (@sections) {
-       my $lines = $section->index + 1;
-       if ($lines) {
-           my $name = $section->name;
-           my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
-           printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
-           $section->output(\*STDOUT, "\t{ %s },\n");
-           print "};\n\n";
-       }
-    }
-
-    print <<"EOT";
-static int $init_name()
-{
-       dTHR;
-EOT
-    $init->output(\*STDOUT, "\t%s\n");
-    print "\treturn 0;\n}\n";
-    if ($verbose) {
-       warn compile_stats();
-       warn "NULLOP count: $nullop_count\n";
-    }
-}
-
-sub output_declarations {
-    print <<'EOT';
-#ifdef BROKEN_STATIC_REDECL
-#define Static extern
-#else
-#define Static static
-#endif /* BROKEN_STATIC_REDECL */
-
-#ifdef BROKEN_UNION_INIT
-/*
- * Cribbed from cv.h with ANY (a union) replaced by void*.
- * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
- */
-typedef struct {
-    char *     xpv_pv;         /* pointer to malloced string */
-    STRLEN     xpv_cur;        /* length of xp_pv as a C string */
-    STRLEN     xpv_len;        /* allocated size */
-    IV         xof_off;        /* integer value */
-    double     xnv_nv;         /* numeric value, if any */
-    MAGIC*     xmg_magic;      /* magic for scalar array */
-    HV*                xmg_stash;      /* class package */
-
-    HV *       xcv_stash;
-    OP *       xcv_start;
-    OP *       xcv_root;
-    void      (*xcv_xsub) _((CV*));
-    void *     xcv_xsubany;
-    GV *       xcv_gv;
-    GV *       xcv_filegv;
-    long       xcv_depth;              /* >= 2 indicates recursive call */
-    AV *       xcv_padlist;
-    CV *       xcv_outside;
-#ifdef USE_THREADS
-    perl_mutex *xcv_mutexp;
-    struct perl_thread *xcv_owner;     /* current owner thread */
-#endif /* USE_THREADS */
-    U8         xcv_flags;
-} XPVCV_or_similar;
-#define ANYINIT(i) i
-#else
-#define XPVCV_or_similar XPVCV
-#define ANYINIT(i) {i}
-#endif /* BROKEN_UNION_INIT */
-#define Nullany ANYINIT(0)
-
-#define UNUSED 0
-#define sym_0 0
-
-EOT
-    print "static GV *gv_list[$gv_index];\n" if $gv_index;
-    print "\n";
-}
-
-
-sub output_boilerplate {
-    print <<'EOT';
-#include "EXTERN.h"
-#include "perl.h"
-#ifndef PATCHLEVEL
-#include "patchlevel.h"
-#endif
-
-/* Workaround for mapstart: the only op which needs a different ppaddr */
-#undef pp_mapstart
-#define pp_mapstart pp_grepstart
-
-static void xs_init _((void));
-static PerlInterpreter *my_perl;
-EOT
-}
-
-sub output_main {
-    print <<'EOT';
-int
-#ifndef CAN_PROTOTYPE
-main(argc, argv, env)
-int argc;
-char **argv;
-char **env;
-#else  /* def(CAN_PROTOTYPE) */
-main(int argc, char **argv, char **env)
-#endif  /* def(CAN_PROTOTYPE) */
-{
-    int exitstatus;
-    int i;
-    char **fakeargv;
-
-    PERL_SYS_INIT(&argc,&argv);
-    perl_init_i18nl10n(1);
-
-    if (!do_undump) {
-       my_perl = perl_alloc();
-       if (!my_perl)
-           exit(1);
-       perl_construct( my_perl );
-    }
-
-#ifdef CSH
-    if (!cshlen) 
-      cshlen = strlen(cshname);
-#endif
-
-#ifdef ALLOW_PERL_OPTIONS
-#define EXTRA_OPTIONS 2
-#else
-#define EXTRA_OPTIONS 3
-#endif /* ALLOW_PERL_OPTIONS */
-    New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
-    fakeargv[0] = argv[0];
-    fakeargv[1] = "-e";
-    fakeargv[2] = "";
-#ifndef ALLOW_PERL_OPTIONS
-    fakeargv[3] = "--";
-#endif /* ALLOW_PERL_OPTIONS */
-    for (i = 1; i < argc; i++)
-       fakeargv[i + EXTRA_OPTIONS] = argv[i];
-    fakeargv[argc + EXTRA_OPTIONS] = 0;
-    
-    exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
-                           fakeargv, NULL);
-    if (exitstatus)
-       exit( exitstatus );
-
-    sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
-    main_cv = compcv;
-    compcv = 0;
-
-    exitstatus = perl_init();
-    if (exitstatus)
-       exit( exitstatus );
-
-    exitstatus = perl_run( my_perl );
-
-    perl_destruct( my_perl );
-    perl_free( my_perl );
-
-    exit( exitstatus );
-}
-
-static void
-xs_init()
-{
-}
-EOT
-}
-
-sub dump_symtable {
-    # For debugging
-    my ($sym, $val);
-    warn "----Symbol table:\n";
-    while (($sym, $val) = each %symtable) {
-       warn "$sym => $val\n";
-    }
-    warn "---End of symbol table\n";
-}
-
-sub save_object {
-    my $sv;
-    foreach $sv (@_) {
-       svref_2object($sv)->save;
-    }
-}
-
-sub B::GV::savecv {
-    my $gv = shift;
-    my $cv = $gv->CV;
-    my $name = $gv->NAME;
-    if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
-       if ($debug_cv) {
-           warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
-                        $gv->STASH->NAME, $name, $$cv, $$gv);
-       }
-       $gv->save;
-    }
-}
-
-sub save_unused_subs {
-    my %search_pack;
-    map { $search_pack{$_} = 1 } @_;
-    no strict qw(vars refs);
-    walksymtable(\%{"main::"}, "savecv", sub {
-       my $package = shift;
-       $package =~ s/::$//;
-       #warn "Considering $package\n";#debug
-       return 1 if exists $search_pack{$package};
-       #warn "    (nothing explicit)\n";#debug
-       # Omit the packages which we use (and which cause grief
-       # because of fancy "goto &$AUTOLOAD" stuff).
-       # XXX Surely there must be a nicer way to do this.
-       if ($package eq "FileHandle"
-           || $package eq "Config"
-           || $package eq "SelectSaver") {
-           return 0;
-       }
-       my $m;
-       foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
-           if (defined(&{$package."::$m"})) {
-               warn "$package has method $m: -u$package assumed\n";#debug
-               return 1;
-           }
-       }
-       return 0;
-    });
-}
-
-sub save_main {
-    my $curpad_sym = (comppadlist->ARRAY)[1]->save;
-    walkoptree(main_root, "save");
-    warn "done main optree, walking symtable for extras\n" if $debug_cv;
-    save_unused_subs(@unused_sub_packages);
-
-    $init->add(sprintf("main_root = s\\_%x;", ${main_root()}),
-              sprintf("main_start = s\\_%x;", ${main_start()}),
-              "curpad = AvARRAY($curpad_sym);");
-    output_boilerplate();
-    print "\n";
-    output_all("perl_init");
-    print "\n";
-    output_main();
-}
-
-sub init_sections {
-    my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
-                   binop => \$binopsect, condop => \$condopsect,
-                   cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
-                   listop => \$listopsect, logop => \$logopsect,
-                   loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
-                   pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
-                   sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
-                   xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
-                   xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
-                   xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
-                   xrv => \$xrvsect, xpvbm => \$xpvbmsect,
-                   xpvio => \$xpviosect);
-    my ($name, $sectref);
-    while (($name, $sectref) = splice(@sections, 0, 2)) {
-       $$sectref = new B::Section $name, \%symtable, 0;
-    }
-}
-
-sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-  OPTION:
-    while ($option = shift @options) {
-       if ($option =~ /^-(.)(.*)/) {
-           $opt = $1;
-           $arg = $2;
-       } else {
-           unshift @options, $option;
-           last OPTION;
-       }
-       if ($opt eq "-" && $arg eq "-") {
-           shift @options;
-           last OPTION;
-       }
-       if ($opt eq "w") {
-           $warn_undefined_syms = 1;
-       } elsif ($opt eq "D") {
-           $arg ||= shift @options;
-           foreach $arg (split(//, $arg)) {
-               if ($arg eq "o") {
-                   B->debug(1);
-               } elsif ($arg eq "c") {
-                   $debug_cops = 1;
-               } elsif ($arg eq "A") {
-                   $debug_av = 1;
-               } elsif ($arg eq "C") {
-                   $debug_cv = 1;
-               } elsif ($arg eq "M") {
-                   $debug_mg = 1;
-               } else {
-                   warn "ignoring unknown debug option: $arg\n";
-               }
-           }
-       } elsif ($opt eq "o") {
-           $arg ||= shift @options;
-           open(STDOUT, ">$arg") or return "$arg: $!\n";
-       } elsif ($opt eq "v") {
-           $verbose = 1;
-       } elsif ($opt eq "u") {
-           $arg ||= shift @options;
-           push(@unused_sub_packages, $arg);
-       } elsif ($opt eq "f") {
-           $arg ||= shift @options;
-           if ($arg eq "cog") {
-               $pv_copy_on_grow = 1;
-           } elsif ($arg eq "no-cog") {
-               $pv_copy_on_grow = 0;
-           }
-       } elsif ($opt eq "O") {
-           $arg = 1 if $arg eq "";
-           $pv_copy_on_grow = 0;
-           if ($arg >= 1) {
-               # Optimisations for -O1
-               $pv_copy_on_grow = 1;
-           }
-       }
-    }
-    init_sections();
-    if (@options) {
-       return sub {
-           my $objname;
-           foreach $objname (@options) {
-               eval "save_object(\\$objname)";
-           }
-           output_all();
-       }
-    } else {
-       return sub { save_main() };
-    }
-}
-
-1;
diff --git a/lib/B/CC.pm b/lib/B/CC.pm
deleted file mode 100644 (file)
index fc7cf6d..0000000
+++ /dev/null
@@ -1,1528 +0,0 @@
-#      CC.pm
-#
-#      Copyright (c) 1996, 1997 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
-package B::CC;
-use strict;
-use B qw(main_start main_root class comppadlist peekop svref_2object
-       timing_info);
-use B::C qw(save_unused_subs objsym init_sections
-           output_all output_boilerplate output_main);
-use B::Bblock qw(find_leaders);
-use B::Stackobj qw(:types :flags);
-
-# These should probably be elsewhere
-# Flags for $op->flags
-sub OPf_LIST () { 1 }
-sub OPf_KNOW () { 2 }
-sub OPf_MOD () { 32 }
-sub OPf_STACKED () { 64 }
-sub OPf_SPECIAL () { 128 }
-# op-specific flags for $op->private 
-sub OPpASSIGN_BACKWARDS () { 64 }
-sub OPpLVAL_INTRO () { 128 }
-sub OPpDEREF_AV () { 32 }
-sub OPpDEREF_HV () { 64 }
-sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV }
-sub OPpFLIP_LINENUM () { 64 }
-sub G_ARRAY () { 1 }
-# cop.h
-sub CXt_NULL () { 0 }
-sub CXt_SUB () { 1 }
-sub CXt_EVAL () { 2 }
-sub CXt_LOOP () { 3 }
-sub CXt_SUBST () { 4 }
-sub CXt_BLOCK () { 5 }
-
-my $module;            # module name (when compiled with -m)
-my %done;              # hash keyed by $$op of leaders of basic blocks
-                       # which have already been done.
-my $leaders;           # ref to hash of basic block leaders. Keys are $$op
-                       # addresses, values are the $op objects themselves.
-my @bblock_todo;       # list of leaders of basic blocks that need visiting
-                       # sometime.
-my @cc_todo;           # list of tuples defining what PP code needs to be
-                       # saved (e.g. CV, main or PMOP repl code). Each tuple
-                       # is [$name, $root, $start, @padlist]. PMOP repl code
-                       # tuples inherit padlist.
-my @stack;             # shadows perl's stack when contents are known.
-                       # Values are objects derived from class B::Stackobj
-my @pad;               # Lexicals in current pad as Stackobj-derived objects
-my @padlist;           # Copy of current padlist so PMOP repl code can find it
-my @cxstack;           # Shadows the (compile-time) cxstack for next,last,redo
-my $jmpbuf_ix = 0;     # Next free index for dynamically allocated jmpbufs
-my %constobj;          # OP_CONST constants as Stackobj-derived objects
-                       # keyed by $$sv.
-my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
-                       # block or even to the end of each loop of blocks,
-                       # depending on optimisation options.
-my $know_op = 0;       # Set when C variable op already holds the right op
-                       # (from an immediately preceding DOOP(ppname)).
-my $errors = 0;                # Number of errors encountered
-my %skip_stack;                # Hash of PP names which don't need write_back_stack
-my %skip_lexicals;     # Hash of PP names which don't need write_back_lexicals
-my %skip_invalidate;   # Hash of PP names which don't need invalidate_lexicals
-my %ignore_op;         # Hash of ops which do nothing except returning op_next
-
-BEGIN {
-    foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
-       $ignore_op{$_} = 1;
-    }
-}
-
-my @unused_sub_packages; # list of packages (given by -u options) to search
-                        # explicitly and save every sub we find there, even
-                        # if apparently unused (could be only referenced from
-                        # an eval "" or from a $SIG{FOO} = "bar").
-
-my ($module_name);
-my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
-    $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
-
-# Optimisation options. On the command line, use hyphens instead of
-# underscores for compatibility with gcc-style options. We use
-# underscores here because they are OK in (strict) barewords.
-my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
-my %optimise = (freetmps_each_bblock   => \$freetmps_each_bblock,
-               freetmps_each_loop      => \$freetmps_each_loop,
-               omit_taint              => \$omit_taint);
-# perl patchlevel to generate code for (defaults to current patchlevel)
-my $patchlevel = int(0.5 + 1000 * ($]  - 5));
-
-# Could rewrite push_runtime() and output_runtime() to use a
-# temporary file if memory is at a premium.
-my $ppname;            # name of current fake PP function
-my $runtime_list_ref;
-my $declare_ref;       # Hash ref keyed by C variable type of declarations.
-
-my @pp_list;           # list of [$ppname, $runtime_list_ref, $declare_ref]
-                       # tuples to be written out.
-
-my ($init, $decl);
-
-sub init_hash { map { $_ => 1 } @_ }
-
-#
-# Initialise the hashes for the default PP functions where we can avoid
-# either write_back_stack, write_back_lexicals or invalidate_lexicals.
-#
-%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
-%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
-
-sub debug {
-    if ($debug_runtime) {
-       warn(@_);
-    } else {
-       runtime(map { chomp; "/* $_ */"} @_);
-    }
-}
-
-sub declare {
-    my ($type, $var) = @_;
-    push(@{$declare_ref->{$type}}, $var);
-}
-
-sub push_runtime {
-    push(@$runtime_list_ref, @_);
-    warn join("\n", @_) . "\n" if $debug_runtime;
-}
-
-sub save_runtime {
-    push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
-}
-
-sub output_runtime {
-    my $ppdata;
-    print qq(#include "cc_runtime.h"\n);
-    foreach $ppdata (@pp_list) {
-       my ($name, $runtime, $declare) = @$ppdata;
-       print "\nstatic\nPP($name)\n{\n";
-       my ($type, $varlist, $line);
-       while (($type, $varlist) = each %$declare) {
-           print "\t$type ", join(", ", @$varlist), ";\n";
-       }
-       foreach $line (@$runtime) {
-           print $line, "\n";
-       }
-       print "}\n";
-    }
-}
-
-sub runtime {
-    my $line;
-    foreach $line (@_) {
-       push_runtime("\t$line");
-    }
-}
-
-sub init_pp {
-    $ppname = shift;
-    $runtime_list_ref = [];
-    $declare_ref = {};
-    runtime("djSP;");
-    declare("I32", "oldsave");
-    declare("SV", "**svp");
-    map { declare("SV", "*$_") } qw(sv src dst left right);
-    declare("MAGIC", "*mg");
-    $decl->add("static OP * $ppname _((ARGSproto));");
-    debug "init_pp: $ppname\n" if $debug_queue;
-}
-
-# Initialise runtime_callback function for Stackobj class
-BEGIN { B::Stackobj::set_callback(\&runtime) }
-
-# Initialise saveoptree_callback for B::C class
-sub cc_queue {
-    my ($name, $root, $start, @pl) = @_;
-    debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
-       if $debug_queue;
-    if ($name eq "*ignore*") {
-       $name = 0;
-    } else {
-       push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
-    }
-    my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
-    $start = $fakeop->save;
-    debug "cc_queue: name $name returns $start\n" if $debug_queue;
-    return $start;
-}
-BEGIN { B::C::set_callback(\&cc_queue) }
-
-sub valid_int { $_[0]->{flags} & VALID_INT }
-sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
-sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
-sub valid_sv { $_[0]->{flags} & VALID_SV }
-
-sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
-sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
-sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
-sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
-sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
-
-sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
-sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
-sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
-sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
-sub pop_bool {
-    if (@stack) {
-       return ((pop @stack)->as_numeric);
-    } else {
-       # Careful: POPs has an auto-decrement and SvTRUE evaluates
-       # its argument more than once.
-       runtime("sv = POPs;");
-       return "SvTRUE(sv)";
-    }
-}
-
-sub write_back_lexicals {
-    my $avoid = shift || 0;
-    debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
-       if $debug_shadow;
-    my $lex;
-    foreach $lex (@pad) {
-       next unless ref($lex);
-       $lex->write_back unless $lex->{flags} & $avoid;
-    }
-}
-
-sub write_back_stack {
-    my $obj;
-    return unless @stack;
-    runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
-    foreach $obj (@stack) {
-       runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
-    }
-    @stack = ();
-}
-
-sub invalidate_lexicals {
-    my $avoid = shift || 0;
-    debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
-       if $debug_shadow;
-    my $lex;
-    foreach $lex (@pad) {
-       next unless ref($lex);
-       $lex->invalidate unless $lex->{flags} & $avoid;
-    }
-}
-
-sub reload_lexicals {
-    my $lex;
-    foreach $lex (@pad) {
-       next unless ref($lex);
-       my $type = $lex->{type};
-       if ($type == T_INT) {
-           $lex->as_int;
-       } elsif ($type == T_DOUBLE) {
-           $lex->as_double;
-       } else {
-           $lex->as_sv;
-       }
-    }
-}
-
-{
-    package B::Pseudoreg;
-    #
-    # This class allocates pseudo-registers (OK, so they're C variables).
-    #
-    my %alloc;         # Keyed by variable name. A value of 1 means the
-                       # variable has been declared. A value of 2 means
-                       # it's in use.
-    
-    sub new_scope { %alloc = () }
-    
-    sub new ($$$) {
-       my ($class, $type, $prefix) = @_;
-       my ($ptr, $i, $varname, $status, $obj);
-       $prefix =~ s/^(\**)//;
-       $ptr = $1;
-       $i = 0;
-       do {
-           $varname = "$prefix$i";
-           $status = $alloc{$varname};
-       } while $status == 2;
-       if ($status != 1) {
-           # Not declared yet
-           B::CC::declare($type, "$ptr$varname");
-           $alloc{$varname} = 2;       # declared and in use
-       }
-       $obj = bless \$varname, $class;
-       return $obj;
-    }
-    sub DESTROY {
-       my $obj = shift;
-       $alloc{$$obj} = 1; # no longer in use but still declared
-    }
-}
-{
-    package B::Shadow;
-    #
-    # This class gives a standard API for a perl object to shadow a
-    # C variable and only generate reloads/write-backs when necessary.
-    #
-    # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
-    # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
-    # Use $obj->invalidate whenever an unknown function may have
-    # set shadow itself.
-
-    sub new {
-       my ($class, $write_back) = @_;
-       # Object fields are perl shadow variable, validity flag
-       # (for *C* variable) and callback sub for write_back
-       # (passed perl shadow variable as argument).
-       bless [undef, 1, $write_back], $class;
-    }
-    sub load {
-       my ($obj, $newval) = @_;
-       $obj->[1] = 0;          # C variable no longer valid
-       $obj->[0] = $newval;
-    }
-    sub write_back {
-       my $obj = shift;
-       if (!($obj->[1])) {
-           $obj->[1] = 1;      # C variable will now be valid
-           &{$obj->[2]}($obj->[0]);
-       }
-    }
-    sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
-}
-my $curcop = new B::Shadow (sub {
-    my $opsym = shift->save;
-    runtime("curcop = (COP*)$opsym;");
-});
-
-#
-# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
-#
-sub dopoptoloop {
-    my $cxix = $#cxstack;
-    while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
-       $cxix--;
-    }
-    debug "dopoptoloop: returning $cxix" if $debug_cxstack;
-    return $cxix;
-}
-
-sub dopoptolabel {
-    my $label = shift;
-    my $cxix = $#cxstack;
-    while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
-          && $cxstack[$cxix]->{label} ne $label) {
-       $cxix--;
-    }
-    debug "dopoptolabel: returning $cxix" if $debug_cxstack;
-    return $cxix;
-}
-
-sub error {
-    my $format = shift;
-    my $file = $curcop->[0]->filegv->SV->PV;
-    my $line = $curcop->[0]->line;
-    $errors++;
-    if (@_) {
-       warn sprintf("%s:%d: $format\n", $file, $line, @_);
-    } else {
-       warn sprintf("%s:%d: %s\n", $file, $line, $format);
-    }
-}
-
-#
-# Load pad takes (the elements of) a PADLIST as arguments and loads
-# up @pad with Stackobj-derived objects which represent those lexicals.
-# If/when perl itself can generate type information (my int $foo) then
-# we'll take advantage of that here. Until then, we'll use various hacks
-# to tell the compiler when we want a lexical to be a particular type
-# or to be a register.
-#
-sub load_pad {
-    my ($namelistav, $valuelistav) = @_;
-    @padlist = @_;
-    my @namelist = $namelistav->ARRAY;
-    my @valuelist = $valuelistav->ARRAY;
-    my $ix;
-    @pad = ();
-    debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
-    # Temporary lexicals don't get named so it's possible for @valuelist
-    # to be strictly longer than @namelist. We count $ix up to the end of
-    # @valuelist but index into @namelist for the name. Any temporaries which
-    # run off the end of @namelist will make $namesv undefined and we treat
-    # that the same as having an explicit SPECIAL sv_undef object in @namelist.
-    # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
-    for ($ix = 1; $ix < @valuelist; $ix++) {
-       my $namesv = $namelist[$ix];
-       my $type = T_UNKNOWN;
-       my $flags = 0;
-       my $name = "tmp$ix";
-       my $class = class($namesv);
-       if (!defined($namesv) || $class eq "SPECIAL") {
-           # temporaries have &sv_undef instead of a PVNV for a name
-           $flags = VALID_SV|TEMPORARY|REGISTER;
-       } else {
-           if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
-               $name = $1;
-               if ($2 eq "i") {
-                   $type = T_INT;
-                   $flags = VALID_SV|VALID_INT;
-               } elsif ($2 eq "d") {
-                   $type = T_DOUBLE;
-                   $flags = VALID_SV|VALID_DOUBLE;
-               }
-               $flags |= REGISTER if $3;
-           }
-       }
-       $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
-                                           "i_$name", "d_$name");
-       declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
-       declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
-       debug sprintf("curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
-    }
-}
-
-#
-# Debugging stuff
-#
-sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
-
-#
-# OP stuff
-#
-
-sub label {
-    my $op = shift;
-    # XXX Preserve original label name for "real" labels?
-    return sprintf("lab_%x", $$op);
-}
-
-sub write_label {
-    my $op = shift;
-    push_runtime(sprintf("  %s:", label($op)));
-}
-
-sub loadop {
-    my $op = shift;
-    my $opsym = $op->save;
-    runtime("op = $opsym;") unless $know_op;
-    return $opsym;
-}
-
-sub doop {
-    my $op = shift;
-    my $ppname = $op->ppaddr;
-    my $sym = loadop($op);
-    runtime("DOOP($ppname);");
-    $know_op = 1;
-    return $sym;
-}
-
-sub gimme {
-    my $op = shift;
-    my $flags = $op->flags;
-    return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
-}
-
-#
-# Code generation for PP code
-#
-
-sub pp_null {
-    my $op = shift;
-    return $op->next;
-}
-
-sub pp_stub {
-    my $op = shift;
-    my $gimme = gimme($op);
-    if ($gimme != 1) {
-       # XXX Change to push a constant sv_undef Stackobj onto @stack
-       write_back_stack();
-       runtime("if ($gimme != G_ARRAY) XPUSHs(&sv_undef);");
-    }
-    return $op->next;
-}
-
-sub pp_unstack {
-    my $op = shift;
-    @stack = ();
-    runtime("PP_UNSTACK;");
-    return $op->next;
-}
-
-sub pp_and {
-    my $op = shift;
-    my $next = $op->next;
-    reload_lexicals();
-    unshift(@bblock_todo, $next);
-    if (@stack >= 1) {
-       my $bool = pop_bool();
-       write_back_stack();
-       runtime(sprintf("if (!$bool) goto %s;", label($next)));
-    } else {
-       runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
-               "*sp--;");
-    }
-    return $op->other;
-}
-           
-sub pp_or {
-    my $op = shift;
-    my $next = $op->next;
-    reload_lexicals();
-    unshift(@bblock_todo, $next);
-    if (@stack >= 1) {
-       my $obj = pop @stack;
-       write_back_stack();
-       runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
-                       $obj->as_numeric, $obj->as_sv, label($next)));
-    } else {
-       runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
-               "*sp--;");
-    }
-    return $op->other;
-}
-           
-sub pp_cond_expr {
-    my $op = shift;
-    my $false = $op->false;
-    unshift(@bblock_todo, $false);
-    reload_lexicals();
-    my $bool = pop_bool();
-    write_back_stack();
-    runtime(sprintf("if (!$bool) goto %s;", label($false)));
-    return $op->true;
-}
-
-sub pp_padsv {
-    my $op = shift;
-    my $ix = $op->targ;
-    push(@stack, $pad[$ix]);
-    if ($op->flags & OPf_MOD) {
-       my $private = $op->private;
-       if ($private & OPpLVAL_INTRO) {
-           runtime("SAVECLEARSV(curpad[$ix]);");
-       } elsif ($private & OPpDEREF) {
-           runtime(sprintf("vivify_ref(curpad[%d], %d);",
-                           $ix, $private & OPpDEREF));
-           $pad[$ix]->invalidate;
-       }
-    }
-    return $op->next;
-}
-
-sub pp_const {
-    my $op = shift;
-    my $sv = $op->sv;
-    my $obj = $constobj{$$sv};
-    if (!defined($obj)) {
-       $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
-    }
-    push(@stack, $obj);
-    return $op->next;
-}
-
-sub pp_nextstate {
-    my $op = shift;
-    $curcop->load($op);
-    @stack = ();
-    debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
-    runtime("TAINT_NOT;") unless $omit_taint;
-    runtime("sp = stack_base + cxstack[cxstack_ix].blk_oldsp;");
-    if ($freetmps_each_bblock || $freetmps_each_loop) {
-       $need_freetmps = 1;
-    } else {
-       runtime("FREETMPS;");
-    }
-    return $op->next;
-}
-
-sub pp_dbstate {
-    my $op = shift;
-    $curcop->invalidate; # XXX?
-    return default_pp($op);
-}
-
-sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
-sub pp_bless { $curcop->write_back; default_pp(@_) }
-sub pp_repeat { $curcop->write_back; default_pp(@_) }
-# The following subs need $curcop->write_back if we decide to support arybase:
-# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
-sub pp_sort { $curcop->write_back; default_pp(@_) }
-sub pp_caller { $curcop->write_back; default_pp(@_) }
-sub pp_reset { $curcop->write_back; default_pp(@_) }
-
-sub pp_gv {
-    my $op = shift;
-    my $gvsym = $op->gv->save;
-    write_back_stack();
-    runtime("XPUSHs((SV*)$gvsym);");
-    return $op->next;
-}
-
-sub pp_gvsv {
-    my $op = shift;
-    my $gvsym = $op->gv->save;
-    write_back_stack();
-    if ($op->private & OPpLVAL_INTRO) {
-       runtime("XPUSHs(save_scalar($gvsym));");
-    } else {
-       runtime("XPUSHs(GvSV($gvsym));");
-    }
-    return $op->next;
-}
-
-sub pp_aelemfast {
-    my $op = shift;
-    my $gvsym = $op->gv->save;
-    my $ix = $op->private;
-    my $flag = $op->flags & OPf_MOD;
-    write_back_stack();
-    runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
-           "PUSHs(svp ? *svp : &sv_undef);");
-    return $op->next;
-}
-
-sub int_binop {
-    my ($op, $operator) = @_;
-    if ($op->flags & OPf_STACKED) {
-       my $right = pop_int();
-       if (@stack >= 1) {
-           my $left = top_int();
-           $stack[-1]->set_int(&$operator($left, $right));
-       } else {
-           runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
-       }
-    } else {
-       my $targ = $pad[$op->targ];
-       my $right = new B::Pseudoreg ("IV", "riv");
-       my $left = new B::Pseudoreg ("IV", "liv");
-       runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
-       $targ->set_int(&$operator($$left, $$right));
-       push(@stack, $targ);
-    }
-    return $op->next;
-}
-
-sub INTS_CLOSED () { 0x1 }
-sub INT_RESULT () { 0x2 }
-sub NUMERIC_RESULT () { 0x4 }
-
-sub numeric_binop {
-    my ($op, $operator, $flags) = @_;
-    my $force_int = 0;
-    $force_int ||= ($flags & INT_RESULT);
-    $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
-                   && valid_int($stack[-2]) && valid_int($stack[-1]));
-    if ($op->flags & OPf_STACKED) {
-       my $right = pop_numeric();
-       if (@stack >= 1) {
-           my $left = top_numeric();
-           if ($force_int) {
-               $stack[-1]->set_int(&$operator($left, $right));
-           } else {
-               $stack[-1]->set_numeric(&$operator($left, $right));
-           }
-       } else {
-           if ($force_int) {
-               runtime(sprintf("sv_setiv(TOPs, %s);",
-                               &$operator("TOPi", $right)));
-           } else {
-               runtime(sprintf("sv_setnv(TOPs, %s);",
-                               &$operator("TOPn", $right)));
-           }
-       }
-    } else {
-       my $targ = $pad[$op->targ];
-       $force_int ||= ($targ->{type} == T_INT);
-       if ($force_int) {
-           my $right = new B::Pseudoreg ("IV", "riv");
-           my $left = new B::Pseudoreg ("IV", "liv");
-           runtime(sprintf("$$right = %s; $$left = %s;",
-                           pop_numeric(), pop_numeric));
-           $targ->set_int(&$operator($$left, $$right));
-       } else {
-           my $right = new B::Pseudoreg ("double", "rnv");
-           my $left = new B::Pseudoreg ("double", "lnv");
-           runtime(sprintf("$$right = %s; $$left = %s;",
-                           pop_numeric(), pop_numeric));
-           $targ->set_numeric(&$operator($$left, $$right));
-       }
-       push(@stack, $targ);
-    }
-    return $op->next;
-}
-
-sub sv_binop {
-    my ($op, $operator, $flags) = @_;
-    if ($op->flags & OPf_STACKED) {
-       my $right = pop_sv();
-       if (@stack >= 1) {
-           my $left = top_sv();
-           if ($flags & INT_RESULT) {
-               $stack[-1]->set_int(&$operator($left, $right));
-           } elsif ($flags & NUMERIC_RESULT) {
-               $stack[-1]->set_numeric(&$operator($left, $right));
-           } else {
-               # XXX Does this work?
-               runtime(sprintf("sv_setsv($left, %s);",
-                               &$operator($left, $right)));
-               $stack[-1]->invalidate;
-           }
-       } else {
-           my $f;
-           if ($flags & INT_RESULT) {
-               $f = "sv_setiv";
-           } elsif ($flags & NUMERIC_RESULT) {
-               $f = "sv_setnv";
-           } else {
-               $f = "sv_setsv";
-           }
-           runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
-       }
-    } else {
-       my $targ = $pad[$op->targ];
-       runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
-       if ($flags & INT_RESULT) {
-           $targ->set_int(&$operator("left", "right"));
-       } elsif ($flags & NUMERIC_RESULT) {
-           $targ->set_numeric(&$operator("left", "right"));
-       } else {
-           # XXX Does this work?
-           runtime(sprintf("sv_setsv(%s, %s);",
-                           $targ->as_sv, &$operator("left", "right")));
-           $targ->invalidate;
-       }
-       push(@stack, $targ);
-    }
-    return $op->next;
-}
-    
-sub bool_int_binop {
-    my ($op, $operator) = @_;
-    my $right = new B::Pseudoreg ("IV", "riv");
-    my $left = new B::Pseudoreg ("IV", "liv");
-    runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
-    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
-    $bool->set_int(&$operator($$left, $$right));
-    push(@stack, $bool);
-    return $op->next;
-}
-
-sub bool_numeric_binop {
-    my ($op, $operator) = @_;
-    my $right = new B::Pseudoreg ("double", "rnv");
-    my $left = new B::Pseudoreg ("double", "lnv");
-    runtime(sprintf("$$right = %s; $$left = %s;",
-                   pop_numeric(), pop_numeric()));
-    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
-    $bool->set_numeric(&$operator($$left, $$right));
-    push(@stack, $bool);
-    return $op->next;
-}
-
-sub bool_sv_binop {
-    my ($op, $operator) = @_;
-    runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
-    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
-    $bool->set_numeric(&$operator("left", "right"));
-    push(@stack, $bool);
-    return $op->next;
-}
-
-sub infix_op {
-    my $opname = shift;
-    return sub { "$_[0] $opname $_[1]" }
-}
-
-sub prefix_op {
-    my $opname = shift;
-    return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
-}
-
-BEGIN {
-    my $plus_op = infix_op("+");
-    my $minus_op = infix_op("-");
-    my $multiply_op = infix_op("*");
-    my $divide_op = infix_op("/");
-    my $modulo_op = infix_op("%");
-    my $lshift_op = infix_op("<<");
-    my $rshift_op = infix_op("<<");
-    my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
-    my $scmp_op = prefix_op("sv_cmp");
-    my $seq_op = prefix_op("sv_eq");
-    my $sne_op = prefix_op("!sv_eq");
-    my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
-    my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
-    my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
-    my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
-    my $eq_op = infix_op("==");
-    my $ne_op = infix_op("!=");
-    my $lt_op = infix_op("<");
-    my $gt_op = infix_op(">");
-    my $le_op = infix_op("<=");
-    my $ge_op = infix_op(">=");
-
-    #
-    # XXX The standard perl PP code has extra handling for
-    # some special case arguments of these operators.
-    #
-    sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
-    sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
-    sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
-    sub pp_divide { numeric_binop($_[0], $divide_op) }
-    sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
-    sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
-
-    sub pp_left_shift { int_binop($_[0], $lshift_op) }
-    sub pp_right_shift { int_binop($_[0], $rshift_op) }
-    sub pp_i_add { int_binop($_[0], $plus_op) }
-    sub pp_i_subtract { int_binop($_[0], $minus_op) }
-    sub pp_i_multiply { int_binop($_[0], $multiply_op) }
-    sub pp_i_divide { int_binop($_[0], $divide_op) }
-    sub pp_i_modulo { int_binop($_[0], $modulo_op) }
-
-    sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
-    sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
-    sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
-    sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
-    sub pp_le { bool_numeric_binop($_[0], $le_op) }
-    sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
-
-    sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
-    sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
-    sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
-    sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
-    sub pp_i_le { bool_int_binop($_[0], $le_op) }
-    sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
-
-    sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
-    sub pp_slt { bool_sv_binop($_[0], $slt_op) }
-    sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
-    sub pp_sle { bool_sv_binop($_[0], $sle_op) }
-    sub pp_sge { bool_sv_binop($_[0], $sge_op) }
-    sub pp_seq { bool_sv_binop($_[0], $seq_op) }
-    sub pp_sne { bool_sv_binop($_[0], $sne_op) }
-}
-
-
-sub pp_sassign {
-    my $op = shift;
-    my $backwards = $op->private & OPpASSIGN_BACKWARDS;
-    my ($dst, $src);
-    if (@stack >= 2) {
-       $dst = pop @stack;
-       $src = pop @stack;
-       ($src, $dst) = ($dst, $src) if $backwards;
-       my $type = $src->{type};
-       if ($type == T_INT) {
-           $dst->set_int($src->as_int);
-       } elsif ($type == T_DOUBLE) {
-           $dst->set_numeric($src->as_numeric);
-       } else {
-           $dst->set_sv($src->as_sv);
-       }
-       push(@stack, $dst);
-    } elsif (@stack == 1) {
-       if ($backwards) {
-           my $src = pop @stack;
-           my $type = $src->{type};
-           runtime("if (tainting && tainted) TAINT_NOT;");
-           if ($type == T_INT) {
-               runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
-           } elsif ($type == T_DOUBLE) {
-               runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
-           } else {
-               runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
-           }
-           runtime("SvSETMAGIC(TOPs);");
-       } else {
-           my $dst = pop @stack;
-           my $type = $dst->{type};
-           runtime("sv = POPs;");
-           runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
-           if ($type == T_INT) {
-               $dst->set_int("SvIV(sv)");
-           } elsif ($type == T_DOUBLE) {
-               $dst->set_double("SvNV(sv)");
-           } else {
-               runtime("SvSetSV($dst->{sv}, sv);");
-               $dst->invalidate;
-           }
-       }
-    } else {
-       if ($backwards) {
-           runtime("src = POPs; dst = TOPs;");
-       } else {
-           runtime("dst = POPs; src = TOPs;");
-       }
-       runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
-               "SvSetSV(dst, src);",
-               "SvSETMAGIC(dst);",
-               "SETs(dst);");
-    }
-    return $op->next;
-}
-
-sub pp_preinc {
-    my $op = shift;
-    if (@stack >= 1) {
-       my $obj = $stack[-1];
-       my $type = $obj->{type};
-       if ($type == T_INT || $type == T_DOUBLE) {
-           $obj->set_int($obj->as_int . " + 1");
-       } else {
-           runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
-           $obj->invalidate();
-       }
-    } else {
-       runtime sprintf("PP_PREINC(TOPs);");
-    }
-    return $op->next;
-}
-
-sub pp_pushmark {
-    my $op = shift;
-    write_back_stack();
-    runtime("PUSHMARK(sp);");
-    return $op->next;
-}
-
-sub pp_list {
-    my $op = shift;
-    write_back_stack();
-    my $gimme = gimme($op);
-    if ($gimme == 1) { # sic
-       runtime("POPMARK;"); # need this even though not a "full" pp_list
-    } else {
-       runtime("PP_LIST($gimme);");
-    }
-    return $op->next;
-}
-
-sub pp_entersub {
-    my $op = shift;
-    write_back_lexicals(REGISTER|TEMPORARY);
-    write_back_stack();
-    my $sym = doop($op);
-    runtime("if (op != ($sym)->op_next) op = (*op->op_ppaddr)(ARGS);");
-    runtime("SPAGAIN;");
-    $know_op = 0;
-    invalidate_lexicals(REGISTER|TEMPORARY);
-    return $op->next;
-}
-
-sub pp_enterwrite {
-    my $op = shift;
-    pp_entersub($op);
-}
-
-sub pp_leavewrite {
-    my $op = shift;
-    write_back_lexicals(REGISTER|TEMPORARY);
-    write_back_stack();
-    my $sym = doop($op);
-    # XXX Is this the right way to distinguish between it returning
-    # CvSTART(cv) (via doform) and pop_return()?
-    runtime("if (op) op = (*op->op_ppaddr)(ARGS);");
-    runtime("SPAGAIN;");
-    $know_op = 0;
-    invalidate_lexicals(REGISTER|TEMPORARY);
-    return $op->next;
-}
-
-sub doeval {
-    my $op = shift;
-    $curcop->write_back;
-    write_back_lexicals(REGISTER|TEMPORARY);
-    write_back_stack();
-    my $sym = loadop($op);
-    my $ppaddr = $op->ppaddr;
-    runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
-    $know_op = 1;
-    invalidate_lexicals(REGISTER|TEMPORARY);
-    return $op->next;
-}
-
-sub pp_entereval { doeval(@_) }
-sub pp_require { doeval(@_) }
-sub pp_dofile { doeval(@_) }
-
-sub pp_entertry {
-    my $op = shift;
-    $curcop->write_back;
-    write_back_lexicals(REGISTER|TEMPORARY);
-    write_back_stack();
-    my $sym = doop($op);
-    my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
-    declare("Sigjmp_buf", $jmpbuf);
-    runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
-    invalidate_lexicals(REGISTER|TEMPORARY);
-    return $op->next;
-}
-
-sub pp_grepstart {
-    my $op = shift;
-    if ($need_freetmps && $freetmps_each_loop) {
-       runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
-       $need_freetmps = 0;
-    }
-    write_back_stack();
-    doop($op);
-    return $op->next->other;
-}
-
-sub pp_mapstart {
-    my $op = shift;
-    if ($need_freetmps && $freetmps_each_loop) {
-       runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
-       $need_freetmps = 0;
-    }
-    write_back_stack();
-    doop($op);
-    return $op->next->other;
-}
-
-sub pp_grepwhile {
-    my $op = shift;
-    my $next = $op->next;
-    unshift(@bblock_todo, $next);
-    write_back_lexicals();
-    write_back_stack();
-    my $sym = doop($op);
-    # pp_grepwhile can return either op_next or op_other and we need to
-    # be able to distinguish the two at runtime. Since it's possible for
-    # both ops to be "inlined", the fields could both be zero. To get
-    # around that, we hack op_next to be our own op (purely because we
-    # know it's a non-NULL pointer and can't be the same as op_other).
-    $init->add("((LOGOP*)$sym)->op_next = $sym;");
-    runtime(sprintf("if (op == ($sym)->op_next) goto %s;", label($next)));
-    $know_op = 0;
-    return $op->other;
-}
-
-sub pp_mapwhile {
-    pp_grepwhile(@_);
-}
-
-sub pp_return {
-    my $op = shift;
-    write_back_lexicals(REGISTER|TEMPORARY);
-    write_back_stack();
-    doop($op);
-    runtime("PUTBACK;", "return 0;");
-    $know_op = 0;
-    return $op->next;
-}
-
-sub nyi {
-    my $op = shift;
-    warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
-    return default_pp($op);
-}
-
-sub pp_range {
-    my $op = shift;
-    my $flags = $op->flags;
-    if (!($flags & OPf_KNOW)) {
-       error("context of range unknown at compile-time");
-    }
-    write_back_lexicals();
-    write_back_stack();
-    if (!($flags & OPf_LIST)) {
-       # We need to save our UNOP structure since pp_flop uses
-       # it to find and adjust out targ. We don't need it ourselves.
-       $op->save;
-       runtime sprintf("if (SvTRUE(curpad[%d])) goto %s;",
-                       $op->targ, label($op->false));
-       unshift(@bblock_todo, $op->false);
-    }
-    return $op->true;
-}
-
-sub pp_flip {
-    my $op = shift;
-    my $flags = $op->flags;
-    if (!($flags & OPf_KNOW)) {
-       error("context of flip unknown at compile-time");
-    }
-    if ($flags & OPf_LIST) {
-       return $op->first->false;
-    }
-    write_back_lexicals();
-    write_back_stack();
-    # We need to save our UNOP structure since pp_flop uses
-    # it to find and adjust out targ. We don't need it ourselves.
-    $op->save;
-    my $ix = $op->targ;
-    my $rangeix = $op->first->targ;
-    runtime(($op->private & OPpFLIP_LINENUM) ?
-           "if (last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(last_in_gv))) {"
-         : "if (SvTRUE(TOPs)) {");
-    runtime("\tsv_setiv(curpad[$rangeix], 1);");
-    if ($op->flags & OPf_SPECIAL) {
-       runtime("sv_setiv(curpad[$ix], 1);");
-    } else {
-       runtime("\tsv_setiv(curpad[$ix], 0);",
-               "\tsp--;",
-               sprintf("\tgoto %s;", label($op->first->false)));
-    }
-    runtime("}",
-         qq{sv_setpv(curpad[$ix], "");},
-           "SETs(curpad[$ix]);");
-    $know_op = 0;
-    return $op->next;
-}
-
-sub pp_flop {
-    my $op = shift;
-    default_pp($op);
-    $know_op = 0;
-    return $op->next;
-}
-
-sub enterloop {
-    my $op = shift;
-    my $nextop = $op->nextop;
-    my $lastop = $op->lastop;
-    my $redoop = $op->redoop;
-    $curcop->write_back;
-    debug "enterloop: pushing on cxstack" if $debug_cxstack;
-    push(@cxstack, {
-       type => CXt_LOOP,
-       op => $op,
-       "label" => $curcop->[0]->label,
-       nextop => $nextop,
-       lastop => $lastop,
-       redoop => $redoop
-    });
-    $nextop->save;
-    $lastop->save;
-    $redoop->save;
-    return default_pp($op);
-}
-
-sub pp_enterloop { enterloop(@_) }
-sub pp_enteriter { enterloop(@_) }
-
-sub pp_leaveloop {
-    my $op = shift;
-    if (!@cxstack) {
-       die "panic: leaveloop";
-    }
-    debug "leaveloop: popping from cxstack" if $debug_cxstack;
-    pop(@cxstack);
-    return default_pp($op);
-}
-
-sub pp_next {
-    my $op = shift;
-    my $cxix;
-    if ($op->flags & OPf_SPECIAL) {
-       $cxix = dopoptoloop();
-       if ($cxix < 0) {
-           error('"next" used outside loop');
-           return $op->next; # ignore the op
-       }
-    } else {
-       $cxix = dopoptolabel($op->pv);
-       if ($cxix < 0) {
-           error('Label not found at compile time for "next %s"', $op->pv);
-           return $op->next; # ignore the op
-       }
-    }
-    default_pp($op);
-    my $nextop = $cxstack[$cxix]->{nextop};
-    push(@bblock_todo, $nextop);
-    runtime(sprintf("goto %s;", label($nextop)));
-    return $op->next;
-}
-
-sub pp_redo {
-    my $op = shift;
-    my $cxix;
-    if ($op->flags & OPf_SPECIAL) {
-       $cxix = dopoptoloop();
-       if ($cxix < 0) {
-           error('"redo" used outside loop');
-           return $op->next; # ignore the op
-       }
-    } else {
-       $cxix = dopoptolabel($op->pv);
-       if ($cxix < 0) {
-           error('Label not found at compile time for "redo %s"', $op->pv);
-           return $op->next; # ignore the op
-       }
-    }
-    default_pp($op);
-    my $redoop = $cxstack[$cxix]->{redoop};
-    push(@bblock_todo, $redoop);
-    runtime(sprintf("goto %s;", label($redoop)));
-    return $op->next;
-}
-
-sub pp_last {
-    my $op = shift;
-    my $cxix;
-    if ($op->flags & OPf_SPECIAL) {
-       $cxix = dopoptoloop();
-       if ($cxix < 0) {
-           error('"last" used outside loop');
-           return $op->next; # ignore the op
-       }
-    } else {
-       $cxix = dopoptolabel($op->pv);
-       if ($cxix < 0) {
-           error('Label not found at compile time for "last %s"', $op->pv);
-           return $op->next; # ignore the op
-       }
-       # XXX Add support for "last" to leave non-loop blocks
-       if ($cxstack[$cxix]->{type} != CXt_LOOP) {
-           error('Use of "last" for non-loop blocks is not yet implemented');
-           return $op->next; # ignore the op
-       }
-    }
-    default_pp($op);
-    my $lastop = $cxstack[$cxix]->{lastop}->next;
-    push(@bblock_todo, $lastop);
-    runtime(sprintf("goto %s;", label($lastop)));
-    return $op->next;
-}
-
-sub pp_subst {
-    my $op = shift;
-    write_back_lexicals();
-    write_back_stack();
-    my $sym = doop($op);
-    my $replroot = $op->pmreplroot;
-    if ($$replroot) {
-       runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
-                       $sym, label($replroot));
-       $op->pmreplstart->save;
-       push(@bblock_todo, $replroot);
-    }
-    invalidate_lexicals();
-    return $op->next;
-}
-
-sub pp_substcont {
-    my $op = shift;
-    write_back_lexicals();
-    write_back_stack();
-    doop($op);
-    my $pmop = $op->other;
-    warn sprintf("substcont: op = %s, pmop = %s\n",
-                peekop($op), peekop($pmop));#debug
-#    my $pmopsym = objsym($pmop);
-    my $pmopsym = $pmop->save; # XXX can this recurse?
-    warn "pmopsym = $pmopsym\n";#debug
-    runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
-                   $pmopsym, label($pmop->pmreplstart));
-    invalidate_lexicals();
-    return $pmop->next;
-}
-
-sub default_pp {
-    my $op = shift;
-    my $ppname = $op->ppaddr;
-    write_back_lexicals() unless $skip_lexicals{$ppname};
-    write_back_stack() unless $skip_stack{$ppname};
-    doop($op);
-    # XXX If the only way that ops can write to a TEMPORARY lexical is
-    # when it's named in $op->targ then we could call
-    # invalidate_lexicals(TEMPORARY) and avoid having to write back all
-    # the temporaries. For now, we'll play it safe and write back the lot.
-    invalidate_lexicals() unless $skip_invalidate{$ppname};
-    return $op->next;
-}
-
-sub compile_op {
-    my $op = shift;
-    my $ppname = $op->ppaddr;
-    if (exists $ignore_op{$ppname}) {
-       return $op->next;
-    }
-    debug peek_stack() if $debug_stack;
-    if ($debug_op) {
-       debug sprintf("%s [%s]\n",
-                    peekop($op),
-                    $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
-    }
-    no strict 'refs';
-    if (defined(&$ppname)) {
-       $know_op = 0;
-       return &$ppname($op);
-    } else {
-       return default_pp($op);
-    }
-}
-
-sub compile_bblock {
-    my $op = shift;
-    #warn "compile_bblock: ", peekop($op), "\n"; # debug
-    write_label($op);
-    $know_op = 0;
-    do {
-       $op = compile_op($op);
-    } while (defined($op) && $$op && !exists($leaders->{$$op}));
-    write_back_stack(); # boo hoo: big loss
-    reload_lexicals();
-    return $op;
-}
-
-sub cc {
-    my ($name, $root, $start, @padlist) = @_;
-    my $op;
-    init_pp($name);
-    load_pad(@padlist);
-    B::Pseudoreg->new_scope;
-    @cxstack = ();
-    if ($debug_timings) {
-       warn sprintf("Basic block analysis at %s\n", timing_info);
-    }
-    $leaders = find_leaders($root, $start);
-    @bblock_todo = ($start, values %$leaders);
-    if ($debug_timings) {
-       warn sprintf("Compilation at %s\n", timing_info);
-    }
-    while (@bblock_todo) {
-       $op = shift @bblock_todo;
-       #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
-       next if !defined($op) || !$$op || $done{$$op};
-       #warn "...compiling it\n"; # debug
-       do {
-           $done{$$op} = 1;
-           $op = compile_bblock($op);
-           if ($need_freetmps && $freetmps_each_bblock) {
-               runtime("FREETMPS;");
-               $need_freetmps = 0;
-           }
-       } while defined($op) && $$op && !$done{$$op};
-       if ($need_freetmps && $freetmps_each_loop) {
-           runtime("FREETMPS;");
-           $need_freetmps = 0;
-       }
-       if (!$$op) {
-           runtime("PUTBACK;", "return 0;");
-       } elsif ($done{$$op}) {
-           runtime(sprintf("goto %s;", label($op)));
-       }
-    }
-    if ($debug_timings) {
-       warn sprintf("Saving runtime at %s\n", timing_info);
-    }
-    save_runtime();
-}
-
-sub cc_recurse {
-    my $ccinfo;
-    my $start;
-    $start = cc_queue(@_) if @_;
-    while ($ccinfo = shift @cc_todo) {
-       cc(@$ccinfo);
-    }
-    return $start;
-}    
-
-sub cc_obj {
-    my ($name, $cvref) = @_;
-    my $cv = svref_2object($cvref);
-    my @padlist = $cv->PADLIST->ARRAY;
-    my $curpad_sym = $padlist[1]->save;
-    cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
-}
-
-sub cc_main {
-    my @comppadlist = comppadlist->ARRAY;
-    my $curpad_sym = $comppadlist[1]->save;
-    my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
-    save_unused_subs(@unused_sub_packages);
-    cc_recurse();
-
-    return if $errors;
-    if (!defined($module)) {
-       $init->add(sprintf("main_root = s\\_%x;", ${main_root()}),
-                  "main_start = $start;",
-                  "curpad = AvARRAY($curpad_sym);");
-    }
-    output_boilerplate();
-    print "\n";
-    output_all("perl_init");
-    output_runtime();
-    print "\n";
-    output_main();
-    if (defined($module)) {
-       my $cmodule = $module;
-       $cmodule =~ s/::/__/g;
-       print <<"EOT";
-
-#include "XSUB.h"
-XS(boot_$cmodule)
-{
-    dXSARGS;
-    perl_init();
-    ENTER;
-    SAVETMPS;
-    SAVESPTR(curpad);
-    SAVESPTR(op);
-    curpad = AvARRAY($curpad_sym);
-    op = $start;
-    pp_main(ARGS);
-    FREETMPS;
-    LEAVE;
-    ST(0) = &sv_yes;
-    XSRETURN(1);
-}
-EOT
-    }
-    if ($debug_timings) {
-       warn sprintf("Done at %s\n", timing_info);
-    }
-}
-
-sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-  OPTION:
-    while ($option = shift @options) {
-       if ($option =~ /^-(.)(.*)/) {
-           $opt = $1;
-           $arg = $2;
-       } else {
-           unshift @options, $option;
-           last OPTION;
-       }
-       if ($opt eq "-" && $arg eq "-") {
-           shift @options;
-           last OPTION;
-       } elsif ($opt eq "o") {
-           $arg ||= shift @options;
-           open(STDOUT, ">$arg") or return "$arg: $!\n";
-       } elsif ($opt eq "n") {
-           $arg ||= shift @options;
-           $module_name = $arg;
-       } elsif ($opt eq "u") {
-           $arg ||= shift @options;
-           push(@unused_sub_packages, $arg);
-       } elsif ($opt eq "f") {
-           $arg ||= shift @options;
-           my $value = $arg !~ s/^no-//;
-           $arg =~ s/-/_/g;
-           my $ref = $optimise{$arg};
-           if (defined($ref)) {
-               $$ref = $value;
-           } else {
-               warn qq(ignoring unknown optimisation option "$arg"\n);
-           }
-       } elsif ($opt eq "O") {
-           $arg = 1 if $arg eq "";
-           my $ref;
-           foreach $ref (values %optimise) {
-               $$ref = 0;
-           }
-           if ($arg >= 2) {
-               $freetmps_each_loop = 1;
-           }
-           if ($arg >= 1) {
-               $freetmps_each_bblock = 1 unless $freetmps_each_loop;
-           }
-       } elsif ($opt eq "m") {
-           $arg ||= shift @options;
-           $module = $arg;
-           push(@unused_sub_packages, $arg);
-       } elsif ($opt eq "p") {
-           $arg ||= shift @options;
-           $patchlevel = $arg;
-       } elsif ($opt eq "D") {
-            $arg ||= shift @options;
-           foreach $arg (split(//, $arg)) {
-               if ($arg eq "o") {
-                   B->debug(1);
-               } elsif ($arg eq "O") {
-                   $debug_op = 1;
-               } elsif ($arg eq "s") {
-                   $debug_stack = 1;
-               } elsif ($arg eq "c") {
-                   $debug_cxstack = 1;
-               } elsif ($arg eq "p") {
-                   $debug_pad = 1;
-               } elsif ($arg eq "r") {
-                   $debug_runtime = 1;
-               } elsif ($arg eq "S") {
-                   $debug_shadow = 1;
-               } elsif ($arg eq "q") {
-                   $debug_queue = 1;
-               } elsif ($arg eq "l") {
-                   $debug_lineno = 1;
-               } elsif ($arg eq "t") {
-                   $debug_timings = 1;
-               }
-           }
-       }
-    }
-    init_sections();
-    $init = B::Section->get("init");
-    $decl = B::Section->get("decl");
-
-    if (@options) {
-       return sub {
-           my ($objname, $ppname);
-           foreach $objname (@options) {
-               $objname = "main::$objname" unless $objname =~ /::/;
-               ($ppname = $objname) =~ s/^.*?:://;
-               eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
-               die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
-               return if $errors;
-           }
-           output_boilerplate();
-           print "\n";
-           output_all($module_name || "init_module");
-           output_runtime();
-       }
-    } else {
-       return sub { cc_main() };
-    }
-}
-
-1;
diff --git a/lib/B/Debug.pm b/lib/B/Debug.pm
deleted file mode 100644 (file)
index d88cef3..0000000
+++ /dev/null
@@ -1,263 +0,0 @@
-package B::Debug;
-use strict;
-use B qw(peekop class walkoptree walkoptree_exec
-         main_start main_root cstring sv_undef);
-use B::Asmdata qw(@specialsv_name);
-
-my %done_gv;
-
-sub B::OP::debug {
-    my ($op) = @_;
-    printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
-%s (0x%lx)
-       op_next         0x%x
-       op_sibling      0x%x
-       op_ppaddr       %s
-       op_targ         %d
-       op_type         %d
-       op_seq          %d
-       op_flags        %d
-       op_private      %d
-EOT
-}
-
-sub B::UNOP::debug {
-    my ($op) = @_;
-    $op->B::OP::debug();
-    printf "\top_first\t0x%x\n", ${$op->first};
-}
-
-sub B::BINOP::debug {
-    my ($op) = @_;
-    $op->B::UNOP::debug();
-    printf "\top_last\t\t0x%x\n", ${$op->last};
-}
-
-sub B::LOGOP::debug {
-    my ($op) = @_;
-    $op->B::UNOP::debug();
-    printf "\top_other\t0x%x\n", ${$op->other};
-}
-
-sub B::CONDOP::debug {
-    my ($op) = @_;
-    $op->B::UNOP::debug();
-    printf "\top_true\t0x%x\n", ${$op->true};
-    printf "\top_false\t0x%x\n", ${$op->false};
-}
-
-sub B::LISTOP::debug {
-    my ($op) = @_;
-    $op->B::BINOP::debug();
-    printf "\top_children\t%d\n", $op->children;
-}
-
-sub B::PMOP::debug {
-    my ($op) = @_;
-    $op->B::LISTOP::debug();
-    printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
-    printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
-    printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
-    printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
-    printf "\top_pmflags\t0x%x\n", $op->pmflags;
-    $op->pmshort->debug;
-    $op->pmreplroot->debug;
-}
-
-sub B::COP::debug {
-    my ($op) = @_;
-    $op->B::OP::debug();
-    my ($filegv) = $op->filegv;
-    printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line;
-       cop_label       %s
-       cop_stash       0x%x
-       cop_filegv      0x%x
-       cop_seq         %d
-       cop_arybase     %d
-       cop_line        %d
-EOT
-    $filegv->debug;
-}
-
-sub B::SVOP::debug {
-    my ($op) = @_;
-    $op->B::OP::debug();
-    printf "\top_sv\t\t0x%x\n", ${$op->sv};
-    $op->sv->debug;
-}
-
-sub B::PVOP::debug {
-    my ($op) = @_;
-    $op->B::OP::debug();
-    printf "\top_pv\t\t0x%x\n", $op->pv;
-}
-
-sub B::GVOP::debug {
-    my ($op) = @_;
-    $op->B::OP::debug();
-    printf "\top_gv\t\t0x%x\n", ${$op->gv};
-    $op->gv->debug;
-}
-
-sub B::CVOP::debug {
-    my ($op) = @_;
-    $op->B::OP::debug();
-    printf "\top_cv\t\t0x%x\n", ${$op->cv};
-}
-
-sub B::NULL::debug {
-    my ($sv) = @_;
-    if ($$sv == ${sv_undef()}) {
-       print "&sv_undef\n";
-    } else {
-       printf "NULL (0x%x)\n", $$sv;
-    }
-}
-
-sub B::SV::debug {
-    my ($sv) = @_;
-    if (!$$sv) {
-       print class($sv), " = NULL\n";
-       return;
-    }
-    printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
-%s (0x%x)
-       REFCNT          %d
-       FLAGS           0x%x
-EOT
-}
-
-sub B::PV::debug {
-    my ($sv) = @_;
-    $sv->B::SV::debug();
-    my $pv = $sv->PV();
-    printf <<'EOT', cstring($pv), length($pv);
-       xpv_pv          %s
-       xpv_cur         %d
-EOT
-}
-
-sub B::IV::debug {
-    my ($sv) = @_;
-    $sv->B::SV::debug();
-    printf "\txiv_iv\t\t%d\n", $sv->IV;
-}
-
-sub B::NV::debug {
-    my ($sv) = @_;
-    $sv->B::IV::debug();
-    printf "\txnv_nv\t\t%s\n", $sv->NV;
-}
-
-sub B::PVIV::debug {
-    my ($sv) = @_;
-    $sv->B::PV::debug();
-    printf "\txiv_iv\t\t%d\n", $sv->IV;
-}
-
-sub B::PVNV::debug {
-    my ($sv) = @_;
-    $sv->B::PVIV::debug();
-    printf "\txnv_nv\t\t%s\n", $sv->NV;
-}
-
-sub B::PVLV::debug {
-    my ($sv) = @_;
-    $sv->B::PVNV::debug();
-    printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
-    printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
-    printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
-}
-
-sub B::BM::debug {
-    my ($sv) = @_;
-    $sv->B::PVNV::debug();
-    printf "\txbm_useful\t%d\n", $sv->USEFUL;
-    printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
-    printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
-}
-
-sub B::CV::debug {
-    my ($sv) = @_;
-    $sv->B::PVNV::debug();
-    my ($stash) = $sv->STASH;
-    my ($start) = $sv->START;
-    my ($root) = $sv->ROOT;
-    my ($padlist) = $sv->PADLIST;
-    my ($gv) = $sv->GV;
-    my ($filegv) = $sv->FILEGV;
-    printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
-       STASH           0x%x
-       START           0x%x
-       ROOT            0x%x
-       GV              0x%x
-       FILEGV          0x%x
-       DEPTH           %d
-       PADLIST         0x%x                           
-       OUTSIDE         0x%x
-EOT
-    $start->debug if $start;
-    $root->debug if $root;
-    $gv->debug if $gv;
-    $filegv->debug if $filegv;
-    $padlist->debug if $padlist;
-}
-
-sub B::AV::debug {
-    my ($av) = @_;
-    $av->B::SV::debug;
-    my(@array) = $av->ARRAY;
-    print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
-    printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
-       FILL            %d    
-       MAX             %d
-       OFF             %d
-       AvFLAGS         %d
-EOT
-}
-    
-sub B::GV::debug {
-    my ($gv) = @_;
-    if ($done_gv{$$gv}++) {
-       printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME;
-       return;
-    }
-    my ($sv) = $gv->SV;
-    my ($av) = $gv->AV;
-    my ($cv) = $gv->CV;
-    $gv->B::SV::debug;
-    printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
-       NAME            %s
-       STASH           %s (0x%x)
-       SV              0x%x
-       GvREFCNT        %d
-       FORM            0x%x
-       AV              0x%x
-       HV              0x%x
-       EGV             0x%x
-       CV              0x%x
-       CVGEN           %d
-       LINE            %d
-       FILEGV          0x%x
-       GvFLAGS         0x%x
-EOT
-    $sv->debug if $sv;
-    $av->debug if $av;
-    $cv->debug if $cv;
-}
-
-sub B::SPECIAL::debug {
-    my $sv = shift;
-    print $specialsv_name[$$sv], "\n";
-}
-
-sub compile {
-    my $order = shift;
-    if ($order eq "exec") {
-        return sub { walkoptree_exec(main_start, "debug") }
-    } else {
-        return sub { walkoptree(main_root, "debug") }
-    }
-}
-
-1;
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
deleted file mode 100644 (file)
index 9802cb4..0000000
+++ /dev/null
@@ -1,102 +0,0 @@
-package B::Deparse;
-use strict;
-use B qw(peekop class main_root);
-
-my $debug;
-
-sub compile {
-    my $opt = shift;
-    if ($opt eq "-d") {
-       $debug = 1;
-    }
-    return sub { print deparse(main_root), "\n" }
-}
-
-sub ppname {
-    my $op = shift;
-    my $ppname = $op->ppaddr;
-    warn sprintf("ppname %s\n", peekop($op)) if $debug;
-    no strict "refs";
-    return defined(&$ppname) ? &$ppname($op) : 0;
-}
-
-sub deparse {
-    my $op = shift;
-    my $expr;
-    warn sprintf("deparse %s\n", peekop($op)) if $debug;
-    while (ref($expr = ppname($op))) {
-       $op = $expr;
-       warn sprintf("Redirecting to %s\n", peekop($op)) if $debug;
-    }
-    return $expr;
-}
-
-sub pp_leave {
-    my $op = shift;
-    my ($child, $expr);
-    for ($child = $op->first; !$expr; $child = $child->sibling) {
-       $expr = ppname($child);
-    }
-    return $expr;
-}
-
-sub SWAP_CHILDREN () { 1 }
-
-sub binop {
-    my ($op, $opname, $flags) = @_;
-    my $left = $op->first;
-    my $right = $op->last;
-    if ($flags & SWAP_CHILDREN) {
-       ($left, $right) = ($right, $left);
-    }
-    warn sprintf("binop deparsing first %s\n", peekop($op->first)) if $debug;
-    $left = deparse($left);
-    warn sprintf("binop deparsing last %s\n", peekop($op->last)) if $debug;
-    $right = deparse($right);
-    return "($left $opname $right)";
-}
-
-sub pp_add { binop($_[0], "+") }
-sub pp_multiply { binop($_[0], "*") }
-sub pp_subtract { binop($_[0], "-") }
-sub pp_divide { binop($_[0], "/") }
-sub pp_modulo { binop($_[0], "%") }
-sub pp_eq { binop($_[0], "==") }
-sub pp_ne { binop($_[0], "!=") }
-sub pp_lt { binop($_[0], "<") }
-sub pp_gt { binop($_[0], ">") }
-sub pp_ge { binop($_[0], ">=") }
-
-sub pp_sassign { binop($_[0], "=", SWAP_CHILDREN) }
-
-sub pp_null {
-    my $op = shift;
-    warn sprintf("Skipping null op %s\n", peekop($op)) if $debug;
-    return $op->first;
-}
-
-sub pp_const {
-    my $op = shift;
-    my $sv = $op->sv;
-    if (class($sv) eq "IV") {
-       return $sv->IV;
-    } elsif (class($sv) eq "NV") {
-       return $sv->NV;
-    } else {
-       return $sv->PV;
-    }
-}
-
-sub pp_gvsv {
-    my $op = shift;
-    my $gv = $op->gv;
-    my $stash = $gv->STASH->NAME;
-    if ($stash eq "main") {
-       $stash = "";
-    } else {
-       $stash = $stash . "::";
-    }
-    return sprintf('$%s%s', $stash, $gv->NAME);
-}
-
-1;
diff --git a/lib/B/Disassembler.pm b/lib/B/Disassembler.pm
deleted file mode 100644 (file)
index 36db354..0000000
+++ /dev/null
@@ -1,144 +0,0 @@
-#      Disassembler.pm
-#
-#      Copyright (c) 1996 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-package B::Disassembler::BytecodeStream;
-use FileHandle;
-use Carp;
-use B qw(cstring cast_I32);
-@ISA = qw(FileHandle);
-sub readn {
-    my ($fh, $len) = @_;
-    my $data;
-    read($fh, $data, $len);
-    croak "reached EOF while reading $len bytes" unless length($data) == $len;
-    return $data;
-}
-
-sub GET_U8 {
-    my $fh = shift;
-    my $c = $fh->getc;
-    croak "reached EOF while reading U8" unless defined($c);
-    return ord($c);
-}
-
-sub GET_U16 {
-    my $fh = shift;
-    my $str = $fh->readn(2);
-    croak "reached EOF while reading U16" unless length($str) == 2;
-    return unpack("n", $str);
-}
-
-sub GET_U32 {
-    my $fh = shift;
-    my $str = $fh->readn(4);
-    croak "reached EOF while reading U32" unless length($str) == 4;
-    return unpack("N", $str);
-}
-
-sub GET_I32 {
-    my $fh = shift;
-    my $str = $fh->readn(4);
-    croak "reached EOF while reading I32" unless length($str) == 4;
-    return cast_I32(unpack("N", $str));
-}
-
-sub GET_objindex { 
-    my $fh = shift;
-    my $str = $fh->readn(4);
-    croak "reached EOF while reading objindex" unless length($str) == 4;
-    return unpack("N", $str);
-}
-
-sub GET_strconst {
-    my $fh = shift;
-    my ($str, $c);
-    while (defined($c = $fh->getc) && $c ne "\0") {
-       $str .= $c;
-    }
-    croak "reached EOF while reading strconst" unless defined($c);
-    return cstring($str);
-}
-
-sub GET_pvcontents {}
-
-sub GET_PV {
-    my $fh = shift;
-    my $str;
-    my $len = $fh->GET_U32;
-    if ($len) {
-       read($fh, $str, $len);
-       croak "reached EOF while reading PV" unless length($str) == $len;
-       return cstring($str);
-    } else {
-       return '""';
-    }
-}
-
-sub GET_comment {
-    my $fh = shift;
-    my ($str, $c);
-    while (defined($c = $fh->getc) && $c ne "\n") {
-       $str .= $c;
-    }
-    croak "reached EOF while reading comment" unless defined($c);
-    return cstring($str);
-}
-
-sub GET_double {
-    my $fh = shift;
-    my ($str, $c);
-    while (defined($c = $fh->getc) && $c ne "\0") {
-       $str .= $c;
-    }
-    croak "reached EOF while reading double" unless defined($c);
-    return $str;
-}
-
-sub GET_none {}
-
-sub GET_op_tr_array {
-    my $fh = shift;
-    my @ary = unpack("n256", $fh->readn(256 * 2));
-    return join(",", @ary);
-}
-
-sub GET_IV64 {
-    my $fh = shift;
-    my ($hi, $lo) = unpack("NN", $fh->readn(8));
-    return sprintf("0x%4x%04x", $hi, $lo); # cheat
-}
-
-package B::Disassembler;
-use Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(disassemble_fh);
-use Carp;
-use strict;
-
-use B::Asmdata qw(%insn_data @insn_name);
-
-sub disassemble_fh {
-    my ($fh, $out) = @_;
-    my ($c, $getmeth, $insn, $arg);
-    bless $fh, "B::Disassembler::BytecodeStream";
-    while (defined($c = $fh->getc)) {
-       $c = ord($c);
-       $insn = $insn_name[$c];
-       if (!defined($insn) || $insn eq "unused") {
-           my $pos = $fh->tell - 1;
-           die "Illegal instruction code $c at stream offset $pos\n";
-       }
-       $getmeth = $insn_data{$insn}->[2];
-       $arg = $fh->$getmeth();
-       if (defined($arg)) {
-           &$out($insn, $arg);
-       } else {
-           &$out($insn);
-       }
-    }
-}
-
-1;
diff --git a/lib/B/Lint.pm b/lib/B/Lint.pm
deleted file mode 100644 (file)
index d34bd77..0000000
+++ /dev/null
@@ -1,367 +0,0 @@
-package B::Lint;
-
-=head1 NAME
-
-B::Lint - Perl lint
-
-=head1 SYNOPSIS
-
-perl -MO=Lint[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-The B::Lint module is equivalent to an extended version of the B<-w>
-option of B<perl>. It is named after the program B<lint> which carries
-out a similar process for C programs.
-
-=head1 OPTIONS AND LINT CHECKS
-
-Option words are separated by commas (not whitespace) and follow the
-usual conventions of compiler backend options. Following any options
-(indicated by a leading B<->) come lint check arguments. Each such
-argument (apart from the special B<all> and B<none> options) is a
-word representing one possible lint check (turning on that check) or
-is B<no-foo> (turning off that check). Before processing the check
-arguments, a standard list of checks is turned on. Later options
-override earlier ones. Available options are:
-
-=over 8
-
-=item B<context>
-
-Produces a warning whenever an array is used in an implicit scalar
-context. For example, both of the lines
-
-    $foo = length(@bar);
-    $foo = @bar;
-will elicit a warning. Using an explicit B<scalar()> silences the
-warning. For example,
-
-    $foo = scalar(@bar);
-
-=item B<implicit-read> and B<implicit-write>
-
-These options produce a warning whenever an operation implicitly
-reads or (respectively) writes to one of Perl's special variables.
-For example, B<implicit-read> will warn about these:
-
-    /foo/;
-
-and B<implicit-write> will warn about these:
-
-    s/foo/bar/;
-
-Both B<implicit-read> and B<implicit-write> warn about this:
-
-    for (@a) { ... }
-
-=item B<dollar-underscore>
-
-This option warns whenever $_ is used either explicitly anywhere or
-as the implicit argument of a B<print> statement.
-
-=item B<private-names>
-
-This option warns on each use of any variable, subroutine or
-method name that lives in a non-current package but begins with
-an underscore ("_"). Warnings aren't issued for the special case
-of the single character name "_" by itself (e.g. $_ and @_).
-
-=item B<undefined-subs>
-
-This option warns whenever an undefined subroutine is invoked.
-This option will only catch explicitly invoked subroutines such
-as C<foo()> and not indirect invocations such as C<&$subref()>
-or C<$obj-E<gt>meth()>. Note that some programs or modules delay
-definition of subs until runtime by means of the AUTOLOAD
-mechanism.
-
-=item B<regexp-variables>
-
-This option warns whenever one of the regexp variables $', $& or
-$' is used. Any occurrence of any of these variables in your
-program can slow your whole program down. See L<perlre> for
-details.
-
-=item B<all>
-
-Turn all warnings on.
-
-=item B<none>
-
-Turn all warnings off.
-
-=back
-
-=head1 NON LINT-CHECK OPTIONS
-
-=over 8
-
-=item B<-u Package>
-
-Normally, Lint only checks the main code of the program together
-with all subs defined in package main. The B<-u> option lets you
-include other package names whose subs are then checked by Lint.
-
-=back
-
-=head1 BUGS
-
-This is only a very preliminary version.
-
-=head1 AUTHOR
-
-Malcolm Beattie, mbeattie@sable.ox.ac.uk.
-
-=cut
-
-use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
-
-# Constants (should probably be elsewhere)
-sub G_ARRAY () { 1 }
-sub OPf_LIST () { 1 }
-sub OPf_KNOW () { 2 }
-sub OPf_STACKED () { 64 }
-
-my $file = "unknown";          # shadows current filename
-my $line = 0;                  # shadows current line number
-my $curstash = "main";         # shadows current stash
-
-# Lint checks
-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));
-}
-
-# Lint checks turned on by default
-my @default_checks = qw(context);
-
-my %valid_check;
-# All valid checks
-BEGIN {
-    map($valid_check{$_}++,
-       qw(context implicit_read implicit_write dollar_underscore
-          private_names undefined_subs regexp_variables));
-}
-
-# Debugging options
-my ($debug_op);
-
-my %done_cv;           # used to mark which subs have already been linted
-my @extra_packages;    # Lint checks mainline code and all subs which are
-                       # in main:: or in one of these packages.
-
-sub warning {
-    my $format = (@_ < 2) ? "%s" : shift;
-    warn sprintf("$format at %s line %d\n", @_, $file, $line);
-}
-
-# This gimme can't cope with context that's only determined
-# at runtime via dowantarray().
-sub gimme {
-    my $op = shift;
-    my $flags = $op->flags;
-    if ($flags & OPf_KNOW) {
-       return(($flags & OPf_LIST) ? 1 : 0);
-    }
-    return undef;
-}
-
-sub B::OP::lint {}
-
-sub B::COP::lint {
-    my $op = shift;
-    if ($op->ppaddr eq "pp_nextstate") {
-       $file = $op->filegv->SV->PV;
-       $line = $op->line;
-       $curstash = $op->stash->NAME;
-    }
-}
-
-sub B::UNOP::lint {
-    my $op = shift;
-    my $ppaddr = $op->ppaddr;
-    if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
-       my $parent = parents->[0];
-       my $pname = $parent->ppaddr;
-       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";
-       }
-       warning("Implicit scalar context for %s in %s",
-               $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
-    }
-    if ($check{private_names} && $ppaddr eq "pp_method") {
-       my $methop = $op->first;
-       if ($methop->ppaddr eq "pp_const") {
-           my $method = $methop->sv->PV;
-           if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
-               warning("Illegal reference to private method name $method");
-           }
-       }
-    }
-}
-
-sub B::PMOP::lint {
-    my $op = shift;
-    if ($check{implicit_read}) {
-       my $ppaddr = $op->ppaddr;
-       if ($ppaddr eq "pp_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)) {
-           warning('Implicit substitution on $_');
-       }
-    }
-}
-
-sub B::LOOP::lint {
-    my $op = shift;
-    if ($check{implicit_read} || $check{implicit_write}) {
-       my $ppaddr = $op->ppaddr;
-       if ($ppaddr eq "pp_enteriter") {
-           my $last = $op->last;
-           if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
-               warning('Implicit use of $_ in foreach');
-           }
-       }
-    }
-}
-
-sub B::GVOP::lint {
-    my $op = shift;
-    if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
-       && $op->gv->NAME eq "_")
-    {
-       warning('Use of $_');
-    }
-    if ($check{private_names}) {
-       my $ppaddr = $op->ppaddr;
-       my $gv = $op->gv;
-       if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_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") {
-           my $gv = $op->gv;
-           my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
-           no strict 'refs';
-           if (!defined(&$subname)) {
-               $subname =~ s/^main:://;
-               warning('Undefined subroutine %s called', $subname);
-           }
-       }
-    }
-    if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
-       my $name = $op->gv->NAME;
-       if ($name =~ /^[&'`]$/) {
-           warning('Use of regexp variable $%s', $name);
-       }
-    }
-}
-
-sub B::GV::lintcv {
-    my $gv = shift;
-    my $cv = $gv->CV;
-    #warn sprintf("lintcv: %s::%s (done=%d)\n",
-    #           $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
-    return if !$$cv || $done_cv{$$cv}++;
-    my $root = $cv->ROOT;
-    #warn "    root = $root (0x$$root)\n";#debug
-    walkoptree_slow($root, "lint") if $$root;
-}
-
-sub do_lint {
-    my %search_pack;
-    walkoptree_slow(main_root, "lint") if ${main_root()};
-    
-    # Now do subs in main
-    no strict qw(vars refs);
-    my $sym;
-    local(*glob);
-    while (($sym, *glob) = each %{"main::"}) {
-       #warn "Trying $sym\n";#debug
-       svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
-    }
-
-    # Now do subs in non-main packages given by -u options
-    map { $search_pack{$_} = 1 } @extra_packages;
-    walksymtable(\%{"main::"}, "lintcv", sub {
-       my $package = shift;
-       $package =~ s/::$//;
-       #warn "Considering $package\n";#debug
-       return exists $search_pack{$package};
-    });
-}
-
-sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-    # Turn on default lint checks
-    for $opt (@default_checks) {
-       $check{$opt} = 1;
-    }
-  OPTION:
-    while ($option = shift @options) {
-       if ($option =~ /^-(.)(.*)/) {
-           $opt = $1;
-           $arg = $2;
-       } else {
-           unshift @options, $option;
-           last OPTION;
-       }
-       if ($opt eq "-" && $arg eq "-") {
-           shift @options;
-           last OPTION;
-       } elsif ($opt eq "D") {
-            $arg ||= shift @options;
-           foreach $arg (split(//, $arg)) {
-               if ($arg eq "o") {
-                   B->debug(1);
-               } elsif ($arg eq "O") {
-                   $debug_op = 1;
-               }
-           }
-       } elsif ($opt eq "u") {
-           $arg ||= shift @options;
-           push(@extra_packages, $arg);
-       }
-    }
-    foreach $opt (@default_checks, @options) {
-       $opt =~ tr/-/_/;
-       if ($opt eq "all") {
-           %check = %valid_check;
-       }
-       elsif ($opt eq "none") {
-           %check = ();
-       }
-       else {
-           if ($opt =~ s/^no-//) {
-               $check{$opt} = 0;
-           }
-           else {
-               $check{$opt} = 1;
-           }
-           warn "No such check: $opt\n" unless defined $valid_check{$opt};
-       }
-    }
-    # Remaining arguments are things to check
-    
-    return \&do_lint;
-}
-
-1;
diff --git a/lib/B/Showlex.pm b/lib/B/Showlex.pm
deleted file mode 100644 (file)
index 9cf8ecc..0000000
+++ /dev/null
@@ -1,58 +0,0 @@
-package B::Showlex;
-use strict;
-use B qw(svref_2object comppadlist class);
-use B::Terse ();
-
-#
-# Invoke as
-#     perl -MO=Showlex,foo bar.pl
-# to see the names of lexical variables used by &foo
-# or as
-#     perl -MO=Showlex bar.pl
-# to see the names of file scope lexicals used by bar.pl
-#    
-
-sub showarray {
-    my ($name, $av) = @_;
-    my @els = $av->ARRAY;
-    my $count = @els;
-    my $i;
-    print "$name has $count entries\n";
-    for ($i = 0; $i < $count; $i++) {
-       print "$i: ";
-       $els[$i]->terse;
-    }
-}
-
-sub showlex {
-    my ($objname, $namesav, $valsav) = @_;
-    showarray("Pad of lexical names for $objname", $namesav);
-    showarray("Pad of lexical values for $objname", $valsav);
-}
-
-sub showlex_obj {
-    my ($objname, $obj) = @_;
-    $objname =~ s/^&main::/&/;
-    showlex($objname, svref_2object($obj)->PADLIST->ARRAY);
-}
-
-sub showlex_main {
-    showlex("comppadlist", comppadlist->ARRAY);
-}
-
-sub compile {
-    my @options = @_;
-    if (@options) {
-       return sub {
-           my $objname;
-           foreach $objname (@options) {
-               $objname = "main::$objname" unless $objname =~ /::/;
-               eval "showlex_obj('&$objname', \\&$objname)";
-           }
-       }
-    } else {
-       return \&showlex_main;
-    }
-}
-
-1;
diff --git a/lib/B/Stackobj.pm b/lib/B/Stackobj.pm
deleted file mode 100644 (file)
index 8be047f..0000000
+++ /dev/null
@@ -1,281 +0,0 @@
-#      Stackobj.pm
-#
-#      Copyright (c) 1996 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
-package B::Stackobj;
-use Exporter ();
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
-               VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
-%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
-               flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
-                            REGISTER TEMPORARY)]);
-
-use Carp qw(confess);
-use strict;
-use B qw(class);
-
-# Perl internal constants that I should probably define elsewhere.
-sub SVf_IOK () { 0x10000 }
-sub SVf_NOK () { 0x20000 }
-
-# Types
-sub T_UNKNOWN () { 0 }
-sub T_DOUBLE ()  { 1 }
-sub T_INT ()     { 2 }
-
-# Flags
-sub VALID_INT ()       { 0x01 }
-sub VALID_DOUBLE ()    { 0x02 }
-sub VALID_SV ()                { 0x04 }
-sub REGISTER ()                { 0x08 } # no implicit write-back when calling subs
-sub TEMPORARY ()       { 0x10 } # no implicit write-back needed at all
-
-#
-# Callback for runtime code generation
-#
-my $runtime_callback = sub { confess "set_callback not yet called" };
-sub set_callback (&) { $runtime_callback = shift }
-sub runtime { &$runtime_callback(@_) }
-
-#
-# Methods
-#
-
-sub write_back { confess "stack object does not implement write_back" }
-
-sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
-
-sub as_sv {
-    my $obj = shift;
-    if (!($obj->{flags} & VALID_SV)) {
-       $obj->write_back;
-       $obj->{flags} |= VALID_SV;
-    }
-    return $obj->{sv};
-}
-
-sub as_int {
-    my $obj = shift;
-    if (!($obj->{flags} & VALID_INT)) {
-       $obj->load_int;
-       $obj->{flags} |= VALID_INT;
-    }
-    return $obj->{iv};
-}
-
-sub as_double {
-    my $obj = shift;
-    if (!($obj->{flags} & VALID_DOUBLE)) {
-       $obj->load_double;
-       $obj->{flags} |= VALID_DOUBLE;
-    }
-    return $obj->{nv};
-}
-
-sub as_numeric {
-    my $obj = shift;
-    return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
-}
-
-#
-# Debugging methods
-#
-sub peek {
-    my $obj = shift;
-    my $type = $obj->{type};
-    my $flags = $obj->{flags};
-    my @flags;
-    if ($type == T_UNKNOWN) {
-       $type = "T_UNKNOWN";
-    } elsif ($type == T_INT) {
-       $type = "T_INT";
-    } elsif ($type == T_DOUBLE) {
-       $type = "T_DOUBLE";
-    } else {
-       $type = "(illegal type $type)";
-    }
-    push(@flags, "VALID_INT") if $flags & VALID_INT;
-    push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
-    push(@flags, "VALID_SV") if $flags & VALID_SV;
-    push(@flags, "REGISTER") if $flags & REGISTER;
-    push(@flags, "TEMPORARY") if $flags & TEMPORARY;
-    @flags = ("none") unless @flags;
-    return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
-                  class($obj), join("|", @flags));
-}
-
-sub minipeek {
-    my $obj = shift;
-    my $type = $obj->{type};
-    my $flags = $obj->{flags};
-    if ($type == T_INT || $flags & VALID_INT) {
-       return $obj->{iv};
-    } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
-       return $obj->{nv};
-    } else {
-       return $obj->{sv};
-    }
-}
-
-#
-# Caller needs to ensure that set_int, set_double,
-# set_numeric and set_sv are only invoked on legal lvalues.
-#
-sub set_int {
-    my ($obj, $expr) = @_;
-    runtime("$obj->{iv} = $expr;");
-    $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
-    $obj->{flags} |= VALID_INT;
-}
-
-sub set_double {
-    my ($obj, $expr) = @_;
-    runtime("$obj->{nv} = $expr;");
-    $obj->{flags} &= ~(VALID_SV | VALID_INT);
-    $obj->{flags} |= VALID_DOUBLE;
-}
-
-sub set_numeric {
-    my ($obj, $expr) = @_;
-    if ($obj->{type} == T_INT) {
-       $obj->set_int($expr);
-    } else {
-       $obj->set_double($expr);
-    }
-}
-
-sub set_sv {
-    my ($obj, $expr) = @_;
-    runtime("SvSetSV($obj->{sv}, $expr);");
-    $obj->invalidate;
-    $obj->{flags} |= VALID_SV;
-}
-
-#
-# Stackobj::Padsv
-#
-
-@B::Stackobj::Padsv::ISA = 'B::Stackobj';
-sub B::Stackobj::Padsv::new {
-    my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
-    bless {
-       type => $type,
-       flags => VALID_SV | $extra_flags,
-       sv => "curpad[$ix]",
-       iv => "$iname",
-       nv => "$dname"
-    }, $class;
-}
-
-sub B::Stackobj::Padsv::load_int {
-    my $obj = shift;
-    if ($obj->{flags} & VALID_DOUBLE) {
-       runtime("$obj->{iv} = $obj->{nv};");
-    } else {
-       runtime("$obj->{iv} = SvIV($obj->{sv});");
-    }
-    $obj->{flags} |= VALID_INT;
-}
-
-sub B::Stackobj::Padsv::load_double {
-    my $obj = shift;
-    $obj->write_back;
-    runtime("$obj->{nv} = SvNV($obj->{sv});");
-    $obj->{flags} |= VALID_DOUBLE;
-}
-
-sub B::Stackobj::Padsv::write_back {
-    my $obj = shift;
-    my $flags = $obj->{flags};
-    return if $flags & VALID_SV;
-    if ($flags & VALID_INT) {
-       runtime("sv_setiv($obj->{sv}, $obj->{iv});");
-    } elsif ($flags & VALID_DOUBLE) {
-       runtime("sv_setnv($obj->{sv}, $obj->{nv});");
-    } else {
-       confess "write_back failed for lexical @{[$obj->peek]}\n";
-    }
-    $obj->{flags} |= VALID_SV;
-}
-
-#
-# Stackobj::Const
-#
-
-@B::Stackobj::Const::ISA = 'B::Stackobj';
-sub B::Stackobj::Const::new {
-    my ($class, $sv) = @_;
-    my $obj = bless {
-       flags => 0,
-       sv => $sv    # holds the SV object until write_back happens
-    }, $class;
-    my $svflags = $sv->FLAGS;
-    if ($svflags & SVf_IOK) {
-       $obj->{flags} = VALID_INT|VALID_DOUBLE;
-       $obj->{type} = T_INT;
-       $obj->{nv} = $obj->{iv} = $sv->IV;
-    } elsif ($svflags & SVf_NOK) {
-       $obj->{flags} = VALID_INT|VALID_DOUBLE;
-       $obj->{type} = T_DOUBLE;
-       $obj->{iv} = $obj->{nv} = $sv->NV;
-    } else {
-       $obj->{type} = T_UNKNOWN;
-    }
-    return $obj;
-}
-
-sub B::Stackobj::Const::write_back {
-    my $obj = shift;
-    return if $obj->{flags} & VALID_SV;
-    # Save the SV object and replace $obj->{sv} by its C source code name
-    $obj->{sv} = $obj->{sv}->save;
-    $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
-}
-
-sub B::Stackobj::Const::load_int {
-    my $obj = shift;
-    $obj->{iv} = int($obj->{sv}->PV);
-    $obj->{flags} |= VALID_INT;
-}
-
-sub B::Stackobj::Const::load_double {
-    my $obj = shift;
-    $obj->{nv} = $obj->{sv}->PV + 0.0;
-    $obj->{flags} |= VALID_DOUBLE;
-}
-
-sub B::Stackobj::Const::invalidate {}
-
-#
-# Stackobj::Bool
-#
-
-@B::Stackobj::Bool::ISA = 'B::Stackobj';
-sub B::Stackobj::Bool::new {
-    my ($class, $preg) = @_;
-    my $obj = bless {
-       type => T_INT,
-       flags => VALID_INT|VALID_DOUBLE,
-       iv => $$preg,
-       nv => $$preg,
-       preg => $preg           # this holds our ref to the pseudo-reg
-    }, $class;
-    return $obj;
-}
-
-sub B::Stackobj::Bool::write_back {
-    my $obj = shift;
-    return if $obj->{flags} & VALID_SV;
-    $obj->{sv} = "($obj->{iv} ? &sv_yes : &sv_no)";
-    $obj->{flags} |= VALID_SV;
-}
-
-# XXX Might want to handle as_double/set_double/load_double?
-
-sub B::Stackobj::Bool::invalidate {}
-
-1;
diff --git a/lib/B/Terse.pm b/lib/B/Terse.pm
deleted file mode 100644 (file)
index 6489dc0..0000000
+++ /dev/null
@@ -1,132 +0,0 @@
-package B::Terse;
-use strict;
-use B qw(peekop class walkoptree_slow walkoptree_exec
-        main_start main_root cstring svref_2object);
-use B::Asmdata qw(@specialsv_name);
-
-sub terse {
-    my ($order, $cvref) = @_;
-    my $cv = svref_2object($cvref);
-    if ($order eq "exec") {
-       walkoptree_exec($cv->START, "terse");
-    } else {
-       walkoptree_slow($cv->ROOT, "terse");
-    }
-}
-
-sub compile {
-    my $order = shift;
-    my @options = @_;
-    if (@options) {
-       return sub {
-           my $objname;
-           foreach $objname (@options) {
-               $objname = "main::$objname" unless $objname =~ /::/;
-               eval "terse(\$order, \\&$objname)";
-               die "terse($order, \\&$objname) failed: $@" if $@;
-           }
-       }
-    } else {
-       if ($order eq "exec") {
-           return sub { walkoptree_exec(main_start, "terse") }
-       } else {
-           return sub { walkoptree_slow(main_root, "terse") }
-       }
-    }
-}
-
-sub indent {
-    my $level = shift;
-    return "    " x $level;
-}
-
-sub B::OP::terse {
-    my ($op, $level) = @_;
-    my $targ = $op->targ;
-    $targ = ($targ > 0) ? " [$targ]" : "";
-    print indent($level), peekop($op), $targ, "\n";
-}
-
-sub B::SVOP::terse {
-    my ($op, $level) = @_;
-    print indent($level), peekop($op), "  ";
-    $op->sv->terse(0);
-}
-
-sub B::GVOP::terse {
-    my ($op, $level) = @_;
-    print indent($level), peekop($op), "  ";
-    $op->gv->terse(0);
-}
-
-sub B::PMOP::terse {
-    my ($op, $level) = @_;
-    my $precomp = $op->precomp;
-    print indent($level), peekop($op),
-       defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
-
-}
-
-sub B::PVOP::terse {
-    my ($op, $level) = @_;
-    print indent($level), peekop($op), " ", cstring($op->pv), "\n";
-}
-
-sub B::COP::terse {
-    my ($op, $level) = @_;
-    my $label = $op->label;
-    if ($label) {
-       $label = " label ".cstring($label);
-    }
-    print indent($level), peekop($op), $label, "\n";
-}
-
-sub B::PV::terse {
-    my ($sv, $level) = @_;
-    print indent($level);
-    printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
-}
-
-sub B::AV::terse {
-    my ($sv, $level) = @_;
-    print indent($level);
-    printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
-}
-
-sub B::GV::terse {
-    my ($gv, $level) = @_;
-    my $stash = $gv->STASH->NAME;
-    if ($stash eq "main") {
-       $stash = "";
-    } else {
-       $stash = $stash . "::";
-    }
-    print indent($level);
-    printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME;
-}
-
-sub B::IV::terse {
-    my ($sv, $level) = @_;
-    print indent($level);
-    printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV;
-}
-
-sub B::NV::terse {
-    my ($sv, $level) = @_;
-    print indent($level);
-    printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
-}
-
-sub B::NULL::terse {
-    my ($sv, $level) = @_;
-    print indent($level);
-    printf "%s (0x%lx)\n", class($sv), $$sv;
-}
-    
-sub B::SPECIAL::terse {
-    my ($sv, $level) = @_;
-    print indent($level);
-    printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
-}
-
-1;
diff --git a/lib/B/Xref.pm b/lib/B/Xref.pm
deleted file mode 100644 (file)
index 0102856..0000000
+++ /dev/null
@@ -1,392 +0,0 @@
-package B::Xref;
-
-=head1 NAME
-
-B::Xref - Generates cross reference reports for Perl programs
-
-=head1 SYNOPSIS
-
-perl -MO=Xref[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-The B::Xref module is used to generate a cross reference listing of all
-definitions and uses of variables, subroutines and formats in a Perl program.
-It is implemented as a backend for the Perl compiler.
-
-The report generated is in the following format:
-
-    File filename1
-      Subroutine subname1
-       Package package1
-         object1        C<line numbers>
-         object2        C<line numbers>
-         ...
-       Package package2
-       ...
-
-Each B<File> section reports on a single file. Each B<Subroutine> section
-reports on a single subroutine apart from the special cases
-"(definitions)" and "(main)". These report, respectively, on subroutine
-definitions found by the initial symbol table walk and on the main part of
-the program or module external to all subroutines.
-
-The report is then grouped by the B<Package> of each variable,
-subroutine or format with the special case "(lexicals)" meaning
-lexical variables. Each B<object> name (implicitly qualified by its
-containing B<Package>) includes its type character(s) at the beginning
-where possible. Lexical variables are easier to track and even
-included dereferencing information where possible.
-
-The C<line numbers> are a comma separated list of line numbers (some
-preceded by code letters) where that object is used in some way.
-Simple uses aren't preceded by a code letter. Introductions (such as
-where a lexical is first defined with C<my>) are indicated with the
-letter "i". Subroutine and method calls are indicated by the character
-"&".  Subroutine definitions are indicated by "s" and format
-definitions by "f".
-
-=head1 OPTIONS
-
-Option words are separated by commas (not whitespace) and follow the
-usual conventions of compiler backend options.
-
-=over 8
-
-=item C<-oFILENAME>
-
-Directs output to C<FILENAME> instead of standard output.
-
-=item C<-r>
-
-Raw output. Instead of producing a human-readable report, outputs a line
-in machine-readable form for each definition/use of a variable/sub/format.
-
-=item C<-D[tO]>
-
-(Internal) debug options, probably only useful if C<-r> included.
-The C<t> option prints the object on the top of the stack as it's
-being tracked. The C<O> option prints each operator as it's being
-processed in the execution order of the program.
-
-=back
-
-=head1 BUGS
-
-Non-lexical variables are quite difficult to track through a program.
-Sometimes the type of a non-lexical variable's use is impossible to
-determine. Introductions of non-lexical non-scalars don't seem to be
-reported properly.
-
-=head1 AUTHOR
-
-Malcolm Beattie, mbeattie@sable.ox.ac.uk.
-
-=cut
-
-use strict;
-use B qw(peekop class comppadlist main_start svref_2object walksymtable);
-
-# Constants (should probably be elsewhere)
-sub OPpLVAL_INTRO () { 128 }
-sub SVf_POK () { 0x40000 }
-
-sub UNKNOWN { ["?", "?", "?"] }
-
-my @pad;                       # lexicals in current pad
-                               # as ["(lexical)", type, name]
-my %done;                      # keyed by $$op: set when each $op is done
-my $top = UNKNOWN;             # shadows top element of stack as
-                               # [pack, type, name] (pack can be "(lexical)")
-my $file;                      # shadows current filename
-my $line;                      # shadows current line number
-my $subname;                   # shadows current sub name
-my %table;                     # Multi-level hash to record all uses etc.
-my @todo = ();                 # List of CVs that need processing
-
-my %code = (intro => "i", used => "",
-           subdef => "s", subused => "&",
-           formdef => "f", meth => "->");
-
-
-# Options
-my ($debug_op, $debug_top, $nodefs, $raw);
-
-sub process {
-    my ($var, $event) = @_;
-    my ($pack, $type, $name) = @$var;
-    if ($type eq "*") {
-       if ($event eq "used") {
-           return;
-       } elsif ($event eq "subused") {
-           $type = "&";
-       }
-    }
-    $type =~ s/(.)\*$/$1/g;
-    if ($raw) {
-       printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
-           $file, $subname, $line, $pack, $type, $name, $event;
-    } else {
-       # Wheee
-       push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
-           $line);
-    }
-}
-
-sub load_pad {
-    my $padlist = shift;
-    my ($namelistav, @namelist, $ix);
-    @pad = ();
-    return if class($padlist) eq "SPECIAL";
-    ($namelistav) = $padlist->ARRAY;
-    @namelist = $namelistav->ARRAY;
-    for ($ix = 1; $ix < @namelist; $ix++) {
-       my $namesv = $namelist[$ix];
-       next if class($namesv) eq "SPECIAL";
-       my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/;
-       $pad[$ix] = ["(lexical)", $type, $name];
-    }
-}
-
-sub xref {
-    my $start = shift;
-    my $op;
-    for ($op = $start; $$op; $op = $op->next) {
-       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)$/) {
-           xref($op->other);
-       } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
-           xref($op->pmreplstart);
-       } elsif ($ppname eq "pp_substcont") {
-           xref($op->other->pmreplstart);
-           $op = $op->other;
-           redo;
-       } elsif ($ppname eq "pp_cond_expr") {
-           # pp_cond_expr never returns op_next
-           xref($op->true);
-           $op = $op->false;
-           redo;
-       } elsif ($ppname eq "pp_enterloop") {
-           xref($op->redoop);
-           xref($op->nextop);
-           xref($op->lastop);
-       } elsif ($ppname eq "pp_subst") {
-           xref($op->pmreplstart);
-       } else {
-           no strict 'refs';
-           &$ppname($op) if defined(&$ppname);
-       }
-    }
-}
-
-sub xref_cv {
-    my $cv = shift;
-    my $pack = $cv->GV->STASH->NAME;
-    $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
-    load_pad($cv->PADLIST);
-    xref($cv->START);
-    $subname = "(main)";
-}
-
-sub xref_object {
-    my $cvref = shift;
-    xref_cv(svref_2object($cvref));
-}
-
-sub xref_main {
-    $subname = "(main)";
-    load_pad(comppadlist);
-    xref(main_start);
-    while (@todo) {
-       xref_cv(shift @todo);
-    }
-}
-
-sub pp_nextstate {
-    my $op = shift;
-    $file = $op->filegv->SV->PV;
-    $line = $op->line;
-    $top = UNKNOWN;
-}
-
-sub pp_padsv {
-    my $op = shift;
-    $top = $pad[$op->targ];
-    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_padav { pp_padsv(@_) }
-sub pp_padhv { pp_padsv(@_) }
-
-sub deref {
-    my ($var, $as) = @_;
-    $var->[1] = $as . $var->[1];
-    process($var, "used");
-}
-
-sub pp_rv2cv { deref($top, "&"); }
-sub pp_rv2hv { deref($top, "%"); }
-sub pp_rv2sv { deref($top, "\$"); }
-sub pp_rv2av { deref($top, "\@"); }
-sub pp_rv2gv { deref($top, "*"); }
-
-sub pp_gvsv {
-    my $op = shift;
-    my $gv = $op->gv;
-    $top = [$gv->STASH->NAME, '$', $gv->NAME];
-    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_gv {
-    my $op = shift;
-    my $gv = $op->gv;
-    $top = [$gv->STASH->NAME, "*", $gv->NAME];
-    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_const {
-    my $op = shift;
-    my $sv = $op->sv;
-    $top = ["?", "",
-           (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
-}
-
-sub pp_method {
-    my $op = shift;
-    $top = ["(method)", "->".$top->[1], $top->[2]];
-}
-
-sub pp_entersub {
-    my $op = shift;
-    if ($top->[1] eq "m") {
-       process($top, "meth");
-    } else {
-       process($top, "subused");
-    }
-    $top = UNKNOWN;
-}
-
-#
-# Stuff for cross referencing definitions of variables and subs
-#
-
-sub B::GV::xref {
-    my $gv = shift;
-    my $cv = $gv->CV;
-    if ($$cv) {
-       #return if $done{$$cv}++;
-       $file = $gv->FILEGV->SV->PV;
-       $line = $gv->LINE;
-       process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
-       push(@todo, $cv);
-    }
-    my $form = $gv->FORM;
-    if ($$form) {
-       return if $done{$$form}++;
-       $file = $gv->FILEGV->SV->PV;
-       $line = $gv->LINE;
-       process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
-    }
-}
-
-sub xref_definitions {
-    my ($pack, %exclude);
-    return if $nodefs;
-    $subname = "(definitions)";
-    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
-                     strict vars FileHandle Exporter Carp)) {
-        $exclude{$pack."::"} = 1;
-    }
-    no strict qw(vars refs);
-    walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
-}
-
-sub output {
-    return if $raw;
-    my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
-       $perpack, $pername, $perev);
-    foreach $file (sort(keys(%table))) {
-       $perfile = $table{$file};
-       print "File $file\n";
-       foreach $subname (sort(keys(%$perfile))) {
-           $persubname = $perfile->{$subname};
-           print "  Subroutine $subname\n";
-           foreach $pack (sort(keys(%$persubname))) {
-               $perpack = $persubname->{$pack};
-               print "    Package $pack\n";
-               foreach $name (sort(keys(%$perpack))) {
-                   $pername = $perpack->{$name};
-                   my @lines;
-                   foreach $ev (qw(intro formdef subdef meth subused used)) {
-                       $perev = $pername->{$ev};
-                       if (defined($perev) && @$perev) {
-                           my $code = $code{$ev};
-                           push(@lines, map("$code$_", @$perev));
-                       }
-                   }
-                   printf "      %-16s  %s\n", $name, join(", ", @lines);
-               }
-           }
-       }
-    }
-}
-
-sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-  OPTION:
-    while ($option = shift @options) {
-       if ($option =~ /^-(.)(.*)/) {
-           $opt = $1;
-           $arg = $2;
-       } else {
-           unshift @options, $option;
-           last OPTION;
-       }
-       if ($opt eq "-" && $arg eq "-") {
-           shift @options;
-           last OPTION;
-       } elsif ($opt eq "o") {
-           $arg ||= shift @options;
-           open(STDOUT, ">$arg") or return "$arg: $!\n";
-       } elsif ($opt eq "d") {
-           $nodefs = 1;
-       } elsif ($opt eq "r") {
-           $raw = 1;
-       } elsif ($opt eq "D") {
-            $arg ||= shift @options;
-           foreach $arg (split(//, $arg)) {
-               if ($arg eq "o") {
-                   B->debug(1);
-               } elsif ($arg eq "O") {
-                   $debug_op = 1;
-               } elsif ($arg eq "t") {
-                   $debug_top = 1;
-               }
-           }
-       }
-    }
-    if (@options) {
-       return sub {
-           my $objname;
-           xref_definitions();
-           foreach $objname (@options) {
-               $objname = "main::$objname" unless $objname =~ /::/;
-               eval "xref_object(\\&$objname)";
-               die "xref_object(\\&$objname) failed: $@" if $@;
-           }
-           output();
-       }
-    } else {
-       return sub {
-           xref_definitions();
-           xref_main();
-           output();
-       }
-    }
-}
-
-1;
diff --git a/lib/B/assemble b/lib/B/assemble
deleted file mode 100755 (executable)
index 43cc5bc..0000000
+++ /dev/null
@@ -1,30 +0,0 @@
-use B::Assembler qw(assemble_fh);
-use FileHandle;
-
-my ($filename, $fh, $out);
-
-if ($ARGV[0] eq "-d") {
-    B::Assembler::debug(1);
-    shift;
-}
-
-$out = \*STDOUT;
-
-if (@ARGV == 0) {
-    $fh = \*STDIN;
-    $filename = "-";
-} elsif (@ARGV == 1) {
-    $filename = $ARGV[0];
-    $fh = new FileHandle "<$filename";
-} elsif (@ARGV == 2) {
-    $filename = $ARGV[0];
-    $fh = new FileHandle "<$filename";
-    $out = new FileHandle ">$ARGV[1]";
-} else {
-    die "Usage: assemble [filename] [outfilename]\n";
-}
-
-binmode $out;
-$SIG{__WARN__} = sub { warn "$filename:@_" };
-$SIG{__DIE__} = sub { die "$filename: @_" };
-assemble_fh($fh, sub { print $out @_ });
diff --git a/lib/B/cc_harness b/lib/B/cc_harness
deleted file mode 100644 (file)
index 79f8727..0000000
+++ /dev/null
@@ -1,12 +0,0 @@
-use Config;
-
-$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
-
-if (!grep(/^-[cS]$/, @ARGV)) {
-    $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
-                       @Config{qw(ldflags libs)});
-}
-
-$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
-print "$cccmd\n";
-exec $cccmd;
diff --git a/lib/B/disassemble b/lib/B/disassemble
deleted file mode 100755 (executable)
index 6530b80..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-use B::Disassembler qw(disassemble_fh);
-use FileHandle;
-
-my $fh;
-if (@ARGV == 0) {
-    $fh = \*STDIN;
-} elsif (@ARGV == 1) {
-    $fh = new FileHandle "<$ARGV[0]";
-} else {
-    die "Usage: disassemble [filename]\n";
-}
-
-sub print_insn {
-    my ($insn, $arg) = @_;
-    if (defined($arg)) {
-       printf "%s %s\n", $insn, $arg;
-    } else {
-       print $insn, "\n";
-    }
-}
-
-disassemble_fh($fh, \&print_insn);
diff --git a/lib/B/makeliblinks b/lib/B/makeliblinks
deleted file mode 100644 (file)
index 8256078..0000000
+++ /dev/null
@@ -1,54 +0,0 @@
-use File::Find;
-use Config;
-
-if (@ARGV != 2) {
-    warn <<"EOT";
-Usage: makeliblinks libautodir targetdir
-where libautodir is the architecture-dependent auto directory
-(e.g. $Config::Config{archlib}/auto).
-EOT
-    exit 2;
-}
-
-my ($libautodir, $targetdir) = @ARGV;
-
-# Calculate relative path prefix from $targetdir to $libautodir
-sub relprefix {
-    my ($to, $from) = @_;
-    my $up;
-    for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
-       $from =~ s(
-                  [^/]+        (?# a group of non-slashes) 
-                  /*           (?# maybe with some trailing slashes)
-                  $            (?# at the end of the path)
-                  )()x;
-    }
-    return (("../" x $up) . substr($to, length($from)));
-}
-
-my $relprefix = relprefix($libautodir, $targetdir);
-
-my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
-
-sub link_if_library {
-    if (/\.($dlext|$lib_ext)$/o) {
-       my $ext = $1;
-       my $name = $File::Find::name;
-       if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
-           die "directory of $name doesn't match $libautodir\n";
-       }
-       substr($name, 0, length($libautodir) + 1) = '';
-       my @parts = split(m(/), $name);
-       if ($parts[-1] ne "$parts[-2].$ext") {
-           die "module name $_ doesn't match its directory $libautodir\n";
-       }
-       pop @parts;
-       my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
-       print "$libpath -> $relprefix/$name\n";
-       symlink("$relprefix/$name", $libpath)
-           or warn "above link failed with error: $!\n";
-    }
-}
-
-find(\&link_if_library, $libautodir);
-exit 0;
diff --git a/lib/O.pm b/lib/O.pm
deleted file mode 100644 (file)
index 40d336e..0000000
--- a/lib/O.pm
+++ /dev/null
@@ -1,21 +0,0 @@
-package O;
-use B qw(minus_c);
-use Carp;    
-
-sub import {
-    my ($class, $backend, @options) = @_;
-    eval "use B::$backend ()";
-    if ($@) {
-       croak "use of backend $backend failed: $@";
-    }
-    my $compilesub = &{"B::${backend}::compile"}(@options);
-    if (ref($compilesub) eq "CODE") {
-       minus_c;
-       eval 'END { &$compilesub() }';
-    } else {
-       die $compilesub;
-    }
-}
-
-1;
-