--- /dev/null
+*.xml
+*.yml
--- /dev/null
+package Nomad;
+
+# Suboptimal things:
+# ast type info is generally still implicit
+# the combined madness calls are actually losing type information
+# brace madprops tend to be too low in the tree
+# could use about 18 more refactorings...
+# lots of unused cruft left around from previous refactorings
+
+use strict;
+use warnings;
+use Carp;
+
+use P5AST;
+use P5re;
+
+my $deinterpolate;
+
+sub xml_to_p5 {
+ my %options = @_;
+
+
+ my $filename = $options{'input'} or die;
+ $deinterpolate = $options{'deinterpolate'};
+ my $YAML = $options{'YAML'};
+
+ local $SIG{__DIE__} = sub {
+ my $e = shift;
+ $e =~ s/\n$/\n [NODE $filename line $::prevstate->{line}]/ if $::prevstate;
+ confess $e;
+ };
+
+ # parse file
+ use XML::Parser;
+ my $p1 = XML::Parser->new(Style => 'Objects', Pkg => 'PLXML');
+ $p1->setHandlers('Char' => sub { warn "Chars $_[1]" if $_[1] =~ /\S/; });
+
+ # First slurp XML into tree of objects.
+
+ my $root = $p1->parsefile($filename);
+
+ # Now turn XML tree into something more like an AST.
+
+ PLXML::prepreproc($root->[0]);
+ my $ast = P5AST->new('Kids' => [$root->[0]->ast()]);
+ #::t($ast);
+
+ if ($YAML) {
+ require YAML::Syck;
+ return YAML::Syck::Dump($ast);
+ }
+
+ # Finally, walk AST to produce new program.
+
+ my $text = $ast->p5text(); # returns encoded, must output raw
+ return $text;
+}
+
+$::curstate = 0;
+$::prevstate = 0;
+$::curenc = 1; # start in iso-8859-1, sigh...
+
+$::H = "HeredocHere000";
+%::H = ();
+
+my @enc = (
+ 'utf-8',
+ 'iso-8859-1',
+);
+
+my %enc = (
+ 'utf-8' => 0,
+ 'iso-8859-1' => 1,
+);
+
+my %madtype = (
+ '$' => 'p5::sigil',
+ '@' => 'p5::sigil',
+ '%' => 'p5::sigil',
+ '&' => 'p5::sigil',
+ '*' => 'p5::sigil',
+ 'o' => 'p5::operator',
+ '~' => 'p5::operator',
+ '+' => 'p5::punct',
+ '?' => 'p5::punct',
+ ':' => 'p5::punct',
+ ',' => 'p5::punct',
+ ';' => 'p5::punct',
+ '#' => 'p5::punct',
+ '(' => 'p5::opener',
+ ')' => 'p5::closer',
+ '[' => 'p5::opener',
+ ']' => 'p5::closer',
+ '{' => 'p5::opener',
+ '}' => 'p5::closer',
+ '1' => 'p5::punct',
+ '2' => 'p5::punct',
+ 'a' => 'p5::operator',
+ 'A' => 'p5::operator',
+ 'd' => 'p5::declarator',
+ 'E' => 'p5::text',
+ 'L' => 'p5::label',
+ 'm' => 'p5::remod',
+# 'n' => 'p5::name',
+ 'q' => 'p5::openquote',
+ 'Q' => 'p5::closequote',
+ '=' => 'p5::text',
+ 'R' => 'p5::text',
+ 's' => 'p5::text',
+ 's' => 'p5::declarator',
+# 'V' => 'p5::version',
+ 'X' => 'p5::token',
+);
+
+use Data::Dumper;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Quotekeys = 0;
+
+sub d {
+ my $text = Dumper(@_);
+ # doesn't scale well, alas
+ 1 while $text =~ s/(.*)^([^\n]*)bless\( \{\n(.*?)^(\s*\}), '([^']*)' \)([^\n]*)/$1$2$5 {\n$3$4$6 # $5/ms;
+ $text =~ s/PLXML:://g;
+ if ($text) {
+ my ($package, $filename, $line) = caller;
+ my $subroutine = (caller(1))[3];
+ $text =~ s/\n?\z/, called from $subroutine, line $line\n/;
+ warn $text;
+ }
+};
+
+{
+
+ my %xmlrepl = (
+ '&' => '&',
+ "'" => ''',
+ '"' => '&dquo;',
+ '<' => '<',
+ '>' => '>',
+ "\n" => ' ',
+ "\t" => '	',
+ );
+
+ sub x {
+ my $indent = 0;
+ if (@_ > 1) {
+ warn xdolist($indent,"LIST",@_);
+ }
+ else {
+ my $type = ref $_[0];
+ if ($type) {
+ warn xdoitem($indent,$type,@_);
+ }
+ else {
+ warn xdoitem($indent,"ITEM",@_);
+ }
+ }
+ }
+
+ sub xdolist {
+ my $indent = shift;
+ my $tag = shift;
+ my $in = ' ' x ($indent * 2);
+ my $result;
+ $result .= "$in<$tag>\n" if defined $tag;
+ for my $it (@_) {
+ my $itt = ref $it || "ITEM";
+ $itt =~ s/::/:/g;
+ $result .= xdoitem($indent+1,$itt,$it);
+ }
+ $result .= "$in</$tag>\n" if defined $tag;
+ return $result;
+ }
+
+ sub xdohash {
+ my $indent = shift;
+ my $tag = shift;
+ my $hash = shift;
+ my $in = ' ' x ($indent * 2);
+ my $result = "$in<$tag>\n";
+ my @keys = sort keys %$hash;
+ my $longest = 0;
+ for my $k (@keys) {
+ $longest = length($k) if length($k) > $longest;
+ }
+ my $K;
+ for my $k (@keys) {
+ my $tmp;
+ $K = $$hash{$k}, next if $k eq 'Kids';
+ my $sp = ' ' x ($longest - length($k));
+ if (ref $$hash{$k}) {
+ $tmp = xdoitem($indent+1,"kv",$$hash{$k});
+ $tmp =~ s!^ *<kv>\n *</kv>!$in <kv/>!;
+ }
+ else {
+ $tmp = xdoitem($indent+1,"kv",$$hash{$k});
+ }
+ $k =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
+ $tmp =~ s/<kv/<kv k='$k'$sp/ or
+ $tmp =~ s/^(.*)$/$in <kv k='$k'>\n$in $1$in <\/kv>\n/s;
+ $result .= $tmp;
+ }
+ if ($K and @$K) {
+ $result .= xdolist($indent, undef, @$K);
+ }
+ $result .= "$in</$tag>\n";
+ }
+
+ sub xdoitem {
+ my $indent = shift;
+ my $tag = shift;
+ my $item = shift;
+ my $in = ' ' x ($indent * 2);
+ my $r = ref $item;
+ if (not $r) {
+ $item =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
+ return "$in<$tag>$item</$tag>\n";
+ }
+ (my $newtag = $r) =~ s/::/:/g;
+ my $t = "$item";
+ if ($t =~ /\bARRAY\b/) {
+ if (@{$item}) {
+ return xdolist($indent,$tag,@{$item});
+ }
+ else {
+ return "$in<$tag />\n";
+ }
+ }
+ if ($t =~ /\bHASH\b/) {
+ return xdohash($indent,$tag,$item);
+ }
+ if ($r =~ /^p5::/) {
+ return "$in<$newtag>$$item</$newtag>\n";
+ }
+ else {
+ return "$in<$newtag type='$r'/>\n";
+ }
+ }
+
+ my %trepl = (
+ "'" => '\\\'',
+ '"' => '\\"',
+ "\n" => '\\n',
+ "\t" => '\\t',
+ );
+
+ sub t {
+ my $indent = 0;
+ if (@_ > 1) {
+ tdolist($indent,"LIST",@_);
+ }
+ else {
+ my $type = ref $_[0];
+ if ($type) {
+ tdoitem($indent,$type,@_);
+ }
+ else {
+ tdoitem($indent,"ITEM",@_);
+ }
+ }
+ print STDERR "\n";
+ }
+
+ sub tdolist {
+ my $indent = shift;
+ my $tag = shift || "ARRAY";
+ my $in = ' ' x ($indent * 2);
+ if (@_) {
+ print STDERR "[\n";
+ for my $it (@_) {
+ my $itt = ref $it || "ITEM";
+ print STDERR $in," ";
+ tdoitem($indent+1,$itt,$it);
+ print STDERR "\n";
+ }
+ print STDERR "$in]";
+ }
+ else {
+ print STDERR "[]";
+ }
+ }
+
+ sub tdohash {
+ my $indent = shift;
+ my $tag = shift;
+ my $hash = shift;
+ my $in = ' ' x ($indent * 2);
+
+ print STDERR "$tag => {\n";
+
+ my @keys = sort keys %$hash;
+ my $longest = 0;
+ for my $k (@keys) {
+ $longest = length($k) if length($k) > $longest;
+ }
+ my $K;
+ for my $k (@keys) {
+ my $sp = ' ' x ($longest - length($k));
+ print STDERR "$in $k$sp => ";
+ tdoitem($indent+1,"",$$hash{$k});
+ if ($k eq 'Kids') {
+ print STDERR " # Kids";
+ }
+ print STDERR "\n";
+ }
+ print STDERR "$in} # $tag";
+ }
+
+ sub tdoitem {
+ my $indent = shift;
+ my $tag = shift;
+ my $item = shift;
+ if (not defined $item) {
+ print STDERR "UNDEF";
+ return;
+ }
+# my $in = ' ' x ($indent * 2);
+ my $r = ref $item;
+ if (not $r) {
+ $item =~ s/([\t\n"])/$trepl{$1}/g;
+ print STDERR "\"$item\"";
+ return;
+ }
+ my $t = "$item";
+ if ($r =~ /^p5::/) {
+ my $str = $$item{uni};
+ my $enc = $enc[$$item{enc}] . ' ';
+ $enc =~ s/iso-8859-1 //;
+ $str =~ s/([\t\n"])/$trepl{$1}/g;
+ print STDERR "$r $enc\"$str\"";
+ }
+ elsif ($t =~ /\bARRAY\b/) {
+ tdolist($indent,$tag,@{$item});
+ }
+ elsif ($t =~ /\bHASH\b/) {
+ tdohash($indent,$tag,$item);
+ }
+ else {
+ print STDERR "$r type='$r'";
+ }
+ }
+}
+
+sub encnum {
+ my $encname = shift;
+ if (not exists $enc{$encname}) {
+ push @enc, $encname;
+ return $enc{$encname} = $#enc;
+ }
+ return $enc{$encname};
+}
+
+use PLXML;
+
+package p5::text;
+
+use Encode;
+
+sub new {
+ my $class = shift;
+ my $text = shift;
+ die "Too many args to new" if @_;
+ die "Attempt to bless non-text $text" if ref $text;
+ return bless( { uni => $text,
+ enc => $::curenc,
+ }, $class);
+}
+
+sub uni { my $self = shift; $$self{uni}; } # internal stuff all in utf8
+
+sub enc {
+ my $self = shift;
+ my $enc = $enc[$$self{enc} || 0];
+ return encode($enc, $$self{uni});
+}
+
+package p5::closequote; BEGIN { @p5::closequote::ISA = 'p5::punct'; }
+package p5::closer; BEGIN { @p5::closer::ISA = 'p5::punct'; }
+package p5::declarator; BEGIN { @p5::declarator::ISA = 'p5::token'; }
+package p5::junk; BEGIN { @p5::junk::ISA = 'p5::text'; }
+package p5::label; BEGIN { @p5::label::ISA = 'p5::token'; }
+#package p5::name; BEGIN { @p5::name::ISA = 'p5::token'; }
+package p5::opener; BEGIN { @p5::opener::ISA = 'p5::punct'; }
+package p5::openquote; BEGIN { @p5::openquote::ISA = 'p5::punct'; }
+package p5::operator; BEGIN { @p5::operator::ISA = 'p5::token'; }
+package p5::punct; BEGIN { @p5::punct::ISA = 'p5::token'; }
+package p5::remod; BEGIN { @p5::remod::ISA = 'p5::token'; }
+package p5::sigil; BEGIN { @p5::sigil::ISA = 'p5::punct'; }
+package p5::token; BEGIN { @p5::token::ISA = 'p5::text'; }
+#package p5::version; BEGIN { @p5::version::ISA = 'p5::token'; }
+
+################################################################
+# Routines to turn XML tree into an AST. Mostly this amounts to hoisting
+# misplaced nodes and flattening various things into lists.
+
+package PLXML;
+
+sub AUTOLOAD {
+ ::x("AUTOLOAD $PLXML::AUTOLOAD", @_);
+ return "[[[ $PLXML::AUTOLOAD ]]]";
+}
+
+sub prepreproc {
+ my $self = shift;
+ my $kids = $$self{Kids};
+ $self->{mp} = {};
+ if (defined $kids) {
+ my $i;
+ for ($i = 0; $i < @$kids; $i++) {
+ if (ref $kids->[$i] eq "PLXML::madprops") {
+ $self->{mp} = splice(@$kids, $i, 1)->hash($self,@_);
+ $i--;
+ next;
+ }
+ else {
+ prepreproc($kids->[$i], $self, @_);
+ }
+ }
+ }
+}
+
+sub preproc {
+ my $self = shift;
+ if (ref $self eq 'PLXML::op_null' and $$self{was}) {
+ return "PLXML::op_$$self{was}"->key();
+ }
+ else {
+ return $self->key();
+ }
+}
+
+sub newtype {
+ my $self = shift;
+ my $t = ref $self || $self;
+ $t = "PLXML::op_$$self{was}" if $t eq 'PLXML::op_null' and $$self{was};
+ $t =~ s/PLXML/P5AST/ or die "Bad type: $t";
+ return $t;
+}
+
+sub madness {
+ my $self = shift;
+ my @keys = split(' ', shift);
+ @keys = map { $_ eq 'd' ? ('k', 'd') : $_ } @keys;
+ my @vals = ();
+ for my $key (@keys) {
+ my $madprop = $self->{mp}{$key};
+ next unless defined $madprop;
+ if (ref $madprop eq 'PLXML::mad_op') {
+ if ($key eq 'b') {
+ push @vals, $madprop->blockast($self, @_);
+ }
+ else {
+ push @vals, $madprop->ast($self, @_);
+ }
+ next;
+ }
+ my $white;
+ if ($white = $self->{mp}{"_$key"}) {
+ push @vals, p5::junk->new($white);
+ }
+ my $type = $madtype{$key} || "p5::token";
+ push @vals, $type->new($madprop);
+ if ($white = $self->{mp}{"#$key"}) {
+ push @vals, p5::junk->new($white);
+ }
+ }
+ @vals;
+}
+
+sub blockast {
+ my $self = shift;
+ $self->ast(@_);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ return $self->newtype->new(Kids => [uc $self->key(), "(", @newkids, ")"]);
+}
+
+sub op {
+ my $self = shift;
+ my $desc = $self->desc();
+ if ($desc =~ /\((.*?)\)/) {
+ return $1;
+ }
+ else {
+ return " <<" . $self->key() . ">> ";
+ }
+}
+
+sub mp {
+ my $self = shift;
+ return $self->{mp};
+}
+
+package PLXML::Characters;
+
+sub ast { die "oops" }
+sub pair { die "oops" }
+
+package PLXML::madprops;
+
+sub ast {
+ die "oops madprops";
+}
+
+sub hash {
+ my $self = shift;
+ my @pairs;
+ my %hash = ();
+ my $firstthing = '';
+ my $lastthing = '';
+
+ # We need to guarantee key uniqueness at this point.
+ for my $kid (@{$$self{Kids}}) {
+ my ($k,$v) = $kid->pair($self, @_);
+ $firstthing ||= $k;
+ $k .= 'x' while exists $hash{$k};
+ $lastthing = $k;
+ $hash{$k} = $v;
+ }
+ $hash{FIRST} = $firstthing;
+ $hash{LAST} = $lastthing;
+ return \%hash;
+}
+
+package PLXML::mad_op;
+
+sub pair {
+ my $self = shift;
+ my $key = $$self{key};
+ return $key,$self;
+}
+
+sub ast {
+ my $self = shift;
+ $self->prepreproc(@_);
+ my @vals;
+ for my $kid (@{$$self{Kids}}) {
+ push @vals, $kid->ast($self, @_);
+ }
+ if (@vals == 1) {
+ return @vals;
+ }
+ else {
+ return P5AST::op_list->new(Kids => [@vals]);
+ }
+}
+
+sub blockast {
+ my $self = shift;
+ $self->prepreproc(@_);
+ my @vals;
+ for my $kid (@{$$self{Kids}}) {
+ push @vals, $kid->blockast($self, @_);
+ }
+ if (@vals == 1) {
+ return @vals;
+ }
+ else {
+ return P5AST::op_lineseq->new(Kids => [@vals]);
+ }
+}
+
+package PLXML::mad_pv;
+
+sub pair {
+ my $self = shift;
+ my $key = $$self{key};
+ my $val = $$self{val};
+ $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
+ return $key,$val;
+}
+
+package PLXML::mad_sv;
+
+sub pair {
+ my $self = shift;
+ my $key = $$self{key};
+ my $val = $$self{val};
+ $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
+ return $key,$val;
+}
+
+package PLXML::baseop;
+
+sub ast {
+ my $self = shift;
+
+ my @retval;
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ if (@newkids) {
+ push @retval, uc $self->key(), "(", @newkids , ")";
+ }
+ else {
+ push @retval, $self->madness('o ( )');
+ }
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::baseop_unop;
+
+sub ast {
+ my $self = shift;
+ my @newkids = $self->madness('d o (');
+
+ if (exists $$self{Kids}) {
+ my $arg = $$self{Kids}[0];
+ push @newkids, $arg->ast($self, @_) if defined $arg;
+ }
+ push @newkids, $self->madness(') ;'); # Nick added ;
+
+ return $self->newtype()->new(Kids => [@newkids]);
+}
+
+package PLXML::binop;
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+
+ my $left = $$self{Kids}[0];
+ push @newkids, $left->ast($self, @_);
+
+ push @newkids, $self->madness('o');
+
+ my $right = $$self{Kids}[1];
+ if (defined $right) {
+ push @newkids, $right->ast($self, @_);
+ }
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::cop;
+
+package PLXML::filestatop;
+
+sub ast {
+ my $self = shift;
+
+ my @newkids = $self->madness('o (');
+
+ if (@{$$self{Kids}}) {
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ }
+ if ($$self{mp}{O}) {
+ push @newkids, $self->madness('O');
+ }
+ push @newkids, $self->madness(')');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::listop;
+
+sub ast {
+ my $self = shift;
+
+ my @retval;
+ my @after;
+ if (@retval = $self->madness('X')) {
+ my @before, $self->madness('o x');
+ return P5AST::listop->new(Kids => [@before,@retval]);
+ }
+
+ push @retval, $self->madness('o d ( [ {');
+
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ next if ref $kid eq 'PLXML::op_pushmark';
+ next if ref $kid eq 'PLXML::op_null' and
+ defined $$kid{was} and $$kid{was} eq 'pushmark';
+ push @newkids, $kid->ast($self, @_);
+ }
+
+ my $x = "";
+
+ if ($$self{mp}{S}) {
+ push @retval, $self->madness('S');
+ }
+ push @retval, @newkids;
+
+ push @retval, $self->madness('} ] )');
+ return $self->newtype->new(Kids => [@retval,@after]);
+}
+
+package PLXML::logop;
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('o (');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ push @newkids, $self->madness(')');
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::loop;
+
+package PLXML::loopexop;
+
+sub ast {
+ my $self = shift;
+ my @newkids = $self->madness('o (');
+
+ if ($$self{mp}{L} or not $$self{flags} =~ /\bSPECIAL\b/) {
+ my @label = $self->madness('L');
+ if (@label) {
+ push @newkids, @label;
+ }
+ else {
+ my $arg = $$self{Kids}[0];
+ push @newkids, $arg->ast($self, @_) if defined $arg;
+ }
+ }
+ push @newkids, $self->madness(')');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+
+package PLXML::padop;
+
+package PLXML::padop_svop;
+
+package PLXML::pmop;
+
+sub ast {
+ my $self = shift;
+
+ return P5AST::pmop->new(Kids => []) unless exists $$self{flags};
+
+ my $bits = $self->fetchbits($$self{flags},@_);
+
+ my @newkids;
+ if ($bits->{binding}) {
+ push @newkids, $bits->{binding};
+ push @newkids, $self->madness('~');
+ }
+ if (exists $bits->{regcomp} and $bits->{regcomp}) {
+ my @front = $self->madness('q');
+ my @back = $self->madness('Q');
+ push @newkids, @front, $bits->{regcomp}, @back,
+ $self->madness('m');
+ }
+ elsif ($$self{mp}{q}) {
+ push @newkids, $self->madness('q = Q m');
+ }
+ elsif ($$self{mp}{X}) {
+ push @newkids, $self->madness('X m');
+ }
+ else {
+ push @newkids, $self->madness('e m');
+ }
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+sub innerpmop {
+ my $pmop = shift;
+ my $bits = shift;
+ for my $key (grep {!/^Kids/} keys %$pmop) {
+ $bits->{$key} = $pmop->{$key};
+ }
+
+ # Have to delete all the fake evals of the repl. This is a pain...
+ if (@{$$pmop{Kids}}) {
+ my $really = $$pmop{Kids}[0]{Kids}[0];
+ if (ref $really eq 'PLXML::op_substcont') {
+ $really = $$really{Kids}[0];
+ }
+ while ((ref $really) =~ /^PLXML::op_.*(null|entereval)/) {
+ if (exists $$really{was}) {
+ $bits->{repl} = $really->ast(@_);
+ return;
+ }
+ $really = $$really{Kids}[0];
+ }
+ if (ref $really eq 'PLXML::op_scope' and
+ @{$$really{Kids}} == 1 and
+ ref $$really{Kids}[0] eq 'PLXML::op_null' and
+ not @{$$really{Kids}[0]{Kids}})
+ {
+ $bits->{repl} = '';
+ return;
+ }
+ if (ref $really eq 'PLXML::op_leave' and
+ @{$$really{Kids}} == 2 and
+ ref $$really{Kids}[1] eq 'PLXML::op_null' and
+ not @{$$really{Kids}[1]{Kids}})
+ {
+ $bits->{repl} = '';
+ return;
+ }
+ if ((ref $really) =~ /^PLXML::op_(scope|leave)/) {
+ # should be at inner do {...} here, so skip that fakery too
+ $bits->{repl} = $really->newtype->new(Kids => [$really->PLXML::op_lineseq::lineseq(@_)]);
+ # but retrieve the whitespace before fake '}'
+ if ($$really{mp}{'_}'}) {
+ push(@{$bits->{repl}->{Kids}}, p5::junk->new($$really{mp}{'_}'}));
+ }
+ }
+ else { # something else, padsv probably
+ $bits->{repl} = $really->ast(@_);
+ }
+ }
+}
+
+sub fetchbits {
+ my $self = shift;
+ my $flags = shift || '';
+ my %bits = %$self;
+ my @kids = @{$$self{Kids}};
+ if (@kids) {
+ delete $bits{Kids};
+ my $arg = shift @kids;
+ innerpmop($arg,\%bits, $self, @_);
+ if ($flags =~ /STACKED/) {
+ $arg = shift @kids;
+ $bits{binding} = $arg->ast($self, @_);
+ }
+ if ($bits{when} ne "COMP" and @kids) {
+ $arg = pop @kids;
+ $bits{regcomp} = $arg->ast($self, @_);
+ }
+ if (not exists $bits{repl} and @kids) {
+ $arg = shift @kids;
+ $bits{repl} = $arg->ast($self, @_);
+ }
+ }
+ return \%bits;
+}
+
+package PLXML::pvop_svop;
+
+package PLXML::unop;
+
+sub ast {
+ my $self = shift;
+ my @newkids = $self->madness('o (');
+
+ if (exists $$self{Kids}) {
+ my $arg = $$self{Kids}[0];
+ push @newkids, $arg->ast($self, @_) if defined $arg;
+ }
+ push @newkids, $self->madness(')');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML;
+package PLXML::Characters;
+package PLXML::madprops;
+package PLXML::mad_op;
+package PLXML::mad_pv;
+package PLXML::baseop;
+package PLXML::baseop_unop;
+package PLXML::binop;
+package PLXML::cop;
+package PLXML::filestatop;
+package PLXML::listop;
+package PLXML::logop;
+package PLXML::loop;
+package PLXML::loopexop;
+package PLXML::padop;
+package PLXML::padop_svop;
+package PLXML::pmop;
+package PLXML::pvop_svop;
+package PLXML::unop;
+package PLXML::op_null;
+
+# Null nodes typed by first madprop.
+
+my %astmad;
+
+BEGIN {
+ %astmad = (
+ 'p' => sub { # peg for #! line, etc.
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('p px');
+ $::curstate = 0;
+ return P5AST::peg->new(Kids => [@newkids])
+ },
+ '(' => sub { # extra parens around the whole thing
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('dx d o (');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ push @newkids, $self->madness(')');
+ return P5AST::parens->new(Kids => [@newkids])
+ },
+ '~' => sub { # binding operator
+ my $self = shift;
+ my @newkids;
+ push @newkids, $$self{Kids}[0]->ast($self,@_);
+ push @newkids, $self->madness('~');
+ push @newkids, $$self{Kids}[1]->ast($self,@_);
+ return P5AST::bindop->new(Kids => [@newkids])
+ },
+ ';' => sub { # null statements/blocks
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('{ ; }');
+ $::curstate = 0;
+ return P5AST::nothing->new(Kids => [@newkids])
+ },
+ 'I' => sub { # if or unless statement keyword
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('L I (');
+ my @subkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @subkids, $kid->ast($self, @_);
+ }
+ die "oops in op_null->new" unless @subkids == 1;
+ my $newself = $subkids[0];
+ @subkids = @{$$newself{Kids}};
+
+ unshift @{$subkids[0]{Kids}}, @newkids;
+ push @{$subkids[0]{Kids}}, $self->madness(')');
+ return bless($newself, 'P5AST::condstate');
+ },
+ 'U' => sub { # use
+ my $self = shift;
+ my @newkids;
+ my @module = $self->madness('U');
+ my @args = $self->madness('A');
+ my $module = $module[-1]{Kids}[-1];
+ if ($module->uni eq 'bytes') {
+ $::curenc = Nomad::encnum('iso-8859-1');
+ }
+ elsif ($module->uni eq 'utf8') {
+ if ($$self{mp}{o} eq 'no') {
+ $::curenc = Nomad::encnum('iso-8859-1');
+ }
+ else {
+ $::curenc = Nomad::encnum('utf-8');
+ }
+ }
+ elsif ($module->uni eq 'encoding') {
+ if ($$self{mp}{o} eq 'no') {
+ $::curenc = Nomad::encnum('iso-8859-1');
+ }
+ else {
+ $::curenc = Nomad::encnum(eval $args[0]->p5text); # XXX bletch
+ }
+ }
+ # (Surrounding {} ends up here if use is only thing in block.)
+ push @newkids, $self->madness('{ o');
+ push @newkids, @module;
+ push @newkids, $self->madness('V');
+ push @newkids, @args;
+ push @newkids, $self->madness('S ; }');
+ $::curstate = 0;
+ return P5AST::use->new(Kids => [@newkids])
+ },
+ '?' => sub { # ternary
+ my $self = shift;
+ my @newkids;
+ my @subkids;
+ my @condkids = @{$$self{Kids}[0]{Kids}};
+
+ push @newkids, $condkids[0]->ast($self,@_), $self->madness('?');
+ push @newkids, $condkids[1]->ast($self,@_), $self->madness(':');
+ push @newkids, $condkids[2]->ast($self,@_);
+ return P5AST::ternary->new(Kids => [@newkids])
+ },
+ '&' => sub { # subroutine
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('d n s a : { & } ;');
+ $::curstate = 0;
+ return P5AST::sub->new(Kids => [@newkids])
+ },
+ 'i' => sub { # modifier if
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('i');
+ my $cond = $$self{Kids}[0];
+ my @subkids;
+ for my $kid (@{$$cond{Kids}}) {
+ push @subkids, $kid->ast($self, @_);
+ }
+ push @newkids, shift @subkids;
+ unshift @newkids, @subkids;
+ push @newkids, $self->madness(';'); # Nick
+ return P5AST::condmod->new(Kids => [@newkids])
+ },
+ 'P' => sub { # package declaration
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('o');
+ push @newkids, $self->madness('P');
+ push @newkids, $self->madness(';');
+ $::curstate = 0;
+ return P5AST::package->new(Kids => [@newkids])
+ },
+ 'F' => sub { # format
+ my $self = shift;
+ my @newkids = $self->madness('F n b');
+ $::curstate = 0;
+ return P5AST::format->new(Kids => [@newkids])
+ },
+ 'x' => sub { # qw literal
+ my $self = shift;
+ return P5AST::qwliteral->new(Kids => [$self->madness('x')])
+ },
+ 'q' => sub { # random quote
+ my $self = shift;
+ return P5AST::quote->new(Kids => [$self->madness('q = Q')])
+ },
+ 'X' => sub { # random literal
+ my $self = shift;
+ return P5AST::token->new(Kids => [$self->madness('X')])
+ },
+ ':' => sub { # attr list
+ my $self = shift;
+ return P5AST::attrlist->new(Kids => [$self->madness(':')])
+ },
+ ',' => sub { # "unary ," so to speak
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness(',');
+ push @newkids, $$self{Kids}[0]->ast($self,@_);
+ return P5AST::listelem->new(Kids => [@newkids])
+ },
+ 'C' => sub { # constant conditional
+ my $self = shift;
+ my @newkids;
+ push @newkids, $$self{Kids}[0]->ast($self,@_);
+ my @folded = $self->madness('C');
+ if (@folded) {
+ my @t = $self->madness('t');
+ my @e = $self->madness('e');
+ if (@e) {
+ return P5AST::op_cond_expr->new(
+ Kids => [
+ $self->madness('I ('),
+ @folded,
+ $self->madness(') ?'),
+ P5AST::op_cond_expr->new(Kids => [@newkids]),
+ $self->madness(':'),
+ @e
+ ] );
+ }
+ else {
+ return P5AST::op_cond_expr->new(
+ Kids => [
+ $self->madness('I ('),
+ @folded,
+ $self->madness(') ?'),
+ @t,
+ $self->madness(':'),
+ @newkids
+ ] );
+ }
+ }
+ return P5AST::op_null->new(Kids => [@newkids])
+ },
+ '+' => sub { # unary +
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('+');
+ push @newkids, $$self{Kids}[0]->ast($self,@_);
+ return P5AST::preplus->new(Kids => [@newkids])
+ },
+ 'D' => sub { # do block
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('D');
+ push @newkids, $$self{Kids}[0]->ast($self,@_);
+ return P5AST::doblock->new(Kids => [@newkids])
+ },
+ '3' => sub { # C-style for loop
+ my $self = shift;
+ my @newkids;
+
+ # What a mess!
+ my (undef, $init, $lineseq) = @{$$self{Kids}[0]{Kids}};
+ my (undef, $leaveloop) = @{$$lineseq{Kids}};
+ my (undef, $null) = @{$$leaveloop{Kids}};
+ my $and;
+ my $cond;
+ my $lineseq2;
+ my $block;
+ my $cont;
+ if (exists $$null{was} and $$null{was} eq 'and') {
+ ($lineseq2) = @{$$null{Kids}};
+ }
+ else {
+ ($and) = @{$$null{Kids}};
+ ($cond, $lineseq2) = @{$$and{Kids}};
+ }
+ if ($$lineseq2{mp}{'{'}) {
+ $block = $lineseq2;
+ }
+ else {
+ ($block, $cont) = @{$$lineseq2{Kids}};
+ }
+
+ push @newkids, $self->madness('L 3 (');
+ push @newkids, $init->ast($self,@_);
+ push @newkids, $self->madness('1');
+ if (defined $cond) {
+ push @newkids, $cond->ast($self,@_);
+ }
+ elsif (defined $null) {
+ push @newkids, $null->madness('1');
+ }
+ push @newkids, $self->madness('2');
+ if (defined $cont) {
+ push @newkids, $cont->ast($self,@_);
+ }
+ push @newkids, $self->madness(')');
+ push @newkids, $block->blockast($self,@_);
+ $::curstate = 0;
+ return P5AST::cfor->new(Kids => [@newkids])
+ },
+ 'o' => sub { # random useless operator
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('o');
+ my $kind = $newkids[-1] || '';
+ $kind = $kind->uni if ref $kind;
+ my @subkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @subkids, $kid->ast($self, @_);
+ }
+ if ($kind eq '=') { # stealth readline
+ unshift(@newkids, shift(@subkids));
+ push(@newkids, @subkids);
+ push @newkids, $self->madness(';'); # Nick
+ return P5AST::op_aassign->new(Kids => [@newkids])
+ }
+ else {
+ my $newself = $subkids[0];
+ splice(@{$newself->{Kids}}, 1, 0,
+ $self->madness('ox ('),
+ @newkids,
+ $self->madness(')')
+ );
+ push @{$newself->{Kids}}, $self->madness(';'); # Nick
+ return $newself;
+ }
+ },
+ );
+}
+
+# Null nodes are an untyped mess inside Perl. Instead of fixing it there,
+# we derive an effective type either from the "was" field or the first madprop.
+# (The individual routines select the actual new type.)
+
+sub ast {
+ my $self = shift;
+ my $was = $$self{was} || 'peg';
+ my $mad = $$self{mp}{FIRST} || "unknown";
+
+ # First try for a "was".
+ my $meth = "PLXML::op_${was}::astnull";
+ if (exists &{$meth}) {
+ return $self->$meth(@_);
+ }
+
+ # Look at first madprop.
+ if (exists $astmad{$mad}) {
+ return $astmad{$mad}->($self);
+ }
+ warn "No mad $mad" unless $mad eq 'unknown';
+
+ # Do something generic.
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+sub blockast {
+ my $self = shift;
+ local $::curstate;
+ local $::curenc = $::curenc;
+ return $self->madness('{ ; }');
+}
+
+package PLXML::op_stub;
+
+sub ast {
+ my $self = shift;
+ return $self->newtype->new(Kids => [$self->madness(', x ( ) q = Q')]);
+}
+
+package PLXML::op_scalar;
+
+sub ast {
+ my $self = shift;
+
+ my @pre = $self->madness('o q');
+ my $op = pop @pre;
+ if ($op->uni =~ /^<</) {
+ my @newkids;
+ my $opstub = bless { start => $op }, 'P5AST::heredoc';
+ push @newkids, $opstub;
+ push @newkids, $self->madness('(');
+
+ my @kids = @{$$self{Kids}};
+
+ my @divert;
+ for my $kid (@kids) {
+ next if ref $kid eq 'PLXML::op_pushmark';
+ next if ref $kid eq 'PLXML::op_null' and
+ defined $$kid{was} and $$kid{was} eq 'pushmark';
+ push @divert, $kid->ast($self, @_);
+ }
+ $opstub->{doc} = P5AST::op_list->new(Kids => [@divert]);
+ $opstub->{end} = ($self->madness('Q'))[-1];
+
+ push @newkids, $self->madness(')');
+
+ return $self->newtype->new(Kids => [@pre,@newkids]);
+ }
+ return $self->PLXML::baseop_unop::ast();
+}
+
+package PLXML::op_pushmark;
+
+sub ast { () }
+
+package PLXML::op_wantarray;
+package PLXML::op_const;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ return unless $$self{mp};
+ push @newkids, $self->madness('q = Q X : f O ( )');
+ return P5AST::op_const->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+ return unless %{$$self{mp}};
+
+ my @before;
+
+ my $const;
+ my @args = $self->madness('f');
+ if (@args) {
+ }
+ elsif (exists $self->{mp}{q}) {
+ push @args, $self->madness('d q');
+ if ($args[-1]->uni =~ /^<</) {
+ my $opstub = bless { start => pop(@args) }, 'P5AST::heredoc';
+ $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
+ $opstub->{end} = ($self->madness('Q'))[-1];
+ push @args, $opstub;
+ }
+ else {
+ push @args, $self->madness('= Q');
+ }
+ }
+ elsif (exists $self->{mp}{X}) {
+ push @before, $self->madness('d'); # was local $[ probably
+ if (not $$self{mp}{O}) {
+ push @before, $self->madness('o'); # was unary
+ }
+ my @X = $self->madness(': X');
+ if (exists $$self{private} and $$self{private} =~ /BARE/) {
+ return $self->newtype->new(Kids => [@X]);
+ }
+ my $X = pop @X;
+ push @before, @X;
+ @args = (
+ $self->madness('x'),
+ $X);
+ if ($$self{mp}{O}) {
+ push @args, $self->madness('o O');
+ }
+ }
+ elsif (exists $self->{mp}{O}) {
+ push @args, $self->madness('O');
+ }
+ elsif ($$self{private} =~ /\bBARE\b/) {
+ @args = ($$self{PV});
+ }
+ elsif (exists $$self{mp}{o}) {
+ @args = $self->madness('o');
+ }
+ elsif (exists $$self{PV}) {
+ @args = ('"', $$self{PV}, '"');
+ }
+ elsif (exists $$self{NV}) {
+ @args = $$self{NV};
+ }
+ elsif (exists $$self{IV}) {
+ @args = $$self{IV};
+ }
+ else {
+ @args = $self->SUPER::text(@_);
+ }
+ return $self->newtype->new(Kids => [@before, @args]);
+}
+
+
+package PLXML::op_gvsv;
+
+sub ast {
+ my $self = shift;
+ my @args;
+ my @retval;
+ for my $attr (qw/gv GV flags/) {
+ if (exists $$self{$attr}) {
+ push @args, $attr, $$self{$attr};
+ }
+ }
+ push @retval, @args;
+ push @retval, $self->madness('X');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_gv;
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('X K');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_gelem;
+
+sub ast {
+ my $self = shift;
+
+ local $::curstate; # in case there are statements in subscript
+ local $::curenc = $::curenc;
+ my @newkids;
+ push @newkids, $self->madness('dx d');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ splice @newkids, -1, 0, $self->madness('o {');
+ push @newkids, $self->madness('}');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_padsv;
+
+sub ast {
+ my $self = shift;
+ my @args;
+ push @args, $self->madness('dx d ( $ )');
+
+ return $self->newtype->new(Kids => [@args]);
+}
+
+package PLXML::op_padav;
+
+sub astnull { ast(@_) }
+
+sub ast {
+ my $self = shift;
+ my @retval;
+ push @retval, $self->madness('dx d (');
+ push @retval, $self->madness('$ @');
+ push @retval, $self->madness(') o O');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_padhv;
+
+sub astnull { ast(@_) }
+
+sub ast {
+ my $self = shift;
+ my @retval;
+ push @retval, $self->madness('dx d (');
+ push @retval, $self->madness('$ @ %');
+ push @retval, $self->madness(') o O');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_padany;
+
+package PLXML::op_pushre;
+
+sub ast {
+ my $self = shift;
+ if ($$self{mp}{q}) {
+ return $self->madness('q = Q m');
+ }
+ if ($$self{mp}{X}) {
+ return $self->madness('X m');
+ }
+ if ($$self{mp}{e}) {
+ return $self->madness('e m');
+ }
+ return $$self{Kids}[1]->ast($self,@_), $self->madness('m');
+}
+
+package PLXML::op_rv2gv;
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('dx d ( * $');
+ push @newkids, $$self{Kids}[0]->ast();
+ push @newkids, $self->madness(')');
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_rv2sv;
+
+sub astnull {
+ my $self = shift;
+ return P5AST::op_rv2sv->new(Kids => [$self->madness('O o dx d ( $ ) : a')]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('dx d ( $');
+ if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
+ push @newkids, $$self{Kids}[0]->ast();
+ }
+ push @newkids, $self->madness(') : a');
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_av2arylen;
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $$self{Kids}[0]->madness('l');
+ push @newkids, $$self{Kids}[0]->ast();
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_rv2cv;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('X');
+ return @newkids if @newkids;
+ if (exists $$self{mp}{'&'}) {
+ push @newkids, $self->madness('&');
+ if (@{$$self{Kids}}) {
+ push @newkids, $$self{Kids}[0]->ast(@_);
+ }
+ }
+ else {
+ push @newkids, $$self{Kids}[0]->ast(@_);
+ }
+ return P5AST::op_rv2cv->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('&');
+ if (@{$$self{Kids}}) {
+ push @newkids, $$self{Kids}[0]->ast();
+ }
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_anoncode;
+
+sub ast {
+ my $self = shift;
+ my $arg = $$self{Kids}[0];
+ local $::curstate; # hide nested statements in sub
+ local $::curenc = $::curenc;
+ if (defined $arg) {
+ return $arg->ast(@_);
+ }
+ return ';'; # XXX literal ; should come through somewhere
+}
+
+package PLXML::op_prototype;
+package PLXML::op_refgen;
+
+sub ast {
+ my $self = shift;
+ my @newkids = $self->madness('o s a');
+
+ if (exists $$self{Kids}) {
+ my $arg = $$self{Kids}[0];
+ push @newkids, $arg->ast($self, @_) if defined $arg;
+ }
+
+ my $res = $self->newtype->new(Kids => [@newkids]);
+ return $res;
+}
+
+package PLXML::op_srefgen;
+
+sub ast {
+ my @newkids;
+ my $self = shift;
+ if ($$self{mp}{FIRST} eq '{') {
+ local $::curstate; # this is officially a block, so hide it
+ local $::curenc = $::curenc;
+ push @newkids, $self->madness('{');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ push @newkids, $self->madness('; }');
+ return P5AST::op_stringify->new(Kids => [@newkids]);
+ }
+ else {
+ push @newkids, $self->madness('o [');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ push @newkids, $self->madness(']');
+ return P5AST::op_stringify->new(Kids => [@newkids]);
+ }
+}
+
+package PLXML::op_ref;
+package PLXML::op_bless;
+package PLXML::op_backtick;
+
+sub ast {
+ my $self = shift;
+ my @args;
+ if (exists $self->{mp}{q}) {
+ push @args, $self->madness('q');
+ if ($args[-1]->uni =~ /^<</) {
+ my $opstub = bless { start => $args[-1] }, 'P5AST::heredoc';
+ $args[-1] = $opstub;
+ $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
+ $opstub->{end} = ($self->madness('Q'))[-1];
+ }
+ else {
+ push @args, $self->madness('= Q');
+ }
+ }
+ return $self->newtype->new(Kids => [@args]);
+}
+
+package PLXML::op_glob;
+
+sub astnull {
+ my $self = shift;
+ my @retval = $self->madness('o q = Q');
+ if (not @retval or $retval[-1]->uni eq 'glob') {
+ push @retval, $self->madness('(');
+ push @retval, $$self{Kids}[0]->ast($self,@_);
+ push @retval, $self->madness(')');
+ }
+ return P5AST::op_glob->new(Kids => [@retval]);
+}
+
+package PLXML::op_readline;
+
+sub astnull {
+ my $self = shift;
+ my @retval;
+ if (exists $$self{mp}{q}) {
+ @retval = $self->madness('q = Q');
+ }
+ elsif (exists $$self{mp}{X}) {
+ @retval = $self->madness('X');
+ }
+ return P5AST::op_readline->new(Kids => [@retval]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @retval;
+
+ my @args;
+ my $const;
+ if (exists $$self{mp}{q}) {
+ @args = $self->madness('q = Q');
+ }
+ elsif (exists $$self{mp}{X}) {
+ @args = $self->madness('X');
+ }
+ elsif (exists $$self{GV}) {
+ @args = $$self{IV};
+ }
+ elsif (@{$$self{Kids}}) {
+ @args = $self->PLXML::unop::ast(@_);
+ }
+ else {
+ @args = $self->SUPER::text(@_);
+ }
+ return $self->newtype->new(Kids => [@retval,@args]);
+}
+
+
+package PLXML::op_rcatline;
+package PLXML::op_regcmaybe;
+package PLXML::op_regcreset;
+package PLXML::op_regcomp;
+
+sub ast {
+ my $self = shift;
+ $self->PLXML::unop::ast(@_);
+}
+
+package PLXML::op_match;
+
+sub ast {
+ my $self = shift;
+ my $retval = $self->SUPER::ast(@_);
+ my $p5re;
+ if (not $p5re = $retval->p5text()) {
+ $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
+ $p5re = $retval->p5text();
+ }
+ if ($deinterpolate) {
+ $retval->{P5re} = P5re::qrparse($p5re);
+ }
+ return $retval;
+}
+
+package PLXML::op_qr;
+
+sub ast {
+ my $self = shift;
+ my $retval;
+ if (exists $$self{flags}) {
+ $retval = $self->SUPER::ast(@_);
+ }
+ else {
+ $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
+ }
+ if ($deinterpolate) {
+ my $p5re = $retval->p5text();
+ $retval->{P5re} = P5re::qrparse($p5re);
+ }
+ return $retval;
+}
+
+package PLXML::op_subst;
+
+sub ast {
+ my $self = shift;
+
+ my $bits = $self->fetchbits($$self{flags},@_);
+
+ my @newkids;
+ if ($bits->{binding}) {
+ push @newkids, $bits->{binding};
+ push @newkids, $self->madness('~');
+ }
+ my $X = p5::token->new($$self{mp}{X});
+ my @lfirst = $self->madness('q');
+ my @llast = $self->madness('Q');
+ push @newkids,
+ @lfirst,
+ $self->madness('E'), # XXX s/b e probably
+ @llast;
+ my @rfirst = $self->madness('z');
+ my @rlast = $self->madness('Z');
+ my @mods = $self->madness('m');
+ if ($rfirst[-1]->uni ne $llast[-1]->uni) {
+ push @newkids, @rfirst;
+ }
+ # remove the fake '\n' if /e and '#' in replacement.
+ if (@mods and $mods[0] =~ m/e/ and ($self->madness('R'))[0]->uni =~ m/#/) {
+ unshift @rlast, bless {}, 'chomp'; # hack to remove '\n'
+ }
+ push @newkids, $bits->{repl}, @rlast, @mods;
+
+ my $retval = $self->newtype->new(Kids => [@newkids]);
+ if ($deinterpolate) {
+ my $p5re = $retval->p5text();
+ $retval->{P5re} = P5re::qrparse($p5re);
+ }
+ return $retval;
+}
+
+package PLXML::op_substcont;
+package PLXML::op_trans;
+
+sub ast {
+ my $self = shift;
+
+# my $bits = $self->fetchbits($$self{flags},@_);
+#
+ my @newkids;
+ my @lfirst = $self->madness('q');
+ my @llast = $self->madness('Q');
+ push @newkids,
+ @lfirst,
+ $self->madness('E'),
+ @llast;
+ my @rfirst = $self->madness('z');
+ my @repl = $self->madness('R');
+ my @rlast = $self->madness('Z');
+ my @mods = $self->madness('m');
+ if ($rfirst[-1]->uni ne $llast[-1]->uni) {
+ push @newkids, @rfirst;
+ }
+
+ push @newkids, @repl, @rlast, @mods;
+
+ my $res = $self->newtype->new(Kids => [@newkids]);
+ return $res;
+}
+
+package PLXML::op_sassign;
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+
+ my $right = $$self{Kids}[1];
+ eval { push @newkids, $right->ast($self, @_); };
+
+ push @newkids, $self->madness('o');
+
+ my $left = $$self{Kids}[0];
+ push @newkids, $left->ast($self, @_);
+
+ push @newkids, $self->madness(';'); # Nick
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_aassign;
+
+sub astnull { ast(@_) }
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+
+ my $right = $$self{Kids}[1];
+ push @newkids, $right->ast($self, @_);
+
+ push @newkids, $self->madness('o');
+
+ my $left = $$self{Kids}[0];
+ push @newkids, $left->ast($self, @_);
+
+ push @newkids, $self->madness(';'); # Nick
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_chop;
+package PLXML::op_schop;
+package PLXML::op_chomp;
+package PLXML::op_schomp;
+package PLXML::op_defined;
+package PLXML::op_undef;
+package PLXML::op_study;
+package PLXML::op_pos;
+package PLXML::op_preinc;
+
+sub ast {
+ my $self = shift;
+ if ($$self{targ}) { # stealth post inc or dec
+ return $self->PLXML::op_postinc::ast(@_);
+ }
+ return $self->SUPER::ast(@_);
+}
+
+package PLXML::op_i_preinc;
+
+sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
+
+package PLXML::op_predec;
+
+sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
+
+package PLXML::op_i_predec;
+
+sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
+
+package PLXML::op_postinc;
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+
+ if (exists $$self{Kids}) {
+ my $arg = $$self{Kids}[0];
+ push @newkids, $arg->ast($self, @_) if defined $arg;
+ }
+ push @newkids, $self->madness('o');
+
+ my $res = $self->newtype->new(Kids => [@newkids]);
+ return $res;
+}
+
+package PLXML::op_i_postinc;
+
+sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
+
+package PLXML::op_postdec;
+
+sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
+
+package PLXML::op_i_postdec;
+
+sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
+
+package PLXML::op_pow;
+package PLXML::op_multiply;
+package PLXML::op_i_multiply;
+package PLXML::op_divide;
+package PLXML::op_i_divide;
+package PLXML::op_modulo;
+package PLXML::op_i_modulo;
+package PLXML::op_repeat;
+
+sub ast {
+ my $self = shift;
+ return $self->SUPER::ast(@_)
+ unless exists $$self{private} and $$self{private} =~ /DOLIST/;
+
+ my $newself = $$self{Kids}[0]->ast($self,@_);
+ splice @{$newself->{Kids}}, -1, 0, $self->madness('o');
+
+ return bless $newself, $self->newtype; # rebless the op_null
+}
+
+package PLXML::op_add;
+package PLXML::op_i_add;
+package PLXML::op_subtract;
+package PLXML::op_i_subtract;
+package PLXML::op_concat;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+
+ my @after;
+ my $left = $$self{Kids}[0];
+ push @newkids, $left->ast($self, @_);
+
+ push @newkids, $self->madness('o');
+
+ my $right = $$self{Kids}[1];
+ push @newkids, $right->ast($self, @_);
+ return P5AST::op_concat->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+ my $parent = $_[0];
+ my @newkids;
+
+ my @after;
+ my $left = $$self{Kids}[0];
+ push @newkids, $left->ast($self, @_);
+
+ push @newkids, $self->madness('o');
+
+ my $right = $$self{Kids}[1];
+ push @newkids, $right->ast($self, @_);
+
+ return $self->newtype->new(Kids => [@newkids, @after]);
+}
+
+package PLXML::op_stringify;
+
+sub astnull {
+ ast(@_);
+}
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+ my @front = $self->madness('q (');
+ my @back = $self->madness(') Q');
+ my @M = $self->madness('M');
+ if (@M) {
+ push @newkids, $M[0], $self->madness('o');
+ }
+ push @newkids, @front;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ push @newkids, @back;
+ return P5AST::op_stringify->new(Kids => [@newkids]);
+}
+
+package PLXML::op_left_shift;
+package PLXML::op_right_shift;
+package PLXML::op_lt;
+package PLXML::op_i_lt;
+package PLXML::op_gt;
+package PLXML::op_i_gt;
+package PLXML::op_le;
+package PLXML::op_i_le;
+package PLXML::op_ge;
+package PLXML::op_i_ge;
+package PLXML::op_eq;
+package PLXML::op_i_eq;
+package PLXML::op_ne;
+package PLXML::op_i_ne;
+package PLXML::op_ncmp;
+package PLXML::op_i_ncmp;
+package PLXML::op_slt;
+package PLXML::op_sgt;
+package PLXML::op_sle;
+package PLXML::op_sge;
+package PLXML::op_seq;
+package PLXML::op_sne;
+package PLXML::op_scmp;
+package PLXML::op_bit_and;
+package PLXML::op_bit_xor;
+package PLXML::op_bit_or;
+package PLXML::op_negate;
+package PLXML::op_i_negate;
+package PLXML::op_not;
+
+sub ast {
+ my $self = shift;
+ my @newkids = $self->madness('o (');
+ my @swap;
+ if (@newkids and $newkids[-1]->uni eq '!~') {
+ @swap = @newkids;
+ @newkids = ();
+ }
+
+ if (exists $$self{Kids}) {
+ my $arg = $$self{Kids}[0];
+ push @newkids, $arg->ast($self, @_) if defined $arg;
+ }
+ if (@swap) {
+ splice @{$newkids[-1][0]{Kids}}, -2, 0, @swap; # XXX WAG
+ }
+ push @newkids, $self->madness(')');
+
+ my $res = $self->newtype->new(Kids => [@newkids]);
+ return $res;
+}
+
+package PLXML::op_complement;
+package PLXML::op_atan2;
+package PLXML::op_sin;
+package PLXML::op_cos;
+package PLXML::op_rand;
+package PLXML::op_srand;
+package PLXML::op_exp;
+package PLXML::op_log;
+package PLXML::op_sqrt;
+package PLXML::op_int;
+package PLXML::op_hex;
+package PLXML::op_oct;
+package PLXML::op_abs;
+package PLXML::op_length;
+package PLXML::op_substr;
+package PLXML::op_vec;
+package PLXML::op_index;
+package PLXML::op_rindex;
+package PLXML::op_sprintf;
+package PLXML::op_formline;
+package PLXML::op_ord;
+package PLXML::op_chr;
+package PLXML::op_crypt;
+package PLXML::op_ucfirst;
+
+sub ast {
+ my $self = shift;
+ return $self->PLXML::listop::ast(@_);
+}
+
+package PLXML::op_lcfirst;
+
+sub ast {
+ my $self = shift;
+ return $self->PLXML::listop::ast(@_);
+}
+
+package PLXML::op_uc;
+
+sub ast {
+ my $self = shift;
+ return $self->PLXML::listop::ast(@_);
+}
+
+package PLXML::op_lc;
+
+sub ast {
+ my $self = shift;
+ return $self->PLXML::listop::ast(@_);
+}
+
+package PLXML::op_quotemeta;
+
+sub ast {
+ my $self = shift;
+ return $self->PLXML::listop::ast(@_);
+}
+
+package PLXML::op_rv2av;
+
+sub astnull {
+ my $self = shift;
+ return P5AST::op_rv2av->new(Kids => [$self->madness('$ @')]);
+}
+
+sub ast {
+ my $self = shift;
+
+ if (ref $$self{Kids}[0] eq 'PLXML::op_const' and $$self{mp}{'O'}) {
+ return $self->madness('O');
+ }
+
+ my @before;
+ push @before, $self->madness('dx d (');
+
+ my @newkids;
+ push @newkids, $self->madness('$ @ K');
+ if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
+ push @newkids, $$self{Kids}[0]->ast();
+ }
+ my @after;
+ push @after, $self->madness(') a');
+ return $self->newtype->new(Kids => [@before, @newkids, @after]);
+}
+
+package PLXML::op_aelemfast;
+
+sub ast {
+ my $self = shift;
+ return $self->madness('$');
+}
+
+package PLXML::op_aelem;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('dx d');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ splice @newkids, -1, 0, $self->madness('a [');
+ push @newkids, $self->madness(']');
+ return P5AST::op_aelem->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @before = $self->madness('dx d');
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast(@_);
+ }
+ splice @newkids, -1, 0, $self->madness('a [');
+ push @newkids, $self->madness(']');
+
+ return $self->newtype->new(Kids => [@before, @newkids]);
+}
+
+package PLXML::op_aslice;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('[');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast(@_);
+ }
+ unshift @newkids, pop @newkids;
+ unshift @newkids, $self->madness('dx d');
+ push @newkids, $self->madness(']');
+ return P5AST::op_aslice->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('[');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast(@_);
+ }
+ unshift @newkids, pop @newkids;
+ unshift @newkids, $self->madness('dx d');
+ push @newkids, $self->madness(']');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_each;
+package PLXML::op_values;
+package PLXML::op_keys;
+package PLXML::op_delete;
+package PLXML::op_exists;
+package PLXML::op_rv2hv;
+
+sub astnull {
+ my $self = shift;
+ return P5AST::op_rv2hv->new(Kids => [$self->madness('$')]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @before;
+ push @before, $self->madness('dx d (');
+
+ my @newkids;
+ push @newkids, $self->madness('$ @ % K');
+ if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
+ push @newkids, $$self{Kids}[0]->ast();
+ }
+ my @after;
+ push @after, $self->madness(') a');
+ return $self->newtype->new(Kids => [@before, @newkids, @after]);
+}
+
+package PLXML::op_helem;
+
+sub astnull {
+ my $self = shift;
+ local $::curstate; # hash subscript potentially a lineseq
+ local $::curenc = $::curenc;
+
+ my @newkids;
+ push @newkids, $self->madness('dx d');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ splice @newkids, -1, 0, $self->madness('a {');
+ push @newkids, $self->madness('}');
+ return P5AST::op_helem->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+ local $::curstate; # hash subscript potentially a lineseq
+ local $::curenc = $::curenc;
+
+ my @before = $self->madness('dx d');
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ splice @newkids, -1, 0, $self->madness('a {');
+ push @newkids, $self->madness('}');
+
+ return $self->newtype->new(Kids => [@before, @newkids]);
+}
+
+
+package PLXML::op_hslice;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('{');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast(@_);
+ }
+ unshift @newkids, pop @newkids;
+ unshift @newkids, $self->madness('dx d');
+ push @newkids, $self->madness('}');
+ return P5AST::op_hslice->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('{');
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast(@_);
+ }
+ unshift @newkids, pop @newkids;
+ unshift @newkids, $self->madness('dx d');
+ push @newkids, $self->madness('}');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_unpack;
+package PLXML::op_pack;
+package PLXML::op_split;
+package PLXML::op_join;
+package PLXML::op_list;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ my @retval;
+ my @before;
+ if (@retval = $self->madness('X')) {
+ push @before, $self->madness('x o');
+ return @before,@retval;
+ }
+ my @kids = @{$$self{Kids}};
+ for my $kid (@kids) {
+ next if ref $kid eq 'PLXML::op_pushmark';
+ next if ref $kid eq 'PLXML::op_null' and
+ defined $$kid{was} and $$kid{was} eq 'pushmark';
+ push @newkids, $kid->ast($self, @_);
+ }
+
+ my $x = "";
+ my @newnewkids = ();
+ push @newnewkids, $self->madness('dx d (');
+ push @newnewkids, @newkids;
+ push @newnewkids, $self->madness(') :');
+ return P5AST::op_list->new(Kids => [@newnewkids]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @retval;
+ my @before;
+ if (@retval = $self->madness('X')) {
+ push @before, $self->madness('o');
+ return $self->newtype->new(Kids => [@before,@retval]);
+ }
+ push @retval, $self->madness('dx d (');
+
+ my @newkids;
+ for my $kid (@{$$self{Kids}}) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ my $x = "";
+ my @newnewkids = ();
+ push @newnewkids, @newkids;
+ @newkids = @newnewkids;
+ push @retval, @newkids;
+ push @retval, $self->madness(') :');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_lslice;
+
+sub ast {
+ my $self = shift;
+ my @newkids;
+
+ if ($$self{mp}{q}) {
+ push @newkids, $self->madness('q = Q');
+ }
+ elsif ($$self{mp}{x}) {
+ push @newkids, $self->madness('x');
+ }
+ else {
+ push @newkids, $self->madness('(');
+ my $list = $$self{Kids}[1];
+ push @newkids, $list->ast($self, @_);
+ push @newkids, $self->madness(')');
+ }
+
+ push @newkids, $self->madness('[');
+
+ my $slice = $$self{Kids}[0];
+ push @newkids, $slice->ast($self, @_);
+ push @newkids, $self->madness(']');
+
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_anonlist;
+package PLXML::op_anonhash;
+package PLXML::op_splice;
+package PLXML::op_push;
+package PLXML::op_pop;
+package PLXML::op_shift;
+package PLXML::op_unshift;
+package PLXML::op_sort;
+package PLXML::op_reverse;
+
+sub astnull {
+ my $self = shift;
+ $self->PLXML::listop::ast(@_);
+}
+
+package PLXML::op_grepstart;
+package PLXML::op_grepwhile;
+package PLXML::op_mapstart;
+package PLXML::op_mapwhile;
+package PLXML::op_range;
+
+sub ast {
+ my $self = shift;
+ return $self->PLXML::binop::ast(@_);
+}
+
+package PLXML::op_flip;
+package PLXML::op_flop;
+package PLXML::op_and;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ my @first = $self->madness('1');
+ my @second = $self->madness('2');
+ my @stuff = $$self{Kids}[0]->ast();
+ if (my @I = $self->madness('I')) {
+ if (@second) {
+ push @newkids, @I;
+ push @newkids, $self->madness('(');
+ push @newkids, @stuff;
+ push @newkids, $self->madness(')');
+ push @newkids, @second;
+ }
+ else {
+ push @newkids, @I;
+ push @newkids, $self->madness('(');
+ push @newkids, @first;
+ push @newkids, $self->madness(')');
+ push @newkids, @stuff;
+ }
+ }
+ elsif (my @i = $self->madness('i')) {
+ if (@second) {
+ push @newkids, @second;
+ push @newkids, @i;
+ push @newkids, @stuff;
+ }
+ else {
+ push @newkids, @stuff;
+ push @newkids, @i;
+ push @newkids, @first;
+ }
+ }
+ elsif (my @o = $self->madness('o')) {
+ if (@second) {
+ push @newkids, @stuff;
+ push @newkids, @o;
+ push @newkids, @second;
+ }
+ else {
+ push @newkids, @first;
+ push @newkids, @o;
+ push @newkids, @stuff;
+ }
+ }
+ return P5AST::op_and->new(Kids => [@newkids]);
+}
+
+package PLXML::op_or;
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ my @first = $self->madness('1');
+ my @second = $self->madness('2');
+ my @i = $self->madness('i');
+ my @stuff = $$self{Kids}[0]->ast();
+ if (@second) {
+ if (@i) {
+ push @newkids, @second;
+ push @newkids, $self->madness('i');
+ push @newkids, @stuff;
+ }
+ else {
+ push @newkids, @stuff;
+ push @newkids, $self->madness('o');
+ push @newkids, @second;
+ }
+ }
+ else {
+ if (@i) {
+ push @newkids, @stuff;
+ push @newkids, $self->madness('i');
+ push @newkids, @first;
+ }
+ else {
+ push @newkids, @first;
+ push @newkids, $self->madness('o');
+ push @newkids, @stuff;
+ }
+ }
+ return "P5AST::op_$$self{was}"->new(Kids => [@newkids]);
+}
+
+
+package PLXML::op_xor;
+package PLXML::op_cond_expr;
+package PLXML::op_andassign;
+package PLXML::op_orassign;
+package PLXML::op_method;
+package PLXML::op_entersub;
+
+sub ast {
+ my $self = shift;
+
+ if ($$self{mp}{q}) {
+ return $self->madness('q = Q');
+ }
+ if ($$self{mp}{X}) { # <FH> override?
+ return $self->madness('X');
+ }
+ if ($$self{mp}{A}) {
+ return $self->astmethod(@_);
+ }
+ if ($$self{mp}{a}) {
+ return $self->astarrow(@_);
+ }
+
+ my @retval;
+
+ my @newkids;
+ my @kids = @{$$self{Kids}};
+ if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
+ @kids = @{$kids[0]{Kids}};
+ }
+ my $dest = pop @kids;
+ my @dest = $dest->ast($self, @_);
+
+ if (ref($dest) =~ /method/) {
+ my $invocant = shift @kids;
+ $invocant = shift @kids if ref($invocant) eq 'PLXML::op_pushmark';
+ my @invocant = $invocant->ast($self, @_);
+ push @retval, @dest;
+ push @retval, @invocant;
+ }
+ elsif (exists $$self{mp}{o} and $$self{mp}{o} eq 'do') {
+ push @retval, $self->madness('o');
+ push @retval, @dest;
+ }
+ else {
+ push @retval, $self->madness('o');
+ push @retval, @dest;
+ }
+ while (@kids) {
+ my $kid = shift(@kids);
+ push @newkids, $kid->ast($self, @_);
+ }
+
+ push @retval, $self->madness('(');
+ push @retval, @newkids;
+ push @retval, $self->madness(')');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+sub astmethod {
+ my $self = shift;
+ my @newkids;
+ my @kids;
+ for my $kid (@{$$self{Kids}}) {
+ next if ref $kid eq 'PLXML::op_pushmark';
+ next if ref $kid eq 'PLXML::op_null' and
+ defined $$kid{was} and $$kid{was} eq 'pushmark';
+ push @kids, $kid;
+ }
+ my @invocant;
+ if ($$self{flags} =~ /\bSTACKED\b/) {
+ push @invocant, shift(@kids)->ast($self, @_);
+ }
+ for my $kid (@kids) {
+ push @newkids, $kid->ast($self, @_);
+ }
+ my $dest = pop(@newkids);
+ if (ref $dest eq 'PLXML::op_rv2cv' and $$self{flags} =~ /\bMOD\b/) {
+ $dest = pop(@newkids);
+ }
+ my $x = "";
+ my @retval;
+ push @retval, @invocant;
+ push @retval, $self->madness('A');
+ push @retval, $dest;
+ push @retval, $self->madness('(');
+ push @retval, @newkids;
+ push @retval, $self->madness(')');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+sub astarrow {
+ my $self = shift;
+ my @newkids;
+ my @retval;
+ my @kids = @{$$self{Kids}};
+ if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
+ @kids = @{$kids[0]{Kids}};
+ }
+ while (@kids > 1) {
+ my $kid = shift(@kids);
+ push @newkids, $kid->ast($self, @_);
+ }
+ my @dest = $kids[0]->ast($self, @_);
+ my $x = "";
+ push @retval, @dest;
+ push @retval, $self->madness('a');
+ push @retval, $self->madness('(');
+ push @retval, @newkids;
+ push @retval, $self->madness(')');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_leavesub;
+
+sub ast {
+ my $self = shift;
+ if (ref $$self{Kids}[0] eq "PLXML::op_null") {
+ return $$self{Kids}[0]->ast(@_);
+ }
+ return $$self{Kids}[0]->blockast($self, @_);
+}
+
+package PLXML::op_leavesublv;
+
+sub ast {
+ my $self = shift;
+
+ return $$self{Kids}[0]->blockast($self, @_);
+}
+
+package PLXML::op_caller;
+package PLXML::op_warn;
+package PLXML::op_die;
+package PLXML::op_reset;
+package PLXML::op_lineseq;
+
+sub lineseq {
+ my $self = shift;
+ my @kids = @{$$self{Kids}};
+ local $::curstate = 0; # (probably redundant, but that's okay)
+ local $::prevstate = 0;
+ local $::curenc = $::curenc;
+ my @retval;
+ my @newstuff;
+ my $newprev;
+ while (@kids) {
+ my $kid = shift @kids;
+ my $thing = $kid->ast($self, @_);
+ next unless defined $thing;
+ if ($::curstate ne $::prevstate) {
+ if ($::prevstate) {
+ push @newstuff, $::prevstate->madness(';');
+ push @{$newprev->{Kids}}, @newstuff if $newprev;
+ @newstuff = ();
+ }
+ $::prevstate = $::curstate;
+ $newprev = $thing;
+ push @retval, $thing;
+ }
+ elsif ($::prevstate) {
+ push @newstuff, $thing;
+ }
+ else {
+ push @retval, $thing;
+ }
+ }
+ if ($::prevstate) {
+ push @newstuff, $::prevstate->madness(';');
+ push @{$newprev->{Kids}}, @newstuff if $newprev;
+ @newstuff = ();
+ $::prevstate = 0;
+ }
+ return @retval;
+}
+
+sub blockast {
+ my $self = shift;
+ local $::curstate;
+
+ my @retval;
+ push @retval, $self->madness('{');
+
+ my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
+ push @retval, @newkids;
+
+ push @retval, $self->madness('; }');
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_nextstate;
+
+sub newtype { return "P5AST::statement" }
+
+sub astnull {
+ my $self = shift;
+ my @newkids;
+ push @newkids, $self->madness('L');
+ $::curstate = $self;
+ return P5AST::statement->new(Kids => [@newkids]);
+}
+
+sub ast {
+ my $self = shift;
+
+ my @newkids;
+ push @newkids, $self->madness('L');
+ $::curstate = $self;
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+
+package PLXML::op_dbstate;
+package PLXML::op_unstack;
+package PLXML::op_enter;
+
+sub ast { () }
+
+package PLXML::op_leave;
+
+sub astnull {
+ ast(@_);
+}
+
+sub ast {
+ my $self = shift;
+
+ my $mad = $$self{mp}{FIRST} || "unknown";
+
+ my @retval;
+ if ($mad eq 'w') {
+ my @newkids;
+ my @tmpkids;
+ push @tmpkids, $self->{Kids};
+ my $anddo = $$self{Kids}[-1]{Kids}[0]{Kids};
+ eval { push @newkids, $anddo->[1]->ast($self,@_); };
+ push @newkids, "[[[NOANDDO]]]" if $@;
+ push @newkids, $self->madness('w');
+ push @newkids, $anddo->[0]->ast($self,@_);
+
+ return $self->newtype->new(Kids => [@newkids]);
+ }
+
+ local $::curstate;
+ push @retval, $self->madness('o {');
+
+ my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
+ push @retval, @newkids;
+ push @retval, $self->madness(q/; }/);
+ my $retval = $self->newtype->new(Kids => [@retval]);
+
+ if ($$self{mp}{C}) {
+ my @before;
+ my @after;
+ push @before, $self->madness('I ( C )');
+ if ($$self{mp}{t}) {
+ push @before, $self->madness('t');
+ }
+ elsif ($$self{mp}{e}) {
+ push @after, $self->madness('e');
+ }
+ return P5AST::op_cond->new(Kids => [@before, $retval, @after]);
+ }
+ else {
+ return $retval;
+ }
+}
+
+package PLXML::op_scope;
+
+sub ast {
+ my $self = shift;
+ local $::curstate;
+
+ my @newkids;
+ push @newkids, $self->madness('o');
+
+ push @newkids, $self->madness('{');
+ push @newkids, $self->PLXML::op_lineseq::lineseq(@_);
+ push @newkids, $self->madness('; }');
+
+ my @folded = $self->madness('C');
+ if (@folded) {
+ my @t = $self->madness('t');
+ my @e = $self->madness('e');
+ if (@e) {
+ return $self->newtype->new(
+ Kids => [
+ $self->madness('I ('),
+ @folded,
+ $self->madness(')'),
+ $self->newtype->new(Kids => [@newkids]),
+ @e
+ ] );
+ }
+ else {
+ return $self->newtype->new(
+ Kids => [
+ $self->madness('I ('),
+ @folded,
+ $self->madness(')'),
+ @t,
+ $self->newtype->new(Kids => [@newkids])
+ ] );
+ }
+ }
+ return $self->newtype->new(Kids => [@newkids]);
+}
+
+package PLXML::op_enteriter;
+
+sub ast {
+ my $self = shift;
+ my (undef,$range,$var) = @{$self->{Kids}};
+ my @retval;
+ push @retval, $self->madness('v');
+ if (!@retval and defined $var) {
+ push @retval, $var->ast($self,@_);
+ }
+ else {
+ push @retval, '';
+ }
+ if (ref $range eq 'PLXML::op_null' and $$self{flags} =~ /STACKED/) {
+ my (undef,$min,$max) = @{$range->{Kids}};
+ push @retval, $min->ast($self,@_);
+ if (defined $max) {
+ if (exists $$range{mp}{O}) { # deeply buried .. operator
+ PLXML::prepreproc($$range{mp}{O});
+ push @retval,
+ $$range{mp}{'O'}{Kids}[0]{Kids}[0]{Kids}[0]{Kids}[0]->madness('o')
+ }
+ else {
+ push @retval, '..'; # XXX missing whitespace
+ }
+ push @retval, $max->ast($self,@_);
+ }
+ }
+ else {
+ push @retval, $range->ast($self,@_);
+ }
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_iter;
+package PLXML::op_enterloop;
+
+sub ast {
+}
+
+package PLXML::op_leaveloop;
+
+sub ast {
+ my $self = shift;
+
+ my @retval;
+ my @newkids;
+ my $enterloop = $$self{Kids}[0];
+ my $nextthing = $$self{Kids}[1];
+
+ if ($$self{mp}{W}) {
+ push @retval, $self->madness('L');
+ push @newkids, $self->madness('W d');
+
+ if (ref $enterloop eq 'PLXML::op_enteriter') {
+ my ($var,@rest) = @{$enterloop->ast($self,@_)->{Kids}};
+ push @newkids, $var if $var;
+ push @newkids, $self->madness('q ( x = Q');
+ push @newkids, @rest;
+ }
+ else {
+ push @newkids, $self->madness('(');
+ push @newkids, $enterloop->ast($self,@_);
+ }
+ }
+ my $andor;
+
+ if (ref $nextthing eq 'PLXML::op_null') {
+ if ($$nextthing{mp}{'1'}) {
+ push @newkids, $nextthing->madness('1');
+ push @newkids, $self->madness(')');
+ push @newkids, $$nextthing{Kids}[0]->blockast($self,@_);
+ }
+ elsif ($$nextthing{mp}{'2'}) {
+ push @newkids, $$nextthing{Kids}[0]->ast($self,@_);
+ push @newkids, $self->madness(')');
+ push @newkids, $$nextthing{mp}{'2'}->blockast($self,@_);
+ }
+ elsif ($$nextthing{mp}{'U'}) {
+ push @newkids, $nextthing->ast($self,@_);
+ }
+ else {
+ # bypass the op_null
+ $andor = $nextthing->{Kids}[0];
+ eval {
+ push @newkids, $$andor{Kids}[0]->ast($self, @_);
+ };
+ push @newkids, $self->madness(')');
+ eval {
+ push @newkids, $$andor{Kids}[1]->blockast($self, @_);
+ };
+ }
+ }
+ else {
+ $andor = $nextthing;
+ push @newkids, $nextthing->madness('O');
+ push @newkids, $self->madness(')');
+ push @newkids, $nextthing->blockast($self, @_);
+ }
+ if ($$self{mp}{w}) {
+ push @newkids, $self->madness('w');
+ push @newkids, $enterloop->ast($self,@_);
+ }
+
+ push @retval, @newkids;
+
+ return $self->newtype->new(Kids => [@retval]);
+}
+
+package PLXML::op_return;
+package PLXML::op_last;
+package PLXML::op_next;
+package PLXML::op_redo;
+package PLXML::op_dump;
+package PLXML::op_goto;
+package PLXML::op_exit;
+package PLXML::op_open;
+package PLXML::op_close;
+package PLXML::op_pipe_op;
+package PLXML::op_fileno;
+package PLXML::op_umask;
+package PLXML::op_binmode;
+package PLXML::op_tie;
+package PLXML::op_untie;
+package PLXML::op_tied;
+package PLXML::op_dbmopen;
+package PLXML::op_dbmclose;
+package PLXML::op_sselect;
+package PLXML::op_select;
+package PLXML::op_getc;
+package PLXML::op_read;
+package PLXML::op_enterwrite;
+package PLXML::op_leavewrite;
+package PLXML::op_prtf;
+package PLXML::op_print;
+package PLXML::op_say;
+package PLXML::op_sysopen;
+package PLXML::op_sysseek;
+package PLXML::op_sysread;
+package PLXML::op_syswrite;
+package PLXML::op_send;
+package PLXML::op_recv;
+package PLXML::op_eof;
+package PLXML::op_tell;
+package PLXML::op_seek;
+package PLXML::op_truncate;
+package PLXML::op_fcntl;
+package PLXML::op_ioctl;
+package PLXML::op_flock;
+package PLXML::op_socket;
+package PLXML::op_sockpair;
+package PLXML::op_bind;
+package PLXML::op_connect;
+package PLXML::op_listen;
+package PLXML::op_accept;
+package PLXML::op_shutdown;
+package PLXML::op_gsockopt;
+package PLXML::op_ssockopt;
+package PLXML::op_getsockname;
+package PLXML::op_getpeername;
+package PLXML::op_lstat;
+package PLXML::op_stat;
+package PLXML::op_ftrread;
+package PLXML::op_ftrwrite;
+package PLXML::op_ftrexec;
+package PLXML::op_fteread;
+package PLXML::op_ftewrite;
+package PLXML::op_fteexec;
+package PLXML::op_ftis;
+package PLXML::op_fteowned;
+package PLXML::op_ftrowned;
+package PLXML::op_ftzero;
+package PLXML::op_ftsize;
+package PLXML::op_ftmtime;
+package PLXML::op_ftatime;
+package PLXML::op_ftctime;
+package PLXML::op_ftsock;
+package PLXML::op_ftchr;
+package PLXML::op_ftblk;
+package PLXML::op_ftfile;
+package PLXML::op_ftdir;
+package PLXML::op_ftpipe;
+package PLXML::op_ftlink;
+package PLXML::op_ftsuid;
+package PLXML::op_ftsgid;
+package PLXML::op_ftsvtx;
+package PLXML::op_fttty;
+package PLXML::op_fttext;
+package PLXML::op_ftbinary;
+package PLXML::op_chdir;
+package PLXML::op_chown;
+package PLXML::op_chroot;
+package PLXML::op_unlink;
+package PLXML::op_chmod;
+package PLXML::op_utime;
+package PLXML::op_rename;
+package PLXML::op_link;
+package PLXML::op_symlink;
+package PLXML::op_readlink;
+package PLXML::op_mkdir;
+package PLXML::op_rmdir;
+package PLXML::op_open_dir;
+package PLXML::op_readdir;
+package PLXML::op_telldir;
+package PLXML::op_seekdir;
+package PLXML::op_rewinddir;
+package PLXML::op_closedir;
+package PLXML::op_fork;
+package PLXML::op_wait;
+package PLXML::op_waitpid;
+package PLXML::op_system;
+package PLXML::op_exec;
+package PLXML::op_kill;
+package PLXML::op_getppid;
+package PLXML::op_getpgrp;
+package PLXML::op_setpgrp;
+package PLXML::op_getpriority;
+package PLXML::op_setpriority;
+package PLXML::op_time;
+package PLXML::op_tms;
+package PLXML::op_localtime;
+package PLXML::op_gmtime;
+package PLXML::op_alarm;
+package PLXML::op_sleep;
+package PLXML::op_shmget;
+package PLXML::op_shmctl;
+package PLXML::op_shmread;
+package PLXML::op_shmwrite;
+package PLXML::op_msgget;
+package PLXML::op_msgctl;
+package PLXML::op_msgsnd;
+package PLXML::op_msgrcv;
+package PLXML::op_semget;
+package PLXML::op_semctl;
+package PLXML::op_semop;
+package PLXML::op_require;
+package PLXML::op_dofile;
+package PLXML::op_entereval;
+
+sub ast {
+ my $self = shift;
+ local $::curstate; # eval {} has own statement sequence
+ return $self->SUPER::ast(@_);
+}
+
+package PLXML::op_leaveeval;
+package PLXML::op_entertry;
+package PLXML::op_leavetry;
+
+sub ast {
+ my $self = shift;
+
+ return $self->PLXML::op_leave::ast(@_);
+}
+
+package PLXML::op_ghbyname;
+package PLXML::op_ghbyaddr;
+package PLXML::op_ghostent;
+package PLXML::op_gnbyname;
+package PLXML::op_gnbyaddr;
+package PLXML::op_gnetent;
+package PLXML::op_gpbyname;
+package PLXML::op_gpbynumber;
+package PLXML::op_gprotoent;
+package PLXML::op_gsbyname;
+package PLXML::op_gsbyport;
+package PLXML::op_gservent;
+package PLXML::op_shostent;
+package PLXML::op_snetent;
+package PLXML::op_sprotoent;
+package PLXML::op_sservent;
+package PLXML::op_ehostent;
+package PLXML::op_enetent;
+package PLXML::op_eprotoent;
+package PLXML::op_eservent;
+package PLXML::op_gpwnam;
+package PLXML::op_gpwuid;
+package PLXML::op_gpwent;
+package PLXML::op_spwent;
+package PLXML::op_epwent;
+package PLXML::op_ggrnam;
+package PLXML::op_ggrgid;
+package PLXML::op_ggrent;
+package PLXML::op_sgrent;
+package PLXML::op_egrent;
+package PLXML::op_getlogin;
+package PLXML::op_syscall;
+package PLXML::op_lock;
+package PLXML::op_threadsv;
+package PLXML::op_setstate;
+package PLXML::op_method_named;
+
+sub ast {
+ my $self = shift;
+ return $self->madness('O');
+}
+
+package PLXML::op_dor;
+
+sub astnull {
+ my $self = shift;
+ $self->PLXML::op_or::astnull(@_);
+}
+
+package PLXML::op_dorassign;
+package PLXML::op_custom;
+
--- /dev/null
+package P5AST;
+
+$::herequeue = '';
+
+1;
+
+{
+ my %newkey = qw(
+ );
+
+ sub translate {
+ my $class = shift;
+ my $key = shift;
+ $key = $newkey{$key} || "op_$key";
+ return "P5AST::$key";
+ }
+}
+
+sub new {
+ my $class = shift;
+ bless {@_}, $class;
+}
+
+sub AUTOLOAD {
+ warn "AUTOLOAD $P5AST::AUTOLOAD(" . join(',', @_) . ")\n";
+}
+
+sub DESTROY { }
+
+sub p5arraytext {
+ my $kid = shift;
+ my $text = "";
+ for my $subkid (@$kid) {
+ my $type = ref $subkid;
+ if ($type eq 'ARRAY') {
+ if ($dowarn) {
+ warn "Extra array\n";
+ $text .= '〔 '. p5arraytext($subkid) . ' 〕';
+ }
+ else {
+ $text .= p5arraytext($subkid);
+ }
+ }
+ elsif ($type =~ /^p5::/) {
+ my $newtext = $subkid->enc();
+ if ($::herequeue && $newtext =~ s/\n/\n$::herequeue/) {
+ $::herequeue = '';
+ }
+ $text .= $newtext;
+ }
+ elsif ($type) {
+ $text .= $subkid->text(@_);
+ }
+ else {
+ $text .= $subkid;
+ }
+ }
+ return $text;
+}
+
+sub p5text {
+ my $self = shift;
+# my $pre = $self->pretext();
+# my $post = $self->posttext();
+ my $text = "";
+ foreach my $kid (@{$$self{Kids}}) {
+ my $type = ref $kid;
+ if ($type eq 'ARRAY') {
+ $text .= p5arraytext($kid);
+ }
+ elsif ($type =~ /^p5::/) {
+ my $newtext = $kid->enc();
+ if ($::herequeue && $newtext =~ s/\n/\n$::herequeue/) {
+ $::herequeue = '';
+ }
+ $text .= $newtext;
+ }
+ elsif ($type eq "chomp") {
+ $text =~ s/\n$//g;
+ }
+ elsif ($type) {
+ $text .= $kid->p5text(@_);
+ }
+ elsif (defined $kid) {
+ $text .= $kid;
+ }
+ else {
+ $text .= '[[[ UNDEF ]]]';
+ }
+ }
+ return $text;
+}
+
+sub p5subtext {
+ my $self = shift;
+ my @text;
+ foreach my $kid (@{$$self{Kids}}) {
+ my $text = $kid->p5text(@_);
+ push @text, $text if defined $text;
+ }
+ return @text;
+}
+
+sub p6text {
+ return $_[0]->p5text(); # assume it's the same
+}
+
+package P5AST::heredoc; @ISA = 'P5AST';
+
+sub p5text {
+ my $self = shift;
+ my $newdoc;
+ {
+ local $::herequeue; # don't interpolate outer heredoc yet
+ $newdoc = $self->{doc}->p5text(@_) . $self->{end}->enc();
+ if ($::herequeue) { # heredoc within the heredoc?
+ $newdoc .= $::herequeue;
+ $::herequeue = '';
+ }
+ }
+ $::herequeue .= $newdoc;
+ my $start = $self->{start};
+ my $type = ref $start;
+ if ($type =~ /^p5::/) { # XXX too much cut-n-paste here...
+ return $start->enc();
+ }
+ elsif ($type) {
+ return $start->p5text(@_);
+ }
+ else {
+ return $start;
+ }
+}
+
+package P5AST::BAD;
+
+sub p5text {
+ my $self = shift;
+ my $t = ref $t;
+ warn "Shouldn't have a node of type $t";
+}
+
+package P5AST::baseop; @ISA = 'P5AST';
+package P5AST::baseop_unop; @ISA = 'P5AST::baseop';
+package P5AST::binop; @ISA = 'P5AST::baseop';
+package P5AST::cop; @ISA = 'P5AST::baseop';
+package P5AST::filestatop; @ISA = 'P5AST::baseop';
+package P5AST::listop; @ISA = 'P5AST::baseop';
+package P5AST::logop; @ISA = 'P5AST::baseop';
+package P5AST::loop; @ISA = 'P5AST::baseop';
+package P5AST::loopexop; @ISA = 'P5AST::baseop';
+package P5AST::padop; @ISA = 'P5AST::baseop';
+package P5AST::padop_svop; @ISA = 'P5AST::baseop';
+package P5AST::pmop; @ISA = 'P5AST::baseop';
+package P5AST::pvop_svop; @ISA = 'P5AST::baseop';
+package P5AST::unop; @ISA = 'P5AST::baseop';
+
+# Nothing.
+
+package P5AST::op_null; @ISA = 'P5AST::baseop';
+package P5AST::op_padrange; @ISA = 'P5AST::baseop'; # Nick
+package P5AST::op_stub; @ISA = 'P5AST::baseop';
+package P5AST::op_scalar; @ISA = 'P5AST::baseop_unop';
+
+# Pushy stuff.
+
+package P5AST::op_pushmark; @ISA = 'P5AST::baseop';
+package P5AST::op_wantarray; @ISA = 'P5AST::baseop';
+package P5AST::op_const; @ISA = 'P5AST::padop_svop';
+package P5AST::op_gvsv; @ISA = 'P5AST::padop_svop';
+package P5AST::op_gv; @ISA = 'P5AST::padop_svop';
+package P5AST::op_gelem; @ISA = 'P5AST::binop';
+package P5AST::op_padsv; @ISA = 'P5AST::baseop';
+package P5AST::op_padav; @ISA = 'P5AST::baseop';
+package P5AST::op_padhv; @ISA = 'P5AST::baseop';
+package P5AST::op_padany; @ISA = 'P5AST::baseop';
+package P5AST::op_pushre; @ISA = 'P5AST::pmop';
+package P5AST::op_rv2gv; @ISA = 'P5AST::unop';
+package P5AST::op_rv2sv; @ISA = 'P5AST::unop';
+package P5AST::op_av2arylen; @ISA = 'P5AST::unop';
+package P5AST::op_rv2cv; @ISA = 'P5AST::unop';
+package P5AST::op_anoncode; @ISA = 'P5AST::padop_svop';
+package P5AST::op_prototype; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_refgen; @ISA = 'P5AST::unop';
+package P5AST::op_srefgen; @ISA = 'P5AST::unop';
+package P5AST::op_ref; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_bless; @ISA = 'P5AST::listop';
+package P5AST::op_backtick; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_glob; @ISA = 'P5AST::listop';
+package P5AST::op_readline; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_rcatline; @ISA = 'P5AST::padop_svop';
+package P5AST::op_regcmaybe; @ISA = 'P5AST::unop';
+package P5AST::op_regcreset; @ISA = 'P5AST::unop';
+package P5AST::op_regcomp; @ISA = 'P5AST::logop';
+package P5AST::op_match; @ISA = 'P5AST::pmop';
+package P5AST::op_qr; @ISA = 'P5AST::pmop';
+package P5AST::op_subst; @ISA = 'P5AST::pmop';
+package P5AST::op_substcont; @ISA = 'P5AST::logop';
+package P5AST::op_trans; @ISA = 'P5AST::pvop_svop';
+package P5AST::op_sassign; @ISA = 'P5AST::baseop';
+package P5AST::op_aassign; @ISA = 'P5AST::binop';
+package P5AST::op_chop; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_schop; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_chomp; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_schomp; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_defined; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_undef; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_study; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_pos; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_preinc; @ISA = 'P5AST::unop';
+package P5AST::op_i_preinc; @ISA = 'P5AST::unop';
+package P5AST::op_predec; @ISA = 'P5AST::unop';
+package P5AST::op_i_predec; @ISA = 'P5AST::unop';
+package P5AST::op_postinc; @ISA = 'P5AST::unop';
+package P5AST::op_i_postinc; @ISA = 'P5AST::unop';
+package P5AST::op_postdec; @ISA = 'P5AST::unop';
+package P5AST::op_i_postdec; @ISA = 'P5AST::unop';
+package P5AST::op_pow; @ISA = 'P5AST::binop';
+package P5AST::op_multiply; @ISA = 'P5AST::binop';
+package P5AST::op_i_multiply; @ISA = 'P5AST::binop';
+package P5AST::op_divide; @ISA = 'P5AST::binop';
+package P5AST::op_i_divide; @ISA = 'P5AST::binop';
+package P5AST::op_modulo; @ISA = 'P5AST::binop';
+package P5AST::op_i_modulo; @ISA = 'P5AST::binop';
+package P5AST::op_repeat; @ISA = 'P5AST::binop';
+package P5AST::op_add; @ISA = 'P5AST::binop';
+package P5AST::op_i_add; @ISA = 'P5AST::binop';
+package P5AST::op_subtract; @ISA = 'P5AST::binop';
+package P5AST::op_i_subtract; @ISA = 'P5AST::binop';
+package P5AST::op_concat; @ISA = 'P5AST::binop';
+package P5AST::op_stringify; @ISA = 'P5AST::listop';
+package P5AST::op_left_shift; @ISA = 'P5AST::binop';
+package P5AST::op_right_shift; @ISA = 'P5AST::binop';
+package P5AST::op_lt; @ISA = 'P5AST::binop';
+package P5AST::op_i_lt; @ISA = 'P5AST::binop';
+package P5AST::op_gt; @ISA = 'P5AST::binop';
+package P5AST::op_i_gt; @ISA = 'P5AST::binop';
+package P5AST::op_le; @ISA = 'P5AST::binop';
+package P5AST::op_i_le; @ISA = 'P5AST::binop';
+package P5AST::op_ge; @ISA = 'P5AST::binop';
+package P5AST::op_i_ge; @ISA = 'P5AST::binop';
+package P5AST::op_eq; @ISA = 'P5AST::binop';
+package P5AST::op_i_eq; @ISA = 'P5AST::binop';
+package P5AST::op_ne; @ISA = 'P5AST::binop';
+package P5AST::op_i_ne; @ISA = 'P5AST::binop';
+package P5AST::op_ncmp; @ISA = 'P5AST::binop';
+package P5AST::op_i_ncmp; @ISA = 'P5AST::binop';
+package P5AST::op_slt; @ISA = 'P5AST::binop';
+package P5AST::op_sgt; @ISA = 'P5AST::binop';
+package P5AST::op_sle; @ISA = 'P5AST::binop';
+package P5AST::op_sge; @ISA = 'P5AST::binop';
+package P5AST::op_seq; @ISA = 'P5AST::binop';
+package P5AST::op_sne; @ISA = 'P5AST::binop';
+package P5AST::op_scmp; @ISA = 'P5AST::binop';
+package P5AST::op_bit_and; @ISA = 'P5AST::binop';
+package P5AST::op_bit_xor; @ISA = 'P5AST::binop';
+package P5AST::op_bit_or; @ISA = 'P5AST::binop';
+package P5AST::op_negate; @ISA = 'P5AST::unop';
+package P5AST::op_i_negate; @ISA = 'P5AST::unop';
+package P5AST::op_not; @ISA = 'P5AST::unop';
+package P5AST::op_complement; @ISA = 'P5AST::unop';
+package P5AST::op_atan2; @ISA = 'P5AST::listop';
+package P5AST::op_sin; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_cos; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_rand; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_srand; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_exp; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_log; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_sqrt; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_int; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_hex; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_oct; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_abs; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_length; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_substr; @ISA = 'P5AST::listop';
+package P5AST::op_vec; @ISA = 'P5AST::listop';
+package P5AST::op_index; @ISA = 'P5AST::listop';
+package P5AST::op_rindex; @ISA = 'P5AST::listop';
+package P5AST::op_sprintf; @ISA = 'P5AST::listop';
+package P5AST::op_formline; @ISA = 'P5AST::listop';
+package P5AST::op_ord; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_chr; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_crypt; @ISA = 'P5AST::listop';
+package P5AST::op_ucfirst; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_lcfirst; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_uc; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_lc; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_quotemeta; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_rv2av; @ISA = 'P5AST::unop';
+package P5AST::op_aelemfast; @ISA = 'P5AST::padop_svop';
+package P5AST::op_aelem; @ISA = 'P5AST::binop';
+package P5AST::op_aslice; @ISA = 'P5AST::listop';
+package P5AST::op_each; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_values; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_keys; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_delete; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_exists; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_rv2hv; @ISA = 'P5AST::unop';
+package P5AST::op_helem; @ISA = 'P5AST::listop';
+package P5AST::op_hslice; @ISA = 'P5AST::listop';
+package P5AST::op_unpack; @ISA = 'P5AST::listop';
+package P5AST::op_pack; @ISA = 'P5AST::listop';
+package P5AST::op_split; @ISA = 'P5AST::listop';
+package P5AST::op_join; @ISA = 'P5AST::listop';
+package P5AST::op_list; @ISA = 'P5AST::listop';
+package P5AST::op_lslice; @ISA = 'P5AST::binop';
+package P5AST::op_anonlist; @ISA = 'P5AST::listop';
+package P5AST::op_anonhash; @ISA = 'P5AST::listop';
+package P5AST::op_splice; @ISA = 'P5AST::listop';
+package P5AST::op_push; @ISA = 'P5AST::listop';
+package P5AST::op_pop; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_shift; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_unshift; @ISA = 'P5AST::listop';
+package P5AST::op_sort; @ISA = 'P5AST::listop';
+package P5AST::op_reverse; @ISA = 'P5AST::listop';
+package P5AST::op_grepstart; @ISA = 'P5AST::listop';
+package P5AST::op_grepwhile; @ISA = 'P5AST::logop';
+package P5AST::op_mapstart; @ISA = 'P5AST::listop';
+package P5AST::op_mapwhile; @ISA = 'P5AST::logop';
+package P5AST::op_range; @ISA = 'P5AST::logop';
+package P5AST::op_flip; @ISA = 'P5AST::unop';
+package P5AST::op_flop; @ISA = 'P5AST::unop';
+package P5AST::op_and; @ISA = 'P5AST::logop';
+package P5AST::op_or; @ISA = 'P5AST::logop';
+package P5AST::op_xor; @ISA = 'P5AST::binop';
+package P5AST::op_cond_expr; @ISA = 'P5AST::logop';
+package P5AST::op_andassign; @ISA = 'P5AST::logop';
+package P5AST::op_orassign; @ISA = 'P5AST::logop';
+package P5AST::op_method; @ISA = 'P5AST::unop';
+package P5AST::op_entersub; @ISA = 'P5AST::unop';
+package P5AST::op_leavesub; @ISA = 'P5AST::unop';
+package P5AST::op_leavesublv; @ISA = 'P5AST::unop';
+package P5AST::op_caller; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_warn; @ISA = 'P5AST::listop';
+package P5AST::op_die; @ISA = 'P5AST::listop';
+package P5AST::op_reset; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_lineseq; @ISA = 'P5AST::listop';
+package P5AST::op_nextstate; @ISA = 'P5AST::BAD';
+package P5AST::op_dbstate; @ISA = 'P5AST::cop';
+package P5AST::op_unstack; @ISA = 'P5AST::baseop';
+package P5AST::op_enter; @ISA = 'P5AST::baseop';
+package P5AST::op_leave; @ISA = 'P5AST::listop';
+package P5AST::op_scope; @ISA = 'P5AST::listop';
+package P5AST::op_enteriter; @ISA = 'P5AST::loop';
+package P5AST::op_iter; @ISA = 'P5AST::baseop';
+package P5AST::op_enterloop; @ISA = 'P5AST::loop';
+package P5AST::op_leaveloop; @ISA = 'P5AST::binop';
+package P5AST::op_return; @ISA = 'P5AST::listop';
+package P5AST::op_last; @ISA = 'P5AST::loopexop';
+package P5AST::op_next; @ISA = 'P5AST::loopexop';
+package P5AST::op_redo; @ISA = 'P5AST::loopexop';
+package P5AST::op_dump; @ISA = 'P5AST::loopexop';
+package P5AST::op_goto; @ISA = 'P5AST::loopexop';
+package P5AST::op_exit; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_open; @ISA = 'P5AST::listop';
+package P5AST::op_close; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_pipe_op; @ISA = 'P5AST::listop';
+package P5AST::op_fileno; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_umask; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_binmode; @ISA = 'P5AST::listop';
+package P5AST::op_tie; @ISA = 'P5AST::listop';
+package P5AST::op_untie; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_tied; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_dbmopen; @ISA = 'P5AST::listop';
+package P5AST::op_dbmclose; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_sselect; @ISA = 'P5AST::listop';
+package P5AST::op_select; @ISA = 'P5AST::listop';
+package P5AST::op_getc; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_read; @ISA = 'P5AST::listop';
+package P5AST::op_enterwrite; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_leavewrite; @ISA = 'P5AST::unop';
+package P5AST::op_prtf; @ISA = 'P5AST::listop';
+package P5AST::op_print; @ISA = 'P5AST::listop';
+package P5AST::op_say; @ISA = 'P5AST::listop';
+package P5AST::op_sysopen; @ISA = 'P5AST::listop';
+package P5AST::op_sysseek; @ISA = 'P5AST::listop';
+package P5AST::op_sysread; @ISA = 'P5AST::listop';
+package P5AST::op_syswrite; @ISA = 'P5AST::listop';
+package P5AST::op_send; @ISA = 'P5AST::listop';
+package P5AST::op_recv; @ISA = 'P5AST::listop';
+package P5AST::op_eof; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_tell; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_seek; @ISA = 'P5AST::listop';
+package P5AST::op_truncate; @ISA = 'P5AST::listop';
+package P5AST::op_fcntl; @ISA = 'P5AST::listop';
+package P5AST::op_ioctl; @ISA = 'P5AST::listop';
+package P5AST::op_flock; @ISA = 'P5AST::listop';
+package P5AST::op_socket; @ISA = 'P5AST::listop';
+package P5AST::op_sockpair; @ISA = 'P5AST::listop';
+package P5AST::op_bind; @ISA = 'P5AST::listop';
+package P5AST::op_connect; @ISA = 'P5AST::listop';
+package P5AST::op_listen; @ISA = 'P5AST::listop';
+package P5AST::op_accept; @ISA = 'P5AST::listop';
+package P5AST::op_shutdown; @ISA = 'P5AST::listop';
+package P5AST::op_gsockopt; @ISA = 'P5AST::listop';
+package P5AST::op_ssockopt; @ISA = 'P5AST::listop';
+package P5AST::op_getsockname; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_getpeername; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_lstat; @ISA = 'P5AST::filestatop';
+package P5AST::op_stat; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftrread; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftrwrite; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftrexec; @ISA = 'P5AST::filestatop';
+package P5AST::op_fteread; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftewrite; @ISA = 'P5AST::filestatop';
+package P5AST::op_fteexec; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftis; @ISA = 'P5AST::filestatop';
+package P5AST::op_fteowned; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftrowned; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftzero; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftsize; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftmtime; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftatime; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftctime; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftsock; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftchr; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftblk; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftfile; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftdir; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftpipe; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftlink; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftsuid; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftsgid; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftsvtx; @ISA = 'P5AST::filestatop';
+package P5AST::op_fttty; @ISA = 'P5AST::filestatop';
+package P5AST::op_fttext; @ISA = 'P5AST::filestatop';
+package P5AST::op_ftbinary; @ISA = 'P5AST::filestatop';
+package P5AST::op_chdir; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_chown; @ISA = 'P5AST::listop';
+package P5AST::op_chroot; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_unlink; @ISA = 'P5AST::listop';
+package P5AST::op_chmod; @ISA = 'P5AST::listop';
+package P5AST::op_utime; @ISA = 'P5AST::listop';
+package P5AST::op_rename; @ISA = 'P5AST::listop';
+package P5AST::op_link; @ISA = 'P5AST::listop';
+package P5AST::op_symlink; @ISA = 'P5AST::listop';
+package P5AST::op_readlink; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_mkdir; @ISA = 'P5AST::listop';
+package P5AST::op_rmdir; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_open_dir; @ISA = 'P5AST::listop';
+package P5AST::op_readdir; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_telldir; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_seekdir; @ISA = 'P5AST::listop';
+package P5AST::op_rewinddir; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_closedir; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_fork; @ISA = 'P5AST::baseop';
+package P5AST::op_wait; @ISA = 'P5AST::baseop';
+package P5AST::op_waitpid; @ISA = 'P5AST::listop';
+package P5AST::op_system; @ISA = 'P5AST::listop';
+package P5AST::op_exec; @ISA = 'P5AST::listop';
+package P5AST::op_kill; @ISA = 'P5AST::listop';
+package P5AST::op_getppid; @ISA = 'P5AST::baseop';
+package P5AST::op_getpgrp; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_setpgrp; @ISA = 'P5AST::listop';
+package P5AST::op_getpriority; @ISA = 'P5AST::listop';
+package P5AST::op_setpriority; @ISA = 'P5AST::listop';
+package P5AST::op_time; @ISA = 'P5AST::baseop';
+package P5AST::op_tms; @ISA = 'P5AST::baseop';
+package P5AST::op_localtime; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_gmtime; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_alarm; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_sleep; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_shmget; @ISA = 'P5AST::listop';
+package P5AST::op_shmctl; @ISA = 'P5AST::listop';
+package P5AST::op_shmread; @ISA = 'P5AST::listop';
+package P5AST::op_shmwrite; @ISA = 'P5AST::listop';
+package P5AST::op_msgget; @ISA = 'P5AST::listop';
+package P5AST::op_msgctl; @ISA = 'P5AST::listop';
+package P5AST::op_msgsnd; @ISA = 'P5AST::listop';
+package P5AST::op_msgrcv; @ISA = 'P5AST::listop';
+package P5AST::op_semget; @ISA = 'P5AST::listop';
+package P5AST::op_semctl; @ISA = 'P5AST::listop';
+package P5AST::op_semop; @ISA = 'P5AST::listop';
+package P5AST::op_require; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_dofile; @ISA = 'P5AST::unop';
+package P5AST::op_entereval; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_leaveeval; @ISA = 'P5AST::unop';
+package P5AST::op_entertry; @ISA = 'P5AST::logop';
+package P5AST::op_leavetry; @ISA = 'P5AST::listop';
+package P5AST::op_ghbyname; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_ghbyaddr; @ISA = 'P5AST::listop';
+package P5AST::op_ghostent; @ISA = 'P5AST::baseop';
+package P5AST::op_gnbyname; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_gnbyaddr; @ISA = 'P5AST::listop';
+package P5AST::op_gnetent; @ISA = 'P5AST::baseop';
+package P5AST::op_gpbyname; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_gpbynumber; @ISA = 'P5AST::listop';
+package P5AST::op_gprotoent; @ISA = 'P5AST::baseop';
+package P5AST::op_gsbyname; @ISA = 'P5AST::listop';
+package P5AST::op_gsbyport; @ISA = 'P5AST::listop';
+package P5AST::op_gservent; @ISA = 'P5AST::baseop';
+package P5AST::op_shostent; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_snetent; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_sprotoent; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_sservent; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_ehostent; @ISA = 'P5AST::baseop';
+package P5AST::op_enetent; @ISA = 'P5AST::baseop';
+package P5AST::op_eprotoent; @ISA = 'P5AST::baseop';
+package P5AST::op_eservent; @ISA = 'P5AST::baseop';
+package P5AST::op_gpwnam; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_gpwuid; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_gpwent; @ISA = 'P5AST::baseop';
+package P5AST::op_spwent; @ISA = 'P5AST::baseop';
+package P5AST::op_epwent; @ISA = 'P5AST::baseop';
+package P5AST::op_ggrnam; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_ggrgid; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_ggrent; @ISA = 'P5AST::baseop';
+package P5AST::op_sgrent; @ISA = 'P5AST::baseop';
+package P5AST::op_egrent; @ISA = 'P5AST::baseop';
+package P5AST::op_getlogin; @ISA = 'P5AST::baseop';
+package P5AST::op_syscall; @ISA = 'P5AST::listop';
+package P5AST::op_lock; @ISA = 'P5AST::baseop_unop';
+package P5AST::op_threadsv; @ISA = 'P5AST::baseop';
+package P5AST::op_setstate; @ISA = 'P5AST::cop';
+package P5AST::op_method_named; @ISA = 'P5AST::padop_svop';
+package P5AST::op_dor; @ISA = 'P5AST::logop';
+package P5AST::op_dorassign; @ISA = 'P5AST::logop';
+package P5AST::op_custom; @ISA = 'P5AST::baseop';
+
+# New node types (implicit types within perl)
+
+package P5AST::statement; @ISA = 'P5AST::cop';
+package P5AST::peg; @ISA = 'P5AST::baseop';
+package P5AST::parens; @ISA = 'P5AST::baseop';
+package P5AST::bindop; @ISA = 'P5AST::baseop';
+package P5AST::nothing; @ISA = 'P5AST::baseop';
+package P5AST::condstate; @ISA = 'P5AST::logop';
+package P5AST::use; @ISA = 'P5AST::baseop';
+package P5AST::ternary; @ISA = 'P5AST::baseop';
+package P5AST::sub; @ISA = 'P5AST::baseop';
+package P5AST::condmod; @ISA = 'P5AST::logop';
+package P5AST::package; @ISA = 'P5AST::baseop';
+package P5AST::format; @ISA = 'P5AST::baseop';
+package P5AST::qwliteral; @ISA = 'P5AST::baseop';
+package P5AST::quote; @ISA = 'P5AST::baseop';
+package P5AST::token; @ISA = 'P5AST::baseop';
+package P5AST::attrlist; @ISA = 'P5AST::baseop';
+package P5AST::listelem; @ISA = 'P5AST::baseop';
+package P5AST::preplus; @ISA = 'P5AST::baseop';
+package P5AST::doblock; @ISA = 'P5AST::baseop';
+package P5AST::cfor; @ISA = 'P5AST::baseop';
+package P5AST::pmop; @ISA = 'P5AST::baseop';
--- /dev/null
+#!/usr/bin/perl
+
+# Copyright (C) 2005, Larry Wall
+# This software may be copied under the same terms as Perl.
+
+package P5re;
+
+use strict;
+use warnings;
+
+our @EXPORT_OK = qw(re re2xml qr2xml);
+
+my $indent = 0;
+my $in = "";
+my $delim = 1;
+my $debug = 0;
+my $maxbrack;
+
+our $extended;
+our $insensitive;
+our $singleline;
+our $multiline;
+
+my %xmlish = (
+ chr(0x00) => "STUPIDXML(#x00)",
+ chr(0x01) => "STUPIDXML(#x01)",
+ chr(0x02) => "STUPIDXML(#x02)",
+ chr(0x03) => "STUPIDXML(#x03)",
+ chr(0x04) => "STUPIDXML(#x04)",
+ chr(0x05) => "STUPIDXML(#x05)",
+ chr(0x06) => "STUPIDXML(#x06)",
+ chr(0x07) => "STUPIDXML(#x07)",
+ chr(0x08) => "STUPIDXML(#x08)",
+ chr(0x09) => "	",
+ chr(0x0a) => " ",
+ chr(0x0b) => "STUPIDXML(#x0b)",
+ chr(0x0c) => "STUPIDXML(#x0c)",
+ chr(0x0d) => " ",
+ chr(0x0e) => "STUPIDXML(#x0e)",
+ chr(0x0f) => "STUPIDXML(#x0f)",
+ chr(0x10) => "STUPIDXML(#x10)",
+ chr(0x11) => "STUPIDXML(#x11)",
+ chr(0x12) => "STUPIDXML(#x12)",
+ chr(0x13) => "STUPIDXML(#x13)",
+ chr(0x14) => "STUPIDXML(#x14)",
+ chr(0x15) => "STUPIDXML(#x15)",
+ chr(0x16) => "STUPIDXML(#x16)",
+ chr(0x17) => "STUPIDXML(#x17)",
+ chr(0x18) => "STUPIDXML(#x18)",
+ chr(0x19) => "STUPIDXML(#x19)",
+ chr(0x1a) => "STUPIDXML(#x1a)",
+ chr(0x1b) => "STUPIDXML(#x1b)",
+ chr(0x1c) => "STUPIDXML(#x1c)",
+ chr(0x1d) => "STUPIDXML(#x1d)",
+ chr(0x1e) => "STUPIDXML(#x1e)",
+ chr(0x1f) => "STUPIDXML(#x1f)",
+ chr(0x7f) => "STUPIDXML(#x7f)",
+ chr(0x80) => "STUPIDXML(#x80)",
+ chr(0x81) => "STUPIDXML(#x81)",
+ chr(0x82) => "STUPIDXML(#x82)",
+ chr(0x83) => "STUPIDXML(#x83)",
+ chr(0x84) => "STUPIDXML(#x84)",
+ chr(0x86) => "STUPIDXML(#x86)",
+ chr(0x87) => "STUPIDXML(#x87)",
+ chr(0x88) => "STUPIDXML(#x88)",
+ chr(0x89) => "STUPIDXML(#x89)",
+ chr(0x90) => "STUPIDXML(#x90)",
+ chr(0x91) => "STUPIDXML(#x91)",
+ chr(0x92) => "STUPIDXML(#x92)",
+ chr(0x93) => "STUPIDXML(#x93)",
+ chr(0x94) => "STUPIDXML(#x94)",
+ chr(0x95) => "STUPIDXML(#x95)",
+ chr(0x96) => "STUPIDXML(#x96)",
+ chr(0x97) => "STUPIDXML(#x97)",
+ chr(0x98) => "STUPIDXML(#x98)",
+ chr(0x99) => "STUPIDXML(#x99)",
+ chr(0x9a) => "STUPIDXML(#x9a)",
+ chr(0x9b) => "STUPIDXML(#x9b)",
+ chr(0x9c) => "STUPIDXML(#x9c)",
+ chr(0x9d) => "STUPIDXML(#x9d)",
+ chr(0x9e) => "STUPIDXML(#x9e)",
+ chr(0x9f) => "STUPIDXML(#x9f)",
+ '<' => "<",
+ '>' => ">",
+ '&' => "&",
+ '"' => """, # XML idiocy
+);
+
+sub xmlquote {
+ my $text = shift;
+ $text =~ s/(.)/$xmlish{$1} || $1/seg;
+ return $text;
+}
+
+sub text {
+ my $self = shift;
+ return xmlquote($self->{text});
+}
+
+sub rep {
+ my $self = shift;
+ return xmlquote($self->{rep});
+}
+
+sub xmlkids {
+ my $self = shift;
+ my $array = $self->{Kids};
+ my $ret = "";
+ $indent += 2;
+ $in = ' ' x $indent;
+ foreach my $chunk (@$array) {
+ if (ref $chunk eq "ARRAY") {
+ die;
+ }
+ elsif (ref $chunk) {
+ $ret .= $chunk->xml();
+ }
+ else {
+ warn $chunk;
+ }
+ }
+ $indent -= 2;
+ $in = ' ' x $indent;
+ return $ret;
+};
+
+package P5re::RE; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my %flags = @_;
+ if ($flags{indent}) {
+ $indent = delete $flags{indent} || 0;
+ $in = ' ' x $indent;
+ }
+
+ my $kind = $self->{kind};
+
+ my $first = $self->{Kids}[0];
+ if ($first and ref $first eq 'P5re::Mod') {
+ for my $c (qw(i m s x)) {
+ next unless defined $first->{$c};
+ $self->{$c} = $first->{$c};
+ delete $first->{$c};
+ }
+ }
+
+ my $modifiers = "";
+ foreach my $k (sort keys %$self) {
+ next if $k eq 'kind' or $k eq "Kids";
+ my $v = $self->{$k};
+ $k =~ s/^[A-Z]//;
+ $modifiers .= " $k=\"$v\"";
+ }
+ my $text = "$in<$kind$modifiers>\n";
+ $text .= $self->xmlkids();
+ $text .= "$in</$kind>\n";
+ return $text;
+}
+
+package P5re::Alt; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my $text = "$in<alt>\n";
+ $text .= $self->xmlkids();
+ $text .= "$in</alt>\n";
+ return $text;
+}
+
+#package P5re::Atom; our @ISA = 'P5re';
+#
+#sub xml {
+# my $self = shift;
+# my $text = "$in<atom>\n";
+# $text .= $self->xmlkids();
+# $text .= "$in</atom>\n";
+# return $text;
+#}
+
+package P5re::Quant; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my $q = $self->{rep};
+ my $min = $self->{min};
+ my $max = $self->{max};
+ my $greedy = $self->{greedy};
+ my $text = "$in<quant rep=\"$q\" min=\"$min\" max=\"$max\" greedy=\"$greedy\">\n";
+ $text .= $self->xmlkids();
+ $text .= "$in</quant>\n";
+ return $text;
+}
+
+package P5re::White; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ return "$in<white text=\"" . $self->text() . "\" />\n";
+}
+
+package P5re::Char; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ return "$in<char text=\"" . $self->text() . "\" />\n";
+}
+
+package P5re::Comment; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ return "$in<comment rep=\"" . $self->rep() . "\" />\n";
+}
+
+package P5re::Mod; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my $modifiers = "";
+ foreach my $k (sort keys %$self) {
+ next if $k eq 'kind' or $k eq "Kids";
+ my $v = $self->{$k};
+ $k =~ s/^[A-Z]//;
+ $modifiers .= " $k=\"$v\"";
+ }
+ return "$in<mod$modifiers />\n";
+}
+
+package P5re::Meta; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my $sem = "";
+ if ($self->{sem}) {
+ $sem = 'sem="' . $self->{sem} . '" '
+ }
+ return "$in<meta rep=\"" . $self->rep() . "\" $sem/>\n";
+}
+
+package P5re::Back; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ return "$in<backref to=\"" . P5re::xmlquote($self->{to}) . "\"/>\n";
+}
+
+package P5re::Var; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ return "$in<var name=\"" . $self->{name} . "\" />\n";
+}
+
+package P5re::Closure; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ return "$in<closure rep=\"" . P5re::xmlquote($self->{rep}) . "\" />\n";
+}
+
+package P5re::CClass; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my $neg = $self->{neg} ? "negated" : "normal";
+ my $text = "$in<cclass match=\"$neg\">\n";
+ $text .= $self->xmlkids();
+ $text .= "$in</cclass>\n";
+ return $text;
+}
+
+package P5re::Range; our @ISA = 'P5re';
+
+sub xml {
+ my $self = shift;
+ my $text = "$in<range>\n";
+ $text .= $self->xmlkids();
+ $text .= "$in</range>\n";
+ return $text;
+}
+
+package P5re;
+
+unless (caller) {
+ while (<>) {
+ chomp;
+ print qr2xml($_);
+ print "#######################################\n";
+ }
+}
+
+sub qrparse {
+ my $qr = shift;
+ my $mod;
+ if ($qr =~ /^s/) {
+ $qr =~ s/^(?:\w*)(\W)((?:\\.|.)*?)\1(.*)\1(\w*)$/$2/;
+ $mod = $4;
+ }
+ else {
+ $qr =~ s/^(?:\w*)(\W)(.*)\1(\w*)$/$2/;
+ $mod = $3;
+ }
+ substr($qr,0,0) = "(?$mod)" if defined $mod and $mod ne "";
+ return parse($qr,@_);
+}
+
+sub qr2xml {
+ return qrparse(@_)->xml();
+}
+
+sub re2xml {
+ my $re = shift;
+ return parse($re,@_)->xml();
+}
+
+sub parse {
+ local($_) = shift;
+ my %flags = @_;
+ $maxbrack = 0;
+ $indent = delete $flags{indent} || 0;
+ $in = ' ' x $indent;
+ warn "$_\n" if $debug;
+ my $re = re('re');
+ @$re{keys %flags} = values %flags;
+ return $re;
+}
+
+sub re {
+ my $kind = shift;
+
+ my $oldextended = $extended;
+ my $oldinsensitive = $insensitive;
+ my $oldmultiline = $multiline;
+ my $oldsingleline = $singleline;
+
+ local $extended = $extended;
+ local $insensitive = $insensitive;
+ local $multiline = $multiline;
+ local $singleline = $singleline;
+
+ my $first = alt();
+
+ my $re;
+ if (not /^\|/) {
+ $first->{kind} = $kind;
+ $re = bless $first, "P5re::RE"; # rebless to remove single alt
+ }
+ else {
+ my @alts = ($first);
+
+ while (s/^\|//) {
+ push(@alts, alt());
+ }
+ $re = bless { Kids => [@alts], kind => $kind }, "P5re::RE";
+ }
+
+ $re->{x} = $oldextended || 0;
+ $re->{i} = $oldinsensitive || 0;
+ $re->{m} = $oldmultiline || 0;
+ $re->{s} = $oldsingleline || 0;
+ return $re;
+}
+
+sub alt {
+ my @quants;
+
+ my $quant;
+ while ($quant = quant()) {
+ if (@quants and
+ ref $quant eq ref $quants[-1] and
+ exists $quants[-1]{text} and
+ exists $quant->{text} )
+ {
+ $quants[-1]{text} .= $quant->{text};
+ }
+ else {
+ push(@quants, $quant);
+ }
+ }
+ return bless { Kids => [@quants] }, "P5re::Alt";
+}
+
+sub quant {
+ my $atom = atom();
+ return 0 unless $atom;
+# $atom = bless { Kids => [$atom] }, "P5re::Atom";
+ if (s/^(([*+?])(\??)|\{(\d+)(?:(,)(\d*))?\}(\??))//) {
+ my $min = 0;
+ my $max = "Inf";
+ my $greed = 1;
+ if ($2) {
+ if ($2 eq '+') {
+ $min = 1;
+ }
+ elsif ($2 eq '?') {
+ $max = 1;
+ }
+ $greed = 0 if $3;
+ }
+ elsif (defined $4) {
+ $min = $4;
+ if ($5) {
+ $max = $6 if $6;
+ }
+ else {
+ $max = $min;
+ }
+ $greed = 0 if $7;
+ }
+ $greed = "na" if $min == $max;
+ return bless { Kids => [$atom],
+ rep => $1,
+ min => $min,
+ max => $max,
+ greedy => $greed
+ }, "P5re::Quant";
+ }
+ return $atom;
+}
+
+sub atom {
+ my $re;
+ if ($_ eq "") { return 0 }
+ if (/^[)|]/) { return 0 }
+
+ # whitespace is special because we don't know if /x is in effect
+ if ($extended) {
+ if (s/^(?=\s|#)(\s*(?:#.*)?)//) { return bless { text => $1 }, "P5re::White"; }
+ }
+
+ # all the parenthesized forms
+ if (s/^\(//) {
+ if (s/^\?://) {
+ $re = re('bracket');
+ }
+ elsif (s/^(\?#.*?)\)/)/) {
+ $re = bless { rep => "($1)" }, "P5re::Comment";
+ }
+ elsif (s/^\?=//) {
+ $re = re('lookahead');
+ }
+ elsif (s/^\?!//) {
+ $re = re('neglookahead');
+ }
+ elsif (s/^\?<=//) {
+ $re = re('lookbehind');
+ }
+ elsif (s/^\?<!//) {
+ $re = re('neglookbehind');
+ }
+ elsif (s/^\?>//) {
+ $re = re('nobacktrack');
+ }
+ elsif (s/^(\?\??\{.*?\})\)/)/) {
+ $re = bless { rep => "($1)" }, "P5re::Closure";
+ }
+ elsif (s/^(\?\(\d+\))//) {
+ my $mods = $1;
+ $re = re('conditional');
+ $re->{Arep} = "$mods";
+ }
+ elsif (s/^\?(?=\(\?)//) {
+ my $mods = $1;
+ my $cond = atom();
+ $re = re('conditional');
+ unshift(@{$re->{Kids}}, $cond);
+ }
+ elsif (s/^(\?[-\w]+)://) {
+ my $mods = $1;
+ local $extended = $extended;
+ local $insensitive = $insensitive;
+ local $multiline = $multiline;
+ local $singleline = $singleline;
+ setmods($mods);
+ $re = re('bracket');
+ $re->{Arep} = "($mods)";
+ $re->{x} = $extended || 0;
+ $re->{i} = $insensitive || 0;
+ $re->{m} = $multiline || 0;
+ $re->{s} = $singleline || 0;
+ }
+ elsif (s/^(\?[-\w]+)//) {
+ my $mods = $1;
+ $re = bless { Arep => "($mods)" }, "P5re::Mod";
+ setmods($mods);
+ $re->{x} = $extended || 0;
+ $re->{i} = $insensitive || 0;
+ $re->{m} = $multiline || 0;
+ $re->{s} = $singleline || 0;
+ }
+ elsif (s/^\?//) {
+ $re = re('UNRECOGNIZED');
+ }
+ else {
+ my $brack = ++$maxbrack;
+ $re = re('capture');
+ $re->{Ato} = $brack;
+ }
+
+ if (not s/^\)//) { warn "Expected right paren at: '$_'" }
+ return $re;
+ }
+
+ # special meta
+ if (s/^\.//) {
+ my $s = $singleline ? '.' : '\N';
+ return bless { rep => '.', sem => $s }, "P5re::Meta";
+ }
+ if (s/^\^//) {
+ my $s = $multiline ? '^^' : '^';
+ return bless { rep => '^', sem => $s }, "P5re::Meta";
+ }
+ if (s/^\$(?:$|(?=[|)]))//) {
+ my $s = $multiline ? '$$' : '$';
+ return bless { rep => '$', sem => $s }, "P5re::Meta";
+ }
+ if (s/^([\$\@](\w+|.))//) { # XXX need to handle subscripts here
+ return bless { name => $1 }, "P5re::Var";
+ }
+
+ # character classes
+ if (s/^\[//) {
+ my $re = cclass();
+ if (not s/^\]//) { warn "Expected right bracket at: '$_'" }
+ return $re;
+ }
+
+ # backwhacks
+ if (/^\\([1-9]\d*)/ and $1 <= $maxbrack) {
+ my $to = $1;
+ onechar();
+ return bless { to => $to }, "P5re::Back";
+ }
+
+ # backwhacks
+ if (/^\\(?=\w)/) {
+ return bless { rep => onechar() }, "P5re::Meta";
+ }
+
+ # backwhacks
+ if (s/^\\(.)//) {
+ return bless { text => $1 }, "P5re::Char";
+ }
+
+ # optimization, would happen anyway
+ if (s/^(\w+)//) { return bless { text => $1 }, "P5re::Char"; }
+
+ # random character
+ if (s/^(.)//) { return bless { text => $1 }, "P5re::Char"; }
+}
+
+sub cclass {
+ my @cclass;
+ my $cclass = "";
+ my $neg = 0;
+ if (s/^\^//) { $neg = 1 }
+ if (s/^([\]\-])//) { $cclass .= $1 }
+
+ while ($_ ne "" and not /^\]/) {
+ # backwhacks
+ if (/^\\(?=.)|.-/) {
+ my $o1 = onecharobj();
+ if ($cclass ne "") {
+ push @cclass, bless { text => $cclass }, "P5re::Char";
+ $cclass = "";
+ }
+
+ if (s/^-(?=[^]])//) {
+ my $o2 = onecharobj();
+ push @cclass, bless { Kids => [$o1, $o2] }, "P5re::Range";
+ }
+ else {
+ push @cclass, $o1;
+ }
+ }
+ elsif (s/^(\[([:=.])\^?\w*\2\])//) {
+ if ($cclass ne "") {
+ push @cclass, bless { text => $cclass }, "P5re::Char";
+ $cclass = "";
+ }
+ push @cclass, bless { rep => $1 }, "P5re::Meta";
+ }
+ else {
+ $cclass .= onechar();
+ }
+ }
+
+ if ($cclass ne "") {
+ push @cclass, bless { text => $cclass }, "P5re::Char";
+ }
+ return bless { Kids => [@cclass], neg => $neg }, "P5re::CClass";
+}
+
+sub onecharobj {
+ my $ch = onechar();
+ if ($ch =~ /^\\/) {
+ $ch = bless { rep => $ch }, "P5re::Meta";
+ }
+ else {
+ $ch = bless { text => $ch }, "P5re::Char";
+ }
+}
+
+sub onechar {
+ die "Oops, short cclass" unless s/^(.)//;
+ my $ch = $1;
+ if ($ch eq '\\') {
+ if (s/^([rntf]|[0-7]{1,4})//) { $ch .= $1 }
+ elsif (s/^(x[0-9a-fA-f]{1,2})//) { $ch .= $1 }
+ elsif (s/^(x\{[0-9a-fA-f]+\})//) { $ch .= $1 }
+ elsif (s/^([NpP]\{.*?\})//) { $ch .= $1 }
+ elsif (s/^([cpP].)//) { $ch .= $1 }
+ elsif (s/^(.)//) { $ch .= $1 }
+ else {
+ die "Oops, short backwhack";
+ }
+ }
+ return $ch;
+}
+
+sub setmods {
+ my $mods = shift;
+ if ($mods =~ /\-.*x/) {
+ $extended = 0;
+ }
+ elsif ($mods =~ /x/) {
+ $extended = 1;
+ }
+ if ($mods =~ /\-.*i/) {
+ $insensitive = 0;
+ }
+ elsif ($mods =~ /i/) {
+ $insensitive = 1;
+ }
+ if ($mods =~ /\-.*m/) {
+ $multiline = 0;
+ }
+ elsif ($mods =~ /m/) {
+ $multiline = 1;
+ }
+ if ($mods =~ /\-.*s/) {
+ $singleline = 0;
+ }
+ elsif ($mods =~ /s/) {
+ $singleline = 1;
+ }
+}
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+package PLXML;
+
+sub DESTROY { }
+
+sub walk {
+ print "walk(" . join(',', @_) . ")\n";
+ my $self = shift;
+ for my $key (sort keys %$self) {
+ print "\t$key = <$$self{$key}>\n";
+ }
+ foreach my $kid (@{$$self{Kids}}) {
+ $kid->walk(@_);
+ }
+}
+
+package PLXML::Characters;
+
+our @ISA = ('PLXML');
+sub walk {}
+
+package PLXML::madprops;
+
+our @ISA = ('PLXML');
+
+package PLXML::mad_op;
+
+our @ISA = ('PLXML');
+
+package PLXML::mad_pv;
+
+our @ISA = ('PLXML');
+
+package PLXML::baseop;
+
+our @ISA = ('PLXML');
+
+package PLXML::baseop_unop;
+
+our @ISA = ('PLXML');
+
+package PLXML::binop;
+
+our @ISA = ('PLXML');
+
+package PLXML::cop;
+
+our @ISA = ('PLXML');
+
+package PLXML::filestatop;
+
+our @ISA = ('PLXML::baseop_unop');
+
+package PLXML::listop;
+
+our @ISA = ('PLXML');
+
+package PLXML::logop;
+
+our @ISA = ('PLXML');
+
+package PLXML::loop;
+
+our @ISA = ('PLXML');
+
+package PLXML::loopexop;
+
+our @ISA = ('PLXML');
+
+package PLXML::padop;
+
+our @ISA = ('PLXML');
+
+package PLXML::padop_svop;
+
+our @ISA = ('PLXML');
+
+package PLXML::pmop;
+
+our @ISA = ('PLXML');
+
+package PLXML::pvop_svop;
+
+our @ISA = ('PLXML');
+
+package PLXML::unop;
+
+our @ISA = ('PLXML');
+
+
+# New ops always go at the end, just before 'custom'
+
+# A recapitulation of the format of this file:
+# The file consists of five columns: the name of the op, an English
+# description, the name of the "check" routine used to optimize this
+# operation, some flags, and a description of the operands.
+
+# The flags consist of options followed by a mandatory op class signifier
+
+# The classes are:
+# baseop - 0 unop - 1 binop - 2
+# logop - | listop - @ pmop - /
+# padop/svop - $ padop - # (unused) loop - {
+# baseop/unop - % loopexop - } filestatop - -
+# pvop/svop - " cop - ;
+
+# Other options are:
+# needs stack mark - m
+# needs constant folding - f
+# produces a scalar - s
+# produces an integer - i
+# needs a target - t
+# target can be in a pad - T
+# has a corresponding integer version - I
+# has side effects - d
+# uses $_ if no argument given - u
+
+# Values for the operands are:
+# scalar - S list - L array - A
+# hash - H sub (CV) - C file - F
+# socket - Fs filetest - F- reference - R
+# "?" denotes an optional operand.
+
+# Nothing.
+
+package PLXML::op_null;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'null' }
+sub desc { 'null operation' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+# Nick
+
+package PLXML::op_padrange;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'padrange' }
+sub desc { 'padrange operation' }
+sub check { 'ck_padrange' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_stub;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'stub' }
+sub desc { 'stub' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_scalar;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'scalar' }
+sub desc { 'scalar' }
+sub check { 'ck_fun' }
+sub flags { 's%' }
+sub args { 'S' }
+
+
+
+# Pushy stuff.
+
+package PLXML::op_pushmark;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'pushmark' }
+sub desc { 'pushmark' }
+sub check { 'ck_null' }
+sub flags { 's0' }
+sub args { '' }
+
+
+package PLXML::op_wantarray;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'wantarray' }
+sub desc { 'wantarray' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+
+package PLXML::op_const;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'const' }
+sub desc { 'constant item' }
+sub check { 'ck_svconst' }
+sub flags { 's$' }
+sub args { '' }
+
+
+
+package PLXML::op_gvsv;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'gvsv' }
+sub desc { 'scalar variable' }
+sub check { 'ck_null' }
+sub flags { 'ds$' }
+sub args { '' }
+
+
+package PLXML::op_gv;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'gv' }
+sub desc { 'glob value' }
+sub check { 'ck_null' }
+sub flags { 'ds$' }
+sub args { '' }
+
+
+package PLXML::op_gelem;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'gelem' }
+sub desc { 'glob elem' }
+sub check { 'ck_null' }
+sub flags { 'd2' }
+sub args { 'S S' }
+
+
+package PLXML::op_padsv;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'padsv' }
+sub desc { 'private variable' }
+sub check { 'ck_null' }
+sub flags { 'ds0' }
+sub args { '' }
+
+
+package PLXML::op_padav;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'padav' }
+sub desc { 'private array' }
+sub check { 'ck_null' }
+sub flags { 'd0' }
+sub args { '' }
+
+
+package PLXML::op_padhv;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'padhv' }
+sub desc { 'private hash' }
+sub check { 'ck_null' }
+sub flags { 'd0' }
+sub args { '' }
+
+
+package PLXML::op_padany;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'padany' }
+sub desc { 'private value' }
+sub check { 'ck_null' }
+sub flags { 'd0' }
+sub args { '' }
+
+
+
+package PLXML::op_pushre;
+
+our @ISA = ('PLXML::pmop');
+
+sub key { 'pushre' }
+sub desc { 'push regexp' }
+sub check { 'ck_null' }
+sub flags { 'd/' }
+sub args { '' }
+
+
+
+# References and stuff.
+
+package PLXML::op_rv2gv;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'rv2gv' }
+sub desc { 'ref-to-glob cast' }
+sub check { 'ck_rvconst' }
+sub flags { 'ds1' }
+sub args { '' }
+
+
+package PLXML::op_rv2sv;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'rv2sv' }
+sub desc { 'scalar dereference' }
+sub check { 'ck_rvconst' }
+sub flags { 'ds1' }
+sub args { '' }
+
+
+package PLXML::op_av2arylen;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'av2arylen' }
+sub desc { 'array length' }
+sub check { 'ck_null' }
+sub flags { 'is1' }
+sub args { '' }
+
+
+package PLXML::op_rv2cv;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'rv2cv' }
+sub desc { 'subroutine dereference' }
+sub check { 'ck_rvconst' }
+sub flags { 'd1' }
+sub args { '' }
+
+
+package PLXML::op_anoncode;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'anoncode' }
+sub desc { 'anonymous subroutine' }
+sub check { 'ck_anoncode' }
+sub flags { '$' }
+sub args { '' }
+
+
+package PLXML::op_prototype;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'prototype' }
+sub desc { 'subroutine prototype' }
+sub check { 'ck_null' }
+sub flags { 's%' }
+sub args { 'S' }
+
+
+package PLXML::op_refgen;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'refgen' }
+sub desc { 'reference constructor' }
+sub check { 'ck_spair' }
+sub flags { 'm1' }
+sub args { 'L' }
+
+
+package PLXML::op_srefgen;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'srefgen' }
+sub desc { 'single ref constructor' }
+sub check { 'ck_null' }
+sub flags { 'fs1' }
+sub args { 'S' }
+
+
+package PLXML::op_ref;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'ref' }
+sub desc { 'reference-type operator' }
+sub check { 'ck_fun' }
+sub flags { 'stu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_bless;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'bless' }
+sub desc { 'bless' }
+sub check { 'ck_fun' }
+sub flags { 's@' }
+sub args { 'S S?' }
+
+
+
+# Pushy I/O.
+
+package PLXML::op_backtick;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'backtick' }
+sub desc { 'quoted execution (``, qx)' }
+sub check { 'ck_open' }
+sub flags { 't%' }
+sub args { '' }
+
+
+# glob defaults its first arg to $_
+package PLXML::op_glob;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'glob' }
+sub desc { 'glob' }
+sub check { 'ck_glob' }
+sub flags { 't@' }
+sub args { 'S?' }
+
+
+package PLXML::op_readline;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'readline' }
+sub desc { '<HANDLE>' }
+sub check { 'ck_null' }
+sub flags { 't%' }
+sub args { 'F?' }
+
+
+package PLXML::op_rcatline;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'rcatline' }
+sub desc { 'append I/O operator' }
+sub check { 'ck_null' }
+sub flags { 't$' }
+sub args { '' }
+
+
+
+# Bindable operators.
+
+package PLXML::op_regcmaybe;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'regcmaybe' }
+sub desc { 'regexp internal guard' }
+sub check { 'ck_fun' }
+sub flags { 's1' }
+sub args { 'S' }
+
+
+package PLXML::op_regcreset;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'regcreset' }
+sub desc { 'regexp internal reset' }
+sub check { 'ck_fun' }
+sub flags { 's1' }
+sub args { 'S' }
+
+
+package PLXML::op_regcomp;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'regcomp' }
+sub desc { 'regexp compilation' }
+sub check { 'ck_null' }
+sub flags { 's|' }
+sub args { 'S' }
+
+
+package PLXML::op_match;
+
+our @ISA = ('PLXML::pmop');
+
+sub key { 'match' }
+sub desc { 'pattern match (m//)' }
+sub check { 'ck_match' }
+sub flags { 'd/' }
+sub args { '' }
+
+
+package PLXML::op_qr;
+
+our @ISA = ('PLXML::pmop');
+
+sub key { 'qr' }
+sub desc { 'pattern quote (qr//)' }
+sub check { 'ck_match' }
+sub flags { 's/' }
+sub args { '' }
+
+
+package PLXML::op_subst;
+
+our @ISA = ('PLXML::pmop');
+
+sub key { 'subst' }
+sub desc { 'substitution (s///)' }
+sub check { 'ck_match' }
+sub flags { 'dis/' }
+sub args { 'S' }
+
+
+package PLXML::op_substcont;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'substcont' }
+sub desc { 'substitution iterator' }
+sub check { 'ck_null' }
+sub flags { 'dis|' }
+sub args { '' }
+
+
+package PLXML::op_trans;
+
+our @ISA = ('PLXML::pvop_svop');
+
+sub key { 'trans' }
+sub desc { 'transliteration (tr///)' }
+sub check { 'ck_match' }
+sub flags { 'is"' }
+sub args { 'S' }
+
+
+
+# Lvalue operators.
+# sassign is special-cased for op class
+
+package PLXML::op_sassign;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'sassign' }
+sub desc { 'scalar assignment' }
+sub check { 'ck_sassign' }
+sub flags { 's0' }
+sub args { '' }
+
+
+package PLXML::op_aassign;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'aassign' }
+sub desc { 'list assignment' }
+sub check { 'ck_null' }
+sub flags { 't2' }
+sub args { 'L L' }
+
+
+
+package PLXML::op_chop;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'chop' }
+sub desc { 'chop' }
+sub check { 'ck_spair' }
+sub flags { 'mts%' }
+sub args { 'L' }
+
+
+package PLXML::op_schop;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'schop' }
+sub desc { 'scalar chop' }
+sub check { 'ck_null' }
+sub flags { 'stu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_chomp;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'chomp' }
+sub desc { 'chomp' }
+sub check { 'ck_spair' }
+sub flags { 'mTs%' }
+sub args { 'L' }
+
+
+package PLXML::op_schomp;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'schomp' }
+sub desc { 'scalar chomp' }
+sub check { 'ck_null' }
+sub flags { 'sTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_defined;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'defined' }
+sub desc { 'defined operator' }
+sub check { 'ck_defined' }
+sub flags { 'isu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_undef;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'undef' }
+sub desc { 'undef operator' }
+sub check { 'ck_lfun' }
+sub flags { 's%' }
+sub args { 'S?' }
+
+
+package PLXML::op_study;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'study' }
+sub desc { 'study' }
+sub check { 'ck_fun' }
+sub flags { 'su%' }
+sub args { 'S?' }
+
+
+package PLXML::op_pos;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'pos' }
+sub desc { 'match position' }
+sub check { 'ck_lfun' }
+sub flags { 'stu%' }
+sub args { 'S?' }
+
+
+
+package PLXML::op_preinc;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'preinc' }
+sub desc { 'preincrement (++)' }
+sub check { 'ck_lfun' }
+sub flags { 'dIs1' }
+sub args { 'S' }
+
+
+package PLXML::op_i_preinc;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'i_preinc' }
+sub desc { 'integer preincrement (++)' }
+sub check { 'ck_lfun' }
+sub flags { 'dis1' }
+sub args { 'S' }
+
+
+package PLXML::op_predec;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'predec' }
+sub desc { 'predecrement (--)' }
+sub check { 'ck_lfun' }
+sub flags { 'dIs1' }
+sub args { 'S' }
+
+
+package PLXML::op_i_predec;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'i_predec' }
+sub desc { 'integer predecrement (--)' }
+sub check { 'ck_lfun' }
+sub flags { 'dis1' }
+sub args { 'S' }
+
+
+package PLXML::op_postinc;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'postinc' }
+sub desc { 'postincrement (++)' }
+sub check { 'ck_lfun' }
+sub flags { 'dIst1' }
+sub args { 'S' }
+
+
+package PLXML::op_i_postinc;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'i_postinc' }
+sub desc { 'integer postincrement (++)' }
+sub check { 'ck_lfun' }
+sub flags { 'disT1' }
+sub args { 'S' }
+
+
+package PLXML::op_postdec;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'postdec' }
+sub desc { 'postdecrement (--)' }
+sub check { 'ck_lfun' }
+sub flags { 'dIst1' }
+sub args { 'S' }
+
+
+package PLXML::op_i_postdec;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'i_postdec' }
+sub desc { 'integer postdecrement (--)' }
+sub check { 'ck_lfun' }
+sub flags { 'disT1' }
+sub args { 'S' }
+
+
+
+# Ordinary operators.
+
+package PLXML::op_pow;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'pow' }
+sub desc { 'exponentiation (**)' }
+sub check { 'ck_null' }
+sub flags { 'fsT2' }
+sub args { 'S S' }
+
+
+
+package PLXML::op_multiply;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'multiply' }
+sub desc { 'multiplication (*)' }
+sub check { 'ck_null' }
+sub flags { 'IfsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_multiply;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_multiply' }
+sub desc { 'integer multiplication (*)' }
+sub check { 'ck_null' }
+sub flags { 'ifsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_divide;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'divide' }
+sub desc { 'division (/)' }
+sub check { 'ck_null' }
+sub flags { 'IfsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_divide;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_divide' }
+sub desc { 'integer division (/)' }
+sub check { 'ck_null' }
+sub flags { 'ifsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_modulo;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'modulo' }
+sub desc { 'modulus (%)' }
+sub check { 'ck_null' }
+sub flags { 'IifsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_modulo;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_modulo' }
+sub desc { 'integer modulus (%)' }
+sub check { 'ck_null' }
+sub flags { 'ifsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_repeat;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'repeat' }
+sub desc { 'repeat (x)' }
+sub check { 'ck_repeat' }
+sub flags { 'mt2' }
+sub args { 'L S' }
+
+
+
+package PLXML::op_add;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'add' }
+sub desc { 'addition (+)' }
+sub check { 'ck_null' }
+sub flags { 'IfsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_add;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_add' }
+sub desc { 'integer addition (+)' }
+sub check { 'ck_null' }
+sub flags { 'ifsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_subtract;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'subtract' }
+sub desc { 'subtraction (-)' }
+sub check { 'ck_null' }
+sub flags { 'IfsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_subtract;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_subtract' }
+sub desc { 'integer subtraction (-)' }
+sub check { 'ck_null' }
+sub flags { 'ifsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_concat;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'concat' }
+sub desc { 'concatenation (.) or string' }
+sub check { 'ck_concat' }
+sub flags { 'fsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_stringify;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'stringify' }
+sub desc { 'string' }
+sub check { 'ck_fun' }
+sub flags { 'fsT@' }
+sub args { 'S' }
+
+
+
+package PLXML::op_left_shift;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'left_shift' }
+sub desc { 'left bitshift (<<)' }
+sub check { 'ck_bitop' }
+sub flags { 'fsT2' }
+sub args { 'S S' }
+
+
+package PLXML::op_right_shift;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'right_shift' }
+sub desc { 'right bitshift (>>)' }
+sub check { 'ck_bitop' }
+sub flags { 'fsT2' }
+sub args { 'S S' }
+
+
+
+package PLXML::op_lt;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'lt' }
+sub desc { 'numeric lt (<)' }
+sub check { 'ck_null' }
+sub flags { 'Iifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_lt;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_lt' }
+sub desc { 'integer lt (<)' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_gt;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'gt' }
+sub desc { 'numeric gt (>)' }
+sub check { 'ck_null' }
+sub flags { 'Iifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_gt;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_gt' }
+sub desc { 'integer gt (>)' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_le;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'le' }
+sub desc { 'numeric le (<=)' }
+sub check { 'ck_null' }
+sub flags { 'Iifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_le;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_le' }
+sub desc { 'integer le (<=)' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_ge;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'ge' }
+sub desc { 'numeric ge (>=)' }
+sub check { 'ck_null' }
+sub flags { 'Iifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_ge;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_ge' }
+sub desc { 'integer ge (>=)' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_eq;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'eq' }
+sub desc { 'numeric eq (==)' }
+sub check { 'ck_null' }
+sub flags { 'Iifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_eq;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_eq' }
+sub desc { 'integer eq (==)' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_ne;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'ne' }
+sub desc { 'numeric ne (!=)' }
+sub check { 'ck_null' }
+sub flags { 'Iifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_ne;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_ne' }
+sub desc { 'integer ne (!=)' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_ncmp;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'ncmp' }
+sub desc { 'numeric comparison (<=>)' }
+sub check { 'ck_null' }
+sub flags { 'Iifst2' }
+sub args { 'S S' }
+
+
+package PLXML::op_i_ncmp;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'i_ncmp' }
+sub desc { 'integer comparison (<=>)' }
+sub check { 'ck_null' }
+sub flags { 'ifst2' }
+sub args { 'S S' }
+
+
+
+package PLXML::op_slt;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'slt' }
+sub desc { 'string lt' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_sgt;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'sgt' }
+sub desc { 'string gt' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_sle;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'sle' }
+sub desc { 'string le' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_sge;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'sge' }
+sub desc { 'string ge' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_seq;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'seq' }
+sub desc { 'string eq' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_sne;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'sne' }
+sub desc { 'string ne' }
+sub check { 'ck_null' }
+sub flags { 'ifs2' }
+sub args { 'S S' }
+
+
+package PLXML::op_scmp;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'scmp' }
+sub desc { 'string comparison (cmp)' }
+sub check { 'ck_null' }
+sub flags { 'ifst2' }
+sub args { 'S S' }
+
+
+
+package PLXML::op_bit_and;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'bit_and' }
+sub desc { 'bitwise and (&)' }
+sub check { 'ck_bitop' }
+sub flags { 'fst2' }
+sub args { 'S S' }
+
+
+package PLXML::op_bit_xor;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'bit_xor' }
+sub desc { 'bitwise xor (^)' }
+sub check { 'ck_bitop' }
+sub flags { 'fst2' }
+sub args { 'S S' }
+
+
+package PLXML::op_bit_or;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'bit_or' }
+sub desc { 'bitwise or (|)' }
+sub check { 'ck_bitop' }
+sub flags { 'fst2' }
+sub args { 'S S' }
+
+
+
+package PLXML::op_negate;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'negate' }
+sub desc { 'negation (-)' }
+sub check { 'ck_null' }
+sub flags { 'Ifst1' }
+sub args { 'S' }
+
+
+package PLXML::op_i_negate;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'i_negate' }
+sub desc { 'integer negation (-)' }
+sub check { 'ck_null' }
+sub flags { 'ifsT1' }
+sub args { 'S' }
+
+
+package PLXML::op_not;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'not' }
+sub desc { 'not' }
+sub check { 'ck_null' }
+sub flags { 'ifs1' }
+sub args { 'S' }
+
+
+package PLXML::op_complement;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'complement' }
+sub desc { '1\'s complement (~)' }
+sub check { 'ck_bitop' }
+sub flags { 'fst1' }
+sub args { 'S' }
+
+
+
+# High falutin' math.
+
+package PLXML::op_atan2;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'atan2' }
+sub desc { 'atan2' }
+sub check { 'ck_fun' }
+sub flags { 'fsT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_sin;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'sin' }
+sub desc { 'sin' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_cos;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'cos' }
+sub desc { 'cos' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_rand;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'rand' }
+sub desc { 'rand' }
+sub check { 'ck_fun' }
+sub flags { 'sT%' }
+sub args { 'S?' }
+
+
+package PLXML::op_srand;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'srand' }
+sub desc { 'srand' }
+sub check { 'ck_fun' }
+sub flags { 's%' }
+sub args { 'S?' }
+
+
+package PLXML::op_exp;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'exp' }
+sub desc { 'exp' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_log;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'log' }
+sub desc { 'log' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_sqrt;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'sqrt' }
+sub desc { 'sqrt' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+
+# Lowbrow math.
+
+package PLXML::op_int;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'int' }
+sub desc { 'int' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_hex;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'hex' }
+sub desc { 'hex' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_oct;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'oct' }
+sub desc { 'oct' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_abs;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'abs' }
+sub desc { 'abs' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+
+# String stuff.
+
+package PLXML::op_length;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'length' }
+sub desc { 'length' }
+sub check { 'ck_lengthconst' }
+sub flags { 'isTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_substr;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'substr' }
+sub desc { 'substr' }
+sub check { 'ck_substr' }
+sub flags { 'st@' }
+sub args { 'S S S? S?' }
+
+
+package PLXML::op_vec;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'vec' }
+sub desc { 'vec' }
+sub check { 'ck_fun' }
+sub flags { 'ist@' }
+sub args { 'S S S' }
+
+
+
+package PLXML::op_index;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'index' }
+sub desc { 'index' }
+sub check { 'ck_index' }
+sub flags { 'isT@' }
+sub args { 'S S S?' }
+
+
+package PLXML::op_rindex;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'rindex' }
+sub desc { 'rindex' }
+sub check { 'ck_index' }
+sub flags { 'isT@' }
+sub args { 'S S S?' }
+
+
+
+package PLXML::op_sprintf;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sprintf' }
+sub desc { 'sprintf' }
+sub check { 'ck_fun' }
+sub flags { 'mfst@' }
+sub args { 'S L' }
+
+
+package PLXML::op_formline;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'formline' }
+sub desc { 'formline' }
+sub check { 'ck_fun' }
+sub flags { 'ms@' }
+sub args { 'S L' }
+
+
+package PLXML::op_ord;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'ord' }
+sub desc { 'ord' }
+sub check { 'ck_fun' }
+sub flags { 'ifsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_chr;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'chr' }
+sub desc { 'chr' }
+sub check { 'ck_fun' }
+sub flags { 'fsTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_crypt;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'crypt' }
+sub desc { 'crypt' }
+sub check { 'ck_fun' }
+sub flags { 'fsT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_ucfirst;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'ucfirst' }
+sub desc { 'ucfirst' }
+sub check { 'ck_fun' }
+sub flags { 'fstu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_lcfirst;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'lcfirst' }
+sub desc { 'lcfirst' }
+sub check { 'ck_fun' }
+sub flags { 'fstu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_uc;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'uc' }
+sub desc { 'uc' }
+sub check { 'ck_fun' }
+sub flags { 'fstu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_lc;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'lc' }
+sub desc { 'lc' }
+sub check { 'ck_fun' }
+sub flags { 'fstu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_quotemeta;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'quotemeta' }
+sub desc { 'quotemeta' }
+sub check { 'ck_fun' }
+sub flags { 'fstu%' }
+sub args { 'S?' }
+
+
+
+# Arrays.
+
+package PLXML::op_rv2av;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'rv2av' }
+sub desc { 'array dereference' }
+sub check { 'ck_rvconst' }
+sub flags { 'dt1' }
+sub args { '' }
+
+
+package PLXML::op_aelemfast;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'aelemfast' }
+sub desc { 'constant array element' }
+sub check { 'ck_null' }
+sub flags { 's$' }
+sub args { 'A S' }
+
+
+package PLXML::op_aelem;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'aelem' }
+sub desc { 'array element' }
+sub check { 'ck_null' }
+sub flags { 's2' }
+sub args { 'A S' }
+
+
+package PLXML::op_aslice;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'aslice' }
+sub desc { 'array slice' }
+sub check { 'ck_null' }
+sub flags { 'm@' }
+sub args { 'A L' }
+
+
+
+# Hashes.
+
+package PLXML::op_each;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'each' }
+sub desc { 'each' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'H' }
+
+
+package PLXML::op_values;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'values' }
+sub desc { 'values' }
+sub check { 'ck_fun' }
+sub flags { 't%' }
+sub args { 'H' }
+
+
+package PLXML::op_keys;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'keys' }
+sub desc { 'keys' }
+sub check { 'ck_fun' }
+sub flags { 't%' }
+sub args { 'H' }
+
+
+package PLXML::op_delete;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'delete' }
+sub desc { 'delete' }
+sub check { 'ck_delete' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_exists;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'exists' }
+sub desc { 'exists' }
+sub check { 'ck_exists' }
+sub flags { 'is%' }
+sub args { 'S' }
+
+
+package PLXML::op_rv2hv;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'rv2hv' }
+sub desc { 'hash dereference' }
+sub check { 'ck_rvconst' }
+sub flags { 'dt1' }
+sub args { '' }
+
+
+package PLXML::op_helem;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'helem' }
+sub desc { 'hash element' }
+sub check { 'ck_null' }
+sub flags { 's2@' }
+sub args { 'H S' }
+
+
+package PLXML::op_hslice;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'hslice' }
+sub desc { 'hash slice' }
+sub check { 'ck_null' }
+sub flags { 'm@' }
+sub args { 'H L' }
+
+
+
+# Explosives and implosives.
+
+package PLXML::op_unpack;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'unpack' }
+sub desc { 'unpack' }
+sub check { 'ck_unpack' }
+sub flags { '@' }
+sub args { 'S S?' }
+
+
+package PLXML::op_pack;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'pack' }
+sub desc { 'pack' }
+sub check { 'ck_fun' }
+sub flags { 'mst@' }
+sub args { 'S L' }
+
+
+package PLXML::op_split;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'split' }
+sub desc { 'split' }
+sub check { 'ck_split' }
+sub flags { 't@' }
+sub args { 'S S S' }
+
+
+package PLXML::op_join;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'join' }
+sub desc { 'join or string' }
+sub check { 'ck_join' }
+sub flags { 'mst@' }
+sub args { 'S L' }
+
+
+
+# List operators.
+
+package PLXML::op_list;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'list' }
+sub desc { 'list' }
+sub check { 'ck_null' }
+sub flags { 'm@' }
+sub args { 'L' }
+
+
+package PLXML::op_lslice;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'lslice' }
+sub desc { 'list slice' }
+sub check { 'ck_null' }
+sub flags { '2' }
+sub args { 'H L L' }
+
+
+package PLXML::op_anonlist;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'anonlist' }
+sub desc { 'anonymous list ([])' }
+sub check { 'ck_fun' }
+sub flags { 'ms@' }
+sub args { 'L' }
+
+
+package PLXML::op_anonhash;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'anonhash' }
+sub desc { 'anonymous hash ({})' }
+sub check { 'ck_fun' }
+sub flags { 'ms@' }
+sub args { 'L' }
+
+
+
+package PLXML::op_splice;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'splice' }
+sub desc { 'splice' }
+sub check { 'ck_fun' }
+sub flags { 'm@' }
+sub args { 'A S? S? L' }
+
+
+package PLXML::op_push;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'push' }
+sub desc { 'push' }
+sub check { 'ck_fun' }
+sub flags { 'imsT@' }
+sub args { 'A L' }
+
+
+package PLXML::op_pop;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'pop' }
+sub desc { 'pop' }
+sub check { 'ck_shift' }
+sub flags { 's%' }
+sub args { 'A?' }
+
+
+package PLXML::op_shift;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'shift' }
+sub desc { 'shift' }
+sub check { 'ck_shift' }
+sub flags { 's%' }
+sub args { 'A?' }
+
+
+package PLXML::op_unshift;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'unshift' }
+sub desc { 'unshift' }
+sub check { 'ck_fun' }
+sub flags { 'imsT@' }
+sub args { 'A L' }
+
+
+package PLXML::op_sort;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sort' }
+sub desc { 'sort' }
+sub check { 'ck_sort' }
+sub flags { 'm@' }
+sub args { 'C? L' }
+
+
+package PLXML::op_reverse;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'reverse' }
+sub desc { 'reverse' }
+sub check { 'ck_fun' }
+sub flags { 'mt@' }
+sub args { 'L' }
+
+
+
+package PLXML::op_grepstart;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'grepstart' }
+sub desc { 'grep' }
+sub check { 'ck_grep' }
+sub flags { 'dm@' }
+sub args { 'C L' }
+
+
+package PLXML::op_grepwhile;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'grepwhile' }
+sub desc { 'grep iterator' }
+sub check { 'ck_null' }
+sub flags { 'dt|' }
+sub args { '' }
+
+
+
+package PLXML::op_mapstart;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'mapstart' }
+sub desc { 'map' }
+sub check { 'ck_grep' }
+sub flags { 'dm@' }
+sub args { 'C L' }
+
+
+package PLXML::op_mapwhile;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'mapwhile' }
+sub desc { 'map iterator' }
+sub check { 'ck_null' }
+sub flags { 'dt|' }
+sub args { '' }
+
+
+
+# Range stuff.
+
+package PLXML::op_range;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'range' }
+sub desc { 'flipflop' }
+sub check { 'ck_null' }
+sub flags { '|' }
+sub args { 'S S' }
+
+
+package PLXML::op_flip;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'flip' }
+sub desc { 'range (or flip)' }
+sub check { 'ck_null' }
+sub flags { '1' }
+sub args { 'S S' }
+
+
+package PLXML::op_flop;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'flop' }
+sub desc { 'range (or flop)' }
+sub check { 'ck_null' }
+sub flags { '1' }
+sub args { '' }
+
+
+
+# Control.
+
+package PLXML::op_and;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'and' }
+sub desc { 'logical and (&&)' }
+sub check { 'ck_null' }
+sub flags { '|' }
+sub args { '' }
+
+
+package PLXML::op_or;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'or' }
+sub desc { 'logical or (||)' }
+sub check { 'ck_null' }
+sub flags { '|' }
+sub args { '' }
+
+
+package PLXML::op_xor;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'xor' }
+sub desc { 'logical xor' }
+sub check { 'ck_null' }
+sub flags { 'fs2' }
+sub args { 'S S ' }
+
+
+package PLXML::op_cond_expr;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'cond_expr' }
+sub desc { 'conditional expression' }
+sub check { 'ck_null' }
+sub flags { 'd|' }
+sub args { '' }
+
+
+package PLXML::op_andassign;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'andassign' }
+sub desc { 'logical and assignment (&&=)' }
+sub check { 'ck_null' }
+sub flags { 's|' }
+sub args { '' }
+
+
+package PLXML::op_orassign;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'orassign' }
+sub desc { 'logical or assignment (||=)' }
+sub check { 'ck_null' }
+sub flags { 's|' }
+sub args { '' }
+
+
+
+package PLXML::op_method;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'method' }
+sub desc { 'method lookup' }
+sub check { 'ck_method' }
+sub flags { 'd1' }
+sub args { '' }
+
+
+package PLXML::op_entersub;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'entersub' }
+sub desc { 'subroutine entry' }
+sub check { 'ck_subr' }
+sub flags { 'dmt1' }
+sub args { 'L' }
+
+
+package PLXML::op_leavesub;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'leavesub' }
+sub desc { 'subroutine exit' }
+sub check { 'ck_null' }
+sub flags { '1' }
+sub args { '' }
+
+
+package PLXML::op_leavesublv;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'leavesublv' }
+sub desc { 'lvalue subroutine return' }
+sub check { 'ck_null' }
+sub flags { '1' }
+sub args { '' }
+
+
+package PLXML::op_caller;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'caller' }
+sub desc { 'caller' }
+sub check { 'ck_fun' }
+sub flags { 't%' }
+sub args { 'S?' }
+
+
+package PLXML::op_warn;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'warn' }
+sub desc { 'warn' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'L' }
+
+
+package PLXML::op_die;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'die' }
+sub desc { 'die' }
+sub check { 'ck_die' }
+sub flags { 'dimst@' }
+sub args { 'L' }
+
+
+package PLXML::op_reset;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'reset' }
+sub desc { 'symbol reset' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'S?' }
+
+
+
+package PLXML::op_lineseq;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'lineseq' }
+sub desc { 'line sequence' }
+sub check { 'ck_null' }
+sub flags { '@' }
+sub args { '' }
+
+
+package PLXML::op_nextstate;
+
+our @ISA = ('PLXML::cop');
+
+sub key { 'nextstate' }
+sub desc { 'next statement' }
+sub check { 'ck_null' }
+sub flags { 's;' }
+sub args { '' }
+
+
+package PLXML::op_dbstate;
+
+our @ISA = ('PLXML::cop');
+
+sub key { 'dbstate' }
+sub desc { 'debug next statement' }
+sub check { 'ck_null' }
+sub flags { 's;' }
+sub args { '' }
+
+
+package PLXML::op_unstack;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'unstack' }
+sub desc { 'iteration finalizer' }
+sub check { 'ck_null' }
+sub flags { 's0' }
+sub args { '' }
+
+
+package PLXML::op_enter;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'enter' }
+sub desc { 'block entry' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_leave;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'leave' }
+sub desc { 'block exit' }
+sub check { 'ck_null' }
+sub flags { '@' }
+sub args { '' }
+
+
+package PLXML::op_scope;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'scope' }
+sub desc { 'block' }
+sub check { 'ck_null' }
+sub flags { '@' }
+sub args { '' }
+
+
+package PLXML::op_enteriter;
+
+our @ISA = ('PLXML::loop');
+
+sub key { 'enteriter' }
+sub desc { 'foreach loop entry' }
+sub check { 'ck_null' }
+sub flags { 'd{' }
+sub args { '' }
+
+
+package PLXML::op_iter;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'iter' }
+sub desc { 'foreach loop iterator' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_enterloop;
+
+our @ISA = ('PLXML::loop');
+
+sub key { 'enterloop' }
+sub desc { 'loop entry' }
+sub check { 'ck_null' }
+sub flags { 'd{' }
+sub args { '' }
+
+
+package PLXML::op_leaveloop;
+
+our @ISA = ('PLXML::binop');
+
+sub key { 'leaveloop' }
+sub desc { 'loop exit' }
+sub check { 'ck_null' }
+sub flags { '2' }
+sub args { '' }
+
+
+package PLXML::op_return;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'return' }
+sub desc { 'return' }
+sub check { 'ck_return' }
+sub flags { 'dm@' }
+sub args { 'L' }
+
+
+package PLXML::op_last;
+
+our @ISA = ('PLXML::loopexop');
+
+sub key { 'last' }
+sub desc { 'last' }
+sub check { 'ck_null' }
+sub flags { 'ds}' }
+sub args { '' }
+
+
+package PLXML::op_next;
+
+our @ISA = ('PLXML::loopexop');
+
+sub key { 'next' }
+sub desc { 'next' }
+sub check { 'ck_null' }
+sub flags { 'ds}' }
+sub args { '' }
+
+
+package PLXML::op_redo;
+
+our @ISA = ('PLXML::loopexop');
+
+sub key { 'redo' }
+sub desc { 'redo' }
+sub check { 'ck_null' }
+sub flags { 'ds}' }
+sub args { '' }
+
+
+package PLXML::op_dump;
+
+our @ISA = ('PLXML::loopexop');
+
+sub key { 'dump' }
+sub desc { 'dump' }
+sub check { 'ck_null' }
+sub flags { 'ds}' }
+sub args { '' }
+
+
+package PLXML::op_goto;
+
+our @ISA = ('PLXML::loopexop');
+
+sub key { 'goto' }
+sub desc { 'goto' }
+sub check { 'ck_null' }
+sub flags { 'ds}' }
+sub args { '' }
+
+
+package PLXML::op_exit;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'exit' }
+sub desc { 'exit' }
+sub check { 'ck_exit' }
+sub flags { 'ds%' }
+sub args { 'S?' }
+
+
+# continued below
+
+#nswitch numeric switch ck_null d
+#cswitch character switch ck_null d
+
+# I/O.
+
+package PLXML::op_open;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'open' }
+sub desc { 'open' }
+sub check { 'ck_open' }
+sub flags { 'ismt@' }
+sub args { 'F S? L' }
+
+
+package PLXML::op_close;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'close' }
+sub desc { 'close' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'F?' }
+
+
+package PLXML::op_pipe_op;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'pipe_op' }
+sub desc { 'pipe' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'F F' }
+
+
+
+package PLXML::op_fileno;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'fileno' }
+sub desc { 'fileno' }
+sub check { 'ck_fun' }
+sub flags { 'ist%' }
+sub args { 'F' }
+
+
+package PLXML::op_umask;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'umask' }
+sub desc { 'umask' }
+sub check { 'ck_fun' }
+sub flags { 'ist%' }
+sub args { 'S?' }
+
+
+package PLXML::op_binmode;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'binmode' }
+sub desc { 'binmode' }
+sub check { 'ck_fun' }
+sub flags { 's@' }
+sub args { 'F S?' }
+
+
+
+package PLXML::op_tie;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'tie' }
+sub desc { 'tie' }
+sub check { 'ck_fun' }
+sub flags { 'idms@' }
+sub args { 'R S L' }
+
+
+package PLXML::op_untie;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'untie' }
+sub desc { 'untie' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'R' }
+
+
+package PLXML::op_tied;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'tied' }
+sub desc { 'tied' }
+sub check { 'ck_fun' }
+sub flags { 's%' }
+sub args { 'R' }
+
+
+package PLXML::op_dbmopen;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'dbmopen' }
+sub desc { 'dbmopen' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'H S S' }
+
+
+package PLXML::op_dbmclose;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'dbmclose' }
+sub desc { 'dbmclose' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'H' }
+
+
+
+package PLXML::op_sselect;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sselect' }
+sub desc { 'select system call' }
+sub check { 'ck_select' }
+sub flags { 't@' }
+sub args { 'S S S S' }
+
+
+package PLXML::op_select;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'select' }
+sub desc { 'select' }
+sub check { 'ck_select' }
+sub flags { 'st@' }
+sub args { 'F?' }
+
+
+
+package PLXML::op_getc;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'getc' }
+sub desc { 'getc' }
+sub check { 'ck_eof' }
+sub flags { 'st%' }
+sub args { 'F?' }
+
+
+package PLXML::op_read;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'read' }
+sub desc { 'read' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'F R S S?' }
+
+
+package PLXML::op_enterwrite;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'enterwrite' }
+sub desc { 'write' }
+sub check { 'ck_fun' }
+sub flags { 'dis%' }
+sub args { 'F?' }
+
+
+package PLXML::op_leavewrite;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'leavewrite' }
+sub desc { 'write exit' }
+sub check { 'ck_null' }
+sub flags { '1' }
+sub args { '' }
+
+
+
+package PLXML::op_prtf;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'prtf' }
+sub desc { 'printf' }
+sub check { 'ck_listiob' }
+sub flags { 'ims@' }
+sub args { 'F? L' }
+
+
+package PLXML::op_print;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'print' }
+sub desc { 'print' }
+sub check { 'ck_listiob' }
+sub flags { 'ims@' }
+sub args { 'F? L' }
+
+
+package PLXML::op_say;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'say' }
+sub desc { 'say' }
+sub check { 'ck_listiob' }
+sub flags { 'ims@' }
+sub args { 'F? L' }
+
+
+package PLXML::op_sysopen;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sysopen' }
+sub desc { 'sysopen' }
+sub check { 'ck_fun' }
+sub flags { 's@' }
+sub args { 'F S S S?' }
+
+
+package PLXML::op_sysseek;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sysseek' }
+sub desc { 'sysseek' }
+sub check { 'ck_fun' }
+sub flags { 's@' }
+sub args { 'F S S' }
+
+
+package PLXML::op_sysread;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sysread' }
+sub desc { 'sysread' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'F R S S?' }
+
+
+package PLXML::op_syswrite;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'syswrite' }
+sub desc { 'syswrite' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'F S S? S?' }
+
+
+
+package PLXML::op_send;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'send' }
+sub desc { 'send' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'Fs S S S?' }
+
+
+package PLXML::op_recv;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'recv' }
+sub desc { 'recv' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'Fs R S S' }
+
+
+
+package PLXML::op_eof;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'eof' }
+sub desc { 'eof' }
+sub check { 'ck_eof' }
+sub flags { 'is%' }
+sub args { 'F?' }
+
+
+package PLXML::op_tell;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'tell' }
+sub desc { 'tell' }
+sub check { 'ck_fun' }
+sub flags { 'st%' }
+sub args { 'F?' }
+
+
+package PLXML::op_seek;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'seek' }
+sub desc { 'seek' }
+sub check { 'ck_fun' }
+sub flags { 's@' }
+sub args { 'F S S' }
+
+
+# truncate really behaves as if it had both "S S" and "F S"
+package PLXML::op_truncate;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'truncate' }
+sub desc { 'truncate' }
+sub check { 'ck_trunc' }
+sub flags { 'is@' }
+sub args { 'S S' }
+
+
+
+package PLXML::op_fcntl;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'fcntl' }
+sub desc { 'fcntl' }
+sub check { 'ck_fun' }
+sub flags { 'st@' }
+sub args { 'F S S' }
+
+
+package PLXML::op_ioctl;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'ioctl' }
+sub desc { 'ioctl' }
+sub check { 'ck_fun' }
+sub flags { 'st@' }
+sub args { 'F S S' }
+
+
+package PLXML::op_flock;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'flock' }
+sub desc { 'flock' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'F S' }
+
+
+
+# Sockets.
+
+package PLXML::op_socket;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'socket' }
+sub desc { 'socket' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs S S S' }
+
+
+package PLXML::op_sockpair;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'sockpair' }
+sub desc { 'socketpair' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs Fs S S S' }
+
+
+
+package PLXML::op_bind;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'bind' }
+sub desc { 'bind' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs S' }
+
+
+package PLXML::op_connect;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'connect' }
+sub desc { 'connect' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs S' }
+
+
+package PLXML::op_listen;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'listen' }
+sub desc { 'listen' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs S' }
+
+
+package PLXML::op_accept;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'accept' }
+sub desc { 'accept' }
+sub check { 'ck_fun' }
+sub flags { 'ist@' }
+sub args { 'Fs Fs' }
+
+
+package PLXML::op_shutdown;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'shutdown' }
+sub desc { 'shutdown' }
+sub check { 'ck_fun' }
+sub flags { 'ist@' }
+sub args { 'Fs S' }
+
+
+
+package PLXML::op_gsockopt;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'gsockopt' }
+sub desc { 'getsockopt' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs S S' }
+
+
+package PLXML::op_ssockopt;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'ssockopt' }
+sub desc { 'setsockopt' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'Fs S S S' }
+
+
+
+package PLXML::op_getsockname;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'getsockname' }
+sub desc { 'getsockname' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'Fs' }
+
+
+package PLXML::op_getpeername;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'getpeername' }
+sub desc { 'getpeername' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'Fs' }
+
+
+
+# Stat calls.
+
+package PLXML::op_lstat;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'lstat' }
+sub desc { 'lstat' }
+sub check { 'ck_ftst' }
+sub flags { 'u-' }
+sub args { 'F' }
+
+
+package PLXML::op_stat;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'stat' }
+sub desc { 'stat' }
+sub check { 'ck_ftst' }
+sub flags { 'u-' }
+sub args { 'F' }
+
+
+package PLXML::op_ftrread;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftrread' }
+sub desc { '-R' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftrwrite;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftrwrite' }
+sub desc { '-W' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftrexec;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftrexec' }
+sub desc { '-X' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_fteread;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'fteread' }
+sub desc { '-r' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftewrite;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftewrite' }
+sub desc { '-w' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_fteexec;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'fteexec' }
+sub desc { '-x' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftis;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftis' }
+sub desc { '-e' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_fteowned;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'fteowned' }
+sub desc { '-O' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftrowned;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftrowned' }
+sub desc { '-o' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftzero;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftzero' }
+sub desc { '-z' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftsize;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftsize' }
+sub desc { '-s' }
+sub check { 'ck_ftst' }
+sub flags { 'istu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftmtime;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftmtime' }
+sub desc { '-M' }
+sub check { 'ck_ftst' }
+sub flags { 'stu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftatime;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftatime' }
+sub desc { '-A' }
+sub check { 'ck_ftst' }
+sub flags { 'stu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftctime;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftctime' }
+sub desc { '-C' }
+sub check { 'ck_ftst' }
+sub flags { 'stu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftsock;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftsock' }
+sub desc { '-S' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftchr;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftchr' }
+sub desc { '-c' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftblk;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftblk' }
+sub desc { '-b' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftfile;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftfile' }
+sub desc { '-f' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftdir;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftdir' }
+sub desc { '-d' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftpipe;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftpipe' }
+sub desc { '-p' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftlink;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftlink' }
+sub desc { '-l' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftsuid;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftsuid' }
+sub desc { '-u' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftsgid;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftsgid' }
+sub desc { '-g' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftsvtx;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftsvtx' }
+sub desc { '-k' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_fttty;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'fttty' }
+sub desc { '-t' }
+sub check { 'ck_ftst' }
+sub flags { 'is-' }
+sub args { 'F-' }
+
+
+package PLXML::op_fttext;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'fttext' }
+sub desc { '-T' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+package PLXML::op_ftbinary;
+
+our @ISA = ('PLXML::filestatop');
+
+sub key { 'ftbinary' }
+sub desc { '-B' }
+sub check { 'ck_ftst' }
+sub flags { 'isu-' }
+sub args { 'F-' }
+
+
+
+# File calls.
+
+package PLXML::op_chdir;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'chdir' }
+sub desc { 'chdir' }
+sub check { 'ck_fun' }
+sub flags { 'isT%' }
+sub args { 'S?' }
+
+
+package PLXML::op_chown;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'chown' }
+sub desc { 'chown' }
+sub check { 'ck_fun' }
+sub flags { 'imsT@' }
+sub args { 'L' }
+
+
+package PLXML::op_chroot;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'chroot' }
+sub desc { 'chroot' }
+sub check { 'ck_fun' }
+sub flags { 'isTu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_unlink;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'unlink' }
+sub desc { 'unlink' }
+sub check { 'ck_fun' }
+sub flags { 'imsTu@' }
+sub args { 'L' }
+
+
+package PLXML::op_chmod;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'chmod' }
+sub desc { 'chmod' }
+sub check { 'ck_fun' }
+sub flags { 'imsT@' }
+sub args { 'L' }
+
+
+package PLXML::op_utime;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'utime' }
+sub desc { 'utime' }
+sub check { 'ck_fun' }
+sub flags { 'imsT@' }
+sub args { 'L' }
+
+
+package PLXML::op_rename;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'rename' }
+sub desc { 'rename' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_link;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'link' }
+sub desc { 'link' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_symlink;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'symlink' }
+sub desc { 'symlink' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_readlink;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'readlink' }
+sub desc { 'readlink' }
+sub check { 'ck_fun' }
+sub flags { 'stu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_mkdir;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'mkdir' }
+sub desc { 'mkdir' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S?' }
+
+
+package PLXML::op_rmdir;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'rmdir' }
+sub desc { 'rmdir' }
+sub check { 'ck_fun' }
+sub flags { 'isTu%' }
+sub args { 'S?' }
+
+
+
+# Directory calls.
+
+package PLXML::op_open_dir;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'open_dir' }
+sub desc { 'opendir' }
+sub check { 'ck_fun' }
+sub flags { 'is@' }
+sub args { 'F S' }
+
+
+package PLXML::op_readdir;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'readdir' }
+sub desc { 'readdir' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'F' }
+
+
+package PLXML::op_telldir;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'telldir' }
+sub desc { 'telldir' }
+sub check { 'ck_fun' }
+sub flags { 'st%' }
+sub args { 'F' }
+
+
+package PLXML::op_seekdir;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'seekdir' }
+sub desc { 'seekdir' }
+sub check { 'ck_fun' }
+sub flags { 's@' }
+sub args { 'F S' }
+
+
+package PLXML::op_rewinddir;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'rewinddir' }
+sub desc { 'rewinddir' }
+sub check { 'ck_fun' }
+sub flags { 's%' }
+sub args { 'F' }
+
+
+package PLXML::op_closedir;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'closedir' }
+sub desc { 'closedir' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'F' }
+
+
+
+# Process control.
+
+package PLXML::op_fork;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'fork' }
+sub desc { 'fork' }
+sub check { 'ck_null' }
+sub flags { 'ist0' }
+sub args { '' }
+
+
+package PLXML::op_wait;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'wait' }
+sub desc { 'wait' }
+sub check { 'ck_null' }
+sub flags { 'isT0' }
+sub args { '' }
+
+
+package PLXML::op_waitpid;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'waitpid' }
+sub desc { 'waitpid' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_system;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'system' }
+sub desc { 'system' }
+sub check { 'ck_exec' }
+sub flags { 'imsT@' }
+sub args { 'S? L' }
+
+
+package PLXML::op_exec;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'exec' }
+sub desc { 'exec' }
+sub check { 'ck_exec' }
+sub flags { 'dimsT@' }
+sub args { 'S? L' }
+
+
+package PLXML::op_kill;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'kill' }
+sub desc { 'kill' }
+sub check { 'ck_fun' }
+sub flags { 'dimsT@' }
+sub args { 'L' }
+
+
+package PLXML::op_getppid;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'getppid' }
+sub desc { 'getppid' }
+sub check { 'ck_null' }
+sub flags { 'isT0' }
+sub args { '' }
+
+
+package PLXML::op_getpgrp;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'getpgrp' }
+sub desc { 'getpgrp' }
+sub check { 'ck_fun' }
+sub flags { 'isT%' }
+sub args { 'S?' }
+
+
+package PLXML::op_setpgrp;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'setpgrp' }
+sub desc { 'setpgrp' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S? S?' }
+
+
+package PLXML::op_getpriority;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'getpriority' }
+sub desc { 'getpriority' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S' }
+
+
+package PLXML::op_setpriority;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'setpriority' }
+sub desc { 'setpriority' }
+sub check { 'ck_fun' }
+sub flags { 'isT@' }
+sub args { 'S S S' }
+
+
+
+# Time calls.
+
+package PLXML::op_time;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'time' }
+sub desc { 'time' }
+sub check { 'ck_null' }
+sub flags { 'isT0' }
+sub args { '' }
+
+
+package PLXML::op_tms;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'tms' }
+sub desc { 'times' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_localtime;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'localtime' }
+sub desc { 'localtime' }
+sub check { 'ck_fun' }
+sub flags { 't%' }
+sub args { 'S?' }
+
+
+package PLXML::op_gmtime;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'gmtime' }
+sub desc { 'gmtime' }
+sub check { 'ck_fun' }
+sub flags { 't%' }
+sub args { 'S?' }
+
+
+package PLXML::op_alarm;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'alarm' }
+sub desc { 'alarm' }
+sub check { 'ck_fun' }
+sub flags { 'istu%' }
+sub args { 'S?' }
+
+
+package PLXML::op_sleep;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'sleep' }
+sub desc { 'sleep' }
+sub check { 'ck_fun' }
+sub flags { 'isT%' }
+sub args { 'S?' }
+
+
+
+# Shared memory.
+
+package PLXML::op_shmget;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'shmget' }
+sub desc { 'shmget' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S' }
+
+
+package PLXML::op_shmctl;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'shmctl' }
+sub desc { 'shmctl' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S' }
+
+
+package PLXML::op_shmread;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'shmread' }
+sub desc { 'shmread' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S S' }
+
+
+package PLXML::op_shmwrite;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'shmwrite' }
+sub desc { 'shmwrite' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S S' }
+
+
+
+# Message passing.
+
+package PLXML::op_msgget;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'msgget' }
+sub desc { 'msgget' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S' }
+
+
+package PLXML::op_msgctl;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'msgctl' }
+sub desc { 'msgctl' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S' }
+
+
+package PLXML::op_msgsnd;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'msgsnd' }
+sub desc { 'msgsnd' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S' }
+
+
+package PLXML::op_msgrcv;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'msgrcv' }
+sub desc { 'msgrcv' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S S S' }
+
+
+
+# Semaphores.
+
+package PLXML::op_semget;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'semget' }
+sub desc { 'semget' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S' }
+
+
+package PLXML::op_semctl;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'semctl' }
+sub desc { 'semctl' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S S S' }
+
+
+package PLXML::op_semop;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'semop' }
+sub desc { 'semop' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S S' }
+
+
+
+# Eval.
+
+package PLXML::op_require;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'require' }
+sub desc { 'require' }
+sub check { 'ck_require' }
+sub flags { 'du%' }
+sub args { 'S?' }
+
+
+package PLXML::op_dofile;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'dofile' }
+sub desc { 'do "file"' }
+sub check { 'ck_fun' }
+sub flags { 'd1' }
+sub args { 'S' }
+
+
+package PLXML::op_entereval;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'entereval' }
+sub desc { 'eval "string"' }
+sub check { 'ck_eval' }
+sub flags { 'd%' }
+sub args { 'S' }
+
+
+package PLXML::op_leaveeval;
+
+our @ISA = ('PLXML::unop');
+
+sub key { 'leaveeval' }
+sub desc { 'eval "string" exit' }
+sub check { 'ck_null' }
+sub flags { '1' }
+sub args { 'S' }
+
+
+#evalonce eval constant string ck_null d1 S
+package PLXML::op_entertry;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'entertry' }
+sub desc { 'eval {block}' }
+sub check { 'ck_null' }
+sub flags { '|' }
+sub args { '' }
+
+
+package PLXML::op_leavetry;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'leavetry' }
+sub desc { 'eval {block} exit' }
+sub check { 'ck_null' }
+sub flags { '@' }
+sub args { '' }
+
+
+
+# Get system info.
+
+package PLXML::op_ghbyname;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'ghbyname' }
+sub desc { 'gethostbyname' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_ghbyaddr;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'ghbyaddr' }
+sub desc { 'gethostbyaddr' }
+sub check { 'ck_fun' }
+sub flags { '@' }
+sub args { 'S S' }
+
+
+package PLXML::op_ghostent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'ghostent' }
+sub desc { 'gethostent' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_gnbyname;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'gnbyname' }
+sub desc { 'getnetbyname' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_gnbyaddr;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'gnbyaddr' }
+sub desc { 'getnetbyaddr' }
+sub check { 'ck_fun' }
+sub flags { '@' }
+sub args { 'S S' }
+
+
+package PLXML::op_gnetent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'gnetent' }
+sub desc { 'getnetent' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_gpbyname;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'gpbyname' }
+sub desc { 'getprotobyname' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_gpbynumber;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'gpbynumber' }
+sub desc { 'getprotobynumber' }
+sub check { 'ck_fun' }
+sub flags { '@' }
+sub args { 'S' }
+
+
+package PLXML::op_gprotoent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'gprotoent' }
+sub desc { 'getprotoent' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_gsbyname;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'gsbyname' }
+sub desc { 'getservbyname' }
+sub check { 'ck_fun' }
+sub flags { '@' }
+sub args { 'S S' }
+
+
+package PLXML::op_gsbyport;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'gsbyport' }
+sub desc { 'getservbyport' }
+sub check { 'ck_fun' }
+sub flags { '@' }
+sub args { 'S S' }
+
+
+package PLXML::op_gservent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'gservent' }
+sub desc { 'getservent' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_shostent;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'shostent' }
+sub desc { 'sethostent' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'S' }
+
+
+package PLXML::op_snetent;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'snetent' }
+sub desc { 'setnetent' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'S' }
+
+
+package PLXML::op_sprotoent;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'sprotoent' }
+sub desc { 'setprotoent' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'S' }
+
+
+package PLXML::op_sservent;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'sservent' }
+sub desc { 'setservent' }
+sub check { 'ck_fun' }
+sub flags { 'is%' }
+sub args { 'S' }
+
+
+package PLXML::op_ehostent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'ehostent' }
+sub desc { 'endhostent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_enetent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'enetent' }
+sub desc { 'endnetent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_eprotoent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'eprotoent' }
+sub desc { 'endprotoent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_eservent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'eservent' }
+sub desc { 'endservent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_gpwnam;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'gpwnam' }
+sub desc { 'getpwnam' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_gpwuid;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'gpwuid' }
+sub desc { 'getpwuid' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_gpwent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'gpwent' }
+sub desc { 'getpwent' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_spwent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'spwent' }
+sub desc { 'setpwent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_epwent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'epwent' }
+sub desc { 'endpwent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_ggrnam;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'ggrnam' }
+sub desc { 'getgrnam' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_ggrgid;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'ggrgid' }
+sub desc { 'getgrgid' }
+sub check { 'ck_fun' }
+sub flags { '%' }
+sub args { 'S' }
+
+
+package PLXML::op_ggrent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'ggrent' }
+sub desc { 'getgrent' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
+package PLXML::op_sgrent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'sgrent' }
+sub desc { 'setgrent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_egrent;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'egrent' }
+sub desc { 'endgrent' }
+sub check { 'ck_null' }
+sub flags { 'is0' }
+sub args { '' }
+
+
+package PLXML::op_getlogin;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'getlogin' }
+sub desc { 'getlogin' }
+sub check { 'ck_null' }
+sub flags { 'st0' }
+sub args { '' }
+
+
+
+# Miscellaneous.
+
+package PLXML::op_syscall;
+
+our @ISA = ('PLXML::listop');
+
+sub key { 'syscall' }
+sub desc { 'syscall' }
+sub check { 'ck_fun' }
+sub flags { 'imst@' }
+sub args { 'S L' }
+
+
+
+# For multi-threading
+package PLXML::op_lock;
+
+our @ISA = ('PLXML::baseop_unop');
+
+sub key { 'lock' }
+sub desc { 'lock' }
+sub check { 'ck_rfun' }
+sub flags { 's%' }
+sub args { 'R' }
+
+
+package PLXML::op_threadsv;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'threadsv' }
+sub desc { 'per-thread value' }
+sub check { 'ck_null' }
+sub flags { 'ds0' }
+sub args { '' }
+
+
+
+# Control (contd.)
+package PLXML::op_setstate;
+
+our @ISA = ('PLXML::cop');
+
+sub key { 'setstate' }
+sub desc { 'set statement info' }
+sub check { 'ck_null' }
+sub flags { 's;' }
+sub args { '' }
+
+
+package PLXML::op_method_named;
+
+our @ISA = ('PLXML::padop_svop');
+
+sub key { 'method_named' }
+sub desc { 'method with known name' }
+sub check { 'ck_null' }
+sub flags { 'd$' }
+sub args { '' }
+
+
+
+package PLXML::op_dor;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'dor' }
+sub desc { 'defined or (//)' }
+sub check { 'ck_null' }
+sub flags { '|' }
+sub args { '' }
+
+
+package PLXML::op_dorassign;
+
+our @ISA = ('PLXML::logop');
+
+sub key { 'dorassign' }
+sub desc { 'defined or assignment (//=)' }
+sub check { 'ck_null' }
+sub flags { 's|' }
+sub args { '' }
+
+
+
+# Add new ops before this, the custom operator.
+
+package PLXML::op_custom;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'custom' }
+sub desc { 'unknown custom operator' }
+sub check { 'ck_null' }
+sub flags { '0' }
+sub args { '' }
+
+
--- /dev/null
+#!/usr/bin/env python3
+
+import sys
+import yaml
+
+EXIT_SUCCESS = 0
+EXIT_FAILURE = 1
+
+if len(sys.argv) < 3:
+ print('usage: {sys.argv[0]} infile.yml outfile.xml')
+ sys.exit(EXIT_FAILURE)
+infile_yml = sys.argv[1]
+outfile_xml = sys.argv[2]
+
+def any_constructor(loader, tag_suffix, node):
+ if isinstance(node, yaml.MappingNode):
+ result = loader.construct_mapping(node)
+ result['tag_suffix'] = tag_suffix
+ elif isinstance(node, yaml.SequenceNode):
+ result = loader.construct_sequence(node)
+ elif isinstance(node, yaml.ScalarNode):
+ result = loader.construct_scalar(node)
+ else:
+ assert False
+ return result
+yaml.add_multi_constructor('', any_constructor, Loader = yaml.SafeLoader)
+
+def dump(node):
+ if 'uni' in node:
+ kids = str(node['uni']).replace('&', '&').replace('<', '<').replace('>', '>')
+ elif 'Kids' in node:
+ kids = ''.join([dump(i) for i in node['Kids']])
+ else:
+ assert False
+
+ tag_suffix = node['tag_suffix']
+ assert tag_suffix[:28] == 'tag:yaml.org,2002:perl/hash:'
+ tag_suffix = tag_suffix[28:].replace(':', '_')
+ return f'<{tag_suffix:s}>{kids:s}</{tag_suffix:s}>'
+
+with open(infile_yml) as fin:
+ ast = yaml.safe_load(fin)
+with open(outfile_xml, 'w') as fout:
+ fout.write(dump(ast))
--- /dev/null
+#!/bin/sh
+
+if test $# -lt 2
+then
+ echo "usage: $0 infile.pl outfile.xml"
+ exit 1
+fi
+infile_pl="$1"
+outfile_xml="$2"
+
+PERL_XMLDUMP=__temp__.xml /usr/local/bin/perl "$infile_pl"
+./nomad.pl __temp__.xml __temp__.yml
+./ast.py __temp__.yml "$outfile_xml"
+rm -f __temp__.xml __temp__.yml
--- /dev/null
+#!/usr/bin/env perl
+
+use Nomad;
+
+$#ARGV >= 1 || die("usage: $0 infile.xml outfile.yml");
+my $infile_xml = $ARGV[0];
+my $outfile_yml = $ARGV[1];
+
+open my $outfile, ">$outfile_yml";
+$outfile->print(Nomad::xml_to_p5(input => $infile_xml, YAML => 1));
+close $outfile;
--- /dev/null
+#!/usr/bin/env perl
+#
+# Dump a binary PDP-7 file where a word is encoded as three bytes,
+# with sixbits are stored big-endian in each of the three byte.
+#
+use strict;
+use warnings;
+
+die("Usage: $0 binaryfile\n") if (@ARGV==0);
+
+open(my $IN, "<", $ARGV[0]) || die("Can't open $ARGV[0]: $!\n");
+while (1) {
+ # Convert three bytes into one 18-bit word
+ my $result= read($IN, my $three, 3);
+ last if ($result != 3); # Not enough bytes read
+ my ($b1, $b2, $b3)= unpack("CCC", $three);
+ my $word= (($b1 & 077) << 12) | (($b2 & 077) << 6) | ($b3 & 077);
+
+ my $c1= ($word >> 9) & 0777;
+ $c1= (($c1 >= 32) && ($c1 <= 126)) ? chr($c1) : ' ';
+ my $c2= $word & 0777;
+ $c2= (($c2 >= 32) && ($c2 <= 126)) ? chr($c2) : ' ';
+ printf("%06o %s%s\n", $word, $c1, $c2)
+}
+close($IN);
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# a7out: user-mode simulator for PDP-7 Unix applications
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Fcntl qw(:seek);
+use DateTime;
+use Data::Dumper;
+
+### Global variables ###
+my $debug = 0; # Debug flag
+my $singlestep = 0; # Are we running in single-step mode?
+my $coverage = 0; # Print out code coverage
+my %Breakpoint; # Hash of defined breakpoints
+my @Mem; # 8K 18-bit words of main memory
+my %Addr2Name; # Map addresses to names
+my %Name2Addr; # Map names to addresses
+my @CC; # Code coverage: what addrs executed instructions
+my @FD; # Array of open filehandles
+my @ISBINARY; # Array of filehandle flags: ASCII or binary files?
+
+# Registers
+my $PC = 010000; # Program counter
+my $AC = 0; # Accumulator
+my $LINK = 0; # Link register, either 0 or LINKMASK
+my $MQ = 0; # MQ register
+
+# Constants
+use constant MAXINT => 0777777; # Biggest unsigned integer
+use constant MAXPOSINT => 0377777; # Biggest signed integer
+use constant MAXADDR => 017777; # Largest memory address
+use constant LINKMASK => 01000000; # Mask for LINK register
+use constant EAESTEP => 077; # EAE step count mask
+use constant EAEIMASK => 0777700; # EAE instruction mask
+use constant SIGN => 0400000; # Sign bit
+
+use constant EPSILON => 99; # max delta for symbol display
+
+### Main program ###
+
+# Get any optional arguments
+while ( defined( $ARGV[0] ) && ( $ARGV[0] =~ m{^-} ) ) {
+
+ # -d: debug mode
+ if ( $ARGV[0] eq "-d" ) {
+ $debug = 1;
+ shift(@ARGV);
+ }
+
+ # -b: set a breakpoint
+ if ( $ARGV[0] eq "-b" ) {
+ shift(@ARGV);
+ $Breakpoint{ lookup( shift(@ARGV) ) } = 1;
+ }
+
+ # -c: print out code coverage
+ if ( $ARGV[0] eq "-c" ) {
+ shift(@ARGV);
+ $coverage= 1;
+ }
+
+ # -n: read a namelist file
+ if ( $ARGV[0] eq "-n" ) {
+ shift(@ARGV);
+ load_names( shift(@ARGV) );
+ }
+}
+
+# Check the arguments
+die("Usage: $0 [-c] [-d] [-b breakpoint] [-n namelist] a.outfile [arg1 arg2 ...]\n")
+ if ( @ARGV < 1 );
+
+# Load the a.out file into memory
+# and simulate it
+load_code( $ARGV[0] );
+set_arguments();
+
+#dump_memory(0, MAXADDR, 0);
+#exit(0);
+simulate();
+print_coverage() if ($coverage);
+exit(0);
+
+# Print out the code coverage
+sub print_coverage {
+ foreach my $addr (0 .. MAXADDR ) {
+ printf("%06o: %d\n", $addr, $CC[$addr]) if ($CC[$addr]);
+ }
+}
+
+### Load the a.out file into memory
+sub load_code {
+ my $filename = shift;
+
+ # Fill all the 8K words in memory with zeroes
+ foreach my $i ( 0 .. MAXADDR ) {
+ $Mem[$i] = 0;
+ }
+
+ # Set up some open filehandles
+ $FD[0] = \*STDIN;
+ $FD[1] = \*STDOUT;
+ $FD[8] = \*STDERR; # According to cat.s (uses d8 == 8)
+
+ # Open up the PDP-7 executable file
+ open( my $IN, "<", $filename ) || die("Unable to open $filename: $!\n");
+ my $c = getc($IN);
+ seek $IN, 0, 0;
+ if ((ord($c) & 0300) == 0200) { # handle "binary paper tape" format
+ my $addr = 010000; # user programs loaded at 4K mark
+ while ($addr <= 017777) {
+ my $result = read_word($IN);
+ last if ($result == -1);
+ $Mem[$addr++] = $result;
+ }
+ close($IN);
+ return;
+ }
+ while (<$IN>) {
+ chomp;
+
+ # Lose any textual stuff after a tab character
+ $_ =~ s{\t.*}{};
+
+ # Split into location and value, both in octal
+ my ( $loc, $val ) = split( /:\s+/, $_ );
+
+ # Convert from octal and save
+ $loc = oct($loc);
+ $val = oct($val);
+ $Mem[$loc] = $val;
+ }
+ close($IN);
+}
+
+### read a word from a file in paper tape binary format
+### return -1 on EOF
+sub read_word {
+ my $F = shift;
+ # Convert three bytes into one 18-bit word
+ return -1 if ( read( $F, my $three, 3 ) != 3 ); # Not enough bytes read
+ my ( $b1, $b2, $b3 ) = unpack( "CCC", $three );
+ return ((($b1 & 077) << 12 ) |
+ (($b2 & 077) << 6 ) |
+ ($b3 & 077));
+}
+
+### Copy the arguments into the PDP-7 memory space, and build
+### an array of pointers to these arguments. Build a pointer
+### at MAXADDR that points at the array.
+###
+### Each argument string is four words long and space padded if the
+### string is not eight characters long. These are stored below
+### address MAXADDR. Below this is the count of words in the strings.
+### Address MAXADDR points at the word count. Graphically (for two arguments):
+###
+### +------------+
+### +--| | Location 017777 (MAXADDR)
+### | +------------+
+### | |............|
+### | |............| argv[2]
+### | |............|
+### | +------------+
+### | |............|
+### | |............| argv[1]
+### | |............|
+### | +------------+
+### | |............|
+### | |............| argv[0]
+### | |............|
+### | +------------+
+### +->| argc=12 |
+### +------------+
+###
+sub set_arguments {
+
+ # Get the number of arguments including the command name
+ my $argc = scalar(@ARGV);
+
+ # We now know that argc will appear in memory
+ # 4*argc +1 below location MAXADDR
+ # Set argc to the number of words
+ my $addr = MAXADDR - ( 4 * $argc + 1 );
+ $Mem[MAXADDR] = $addr;
+ $Mem[ $addr++ ] = $argc * 4;
+
+ # Now start saving the arguments
+ foreach (@ARGV) {
+
+ # Truncate and/or space pad the argument
+ my $str = sprintf( "%-8s", substr( $_, 0, 8 ) );
+
+ # XXX: use ascii2words
+ # Store pairs of characters into memory
+ for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
+ my $c1 = substr( $str, $i, 1 ) || "";
+ my $c2 = substr( $str, $i + 1, 1 ) || "";
+
+ #printf("Saving %06o to %s\n", (ord($c1) << 9 ) | ord($c2), addr($addr));
+ $Mem[ $addr++ ] = ( ord($c1) << 9 ) | ord($c2);
+ }
+ }
+}
+
+### Load a namelist file
+sub load_names {
+ my $filename = shift;
+ open( my $IN, "<", $filename ) || die("Unable to open $filename: $!\n");
+ while (<$IN>) {
+ chomp;
+ if ($_ =~ m{([a-z0-9.]+)\s+([0-7]+)}) {
+ my $i = oct($2);
+ $Name2Addr{$1} = $i;
+ $Addr2Name{$i} = $1;
+ }
+ }
+ close ($IN);
+}
+
+### Format an address
+sub addr {
+ my $addr = shift;
+ my $oct = sprintf("%06o", $addr);
+ if (%Addr2Name) {
+ return "$oct ($Addr2Name{$addr})" if ($Addr2Name{$addr});
+ # XXX keep Addr2Name as a sorted array?
+ # prefer after to before
+ for (my $epsilon = 1; $epsilon <= EPSILON; $epsilon++) {
+ my $n = $Addr2Name{$addr-$epsilon};
+ return "$oct ($n+$epsilon)" if (defined($n));
+ }
+ for (my $epsilon = 1; $epsilon <= EPSILON; $epsilon++) {
+ my $n = $Addr2Name{$addr+$epsilon};
+ return "$oct ($n-$epsilon)" if (defined($n));
+ }
+ }
+ return $oct;
+}
+
+### convert string (symbol or octal) to address
+sub lookup {
+ my $x = shift;
+ return oct($x) if ($x =~ m/^[0-7]+$/);
+ return $Name2Addr{$x} if (defined($Name2Addr{$x}));
+ return 0;
+}
+
+### Simulate the machine code loaded into memory
+sub simulate {
+
+ # List of opcodes that we can simulate
+ my %Oplist = (
+ oct("000") => \&cal,
+ oct("004") => \&dac,
+ oct("010") => \&jms,
+ oct("014") => \&dzm,
+ oct("020") => \&lac,
+ oct("030") => \&add,
+ oct("024") => \&xor,
+ oct("034") => \&tad,
+ oct("044") => \&isz,
+ oct("050") => \&and,
+ oct("054") => \&sad,
+ oct("060") => \&jmp,
+ oct("064") => \&eae,
+ oct("074") => \&opr,
+ );
+
+ # List of opcodes that DON'T auto-increment
+ # locations 10-17 when we have the indirect bit
+ my %NoIncr = (
+ oct("000") => 1, # cal
+ oct("064") => 1, # eae
+ oct("074") => 1 # opr
+ );
+
+ # Loop indefinitely
+ while (1) {
+
+ # Get the instruction pointed to by PC and decode it
+ # Also do code coverage
+ my $instruction = $Mem[$PC]; $CC[$PC]++;
+ my $opcode = ( $instruction >> 12 ) & 074;
+ my $indirect = ( $instruction >> 13 ) & 1;
+ my $addr = $instruction & MAXADDR;
+
+ # Auto-increment locations 010 to 017 if $indirect
+ # and this is an instruction that does increment
+ if ( $indirect
+ && ( $addr >= 010 )
+ && ( $addr <= 017 )
+ && !defined( $NoIncr{$opcode} ) )
+ {
+ $Mem[$addr]++;
+ $Mem[$addr] &= MAXINT;
+ }
+
+ # Work out what any indirect address would be
+ my $indaddr = ($indirect) ? $Mem[$addr] & MAXADDR : $addr;
+
+ # If this is a breakpoint, stop now and get a user command
+ if ( defined( $Breakpoint{$PC} ) ) {
+ $singlestep = 1;
+ printf( "break at PC %s\n", addr($PC) )
+ if ( ($debug) || ($singlestep) );
+ }
+ get_user_command() if ($singlestep);
+ printf( "PC %-20.20s L.AC %d.%06o MQ %06o: ", addr($PC),
+ ($LINK ? 1 : 0), $AC & 0777777, $MQ )
+ if ( ($debug) || ($singlestep) );
+
+ #dprintf("PC %06o: instr %06o, op %03o, in %o, addr %06o indaddr %06o\n",
+ # $PC, $instruction, $opcode, $indirect, $addr, $indaddr );
+
+ # Simulate the instruction. Each subroutine updates the $PC
+ if ( defined( $Oplist{$opcode} ) ) {
+ $Oplist{$opcode}->( $instruction, $addr, $indaddr );
+ }
+ else {
+ printf( STDERR "Unknown instruction 0%06o at location %s\n",
+ $instruction, addr($PC) );
+ exit(1);
+ }
+ }
+}
+
+# Debug code: dump memory contents
+# Print from $start to $end.
+# Print empty locations if $yeszero
+sub dump_memory {
+ my ( $start, $end, $yeszero ) = @_;
+ foreach my $i ( $start .. $end ) {
+
+ # Convert the word into possibly two ASCII characters
+ my $c1 = ( $Mem[$i] >> 9 ) & 0777;
+ $c1 = ( $c1 < 0200 ) ? chr($c1) : " ";
+ my $c2 = $Mem[$i] & 0777;
+ $c2 = ( $c2 < 0200 ) ? chr($c2) : " ";
+ printf( STDERR "%06o: %06o %s%s\n", $i, $Mem[$i], $c1, $c2 )
+ if ( $yeszero || $Mem[$i] != 0 );
+ }
+}
+
+# Load AC
+sub lac {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "lac %s (value %06o) into AC\n", addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $AC = $Mem[$indaddr];
+ $PC++;
+}
+
+# Deposit AC
+sub dac {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "dac AC (value %06o) into %s\n", $AC, addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+
+ # Catch writes below the process' memory range
+ if ($indaddr < 010000 && !($indaddr >= 010 && $indaddr <= 020) ) {
+ $singlestep = 1;
+ dprintf("(****WRITE TO LOW MEMORY 0%o ****)\n", $indaddr);
+ printf( "break at PC %s\n", addr($PC) )
+ if ( ($debug) || ($singlestep) );
+ }
+ $Mem[$indaddr] = $AC;
+ $PC++;
+}
+
+# Add to AC, twos complement
+sub tad {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "tad AC (value %06o) with addr %s (%06o)\n",
+ $AC, addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $AC = $AC + $Mem[$indaddr];
+ $LINK = ( $LINK ^ $AC ) & LINKMASK;
+ $AC = $AC & MAXINT;
+ $PC++;
+}
+
+# Add to AC, ones complement
+sub add {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "add AC (value %06o) with addr %s (%06o)\n",
+ $AC, addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+
+ # This logic shamelessly borrowed from SimH
+ # https://github.com/simh/simh/blob/master/PDP18B/pdp18b_cpu.c
+ my $sum = $AC + $Mem[$indaddr];
+ if ( $sum > MAXINT ) { # end around carry
+ $sum = ( $sum + 1 ) & MAXINT;
+ }
+ if ( ( ( ~$AC ^ $sum ) & ( $AC ^ $sum ) ) & SIGN ) { # overflow?
+ $LINK = LINKMASK; # set link
+ }
+ $AC = $sum;
+ $PC++;
+}
+
+# And AC and Y
+sub and {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "and AC (value %06o) with addr %s (%06o)\n",
+ $AC, addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $AC &= $Mem[$indaddr];
+ $PC++;
+}
+
+# Xor AC and Y
+sub xor {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ dprintf( "xor %s (%06o)\n",
+ addr($indaddr), $Mem[$indaddr] );
+ $AC ^= $Mem[$indaddr];
+ $PC++;
+}
+
+# Skip if AC different to Y
+sub sad {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "sad %s (%06o)\n", addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ if ($AC != $Mem[$indaddr]) {
+ dprintf( " adding 2 to PC\n");
+ } else {
+ dprintf( " adding 1 to PC\n");
+ }
+ $PC += ( $AC != $Mem[$indaddr] ) ? 2 : 1;
+}
+
+# Deposit zero in memory
+sub dzm {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "dzm %s\n", addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+ $Mem[$indaddr] = 0;
+ $PC++;
+}
+
+# Index and skip if zero
+sub isz {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "isz %s (value %06o)\n", addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $Mem[$indaddr]++;
+ $Mem[$indaddr] &= MAXINT;
+ $PC += ( $Mem[$indaddr] == 0 ) ? 2 : 1;
+}
+
+# Jump
+sub jmp {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "jmp %s\n", addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+ $PC = $indaddr;
+}
+
+# Jump to subroutine
+sub jms {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "jms %s\n", addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+
+ # Save the LINK and current PC into the $indaddr location
+ $Mem[ $indaddr++ ] = $PC + 1 | ( ($LINK) ? 0400000 : 0 );
+ $PC = $indaddr;
+}
+
+# OPR instructions
+sub opr {
+ my ( $instruction, $addr, $indaddr ) = @_;
+
+ # hlt: halt simulation
+ if ( $instruction == 0740040 ) {
+ printf( STDERR "PC %s: program halted\n", addr($PC) );
+ dump_memory( 0, MAXADDR, 0 ) if ($debug);
+ exit(1);
+ }
+
+ # law: load word into AC
+ my $indirect = ( $instruction >> 13 ) & 1;
+ if ($indirect) {
+ dprintf( "law %06o into AC\n", $instruction );
+ $AC = $instruction;
+ $PC++;
+ return;
+ }
+
+ # List of skip opcode names for the next section
+ my @skipop = (
+ '', 'sma', 'sza', 'sza sma',
+ 'snl', 'snl sma', 'snl sza', 'snl sza sma',
+ 'skp', 'spa', 'sna', 'sna spa',
+ 'szl', 'szl spa', 'szl sna', 'szl sna spa'
+ );
+
+ # This logic shamelessly borrowed from SimH
+ # https://github.com/simh/simh/blob/master/PDP18B/pdp18b_cpu.c
+ my $skip = 0;
+ my $i = ( $instruction >> 6 ) & 017; # decode IR<8:11>
+ dprintf( "%s", $skipop[$i] );
+
+ $skip = 1 if ( ( $i == 1 ) && ( $AC & SIGN ) != 0 ); # sma
+ $skip = 1 if ( ( $i == 2 ) && ( $AC & MAXINT ) == 0 ); # sza
+ $skip = 1
+ if ( ( $i == 3 )
+ && ( ( ( $AC & MAXINT ) == 0 ) || ( ( $AC & SIGN ) != 0 ) ) )
+ ; # sza | sma
+ $skip = 1 if ( ( $i == 4 ) && ($LINK) ); # snl
+ $skip = 1 if ( ( $i == 5 ) && ( $LINK || ( $AC >= SIGN ) ) ); # snl | sma
+ $skip = 1 if ( ( $i == 6 ) && ( $LINK || ( $AC == 0 ) ) ); # snl | sza
+ $skip = 1
+ if ( ( $i == 7 )
+ && ( $LINK || ( $AC >= SIGN ) || ( $AC == 0 ) ) ); # snl | sza | sma
+ $skip = 1 if ( $i == 010 ); # skp
+ $skip = 1 if ( ( $i == 011 ) && ( ( $AC & SIGN ) == 0 ) ); # spa
+ $skip = 1 if ( ( $i == 012 ) && ( ( $AC & MAXINT ) != 0 ) ); # sna
+ $skip = 1
+ if ( ( $i == 013 )
+ && ( ( $AC & MAXINT ) != 0 )
+ && ( ( $AC & SIGN ) == 0 ) ); # sna & spa
+ $skip = 1 if ( ( $i == 014 ) && ( $LINK == 0 ) ); # szl
+ $skip = 1
+ if ( ( $i == 015 ) && ( $LINK == 0 ) && ( $AC < SIGN ) ); # szl & spa
+ $skip = 1
+ if ( ( $i == 016 ) && ( $LINK == 0 ) && ( $AC != 0 ) ); # szl & sna
+ $skip = 1
+ if ( ( $i == 017 )
+ && ( $LINK == 0 )
+ && ( $AC < SIGN )
+ && ( $AC != 0 ) ); # szl & sna & spa
+
+ # Clear operations
+ if ( $instruction & 010000 ) { # cla
+ dprintf(" cla");
+ $AC = 0;
+ }
+ if ( $instruction & 004000 ) { # cll
+ dprintf(" cll");
+ $LINK = 0;
+ }
+ if ( $instruction & 000002 ) { # cml
+ dprintf(" cml");
+ $LINK = ($LINK) ? 0 : LINKMASK;
+ }
+ if ( $instruction & 000001 ) { # cma
+ dprintf(" cma");
+ $AC = ( $AC ^ MAXINT ) & MAXINT;
+ }
+
+ # Rotate instructions
+ $i = $instruction & 02030;
+
+ # Single rotate right
+ if ( $i == 020 ) {
+ dprintf(" rar");
+ my $newlink = ( $AC & 1 ) ? LINKMASK : 0;
+ $AC = ( $LINK | $AC ) >> 1;
+ $LINK = $newlink;
+ }
+
+ # Double rotate right
+ if ( $i == 02020 ) {
+ dprintf(" rtr");
+ my $msb = ( $AC & 1 ) << 17;
+ my $newlink = ( $AC & 2 ) ? LINKMASK : 0;
+ $AC = ( ( $LINK | $AC ) >> 2 ) | $msb;
+ $LINK = $newlink;
+ }
+
+ # Single rotate left
+ if ( $i == 010 ) {
+ dprintf(" ral");
+ my $newlink = ( $AC & SIGN ) ? LINKMASK : 0;
+ my $lsb = $LINK ? 1 : 0;
+ $AC = ( ( $AC << 1 ) | $lsb ) & MAXINT;
+ $LINK = $newlink;
+ }
+
+ # Double rotate left
+ if ( $i == 02010 ) {
+ dprintf(" rtl");
+ my $newlink = ( $AC & 0200000 ) ? LINKMASK : 0;
+ my $lsb = ( $AC & SIGN ) ? 1 : 0;
+ my $twolsb = $LINK ? 2 : 0;
+ $AC = ( ( $AC << 2 ) | $twolsb | $lsb ) & MAXINT;
+ $LINK = $newlink;
+ }
+
+ # Impossible left and right rotates: 02030 or 00030. Do nothing!
+
+ # Note: We didn't do the oas instruction above.
+ $PC += 1 + $skip;
+ dprintf("\n");
+ return;
+}
+
+# Extended arithmetic element instructions
+sub eae {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ my $step = $instruction & EAESTEP;
+ my $maskedinstr = $instruction & EAEIMASK;
+
+ if ( $instruction == 0653323 ) { # idiv: integer division
+ my $divisor= $Mem[ $PC+1 ];
+ dprintf( "idiv %06o by %06o (decimal %d by %d)\n",
+ $AC, $divisor, $AC, $divisor );
+ # Prevent division by zero :-)
+ my $quotient = ($divisor) ? int($AC / $divisor) : 0;
+ my $remainder = ($divisor) ? $AC % $divisor : 0;
+ $MQ= $quotient;
+ $AC= $remainder;
+ $PC+=2;
+ return;
+ }
+ if ( $instruction == 0640323 ) { # div: 36-bit unsigned integer division
+ my $divisor= $Mem[ $PC+1 ];
+ dprintf( "div MQ.AC %06o.%06o by %06o (decimal %d)\n",
+ $MQ, $AC, $divisor, $divisor );
+ # http://www.perlmonks.org/?node_id=718414 says that we won't
+ # lose accuracy before 2^53
+ my $dividend= ($MQ << 18) | $AC;
+ # Prevent division by zero :-)
+ my $quotient = ($divisor) ? $dividend / $divisor : 0;
+ my $remainder = ($divisor) ? $dividend % $divisor : 0;
+ $MQ= $quotient;
+ $AC= $remainder;
+ $PC+=2;
+ return;
+ }
+ if ( $maskedinstr == 0660500 ) { # lrss: long right shift, signed
+ # We ignore the MQ as it's not
+ # used by any user-mode programs
+ dprintf( "lrss %06o AC step %d\n", $AC, $step );
+
+ # Save the AC's sign into LINK
+ my $newlink = ( $AC << 1 ) & LINKMASK;
+# $AC = ( ( $LINK | $AC ) >> $step ) & MAXINT;
+ $AC = ( ( ($newlink * -1) | $AC ) >> $step ) & MAXINT; # XXX Not sure if this is correct!?!?!
+ $LINK = $newlink;
+ $PC++;
+ return;
+ }
+ if ( $maskedinstr == 0660700 ) { # alss: AC left shift, signed
+ dprintf( "alss step %d\n", $step );
+ $AC = ( $AC << $step ) & MAXINT;
+ $LINK = ( $AC << 1 ) & LINKMASK;
+ $PC++;
+ return;
+ }
+ if ( ($maskedinstr == 0660600) ||
+ ($maskedinstr == 0661600) ) { # llss: long left shift, signed
+ # Set the link to be the AC sign bit
+ $LINK= ($AC & SIGN) ? LINKMASK : 0;
+ $AC = 0 if ($maskedinstr & 01000); # PLB: ecla llss seen in adm,apr,bc,ds,sh
+ dprintf( "llss step %d\n", $step );
+ foreach my $i ( 1 .. $step ) {
+ my $MQmsb = ( $MQ & SIGN ) ? 1 : 0;
+ $AC = ( ( $AC << 1 ) | $MQmsb ) & MAXINT;
+ $MQ = ( ( $MQ << 1 ) | ( ($LINK) ? 1 : 0 ) ) & MAXINT;
+ }
+ $PC++;
+ return;
+ }
+ # lls: long left shift
+ if ( ($maskedinstr == 0640600) || ($maskedinstr == 0641600) ) {
+ dprintf( "lls step %d\n", $step );
+ # Clear AC if the 01000 bit is set
+ $AC=0 if ($maskedinstr == 0641600);
+ foreach my $i ( 1 .. $step ) {
+ my $MQmsb = ( $MQ & SIGN ) ? 1 : 0;
+ $AC = ( ( $AC << 1 ) | $MQmsb ) & MAXINT;
+ $MQ = ( ( $MQ << 1 ) | ( ($LINK) ? 1 : 0 ) ) & MAXINT;
+ }
+ $PC++;
+ return;
+ }
+ # lrs: long right shift
+ if (($maskedinstr & 0766777) == 0640500) {
+ dprintf( "lrs step %d\n", $step );
+ # Clear AC if the 01000 bit is set
+ $AC=0 if ($maskedinstr & 01000);
+ # Clear MQ if the 010000 bit is set
+ $MQ=0 if ($maskedinstr & 010000);
+ foreach my $i ( 1 .. $step ) {
+ my $MQmsb = ( $AC & 1 ) ? 0400000 : 0;
+ $AC = ( ( $AC >> 1 ) | ( ($LINK) ? 0400000 : 0 ) ) & MAXINT;
+ $MQ = ( ( $MQ >> 1 ) | $MQmsb ) & MAXINT;
+ }
+ $PC++;
+ return;
+ }
+ if ( $maskedinstr == 0640700 ) { # als: AC left shift
+ dprintf( "als AC step %d\n", $step );
+ $AC = ( $AC << $step ) & MAXINT;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0652000 ) { # lmq: load MC from AC
+ dprintf( "lmq AC %06o into MQ\n", $AC );
+ $MQ = $AC;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0641002 ) { # lacq: load AC from MQ
+ dprintf( "lacq MQ %06o into AC\n", $MQ );
+ $AC = $MQ;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0640002 ) { # lacq: OR AC with MQ
+ dprintf( "omq MQ %06o and AC %06o\n", $MQ, $AC );
+ $AC |= $MQ;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0653122 ) { # mul: unsigned multiply
+ # This logic shamelessly borrowed from SimH
+ # https://github.com/simh/simh/blob/master/PDP18B/pdp18b_cpu.c
+ my $MB= $Mem[ $PC+1 ];
+ my $eae_ac_sign;
+ dprintf("mul AC %06o by %06o (decimal %d by %d)\n", $AC, $MB, $AC, $MB);
+
+ if (($instruction & 0004000) && ($AC & SIGN)) { # IR<6> and minus?
+ $eae_ac_sign = $LINK; # set eae_ac_sign
+ } else {
+ $eae_ac_sign = 0; # if not, unsigned
+ }
+ $MQ = $MQ ^ MAXINT if ($eae_ac_sign); # EAE AC sign? ~MQ
+ my $oldlink= $LINK;
+ $LINK = 0; # Clear link
+
+ my $result= $AC * $MB;
+ $AC= ($result >> 18) & MAXINT;
+ $MQ= $result & MAXINT;
+
+## foreach my $SC (1 .. $instruction & 077) { # Loop for SC times
+## $AC = $AC + $MB
+## if ($MQ & 1); # MQ<17>? add
+## $MQ = ($MQ >> 1) | (($AC & 1) << 17);
+## $AC = $AC >> 1; # Shift AC'MQ right
+## }
+ if ($eae_ac_sign ^ $oldlink) { # Result negative?
+ $AC = $AC ^ MAXINT;
+ $MQ = $MQ ^ MAXINT;
+ }
+
+ $PC+=2;
+ return;
+ }
+ printf( STDERR "PC %s: Unknown eae instruction %06o\n",
+ addr($PC), $instruction );
+ exit(1);
+}
+
+# cal: used for system calls
+sub cal {
+ my ( $instruction, $addr, $indaddr ) = @_;
+
+ # Syscalls that we can simulate
+ my %Syscallist = (
+
+ # 1: save
+ 2 => \&sys_getuid,
+ 3 => \&sys_open,
+ 4 => \&sys_read,
+ 5 => \&sys_write,
+ 6 => \&sys_creat,
+ 7 => \&sys_seek,
+ # 8 tell
+ 9 => \&sys_close,
+ 10 => \&sys_link,
+ 11 => \&sys_unlink,
+ 12 => \&sys_setuid,
+ 13 => \&sys_rename,
+ 14 => \&sys_exit,
+ 15 => \&sys_time,
+ 16 => \&sys_intrp,
+ 17 => \&sys_chdir,
+ 18 => \&sys_chmod,
+ 19 => \&sys_chown,
+ # 20 badcal
+ # 21 syslog
+ # 22 badcal
+ # 23 capt
+ # 24 rele
+ 25 => \&sys_status,
+ # 26 badcal
+ 27 => \&sys_smes,
+ 28 => \&sys_rmes,
+ 29 => \&sys_fork,
+ );
+
+ # Simulate the syscall. Each syscall updates the $PC
+ if ( defined( $Syscallist{$addr} ) ) {
+ $Syscallist{$addr}->();
+ }
+ else {
+ printf( STDERR "PC %s: Unknown syscall %d\n", addr($PC), $addr );
+ exit(1);
+ }
+}
+
+# Exit system call
+sub sys_exit {
+ dprintf( "exit system call, pid %06o\n", $$ );
+ print_coverage() if ($coverage);
+ exit(0);
+}
+
+# Getuid system call
+sub sys_getuid {
+ $AC = $< & MAXINT;
+ # On PDP-7 Unix, the root user is user-id -1
+ $AC= MAXINT if ($AC==0);
+ dprintf( "getuid system call, uid %06o\n", $AC );
+ $PC += 1;
+ return;
+}
+
+# Setuid system call
+sub sys_setuid {
+
+ # For now, do nothing
+ dprintf("setuid system call\n");
+ $PC += 1;
+ return;
+}
+
+# Intrp system call
+sub sys_intrp {
+
+ # For now, do nothing
+ dprintf("intrp system call\n");
+ $PC += 1;
+ return;
+}
+
+# Fork system call
+sub sys_fork {
+
+ # Fork and get the child's process-id back, or zero if we are the child
+ my $pid = fork();
+ $AC = $pid & MAXINT;
+ dprintf( "fork, got id %06o\n", $AC );
+
+ # The parent returns back to PC+1, the child returns to PC+2
+ $PC += ($pid) ? 1 : 2;
+ return;
+}
+
+# shell depends on smes hanging while child process exists
+# https://www.bell-labs.com/usr/dmr/www/hist.html
+# The message facility was used as follows: the parent shell, after
+# creating a process to execute a command, sent a message to the new
+# process by smes; when the command terminated (assuming it did not
+# try to read any messages) the shell's blocked smes call returned an
+# error indication that the target process did not exist. Thus the
+# shell's smes became, in effect, the equivalent of wait.
+sub sys_smes {
+ waitpid($AC,0);
+ dprintf("smes returning error\n");
+ $AC = -1;
+ $PC += 1;
+}
+
+# Rmes system call. We simply call wait and
+# return the process-id in AC
+sub sys_rmes {
+ my $pid = wait();
+ dprintf("rmes system call, got pid $pid\n");
+ $AC = $pid & MAXINT;
+ $PC += 1;
+ return;
+}
+
+# Close system call
+sub sys_close {
+
+ # AC is the file descriptor
+ my $fd = $AC;
+ dprintf( "close: closing fd %d\n", $fd );
+
+ # Bump up the PC
+ $PC += 1;
+
+ # That filehandle is not open, set an error -1 in octal
+ if ( !defined( $FD[$fd] ) ) {
+ dprintf("close: fd $fd is not open\n");
+ $AC = MAXINT;
+ return;
+ }
+ close( $FD[$fd] );
+ $FD[$fd] = undef;
+ $ISBINARY[$fd] = 0; # For next time
+ $AC = 0;
+ return;
+}
+
+# Open something which could be a file or a directory
+# Convert directories into files. Return the file handle and
+# if the file is ASCII or binary.
+sub opensomething {
+ my ( $readorwrite, $filename ) = @_;
+ my $tempfile = "/tmp/a7out.$$";
+ my $FH;
+
+ # If this is not a directory, open it and return the FH
+ if ( !-d $filename ) {
+ open( $FH, $readorwrite, $filename ) || return (undef);
+
+ # Opened for writing, so for now this is not binary
+ return ( $FH, 0) if ($readorwrite eq ">");
+
+ # Determine if the file is pure ASCII or contains 18-bit
+ # words encoded in 24-bit groups. We test the msb of the
+ # first character in the file. If it's on then it's a
+ # binary file and not ASCII.
+ # XXX: This means that we have to seek back to the beginning,
+ # which may be a problem on things like stdin.
+ my $ch = getc($FH);
+ my $isbinary = ( defined($ch) && ( ord($ch) & 0x80 ) ) ? 1 : 0;
+ binmode($FH) if ($isbinary);
+ seek( $FH, 0, SEEK_SET );
+ return ( $FH, $isbinary );
+ }
+
+ # It's a directory. The on-disk format for this was:
+ # d.i: .=.+1 " inode number
+ # d.name: .=.+4 " name (space padded)
+ # d.uniq: .=.+1 " unique number from directory inode
+ # followed by two unused words
+ # The code creates a temporary file and fills in the i-node numbers
+ # and space padded filenames from the directory. The file is closed
+ # opened read-only and unlinked, and the open filehandle is returned.
+ opendir( my $dh, $filename ) || return (undef);
+ open( $FH, ">", $tempfile ) || return (undef);
+ dprintf("Converting directory $filename\n");
+
+ my @list = sort( readdir($dh) );
+ foreach my $name (@list) {
+
+ # Get the file's i-node number and write it
+ my ( undef, $inode ) = stat($name);
+ print( $FH word2three($inode) );
+
+ # Convert the name into 8 characters, space padded
+ my $spaceword = sprintf( "%-8s", substr( $name, 0, 8 ) );
+
+ # Convert to four words and write each as three bytes
+ foreach my $word ( ascii2words($spaceword) ) {
+ print( $FH word2three($word) );
+ }
+
+ # Now write three zero words to pad to eight in total
+ print( $FH word2three(0) );
+ print( $FH word2three(0) );
+ print( $FH word2three(0) );
+ }
+ closedir($dh);
+ close($FH);
+ open( $FH, "<", $tempfile ) || return (undef);
+ binmode($FH);
+ #exit(0);
+ unlink($tempfile);
+ return ( $FH, 1 );
+}
+
+# Common code for creat and open
+sub creatopen {
+ my ( $filename, $readorwrite ) = @_;
+
+ # Open the file
+ my ( $FH, $isbinary ) = opensomething( $readorwrite, $filename );
+ if ($FH) {
+
+ # Find a place in the @FD array to store this filehandle.
+ # 99 is arbitrary
+ foreach my $fd ( 0 .. 99 ) {
+ if ( !defined( $FD[$fd] ) ) {
+ $FD[$fd] = $FH;
+ $ISBINARY[$fd] = $isbinary;
+ $AC = $fd;
+ last;
+ }
+ }
+ }
+ else {
+ # No filehandle, so it's an error
+ dprintf("open failed: $!\n");
+ $AC = MAXINT;
+ }
+}
+
+# Open system call
+sub sys_open {
+
+ # Open seems to have 2 arguments: PC+1 is a pointer to the filename.
+ # PC+2 seems to be 1 for write, 0 for read.
+ # Some programs seem to have a third argument always set to 0.
+ # AC is the opened fd on success, or -1 on error
+
+ # Get the start address of the string
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+
+ # Choose to open read-only or write-only
+ my $readorwrite = ( $Mem[ $PC + 2 ] ) ? ">" : "<";
+ dprintf( "open: base %06o, %s file %s\n", $start, $readorwrite, $filename );
+
+ # Bump up the PC
+ $PC += 3;
+
+ # Now open the file and return
+ creatopen( $filename, $readorwrite );
+}
+
+# Creat system call
+sub sys_creat {
+
+ # Creat seems to have 1 argument: PC+1 is a pointer to the filename.
+ # Some programs seem to have a second argument always set to 0.
+ # AC is the opened fd on success, or -1 on error
+
+ # Get the start address of the string
+ my $start = $Mem[ $PC + 1 ];
+
+ # Convert this to a sensible ASCII filename
+ my $filename = mem2arg($start);
+
+ # Choose to open write-only
+ my $readorwrite = ">";
+ dprintf( "creat: base %06o, file %s\n", $start, $filename );
+
+ # Bump up the PC
+ $PC += 2;
+
+ # Now open the file and return
+ creatopen( $filename, $readorwrite );
+}
+
+# Read system call
+sub sys_read {
+
+ # Read seems to have arguments: AC is the file descriptor, PC+1 is
+ # the pointer to the buffer and PC+2 is the number of words to read.
+ # Return the number of words read in AC on success, or -1 on error.
+
+ # Get the file descriptor, start address and end address
+ my $fd = $AC;
+ my $start = $Mem[ $PC + 1 ];
+ my $count = $Mem[ $PC + 2 ];
+ my $end = ( $start + $count - 1 ) & MAXADDR;
+ die("sys_read: bad start/end addresses $start $end\n") if ( $end < $start );
+ printf( "read: %d words into %s from fd %d\n", $count, addr($start), $fd )
+ if ( ($debug) || ($singlestep) );
+
+ # Bump up the PC
+ $PC += 3;
+
+ # That filehandle is not open, set an error -1 in octal
+ if ( !defined( $FD[$fd] ) ) {
+ dprintf("read: fd $fd is not open\n");
+ $AC = MAXINT;
+ return;
+ }
+
+ # Read each word in
+ my $FH = $FD[$fd];
+ $count = 0;
+ if (-t $FH) { # TTY?
+ my $char = getc($FH); # use Term::ReadKey for 'cbreak' mode??
+ if (defined($char)) {
+ $Mem[$start] = ord($char) << 9; # only ever returns one char
+ $AC = 1;
+ }
+ else {
+ $AC = 0; # EOF
+ }
+ return;
+ }
+ foreach my $addr ( $start .. $end ) {
+
+ if ( $ISBINARY[$fd] ) {
+ # Convert three bytes into one 18-bit word
+ my $result = read_word($FH);
+ last if ($result == -1);
+ $Mem[$addr] = $result;
+ $count++;
+ }
+ else {
+ # Convert two ASCII characters into one 18-bit word
+ my $c1 = getc($FH);
+ last if ( !defined($c1) ); # No character, leave the loop
+ my $word = ord($c1) << 9;
+ my $c2 = getc($FH);
+ $word |= ord($c2) if (defined($c2));
+ $Mem[$addr] = $word;
+ $count++;
+ } # ascii
+ }
+
+ # No error
+ $AC = $count;
+ return;
+}
+
+# Write system call
+sub sys_write {
+
+ # Write seems to have arguments: AC is the file descriptor, PC+1 is
+ # the pointer to the buffer and PC+2 is the number of words to write
+
+ # Get the file descriptor, start address and end address
+ my $fd = $AC;
+ my $start = $Mem[ $PC + 1 ];
+ my $count = $Mem[ $PC + 2 ];
+ my $end = ( $start + $count - 1 ) & MAXADDR;
+ die("sys_write: bad start/end addresses $start $end\n")
+ if ( $count != 0 && $end < $start );
+ printf( "write: %d words from %s to fd %d\n", $count, addr($start), $fd )
+ if ( ($debug) || ($singlestep) );
+
+ # Bump up the PC
+ $PC += 3;
+
+ # That filehandle is not open, set an error -1 in octal
+ if ( !defined( $FD[$fd] ) ) {
+ dprintf("write: fd $fd is not open\n");
+ $AC = MAXINT;
+ return;
+ }
+
+ # Write each word out either in binary or in ASCII
+ my $FH = $FD[$fd];
+ foreach my $addr ( $start .. $end ) {
+ # First see if any "non-ASCII" bits are set in the word.
+ # If so, then this is a binary file
+ my $word= $Mem[$addr];
+ $ISBINARY[$fd]=1 if ($word & 0600600);
+
+ if ($ISBINARY[$fd]) {
+ print( $FH word2three($word) );
+ } else {
+ print( $FH word2ascii($word) );
+ }
+ }
+
+ # No error
+ $AC = 0;
+ return;
+}
+
+# Chmod system call
+sub sys_chmod {
+
+ # Chmod gets the permission bits in AC and a pointer
+ # to the file's name in PC+1. s2.s has these instruction for chmod:
+ # lac u.ac; and o17 so only the lowest 4
+ # bits are the permission bits that can be set.
+ # I'm going to guess these (from v1 chmod manual):
+ # 01 write for non-owner
+ # 02 read for non-owner
+ # 04 write for owner
+ # 10 read for owner
+ my $mode = 0;
+ $mode |= 0002 if ( $AC & 01 );
+ $mode |= 0004 if ( $AC & 02 );
+ $mode |= 0220 if ( $AC & 04 );
+ $mode |= 0440 if ( $AC & 010 );
+
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "chmod %06o file %s\n", $mode, $filename );
+
+ # Do the chmod on the file
+ my $result = chmod( $mode, $filename );
+
+ # Set AC to -1 if no files were changed, else 0
+ $AC = ( $result == 0 ) ? MAXINT : 0;
+ $PC += 2;
+ return;
+}
+
+# Chown system call
+sub sys_chown {
+
+ # Chown gets the numeric user-id in AC and a pointer
+ # to the file's name in PC+1.
+ # Get the start address of the string
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "chown file %s to uid %06o\n", $filename, $AC );
+
+ # Do the chown, leave group-id untouched. Get number of files changed
+ my $result = chown( $AC, -1, $filename );
+
+ # Set AC to -1 if no files were changed, else 0
+ $AC = ( $result == 0 ) ? MAXINT : 0;
+ $PC += 2;
+ return;
+}
+
+# Chdir system call
+sub sys_chdir {
+
+ # Chdir gets the directory name in PC+1
+ # Return 0 on success, -1 on error
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "chdir %s\n", $filename );
+
+ # Bump up the PC
+ $PC += 2;
+
+ # Do nothing on chdir to "dd"
+ return (0) if ( $filename eq "dd" );
+
+ # Do the chdir
+ return ( chdir($filename) ? 0 : MAXINT );
+}
+
+# Unlink system call
+sub sys_unlink {
+
+ # Unlink gets the file name in PC+1
+ # Return 0 on success, -1 on error
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "unlink %s\n", $filename );
+
+ # Bump up the PC and do the unlink
+ $PC += 2;
+ return ( unlink($filename) ? 0 : MAXINT );
+}
+
+# Time system call
+sub sys_time {
+
+ # Dennis' draft says: The call sys time returns in
+ # the AC and MQ registers the number of sixtieths of
+ # a second since the start of the current year.
+
+ # Get two Datetime objects set to now
+ my $dt = DateTime->now;
+ my $yearstart = DateTime->now;
+
+ # Set one object back to the beginning of the year
+ $yearstart->set( month => 1 );
+ $yearstart->set( day => 1 );
+ $yearstart->set( hour => 0 );
+ $yearstart->set( minute => 0 );
+ $yearstart->set( second => 0 );
+
+ # Get the duration in sixtieths of a second
+ my $duration = $dt->subtract_datetime_absolute($yearstart);
+ my $sixtieths = $duration->seconds() * 60;
+
+ # Set MQ to the high 18 bits and AC to the low 18 bits
+ $MQ = $sixtieths >> 18;
+ $AC = $sixtieths & 0777777;
+ dprintf( "time %06o %06o, %d sixtieths\n", $MQ, $AC, $sixtieths );
+ $PC += 1;
+ return;
+}
+
+# Status system call
+sub sys_status {
+
+ # AC holds the pointer to the stat buffer
+ # PC+1 is the directory holding the entry
+ # PC+2 is the directory entry we want to stat.
+ # The statbuf is:
+ # word 0: permission bits
+ # words 1-7: disk block pointers
+ # word 8: user-id
+ # word 9: number of links
+ # word 10: size in words
+ # word 11: uniq, I have no idea what this is.
+ # word 12: i-number.
+ # The permission bits are:
+ # 200000 large file, bigger than 4096 words
+ # 000020 directory
+ # 000010 owner read
+ # 000004 owner write
+ # 000002 user write
+ # 000001 user write
+
+ # Get the directory and file names
+ # Convert this to a sensible ASCII filename
+ my $dirname = mem2arg($Mem[ $PC + 1 ]);
+ my $filename = mem2arg($Mem[ $PC + 2 ]);
+ dprintf( "status file %s/%s statbuf %06o\n", $dirname, $filename, $AC );
+
+ # Get the file's details
+ my ( undef, $ino, $mode, $nlink, $uid, undef, undef, $size ) =
+ stat("$dirname/$filename");
+
+ # Set up the statbuf if we got a result
+ if ($nlink) {
+ $Mem[ $AC + 8 ] = $uid & MAXINT;
+ $Mem[ $AC + 9 ] = (-$nlink) & MAXINT;
+ $Mem[ $AC + 10 ] = $size & MAXINT; # Yes, I know, not words
+ $Mem[ $AC + 12 ] = $ino & MAXINT;
+
+ my $perms = 0;
+ $perms = 01 if ( $mode & 02 ); # World writable
+ $perms |= 02 if ( $mode & 04 ); # World readable
+ $perms |= 04 if ( $mode & 0200 ); # Owner writable
+ $perms |= 010 if ( $mode & 0400 ); # Owner readable
+ $perms |= 020 if ( -d $filename ); # Directory
+ $perms |= 0200000 if ( $size > 4096 ); # Large file
+ $Mem[$AC] = $perms;
+
+ # Set AC to zero as we got something, else return -1
+ $AC = 0;
+ }
+ else {
+ $AC = MAXINT;
+ }
+
+ $PC += 3;
+ return;
+}
+
+# Seek syscall
+sub sys_seek {
+ # Seek takes three arguments: AC is the fd, PC+1 is a signed count
+ # and PC+2 is how to seek: 0=from start, 1=from curptr, 2=from end
+ # of file. Return AC=0 if OK, -1 on error.
+ my $fd= $AC;
+ my $FH= $FD[$fd];
+ my $offset= $Mem[ $PC + 1 ];
+ # XXX For now, we always do SEEK_SET.
+
+ # If it's a binary file, we have to seek 3 bytes for every word,
+ # but for an ASCII file that's 2 bytes per word.
+ $offset *= ($ISBINARY[$fd]) ? 3 : 2;
+ my $result= seek($FH, $offset, SEEK_SET);
+
+ # Set the AC result
+ $AC= ($result)? 0: MAXINT;
+ $PC += 3;
+ return;
+}
+
+# Rename syscall
+sub sys_rename {
+ # Rename takes two arguments: PC+1 is the current filename and
+ # PC+2 is the new filename. Returns AC=0 on success, AC=-1 on error.
+ #
+ my $oldname = mem2arg($Mem[$PC+1]);
+ my $newname = mem2arg($Mem[$PC+2]);
+ dprintf( "rename file %s to %s\n", $oldname, $newname );
+ my $result= rename($oldname, $newname);
+
+ # Set the AC result
+ $AC= ($result)? 0: MAXINT;
+ $PC += 3;
+ return;
+}
+
+# Link syscall
+sub sys_link {
+ # Link takes two arguments: PC+1 is the current filename and
+ # PC+2 is the new filename. Returns AC=0 on success, AC=-1 on error.
+ # Yes, this is not strictly what PDP-7 Unix would have done.
+ #
+ my $oldname = mem2arg($Mem[$PC+1]);
+ my $newname = mem2arg($Mem[$PC+2]);
+ dprintf( "link file %s to %s\n", $oldname, $newname );
+ my $result= link($oldname, $newname);
+
+ # Set the AC result
+ $AC= ($result)? 0: MAXINT;
+ $PC += 3;
+ return;
+}
+
+# Convert an 18-bit word into a scalar which has three sixbit
+# values in three bytes. Set the msb in the first byte
+sub word2three {
+ my $val = shift;
+
+ my $b1 = ( ( $val >> 12 ) & 077 ) | 0x80;
+ my $b2 = ( $val >> 6 ) & 077;
+ my $b3 = $val & 077;
+ return ( pack( "CCC", $b1, $b2, $b3 ) );
+}
+
+# Convert an ASCII string into an array of 18-bit word values
+# where two characters are packed into each word. Put NUL in
+# if the string has an odd number of characters. Return the array
+sub ascii2words {
+ my $str = shift;
+ my @words;
+ for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
+ my $c1 = substr( $str, $i, 1 ) || "\0";
+ my $c2 = substr( $str, $i + 1, 1 ) || "\0";
+
+ push( @words, ( ord($c1) << 9 ) | ord($c2) );
+ }
+ return (@words);
+}
+
+# Convert an 18-bit word into two ASCII characters and return them.
+# Don't return NUL characters
+sub word2ascii {
+ my $word = shift;
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ my $result = "";
+ if (($c1 >= 1) && ($c1 <= 126)) { $result .= chr($c1); }
+ if (($c2 >= 1) && ($c2 <= 126)) { $result .= chr($c2); }
+ return ($result);
+}
+
+# Given the address of a four word argument string in
+# memory, return a copy of the string in ASCII format.
+# Lose any trailing spaces as well.
+sub mem2arg {
+ my $addr = shift;
+ my $result = "";
+
+ $addr &= MAXADDR;
+ foreach ( 1 .. 4 ) {
+
+ # Stop if the address leave the 8K word address space
+ last if ( $addr > MAXADDR );
+ my $word = $Mem[ $addr++ ];
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ $result .= chr($c1) . chr($c2);
+ }
+ $result =~ s{ *$}{};
+ return ($result);
+}
+
+# Print out debug messages
+sub dprintf {
+ printf( STDERR @_ ) if ( ($debug) || ($singlestep) );
+}
+
+# Get one or more commands from the user and execute them
+sub get_user_command {
+ my %Cmdlist = (
+ 'b' => \&cmd_setbreak,
+ 'break' => \&cmd_setbreak,
+ 'd' => \&cmd_dump,
+ 'dump' => \&cmd_dump,
+ 'db' => \&cmd_delbreak,
+ 'del' => \&cmd_delbreak,
+ 'delete' => \&cmd_delbreak,
+ '?' => \&cmd_help,
+ 'h' => \&cmd_help,
+ 'help' => \&cmd_help,
+ 's' => \&cmd_step,
+ 'l' => \&cmd_listbreak,
+ 'list' => \&cmd_listbreak,
+ 'step' => \&cmd_step,
+ 'q' => \&cmd_exit,
+ 'x' => \&cmd_exit,
+ 'quit' => \&cmd_exit,
+ 'exit' => \&cmd_exit,
+ 'c' => \&cmd_continue,
+ 'continue' => \&cmd_continue,
+ 'r' => \&cmd_showregs,
+ 'regs' => \&cmd_showregs,
+ );
+
+ # Loop until we get a leave result
+ while (1) {
+
+ # Get a command from the user
+ # and split into command, start and end addresses.
+ # Convert addresses from octal
+ print("a7out> ");
+ chomp( my $line = <STDIN> );
+ my ( $cmd, $addr, $endaddr ) = split( /\s+/, $line );
+
+ $addr = lookup($addr) if ( defined($addr) );
+ $endaddr = lookup($endaddr) if ( defined($endaddr) );
+
+ # Run the command
+ my $leave;
+ if ( defined($cmd) && defined( $Cmdlist{$cmd} ) ) {
+ $leave = $Cmdlist{$cmd}->( $addr, $endaddr );
+ }
+ else {
+ printf( "%s: unknown command\n", $cmd || "" );
+ cmd_help();
+ }
+ return if ($leave);
+ }
+}
+
+# Exit the program
+sub cmd_exit {
+ exit(0);
+}
+
+# Continue by disabling single-step
+# and break out of the command loop
+sub cmd_continue {
+ $singlestep = 0;
+ return (1);
+}
+
+# Step by staying in single-step
+# but break out of the command loop
+sub cmd_step {
+ return (1);
+}
+
+# Set a breakpoint
+sub cmd_setbreak {
+ my $addr = shift;
+ $Breakpoint{$addr} = 1;
+ return (0);
+}
+
+# Delete a breakpoint
+sub cmd_delbreak {
+ my $addr = shift;
+ delete( $Breakpoint{$addr} );
+ printf( "Delete breakpoint %06o\n", $addr );
+ return (0);
+}
+
+sub cmd_help {
+ print(" [b]reak <octal> set a breakpoint\n");
+ print(" [c]ontinue leave single-step and continue\n");
+ print(" [d]ump [<octal>] [<octal>] dump addresses in range\n");
+ print(" db <octal> delete a breakpoint\n");
+ print(" [del]ete <octal> delete a breakpoint\n");
+ print(" [l]ist list breakpoints\n");
+ print(" [r]egs print PC, LINK, AC and MQ regs\n");
+ print(" [s]tep single-step next instruction\n");
+ print(" ?, h, help print this help list\n");
+ print(" e[x]it, [q]uit exit the program\n");
+ return (0);
+}
+
+sub cmd_showregs {
+ my $link = ($LINK) ? 1 : 0;
+ printf( "PC: %s, L.AC %d.%06o, MQ: %06o\n", addr($PC), $link, $AC, $MQ );
+ return (0);
+}
+
+sub cmd_dump {
+ my ( $start, $end ) = @_;
+
+ # No arguments, so dump everything but not empty locations
+ if ( !defined($start) ) {
+ dump_memory( 0, MAXADDR, 0 );
+ return (0);
+ }
+
+ # Dump a limited range
+ $end = $start if ( !defined($end) );
+ dump_memory( $start, $end, 1 );
+ return (0);
+}
+
+sub cmd_listbreak {
+ print("Breakpoints:\n");
+ foreach my $addr ( sort( keys(%Breakpoint) ) ) {
+ printf( " %06o\n", $addr );
+ }
+ return (0);
+}
--- /dev/null
+#!/usr/bin/env perl
+#
+# Read in files of PDP-7 assembly code in Ken Thompson's as format
+# and convert them into PDP-7 machine code
+#
+# (c) 2016 Warren Toomey, GPL3
+# Tweaked by Phil Budne (line, expression parsing, output formats)
+#
+use strict;
+use warnings;
+use Data::Dumper;
+use Getopt::Long qw(GetOptions);
+
+Getopt::Long::Configure qw(gnu_getopt);
+
+### Global variables ###
+my %Var; # Variables such as ., .., t
+my %Glabel; # Global labels that are defined once
+my %Llabel; # Local labels that are defined once
+my %Islocal; # True if the label is a local label
+my %Rlabel; # Relative labels, e.g. 1:, 2:
+ # with an array of locations for each label
+
+my @Mem; # Actual PDP-7 memory locations
+my @Mline; # Source lines associated with mem locations
+my $origline; # The original current input line of code
+my $line; # line being parsed
+my $stage = 1; # Pass one or pass two
+my $errors = 0; # set to non-zero on error
+my $line_error = ' ';
+my $file; # current file name
+my $lineno; # current line number
+my $OUTPUT; # output file
+my $RELATIVE = 01000000; # set on non-absolute symbol values
+my $BASE = 0|$RELATIVE; # starting value for "."
+### Main program ###
+
+## command line options
+my $debug = 0; # Run in debug mode
+my $format = 'a7out'; # output format
+my $namelist = 0; # output n.out file
+my $output = 'a.out'; # output file
+my $no_label_warnings = 0; # suppress multiply defined label warnings
+
+# keep this near the GetOptions call to make it easy to add documentation!
+sub usage {
+ die("Usage: $0 [--debug] [--format=a7out|list|ptr|rim ]\n" .
+ "\t[-n] [--out file] file1.s [file2.s ...]\n");
+}
+
+GetOptions(
+ 'debug|d' => \$debug,
+ 'format|f=s' => \$format,
+ 'namelist|n' => \$namelist,
+ 'output|o=s' => \$output,
+ 'no-label-warnings' => \$no_label_warnings,
+) or usage();
+
+usage() if ( @ARGV < 1 );
+
+# http://minnie.tuhs.org/cgi-bin/utree.pl?file=V3/man/manx/as.1
+# ".." is the relocation constant and is added to each relocatable
+# reference. On a PDP-11 with relocation hardware, its value is 0; on
+# most systems without protection, its value is 40000(8).
+
+# PLB: "relocatable" values are flagged with $RELATIVE
+
+# start with the location counter at zero
+# predefine syscall and opcodes as variables
+%Var = (
+ '.' => $BASE,
+ '..' => 4096, # output base addr?
+
+ # as.s does not have an initial symbol table
+ # (except for the above), so there must have been a
+ # user "ops" file
+
+ save => 1, # saves core dump & user area!
+ getuid => 2,
+ open => 3,
+ read => 4,
+ write => 5,
+ creat => 6,
+ seek => 7,
+ tell => 8,
+ close => 9,
+ link => 10,
+ unlink => 11,
+ setuid => 12,
+ rename => 13,
+ exit => 14,
+ time => 15,
+ intrp => 16,
+ chdir => 17,
+ chmod => 18,
+ chown => 19,
+ # 20 removed
+ sysloc => 21, # return system addresses
+ # 22 removed
+ capt => 23, # capture display?
+ rele => 24, # release display?
+ status => 25, # "stat"
+ smes => 27,
+ rmes => 28,
+ fork => 29,
+
+ # List of instruction names and machine code values
+ # These come from https://raw.githubusercontent.com/simh/
+
+ sys => 0020000, # "cal i" instruction (trap indirect thru 020)
+ i => 0020000, # indirect bit
+
+ # memory reference instructions
+ dac => 0040000, # deposit AC
+ jms => 0100000, # jump to subroutine
+ dzm => 0140000, # deposit zero in memory
+ lac => 0200000, # load AC
+ xor => 0240000, # exclusive or
+ add => 0300000, # one's complement add
+ tad => 0340000, # two's complement add
+ xct => 0400000, # execute
+ isz => 0440000, # increment and skip if zero
+ and => 0500000, # AND with contents of Y
+ sad => 0540000, # skip if AC different from content of Y
+ jmp => 0600000, # jump to Y
+
+ # Type 177 Extended Arithmetic Element (EAE)
+ eae => 0640000, # base instruction (nop)
+ osc => 0640001, # OR SC into AC
+ omq => 0640002, # OR MQ into AC
+ cmq => 0640004, # Complement MQ
+ div => 0640323, # divide
+ norm => 0640444, # normalize, unsigned
+ lls => 0640600, # long left shift
+ clls => 0641600, # lls but clear AC first
+ als => 0640700, # AC shift
+ lrs => 0640500, # long right shift
+ ecla => 0641000, # clear AC
+ lacs => 0641001, # load AC with SC
+ lacq => 0641002, # load AC with MQ
+ abs => 0644000, # absolute value
+ divs => 0644323, # divide, signed
+
+ clq => 0650000, # clear MQ
+ frdiv => 0650323, # fractional divide
+ lmq => 0652000, # load MQ from AC
+ mul => 0653122, # multiply
+ idiv => 0653323, # integer divide
+ idivs => 0657323, # integer divide, signed
+ frdivs => 0654323, # fractional divide, signed
+ muls => 0657122, # multiply, signed
+
+ norms => 0660444, # normalize, signed
+ gsm => 0664000, # get sign and magnitude
+ lrss => 0660500, # long right shift, signed
+ llss => 0660600, # long left shift, signed
+ alss => 0660700, # AC left shift, signed
+
+ # PLB: removed I/OT instructions: kernel uses sop.s
+
+ # Operate Instructions
+
+ # Group 1 (OPR 1) instructions
+ opr => 0740000, # base operate instruction (nop)
+ nop => 0740000,
+ cma => 0740001, # complement accumulator
+ cml => 0740002, # complement link
+ oas => 0740004, # inclusive or accumulator switches
+ ral => 0740010, # rotate (ac, link) left
+ rar => 0740020, # rotate (ac, link) right
+ hlt => 0740040, # HALT
+ xx => 0740040,
+ sma => 0740100, # skip on minus accumulator
+ sza => 0740200, # skip on zero accumulator
+ snl => 0740400, # skip on non-zero link
+
+ skp => 0741000, # unconditional skip
+ spa => 0741100, # skip on positive accumulator
+ sna => 0741200, # skip on negative accumulator
+ szl => 0741400, # skip on zero link
+
+ rtl => 0742010, # rotate two left (ral*2)
+ rtr => 0742020, # rotate two right (rar*2)
+
+ cll => 0744000, # clear link
+ stl => 0744002, # set link
+ rcl => 0744010, # clear link, rotate left
+ rcr => 0744020, # clear link, rotate right
+
+ cla => 0750000, # clear accumulator
+ clc => 0750001, # clear and complement acc
+ las => 0750004, # load acc from switches
+ glk => 0750010, # get link
+
+ # Group 2 operate
+ law => 0760000, # load accumulator with (instruction)
+# lam => 0777777, # (load accumulator minus)
+);
+
+
+# Parse all the files
+print STDERR "I\n"; # like the real as
+foreach my $file (@ARGV) {
+ parse_file($file);
+}
+
+# Now do it all again, pass two
+$Var{'.'} = $BASE;
+$stage = 2;
+open(my $OUT, ">$output") || die "$output";
+
+print STDERR "II\n"; # like the real as
+foreach my $file (@ARGV) {
+ print STDERR "$file\n"; # like the real as
+ parse_file($file);
+}
+
+if ($format eq 'a7out') {
+ # print out the contents of memory
+ for my $i ( 0 .. $#Mem ) {
+ if ( defined( $Mem[$i] ) ) {
+ printf $OUT "%06o: %06o\t%s\n", $i, $Mem[$i], ($Mline[$i] || "");
+ }
+ }
+}
+elsif ($format eq 'list') {
+ print $OUT "\n";
+ print $OUT "Labels:\n";
+ dump_labels($OUT);
+}
+elsif ($format eq 'ptr') { # dump absolute memory in PTR binary
+ for my $loc ( $Var{'..'} .. $#Mem ) {
+ punch($Mem[$loc] || 0);
+ }
+}
+elsif ($format eq 'rim') { # "Hardware Read In" tape
+ # only handles continguous memory, but no overhead
+ my $base = $Var{'..'};
+ for my $loc ( $base .. $#Mem ) {
+ punch($Mem[$loc] || 0);
+ }
+ # final word: command; has 0100 lit on last frame
+ punch(0600000 | $base, 0100 );
+}
+else {
+ die("unknown format $format");
+}
+close($OUT);
+
+if ($namelist) {
+ # as.s writes a binary file named n.out, ours is ascii
+ open (my $NOUT, ">", "n.out") || die "n.out";
+ dump_labels($NOUT);
+ close($NOUT);
+}
+
+exit($errors);
+
+# report an assmebly error:
+# sets error flag
+# reports filename:lineno for emacs m-x compile
+sub err {
+ $line_error = shift;
+ my $msg = shift;
+
+ $errors = 1; # exit status
+ if ($stage == 2) {
+ print STDERR "$file:$lineno: $msg\n";
+ print $OUT "$file:$lineno: $msg\n" if ($format eq 'list');
+ }
+ return 0; # expression value
+}
+
+# Set a label, either global or local
+sub set_label
+{
+ my ($label,$loc)= @_;
+
+ # PLB: truncate to eight: moo.s declares "standing"
+ # but references it as "standings"
+ $label = substr($label, 0, 8);
+
+ # It is a local label if we're told it is, or if it starts with "L"
+ if ($Islocal{$file}{$label} || $label=~ m{^L}) {
+ # An error to have different values
+ if ( defined( $Llabel{$file}{$label} ) && $Llabel{$file}{$label} != $loc ) {
+ # non-fatal: as.s doesn't even warn!!!!
+ print STDERR "$file:$lineno: Local label $label multiply defined\n"
+ if ($stage == 2 && !$no_label_warnings);
+ }
+ else {
+ $Llabel{$file}{$label} = $loc;
+ printf( "Set local label %s to %#o\n", $label, $loc ) if ($debug);
+ }
+ } else {
+ # original as doesn't complain about multiple definitions of labels
+ # (Space Travel depends on this). Now a warning (on by default)
+ if ( defined( $Glabel{$label} ) && $Glabel{$label} != $loc ) {
+ print STDERR "$file:$lineno: Warning: Global label $label multiply defined\n"
+ if ($stage == 2 && !$no_label_warnings);
+ }
+ $Glabel{$label} = $loc;
+ printf( "Set global label %s to %#o\n", $label, $loc ) if ($debug);
+ }
+}
+
+# Get the value of a global or local label
+sub get_label
+{
+ my $label= shift;
+ # PLB: truncate to eight: moo.s declares "standing"
+ # but references it as "standings"
+ $label = substr($label, 0, 8);
+ return($Llabel{$file}{$label}) if (defined($Llabel{$file}{$label}));
+ return($Glabel{$label});
+}
+
+# Open and parse the given file
+sub parse_file {
+ $file = shift;
+
+ open( my $IN, "<", $file ) || die("Cannot open $file: $!\n");
+ $lineno = 0;
+ while ( $line = <$IN> ) {
+ $lineno++;
+ chomp($line); # Lose the end of line
+ $origline = $line;
+ print $OUT "\t\t$line\n"
+ if ($stage == 2 && $line ne '' && $format eq 'list');
+ parse_line();
+ }
+ close($IN);
+}
+
+# process a label and set its value to the location counter
+# OK for symbolic label to be entered twice, so long as it's the same value
+# (ie; both passes)
+sub process_label {
+ my $label = shift;
+ my $loc = $Var{'.'};
+
+ print "process_label $label\n" if ($debug);
+
+ if ( $label =~ m{^\d+$} ) { # numeric (relative) label?
+ if ($stage == 1) {
+ push( @{ $Rlabel{$label} }, $loc );
+ printf( "Pushing %#o for label %s\n", $loc, $label ) if ($debug);
+ }
+ } # numeric label
+ else { # symbolic label
+ set_label($label, $loc);
+ }
+}
+
+# Parse assembler directives. These were not in the original
+# PDP-7 Unix source, but we need them so that we can write
+# compilers that target this assembler.
+sub parse_directive
+{
+ my $directive= shift;
+ print("Got directive $directive\n") if ($debug);
+
+ # Set this as a local label
+ if ($directive=~ m{^\@local\s+(\S+)}) {
+ $Islocal{$file}{$1}=1;
+ }
+}
+
+sub eol {
+ return $line eq '' || $line =~ m{^"}; # empty or comment
+}
+
+# Blame Phil for this....
+# parses global $line based on prefixes, nibbling of a bit at a time
+# (: and ; can appear in char literals)
+# handles multiple ';' separated words per line
+# allows " in character literals (tho none appear in listings)
+sub parse_line {
+ while (1) {
+ $line_error = ' '; # clear listing error indicator
+
+ return if (eol());
+
+ print "parse_line: '$line'\n" if ($debug);
+
+ # Lose any leading whitespace
+ $line =~ s{^\s*}{};
+
+ # Assembler directives start with an @
+ if ($line =~ m{^\@}) {
+ parse_directive($line);
+ return;
+ }
+
+ while ($line =~ s{^([A-Za-z0-9_\.]+):\s*}{}) { # labels
+ process_label($1);
+ }
+
+ return if (eol());
+
+ if ( $line =~ s{^([^;= \t]+)\s*=}{}) { # assignment
+ my $lhs = $1;
+ my $word = parse_expression();
+ printf( "Setting variable %s to 0%o\n", $lhs, $word ) if ($debug);
+ $Var{$lhs} = $word;
+ printf $OUT "\t%06o %s\n", $word, $line_error
+ if ($stage == 2 && $format eq 'list');
+ }
+ else { # bare expression (not assignment)
+ # Get its value on pass two and save to memory
+ # Also save the input line that altered memory
+ my $word = parse_expression();
+ if ( $stage == 2 ) {
+ my $location = $Var{'.'};
+ if ($location & $RELATIVE) { # non-absolute location?
+ $location &= 0777777;
+ $location += $Var{'..'} & 0777777; # relocate
+ # XXX check for overflow?
+ }
+ if ($word & $RELATIVE) { # word created from relative addresses?
+ $word &= 0777777;
+ $word += $Var{'..'} & 0777777; # relocate
+ # XXX check for overflow?
+ }
+ if ($location < 0) {
+ err('.', 'below base');
+ }
+ else {
+ $Mem[$location] = $word;
+ }
+ $Mline[$location] = $origline;
+ $origline = '';
+ if ($format eq 'list' and defined($word)) {
+ # show flags??
+ printf $OUT "%06o: %06o %s\n",
+ $location, $word, $line_error;
+ }
+ }
+ # Move up to the next location in both passes
+ $Var{'.'}++;
+ } # expr
+
+ # eat trailing whitespace and ";", if any
+ $line =~ s{^\s*;?}{};
+ } # while
+}
+
+# Blame Phil for this bit too...
+# Parse an expression off $line and return a PDP-7 word
+# as a series of whitespace separated "syllables"
+# ORed, added, or subtracted
+sub parse_expression {
+ my $word = 0;
+ my $flags = 0;
+
+ print "expression: '$line'\n" if ($debug);
+
+ while (1) {
+ my $syllable = 0;
+ my $op = '|';
+
+ $line =~ s{^\s+}{}; # as.s accepts ",' as whitespace too!
+
+ if ($line eq '' || $line =~ m{^[";]}) { # EOL ; and " terminate expr
+ $word |= $flags;
+ printf("\tparse_expression => %#o\n", $word) if ($debug);
+ return $word;
+ }
+
+ print " '$line'\n" if ($debug);
+
+ if ($line =~ s{^-}{}) {
+ print "\tfound -\n" if ($debug);
+ $op = '-';
+ }
+ elsif ($line =~ s{^\+}{}) {
+ print "\tfound +\n" if ($debug);
+ $op = '+';
+ }
+
+ if ($line =~ s{^<(.)}{}) { # <char
+ print "\tfound <x\n" if ($debug);
+ $syllable = ord($1) << 9; # absolute
+ }
+ elsif ($line =~ s{^(.)>}{}) { # char>
+ print "\tfound x>\n" if ($debug);
+ $syllable = ord($1) # absolute
+ }
+ elsif ($line =~ s{^>(.)}{}) { # >char !!
+ print "\tfound >x\n" if ($debug);
+ $syllable = ord($1) # absolute
+ }
+ elsif ($line =~ s{^([A-Za-z_\.][A-Za-z0-9_\.]*)}{}) {
+ my $sym = $1;
+ print "\tsym: $sym\n" if ($debug);
+
+ if (defined($Var{$sym})) {
+ $syllable = $Var{$sym};
+ printf("\tvar: %s: %#o\n", $sym, $syllable) if ($debug);
+ }
+ elsif (defined(get_label($sym))) {
+ $syllable = get_label($sym);
+ printf("\tlbl: %s: %#o\n", $sym, $syllable) if ($debug);
+ }
+ elsif ($stage == 2) {
+ err('U', "$sym not defined")
+ } # pass 2
+ } # symbol
+ elsif ( $line =~ s{^(\d+)([fb])}{} ) { # relative label
+ printf "\tfound relative: $1$2\n" if ($debug);
+ $syllable = find_relative_label( $1, $2 ) if ($stage == 2);
+ }
+ elsif ( $line =~ s{^(\d+)}{} ) { # constant
+ my $value = $1;
+ printf "\tfound constant: $value\n" if ($debug);
+ if ( $value =~ m{^0} ) {
+ # PLB 2020-10-05: behave like as.s
+ $syllable = 0;
+ for my $digit (split(//, $value)) {
+ $syllable = $syllable * 010 + ord($digit) - ord('0');
+ }
+ }
+ else {
+ $syllable = $value + 0;
+ }
+ $syllable &= 0777777; # absolute
+ }
+ else {
+ # From the BSD fortune file:
+ # Ken Thompson has an automobile which he helped design.
+ # Unlike most automobiles, it has neither speedometer,
+ # nor gas gauge, nor any of the numerous idiot lights
+ # which plague the modern driver. Rather, if the driver
+ # makes any mistake, a giant "?" lights up in the center
+ # of the dashboard. "The experienced driver",
+ # he says, "will usually know what's wrong.
+ err('?', "huh? '$line'");
+ $line = ''; # abort processing
+ return undef;
+ }
+
+ my $sylflags = $syllable & $RELATIVE;
+ $syllable &= 0777777;
+
+ if ($op eq '+') {
+ $word += $syllable;
+ $flags |= $sylflags;
+ }
+ elsif ($op eq '-') {
+ $word -= $syllable;
+ if ($flags & $RELATIVE) {
+ # relative-relative => absolute!
+ if ($sylflags & $RELATIVE) {
+ $flags &= ~$RELATIVE;
+ }
+ # else: relative-abs => relative (no change)
+ }
+ else { # word is absolute
+ if ($sylflags & $RELATIVE) {
+ err('A', 'absolute value minus relative??');
+ }
+ # else: absolute-absolute => absolute (no change)
+ }
+ }
+ else {
+ $word |= $syllable;
+ $flags |= $sylflags;
+ }
+ $word &= 0777777;
+ printf("\tsyllable: %#o word: %#o\n", $syllable, $word) if ($debug);
+ }
+}
+
+# Given a relative label number and a direction,
+# return the location of this relative label or
+# die if we don't have one
+sub find_relative_label {
+ my ( $label, $direction ) = @_;
+ my $curlocation = $Var{'.'};
+
+ # Error check: no labels at all
+ if ( !defined( $Rlabel{$label} ) ) {
+ return err('U', "relative label $label never defined");
+ }
+
+ # Get the list of possible locations for this label
+ my $locarray = $Rlabel{$label};
+
+ # Error check: no locations
+ return err('U', "No relative labels") if ( @{$locarray} == 0 );
+
+ if ( $direction eq 'f' ) {
+ # Search forward for first location larger then the current one
+ foreach my $reflocation ( @{$locarray} ) {
+ printf("forward %#o %#o\n", $reflocation, $curlocation) if ($debug);
+ return ($reflocation) if ( $reflocation > $curlocation );
+ }
+ }
+ else {
+ # Search backwards for first location smaller than the current one
+ foreach my $reflocation ( sort( { $b <=> $a } @{$locarray} ) ) {
+ printf("backward %#o %#o\n", $reflocation, $curlocation) if ($debug);
+ return ($reflocation) if ( $reflocation < $curlocation );
+ }
+ }
+ return err('U', "undefined relative reference $label$direction");
+}
+
+sub punch { # output a word in paper tape binary format
+ my $word = shift;
+ my $final = shift || 0;
+
+ printf $OUT "%c%c%c",
+ (($word >> 12) & 077) | 0200,
+ (($word >> 6) & 077) | 0200,
+ ($word & 077) | 0200 | $final;
+}
+
+sub dump_labels { # for 'list' and --namelist
+ my $file = shift;
+
+ foreach my $key (sort keys %Glabel) {
+ my $addr = $Glabel{$key};
+ my $flags = ($addr & $RELATIVE) ? "r" : "";
+ if ($addr & $RELATIVE) {
+ $addr &= 0777777;
+ $addr += $Var{'..'};
+ }
+ printf $file "%-8.8s %#06o %s\n", $key, $addr & 0777777, $flags;
+ }
+}
--- /dev/null
+#!/usr/bin/env perl
+#
+# Load a code coverage report from SimH and a kernel assembly listing
+# from as7, and show which lines in the kernel were not executed.
+#
+# To capture the list of executed locations in SimH, run SimH but stop
+# before executing any code, e.g. dep pc 0100 but don't go.
+#
+# Run this command to log execution of locations 21-4545:
+# set br 21-4545[200000000]
+#
+# Eventually, ctrl-E to stop execution. Now dump the results:
+# show @brk.list break all
+#
+# which will output a BRK.LIST Then run this command:
+# ccov7 BRK.LIST a.lst | less
+#
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Data::Dumper;
+
+die("Usage: $0 breaklist_file a.lst\n") if (@ARGV !=2);
+
+# Read in the breaklist file and work out which lines were not
+# used. We assume that [200000000] was used in SimH
+my @Unused;
+open(my $IN, "<", $ARGV[0]) || die("Can't open $ARGV[0]: $!\n");
+while (<$IN>) {
+ if (m{^(\d+):.*\[(\d+)\]}) {
+ $Unused[$1]=1 if ($2 == 200000000);
+ }
+}
+close($IN);
+
+# Now open the kernel listing file. Decorate those lines which
+# were not executed
+my $decoration= "\t NOT EXECUTED";
+
+open($IN, "<", $ARGV[1]) || die("Can't open $ARGV[1]: $!\n");
+while (<$IN>) {
+ chomp;
+ if (m{^(\d+):}) { # Find a line starting with digits, trim
+ my $location= $1; # leading zeroes, append $decoration
+ $location=~ s{^0+}{}; # if this is an unused location
+ $_ .= $decoration if (defined($Unused[$location]));
+ }
+ print("$_\n");
+}
+close($IN);
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# fsck7: Check a PDP-7 filesystem for consistency
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Fcntl qw(:flock SEEK_SET);
+use Data::Dumper;
+use Getopt::Long qw(GetOptions);
+
+Getopt::Long::Configure qw(gnu_getopt);
+
+# Constants
+use constant NUMBLOCKS => 8000; # Number of blocks on a surface
+use constant WORDSPERBLK => 64; # 64 words per block
+use constant LASTFREEBLOCK => 6399; # That's what s9.s uses
+use constant NUMINODEBLKS => 710; # Number of i-node blocks
+use constant FIRSTINODEBLK => 2; # First i-node block number
+use constant INODESIZE => 12; # Size of an i-node
+use constant INODESPERBLK => int( WORDSPERBLK / INODESIZE );
+use constant DIRENTSIZE => 8; # Size of an directory entry
+use constant DIRENTSPERBLK => WORDSPERBLK / DIRENTSIZE;
+
+use constant MAXINT => 0777777; # Biggest unsigned integer
+use constant SIGN => 0400000; # Sign bit
+use constant BYTESPERWORD => 4; # We encode each word into 4 bytes
+
+# i-node field offsets
+use constant I_FLAGS => 0;
+use constant I_DISKPS => 1;
+use constant I_UID => 8;
+use constant I_NLKS => 9;
+use constant I_SIZE => 10;
+use constant I_UNIQ => 11;
+
+use constant I_NUMBLKS => 7; # Seven block pointers in i-node
+
+# i-node flag masks
+use constant I_USED => 0400000;
+use constant I_LARGE => 0200000;
+use constant I_SPECIAL => 0000040;
+use constant I_DIRECTORY => 0000020;
+use constant I_FILE => 0000000;
+use constant I_OWNERREAD => 0000010;
+use constant I_OWNERWRITE => 0000004;
+use constant I_WORLDREAD => 0000002;
+use constant I_WORLDWRITE => 0000001;
+
+use constant I_LINK => 0000001; # Never used in an i-node: just internal use
+
+# Directory field offsets
+use constant D_INUM => 0;
+use constant D_NAME => 1;
+use constant D_UNIQ => 5;
+use constant D_NUMWORDS => 8; # Eight words in a direntry
+
+# Globals
+my ($debug, $no_dd) = (0,0);
+my @Block; # Array of blocks and words in each block
+my @Freelist; # List of free block numbers
+my @Usedlist; # List of in-use block numbers
+my @Usedinode; # List of i-nodes in use
+my @Dirdone; # List of directory i-nodes already processed
+
+# Debug printing
+sub dprint {
+ print(@_) if ($debug);
+}
+
+sub dprintf {
+ printf(@_) if ($debug);
+}
+
+### read a word from a file in SimH format
+### return -1 on EOF
+sub read_word {
+ my $F = shift;
+
+ # Convert four bytes into one 18-bit word
+ return -1 if ( read( $F, my $four, 4 ) != 4 ); # Not enough bytes read
+ my ( $b1, $b2, $b3, $b4 ) = unpack( "CCCC", $four );
+ return (
+ ( $b1 & 0xff ) | ( ( $b2 & 0xff ) << 8 ) | ( ( $b3 & 0xff ) << 16 ) |
+ ( ( $b4 & 0xff ) << 24 ) );
+}
+
+# Return blocknumber and offset for a specific i-node
+sub get_inode_block_offset {
+ my $inum = shift;
+ my $blocknum = FIRSTINODEBLK + int( $inum / INODESPERBLK );
+ my $offset = INODESIZE * ( $inum % INODESPERBLK );
+ return ( $blocknum, $offset );
+}
+
+# Mark a block as being in-use
+sub mark_block_inuse {
+ my $usedblk = shift;
+ die("bad usedblk $usedblk\n") if ($usedblk >= NUMBLOCKS);
+
+ dprint("Block $usedblk is in-use\n");
+ print("Free block $usedblk is being used\n")
+ if ( $Freelist[$usedblk] );
+ print("In-use block $usedblk is being re-used\n")
+ if ( $Usedlist[$usedblk] );
+ $Usedlist[$usedblk] = 1;
+}
+
+# Given an i-node number and a flag mask, return true
+# if the flags contains that mask, 0 otherwise
+sub is_inode {
+ my ( $inode, $mask ) = @_;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inode);
+ my $flags = $Block[$blocknum][ $offset + I_FLAGS ];
+ return ( $flags & $mask );
+}
+
+# Given an i-node number, return the flags, uid, # link,
+# file size, uniq number and list of disk blocks for
+# the i-node (if $wantblocks is true).
+# Return undef if the i-node is not used.
+sub get_inode {
+ my ( $inode, $wantblocks ) = @_;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inode);
+ my $flags = $Block[$blocknum][ $offset + I_FLAGS ];
+ my $uid = $Block[$blocknum][ $offset + I_UID ];
+ my $links = $Block[$blocknum][ $offset + I_NLKS ];
+ my $size = $Block[$blocknum][ $offset + I_SIZE ];
+ my $uniq = $Block[$blocknum][ $offset + I_UNIQ ];
+
+ # Skip unused i-nodes
+ return (undef) if ( ( $flags & I_USED ) == 0 );
+
+ # Return now if they don't want the blocks
+ return ( $flags, $uid, $links, $size, $uniq ) if ( !$wantblocks );
+
+ # Build a list of in-use blocks
+ my @used;
+ if ( $flags & I_LARGE ) {
+
+ # Large file
+ foreach
+ my $o ( $offset + I_DISKPS .. $offset + I_DISKPS + I_NUMBLKS - 1 )
+ {
+ my $usedptr = $Block[$blocknum][$o];
+ next if ( $usedptr == 0 );
+ die("bad usedptr $usedptr in i-node $inode\n") if ($usedptr >= NUMBLOCKS);
+
+ mark_block_inuse($usedptr);
+ foreach my $indo ( 0 .. WORDSPERBLK - 1 ) {
+
+ my $usedblk = $Block[$usedptr][$indo];
+ next if ( $usedblk == 0 );
+ push( @used, $usedblk );
+ }
+ }
+ }
+ else {
+ # Small file
+ foreach
+ my $o ( $offset + I_DISKPS .. $offset + I_DISKPS + I_NUMBLKS - 1 )
+ {
+ my $usedblk = $Block[$blocknum][$o];
+ next if ( $usedblk == 0 );
+ push( @used, $usedblk );
+ }
+ }
+ return ( $flags, $uid, $links, $size, $uniq, @used );
+}
+
+# Given the address of a four word argument string in
+# a block, return a copy of the string in ASCII format.
+# Lose any trailing spaces as well.
+sub word2filename {
+ my ( $block, $offset ) = @_;
+ my $result = "";
+
+ foreach ( 1 .. 4 ) {
+
+ my $word = $Block[$block][ $offset++ ];
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ $result .= chr($c1) . chr($c2);
+ }
+ $result =~ s{ *$}{};
+ return ($result);
+}
+
+# Print out a directory entry
+sub print_direntry {
+ my ( $inum, $name ) = @_;
+ my ( $flags, $uid, $links, $size, $uniq ) = get_inode( $inum, 0 );
+ if ( !defined($flags) ) {
+ printf( "%4d unallocated i-node in this dir named %s\n", $inum, $name );
+ return;
+ }
+
+ # Get the text perm characters
+ my ( $p1, $p2, $p3, $p4, $p5 ) = ( 's', '-', '-', '-', '-' );
+ $p1 = 'l' if ( $flags & I_LARGE );
+ $p1 = 'i' if ( $flags & I_SPECIAL );
+ $p1 = 'd' if ( $flags & I_DIRECTORY );
+ $p2 = 'r' if ( $flags & I_OWNERREAD );
+ $p3 = 'w' if ( $flags & I_OWNERWRITE );
+ $p4 = 'r' if ( $flags & I_WORLDREAD );
+ $p5 = 'w' if ( $flags & I_WORLDWRITE );
+
+ # Convert links and uid
+ $links = MAXINT - $links + 1;
+ $uid = -1 if ( $uid == MAXINT );
+
+ # Warn about empty filename
+ $name= "EMPTY FILENAME" if ($name=~ m{/$});
+
+ printf( "%4d %s%s%s%s%s %2d %3o %5d %s\n",
+ $inum, $p1, $p2, $p3, $p4, $p5, $links, $uid & 0777, $size, $name );
+}
+
+# Given a directory's i-num and name, check it
+sub check_directory {
+ my ( $inode, $name ) = @_;
+ my @dirtocheck; # List of dirs to check
+
+ print("Directory $name, i-node $inode\n");
+
+ my ( $flags, $uid, $links, $size, $uniq, @used ) = get_inode( $inode, 1 );
+ if ( !defined($flags) ) {
+ print("Directory $name has empty i-node $inode\n");
+ return;
+ }
+
+ if ( ( $flags & I_DIRECTORY ) == 0 ) {
+ print("Directory $name i-node $inode not a directory\n");
+ return;
+ }
+ $Dirdone[$inode] = 1;
+
+ # Read the contents of the data blocks
+ foreach my $block (@used) {
+ for (
+ my $direntoff = 0 ;
+ $direntoff < WORDSPERBLK ;
+ $direntoff += DIRENTSIZE
+ )
+ {
+ my $inum = $Block[$block][ $direntoff + D_INUM ];
+ my $direntname = word2filename( $block, $direntoff + D_NAME );
+ next if ( $inum == 0 );
+ print_direntry( $inum, "$name/$direntname" );
+
+ # Check sub-directories
+ if ( is_inode( $inum, I_DIRECTORY ) && ( !$Dirdone[$inum] ) ) {
+ push( @dirtocheck, [ $inum, "$name/$direntname" ] );
+ }
+ }
+ }
+ print("\n");
+
+ # Now check the subdirs
+ foreach my $d (@dirtocheck) {
+ check_directory( $d->[0], $d->[1] );
+ }
+
+}
+
+# Keep this near the GetOptions call to make it easy to add documentation!
+sub usage {
+ die("Usage: $0 [--debug] imagefile\n");
+}
+
+### MAIN PROGRAM
+
+GetOptions(
+ 'debug|d' => \$debug,
+ 'no_dd|3' => \$no_dd,
+)
+ or usage();
+
+usage() if ( @ARGV < 1 );
+
+# Open the image and skip the first surface
+open( my $IN, "<", $ARGV[0] ) || die("Can't open $ARGV[0]: $!\n");
+seek($IN, NUMBLOCKS*WORDSPERBLK*BYTESPERWORD, SEEK_SET) ||
+ die("Cannot seek: $!\n");
+
+# Now read the filesystem into the Block array
+foreach my $block ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $posn ( 0 .. WORDSPERBLK - 1 ) {
+ my $word = read_word($IN);
+ last if ( $word == -1 );
+ $Block[$block][$posn] = $word;
+ }
+}
+
+# Build and check the free list
+my $freeptr = $Block[0][0];
+while ( $freeptr != 0 ) {
+
+ # Add nine blocks to the free list
+ foreach my $posn ( 1 .. 9 ) {
+ my $freeblock = $Block[$freeptr][$posn];
+ if ( $freeblock != 0 ) {
+ print("Block $freeblock multiply free\n")
+ if ( $Freelist[$freeblock] );
+ $Freelist[$freeblock] = 1;
+ }
+ }
+
+ # Move the pointer up
+ $freeptr = $Block[$freeptr][0];
+}
+
+# Check the list of i-nodes
+foreach my $inode ( 0 .. NUMINODEBLKS * INODESPERBLK - 1 ) {
+
+ my ( $flags, $uid, $links, $size, $uniq, @used ) = get_inode( $inode, 1 );
+ next if ( !defined($flags) );
+ $Usedinode[$inode] = 1;
+ dprint("I-node $inode in use\n");
+
+ # Check number of links is not zero
+ print("I-node $inode link count 0\n") if ( $links == 0 );
+
+ # Mark all the file's blocks in-use
+ foreach my $b (@used) {
+ mark_block_inuse($b);
+ }
+ dprint("\n");
+}
+
+# Now check the directories. We start with dd at i-num 4.
+if ($no_dd) {
+ check_directory( 2, "" );
+} else {
+ check_directory( 4, "dd" );
+}
+
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# mkfs7: Make a PDP-7 filesystem image for SimH
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Data::Dumper;
+use Getopt::Long qw(GetOptions);
+
+Getopt::Long::Configure qw(gnu_getopt);
+
+# Constants
+use constant NUMBLOCKS => 8000; # Number of blocks on a surface
+use constant WORDSPERBLK => 64; # 64 words per block
+use constant LASTFREEBLOCK => 6399; # That's what s9.s uses
+use constant NUMINODEBLKS => 710; # Number of i-node blocks
+use constant FIRSTINODEBLK => 2; # First i-node block number
+use constant INODESIZE => 12; # Size of an i-node
+use constant INODESPERBLK => int(WORDSPERBLK / INODESIZE);
+use constant DIRENTSIZE => 8; # Size of an directory entry
+use constant DIRENTSPERBLK => WORDSPERBLK / DIRENTSIZE;
+
+use constant DD_INUM => 2; # I-number of the dd directory
+use constant MAXINT => 0777777; # Biggest unsigned integer
+
+# i-node field offsets
+use constant I_FLAGS => 0;
+use constant I_DISKPS => 1;
+use constant I_UID => 8;
+use constant I_NLKS => 9;
+use constant I_SIZE => 10;
+use constant I_UNIQ => 11;
+
+use constant I_NUMBLKS => 7; # Seven block pointers in i-node
+
+# i-node flag masks
+use constant I_USED => 0400000;
+use constant I_LARGE => 0200000;
+use constant I_SPECIAL => 0000040;
+use constant I_DIRECTORY => 0000020;
+use constant I_FILE => 0000000;
+use constant I_OWNERREAD => 0000010;
+use constant I_OWNERWRITE => 0000004;
+use constant I_WORLDREAD => 0000002;
+use constant I_WORLDWRITE => 0000001;
+
+use constant I_LINK => 0000001; # Never used in an i-node: just internal use
+
+# Directory field offsets
+use constant D_INUM => 0;
+use constant D_NAME => 1;
+use constant D_UNIQ => 5;
+use constant D_NUMWORDS => 8; # Eight words in a direntry
+
+# Globals
+my ($debug,$wantdot,$wantdotdot, $no_dd)=(0,0,0,0);
+my @Block; # Array of blocks and words in each block
+my @Freelist; # List of free block numbers
+my $nextinum = 1; # i-num 0 is never used
+my @Dirstack; # Stack of directories. Each value is a ref
+ # to a [ blocknum, offset, inum ] array which
+ # is the next free position in the directory
+my $lastinum = -1; # last inum assigned, for link to i-num -1
+
+# Debug printing
+sub dprint {
+ print(@_) if ($debug);
+}
+
+sub dprintf {
+ printf(@_) if ($debug);
+}
+
+# Initialise the free block list
+# s9.s sets up blocks 710 to 6399 as free
+sub init_freelist {
+ foreach my $blk (FIRSTINODEBLK+NUMINODEBLKS-1 .. LASTFREEBLOCK) {
+ push(@Freelist, $blk);
+ }
+}
+
+# Recursively write the free list of blocks to disk.
+# Set up a block with nine free block numbers in it,
+# plus a pointer to the next block in the free list.
+# Return the block number of this block with nine free block numbers
+# or 0 if we did not set up a block.
+# The argument is only used to make the debug output pleasing
+sub write_freelist {
+ no warnings 'recursion';
+ my $i= shift;
+
+ # Get a block to store nine free block numbers
+ # Return if there are no free blocks
+ my $thisblock= shift(@Freelist);
+ return(0) if (!defined($thisblock));
+ dprint("$thisblock ");
+ dprint("\n") if (($i % 14) == 0);
+
+ # Try to grab nine of them and store in this block
+ foreach my $count (1 .. 9) {
+ $Block[$thisblock][$count]= shift(@Freelist) || 0;
+ }
+
+ # Now we need the pointer to the next block in the chain
+ $Block[$thisblock][0]= write_freelist($i+1);
+
+ # and return our own block number
+ return($thisblock);
+}
+
+# Fill block zero, the sysdata block, with whatever it needs.
+# As far as we can tell, all it needs is the pointer to the
+# beginning of the free list.
+sub fill_sysdata {
+ $Block[0][0]= write_freelist(6);
+}
+
+# Given a size in words, allocate and return a set of block numbers
+# for the entity
+sub allocate_blocks {
+ my $numwords = shift;
+ my @blklist;
+
+ my $numblocks = int( ( $numwords + WORDSPERBLK - 1 ) / WORDSPERBLK );
+ foreach my $cnt ( 1 .. $numblocks ) {
+ my $blk= shift(@Freelist);
+ die("Not enough blocks\n") if (!defined($blk));
+ push( @blklist, $blk );
+ }
+ dprintf(
+ "Allocated blocks for size %d: %d .. %d (%06o .. %06o)\n",
+ $numwords, $blklist[0], $blklist[-1], $blklist[0], $blklist[-1])
+ if ($blklist[0]);
+ return (@blklist);
+}
+
+# Allocate and return either the specified i-node or the next
+# available one if there is no argument
+sub allocate_inode {
+ my $inum = shift;
+ return ( $nextinum++ ) if ( !defined($inum) );
+ if ( $inum < $nextinum ) {
+ print("i-num $inum already allocated, ignoring this\n")
+ } else {
+ $nextinum = $inum + 1;
+ }
+ return ($inum);
+}
+
+# Given a list of block numbers, allocate a set of indirect blocks
+# and install block pointers into the indirect blocks. Return the
+# list of indirect block numbers.
+sub build_indirect_blocks {
+ my @blklist = @_;
+ my $blkcount = @blklist;
+
+ # Divide the number of data blocks by WORDSPERBLK and round up, so
+ # we know how many indirect blocks to allocate.
+ my $indcount = int( ( $blkcount + WORDSPERBLK - 1 ) / WORDSPERBLK );
+ dprint("Allocating $indcount indirect blks for $blkcount direct blks\n");
+
+ # Get enough indirect blocks
+ my @indlist = allocate_blocks(WORDSPERBLK * $indcount);
+
+ # Now fill in the pointers
+ my $indblock = $indlist[0];
+ my $offset = 0;
+ foreach my $datablock (@blklist) {
+ # dprint("$indblock $offset -> $datablock\n");
+ $Block[$indblock][ $offset++ ] = $datablock;
+ if ( $offset == WORDSPERBLK ) {
+ $offset = 0;
+ $indblock++;
+ }
+ }
+
+ # Return the indirect block numbers
+ dprint("Built indirect blocks $indlist[0] .. $indlist[-1]\n");
+ return (@indlist);
+}
+
+# Return blocknumber and offset for a specific i-node
+sub get_inode_block_offset {
+ my $inum = shift;
+ my $blocknum = FIRSTINODEBLK + int( $inum / INODESPERBLK );
+ my $offset = INODESIZE * ( $inum % INODESPERBLK );
+ dprint("inum $inum => block $blocknum offset $offset\n");
+ return ( $blocknum, $offset );
+}
+
+# Given an i-node number (possibly undef), permission, filetype, uid, size
+# and up to seven direct or indirect block numbers, fill in the given i-node
+# with the data. If the i-node number is undef, allocate an i-node number.
+# Return the i-node number used.
+sub fill_inode {
+ my ( $inum, $perms, $filetype, $uid, $size, @blklist ) = @_;
+ die("Too many blocks\n") if ( @blklist > 7 );
+
+ $uid &= MAXINT; # truncate negative UID to 18 bits
+
+ # Calculate the block number and word offset for this
+ $inum = allocate_inode() if ( !defined($inum) );
+ my ( $blocknum, $offset ) = get_inode_block_offset($inum);
+
+ # Fill in the easy fields. Link count is negative
+ $Block[$blocknum][ $offset + I_UID ] = $uid;
+ $Block[$blocknum][ $offset + I_SIZE ] = $size;
+ $Block[$blocknum][ $offset + I_NLKS ] = 0;
+
+ my $i = $offset;
+ foreach my $datablocknum (@blklist) {
+ $Block[$blocknum][ $i + I_DISKPS ] = $datablocknum;
+ $i++;
+ }
+
+ # Deal with the flags and see if it's a large file
+ my $flags = $perms | $filetype | I_USED;
+ $flags |= I_LARGE if ( $size > WORDSPERBLK * I_NUMBLKS );
+ $Block[$blocknum][ $offset + I_FLAGS ] = $flags;
+
+ dprintf( "Fill inum %d: flags %06o uid %06o size %d (%06o)=> blk %d off %d\n",
+ $inum, $flags, $uid, $size, $size, $blocknum, $offset );
+ return ($inum);
+}
+
+# Increase the file size of an i-node
+sub increment_file_length {
+ my ( $inum, $incr) = @_;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inum);
+ $Block[$blocknum][ $offset + I_SIZE ] += $incr;
+}
+
+# Increase the link count of an i-node
+sub increment_link_count {
+ my $inum = shift;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inum);
+ $Block[$blocknum][ $offset + I_NLKS ] --;
+ $Block[$blocknum][ $offset + I_NLKS ] &= MAXINT;
+}
+
+# Convert an ASCII string into an array of 18-bit word values
+# where two characters are packed into each word. Put NUL in
+# if the string has an odd number of characters. Return the array
+sub ascii2words {
+ my $str = shift;
+ my @words;
+ # Pad the string to eight characters
+ $str = sprintf( "%-8s", substr( $str, 0, 8 ) );
+ for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
+ my $c1 = substr( $str, $i, 1 ) || "\0";
+ my $c2 = substr( $str, $i + 1, 1 ) || "\0";
+
+ push( @words, ( ord($c1) << 9 ) | ord($c2) );
+ }
+ return (@words);
+}
+
+# Add an extra block to an i-node. NOTE: for now, we don't change the size
+# in the i-node.
+sub add_block_to_inode {
+ my ( $blknum, $inum ) = @_;
+
+ my ( $iblock, $offset ) = get_inode_block_offset($inum);
+
+ foreach my $i ( 1 .. I_NUMBLKS ) {
+ next if ( $Block[$iblock][ $offset + $i ] ); # Skip in-use blocks
+ $Block[$iblock][ $offset + $i ] = $blknum;
+ return;
+ }
+ die("Unable to add extra block to i-node $inum\n");
+ dprint("Added block $blknum to i-node $inum\n");
+}
+
+# Add a name and an i-node number to the current directory in the
+# directory stack.
+sub add_direntry {
+ my ( $name, $inum ) = @_;
+
+ $inum = $lastinum if ($inum == -1);
+
+ # Get the block and offset to the next empty slot in the directory
+ my $dirref = $Dirstack[-1];
+
+ if ( !defined($dirref) ) {
+ dprint("Adding $name inode $inum to current directory\n");
+ dprint("Empty dirstack, we must be building the root dir\n");
+ return;
+ }
+
+ my $blocknum = $dirref->[0];
+ my $offset = $dirref->[1];
+ dprint("Adding $name inode $inum to curdir inum $dirref->[2]" .
+ " blk $blocknum off $offset\n");
+
+ # Convert the name into four words
+ my @wlist = ascii2words($name);
+
+ # Fill in the directory entry
+ $Block[$blocknum][ $offset + D_INUM ] = $inum;
+ $Block[$blocknum][ $offset + D_NAME ] = shift(@wlist);
+ $Block[$blocknum][ $offset + D_NAME + 1 ] = shift(@wlist);
+ $Block[$blocknum][ $offset + D_NAME + 2 ] = shift(@wlist);
+ $Block[$blocknum][ $offset + D_NAME + 3 ] = shift(@wlist);
+
+ # Move up to the next position in the directory.
+ $dirref->[1] += D_NUMWORDS;
+
+ # Update the directory inode's i.size, another 8 words
+ increment_file_length( $dirref->[2], D_NUMWORDS );
+
+ # If we have filled the directory up, allocate another block to it
+ if ( $dirref->[1] == WORDSPERBLK ) {
+ my ($nextblock) = allocate_blocks(WORDSPERBLK);
+ dprint("Extra block $nextblock for this directory\n");
+ $dirref->[0] = $nextblock;
+ $dirref->[1] = 0;
+
+ # And add this new block to the directory's i-node
+ add_block_to_inode( $nextblock, $dirref->[2] );
+ }
+
+ # Finally, increment the link count
+ increment_link_count($inum);
+ $lastinum = $inum;
+}
+
+# Given a name, perms, a user-id and an optional i-node number, make a
+# directory. Link it to the previous directory in the directory stack.
+# Allocate blocks and i-nodes for it. Add a "dd" entry as well.
+sub make_dir {
+ my ( $dirname, $perms, $uid, $inum ) = @_;
+
+ # Get an i-node number or validate the one we got
+ $inum = allocate_inode($inum);
+
+ # Get a block for this directory
+ my ($dirblock) = allocate_blocks(WORDSPERBLK);
+
+ # Add this to the previous directory
+ # and fill the i-node with the details
+ fill_inode( $inum, $perms, I_DIRECTORY, $uid, 0, $dirblock );
+ add_direntry( $dirname, $inum );
+
+ # Make this the top directory on the dirstack
+ dprint("Pushing dir block $dirblock inum $inum to dirstack\n");
+ push( @Dirstack, [ $dirblock, 0, $inum ] );
+
+ # Add a "." entry to this directory if requested
+ if ($wantdot) {
+ add_direntry( ".", $inum );
+ dprint("Added a . entry to ourselves\n");
+ }
+
+ # and a ".." directory to the previous one on the stack
+ if ($wantdotdot && defined($Dirstack[-2])) {
+ add_direntry( "..", $Dirstack[-2]->[2] );
+ dprintf("Added a .. entry to i-num %d\n", $Dirstack[-2]->[2] );
+ }
+
+ # Finally, add a "dd" entry to this directory. We get the
+ # i-num from the first entry in the Dirstack. Sorry for the dbl negative.
+ if (!$no_dd) {
+ add_direntry( "dd", $Dirstack[0]->[2] );
+ dprintf("Added a dd entry to i-num %d\n", $Dirstack[0]->[2] );
+ if (!$wantdotdot && !$wantdot) { # PLB 2019
+ add_direntry( "..", $inum );
+ dprint("Added a .. entry to ourselves\n");
+ }
+ }
+ dprintf( "Made directory %s perms %06o uid %d in inum %d\n\n",
+ $dirname, $perms, $uid, $inum );
+}
+
+# Read a word from a file in paper tape binary format.
+# Return -1 on EOF
+sub read_word {
+ my $FH = shift;
+
+ # Convert three bytes into one 18-bit word
+ return (-1) if ( read( $FH, my $three, 3 ) != 3 ); # Not enough bytes read
+ my ( $b1, $b2, $b3 ) = unpack( "CCC", $three );
+ return ( ( ( $b1 & 077 ) << 12 ) | ( ( $b2 & 077 ) << 6 ) | ( $b3 & 077 ) );
+}
+
+# Given a filename, read that file in and return an array of
+# words containing that file, or die otherwise
+sub read_file {
+ my $extfile= shift;
+ my @buf;
+
+ # Open the external file
+ open( my $IN, "<", $extfile ) || die("Can't open $extfile: $!\n");
+
+ # Determine if this is ASCII or binary
+ my $isbinary = 0;
+ my $c = getc($IN);
+ seek( $IN, 0, 0 );
+ $isbinary = 1 if ($c && (( ord($c) & 0300 ) == 0200 ));
+
+ # Read the file into a buffer, converting from ASCII or sixbit encoding
+ while (1) {
+ if ($isbinary) {
+
+ # Convert three bytes into one 18-bit word
+ my $result = read_word($IN);
+ last if ( $result == -1 );
+ push(@buf, $result);
+ } else {
+ # Convert two ASCII characters into one 18-bit word
+ my $c1 = getc($IN);
+ last if ( !defined($c1) ); # No character, leave the loop
+ my $word = ord($c1) << 9;
+ my $c2 = getc($IN);
+ $word |= ord($c2) if ( defined($c2) );
+ push(@buf, $word);
+ }
+ }
+ return(@buf);
+}
+
+# Write a file which is stored in a buffer into the in-memory
+# disk image. Takes the base block number and the buffer of words
+sub write_file {
+ my ($blocknum, @buf)= @_;
+ my $size= @buf;
+ my $offset=0;
+
+ foreach my $i (0 .. $size-1) {
+ $Block[$blocknum][$offset++]= $buf[$i];
+ if ( $offset == WORDSPERBLK ) {
+ $offset = 0;
+ $blocknum++;
+ dprint("Filling block $blocknum\n");
+ }
+ }
+}
+
+# Given a filename, perms, user-id and an external file, add a file to the
+# filesystem. Add an entry to this file in the current directory on
+# the dirstack.
+sub add_file {
+ my ( $name, $perms, $uid, $extfile, $inum ) = @_;
+ dprintf( "Adding file %s perms %06o uid %d extfile %s\n",
+ $name, $perms, $uid, $extfile );
+
+ # Read the file into a buffer
+ my @buf= read_file($extfile);
+ my $size= @buf;
+
+ # Allocate enough blocks for the file
+ my @blklist = allocate_blocks($size);
+
+ # Put the contents of the file into the blocks
+ if ($blklist[0]) {
+ dprint("Filling block $blklist[0] with content from $extfile\n");
+ write_file($blklist[0], @buf);
+ }
+
+ # If it's too big, allocate indirect blocks
+ my $large = 0;
+ my @indblocks;
+ if ( @blklist > I_NUMBLKS ) {
+ $large = 1;
+ @indblocks = build_indirect_blocks(@blklist);
+ }
+
+ # Allocate and fill in the i-node
+ $inum = allocate_inode($inum);
+ if ($large) {
+ fill_inode( $inum, $perms, I_FILE, $uid, $size, @indblocks );
+ } else {
+ fill_inode( $inum, $perms, I_FILE, $uid, $size, @blklist );
+ }
+
+ # and add the entry in the directory
+ add_direntry( $name, $inum );
+ dprint("Done adding file $name as inum $inum\n\n");
+}
+
+# Given a name, perms, uid and i-number
+# add a special file to the filesystem
+sub add_special {
+ my ( $name, $perms, $uid, $inum ) = @_;
+
+ # Allocate and fill in the i-node
+ $inum = allocate_inode($inum);
+ fill_inode( $inum, $perms, I_SPECIAL, $uid, 0 );
+
+ # Add the entry in the directory
+ add_direntry( $name, $inum );
+ dprint("Done adding special file $name inum $inum\n\n");
+}
+
+# Parse the perms word from the proto file.
+# Return filetype and perms as a number.
+sub parse_perms {
+ my $permstring = shift;
+ my ( $filetype, $perms ) = ( I_FILE, 0 );
+
+ die("perms word $permstring is not 5 characters long\n")
+ if ( length($permstring) != 5 );
+
+ $filetype = I_DIRECTORY if ( $permstring =~ m{^d} );
+ $filetype = I_SPECIAL if ( $permstring =~ m{^i} );
+ $filetype = I_LINK if ( $permstring =~ m{^l} );
+
+ $perms |= I_OWNERREAD if ( $permstring =~ m{^.r} );
+ $perms |= I_OWNERWRITE if ( $permstring =~ m{^..w} );
+ $perms |= I_WORLDREAD if ( $permstring =~ m{^...r} );
+ $perms |= I_WORLDWRITE if ( $permstring =~ m{^....w} );
+ return ( $filetype, $perms );
+}
+
+sub uid {
+ my $uid = shift;
+ return -1 if ($uid eq '-1');
+ return oct($uid);
+}
+
+# Open the named proto file and parse it
+sub parse_proto_file {
+ my $file = shift;
+ open( my $IN, "<", $file ) || die("Can't one $file: $!\n");
+ while (<$IN>) {
+ chomp;
+
+ # Skip comments
+ s{#.*}{};
+
+ # Get the words on the line;
+ my @words = split( /\s+/, $_ );
+
+ # Skip if no words on this line
+ # but lose any empty word
+ next if ( @words == 0 );
+ shift(@words) if ( $words[0] eq '' );
+
+ # If the first word is a $, then pop a directory from the stack
+ if ( $words[0] eq '$' ) {
+ pop(@Dirstack);
+ dprint("Popping back a directory in the dirstack\n\n");
+ next;
+ }
+
+ # Get the filetype and permissions
+ my ( $type, $perms ) = parse_perms( $words[1] );
+
+ if ( $type eq I_DIRECTORY ) {
+ my ( $name, $permstr, $uid, $inum ) = @words;
+ make_dir( $name, $perms, uid($uid), $inum );
+ next;
+ }
+ if ( $type eq I_FILE ) {
+ my ( $name, $permstr, $uid, $extfile, $inum ) = @words;
+ add_file( $name, $perms, uid($uid), $extfile, $inum );
+ next;
+ }
+ if ( $type eq I_SPECIAL ) {
+ my ( $name, $permstr, $uid, $inum ) = @words;
+ add_special( $name, $perms, uid($uid), $inum );
+ next;
+ }
+ if ( $type eq I_LINK ) {
+ my ( $name, $permstr, $inum ) = @words;
+ dprint("Adding link in curdir to $name inum $inum\n");
+ add_direntry( $name, $inum );
+ next;
+ }
+ }
+ close($IN);
+}
+
+# Convert an 18-bit word into two ASCII characters and return them.
+# Don't return NUL characters
+sub word2ascii {
+ my $word = shift;
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ my $result = "";
+ $result .= (($c1 >= 32) && ($c1 <= 126)) ? chr($c1) : ' ';
+ $result .= (($c2 >= 32) && ($c2 <= 126)) ? chr($c2) : ' ';
+ return ($result);
+}
+
+# Convert an 18-bit word into a scalar which has three sixbit
+# values in three bytes. Set the msb in the first byte
+sub word2three {
+ my $val = shift;
+
+ my $b1 = ( ( $val >> 12 ) & 077 ) | 0x80;
+ my $b2 = ( $val >> 6 ) & 077;
+ my $b3 = $val & 077;
+ return ( pack( "CCC", $b1, $b2, $b3 ) );
+}
+
+# Dump the image to the output file
+sub dump_image {
+ my ( $format, $output ) = @_;
+ open( my $OUT, ">", $output ) || die("Can't write to $output: $!\n");
+
+ # list: Octal output with block comments. We don't dump the first 8K blocks
+ if ( $format eq "list" ) {
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ printf( $OUT "Block %d (%06o)\n", $blocknum, $blocknum );
+ foreach my $line ( 0 .. 7 ) {
+
+ # Print out the words in octal
+ foreach my $offset ( 0 .. 7 ) {
+ printf( $OUT "%06o ",
+ $Block[$blocknum][ 8 * $line + $offset ] || 0
+ );
+ }
+
+ # Now print out the ASCII characters in the word
+ foreach my $offset ( 0 .. 7 ) {
+ print( $OUT word2ascii(
+ $Block[$blocknum][ 8 * $line + $offset ] || 0));
+ }
+ print( $OUT "\n" );
+ }
+ print( $OUT "\n" );
+ }
+ }
+
+ # ptr: Each word into three bytes, a sixbit in each one
+ if ( $format eq "ptr" ) {
+ # Dump 8000 empty blocks first
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ print( $OUT word2three( 0 ) );
+ }
+ }
+
+ # Now the real blocks
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ print( $OUT word2three( $Block[$blocknum][$offset] || 0 ) );
+ }
+ }
+ }
+
+ # simh: Each word into four bytes, little endian
+ if ( $format eq "simh" ) {
+ # Dump 8000 empty blocks first
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ print( $OUT pack( "CCCC", 0,0,0,0));
+ }
+ }
+
+ # Now the real blocks
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ my $word = $Block[$blocknum][$offset] || 0;
+ # SIMH format packs word in a little-endian 32-bit int
+ my $packedword = pack( "CCCC",
+ $word & 0xff,
+ ( $word >> 8 ) & 0xff,
+ ( $word >> 16 ) & 0xff,
+ ( $word >> 24 ) & 0xff);
+ print( $OUT $packedword );
+ }
+ }
+ }
+
+ close($OUT);
+}
+
+# Keep this near the GetOptions call to make it easy to add documentation!
+sub usage {
+ die("Usage: $0 [--debug] [--format=list|ptr|simh] [--out file] protofile\n");
+}
+
+### MAIN PROGRAM
+
+my ( $format, $output, $kernelfile, $chartable ) = ( "simh", "image.fs" );
+
+GetOptions(
+ 'debug|d' => \$debug,
+ 'dot|1' => \$wantdot,
+ 'dotdot|2' => \$wantdotdot,
+ 'no_dd|3' => \$no_dd,
+ 'format|f=s' => \$format,
+ 'output|o=s' => \$output,
+ 'kernel|k=s' => \$kernelfile,
+ 'chars|c=s' => \$chartable,
+) or usage();
+
+usage() if ( @ARGV < 1 );
+init_freelist();
+parse_proto_file( $ARGV[0] );
+dprint("Storing free list in blocks ");
+fill_sysdata();
+dprint("\n");
+
+# If we were given a kernel image, write that to track 80
+# which is block number 6400.
+# (maksys.s can write to tracks 80-89)
+my $bootblock = 6400;
+if ($kernelfile) {
+ dprint("Adding kernel $kernelfile to track 80\n");
+ my @buf= read_file($kernelfile);
+ write_file($bootblock, @buf);
+}
+# If we were given a character table, write that
+# so it gets loaded at the 3K mark
+# maksys.s writes the contents of memory at 3K to the boot track!
+if ($chartable) {
+ dprint("Adding character table $chartable to track 80\n");
+ my @buf= read_file($chartable);
+ # XXX truncate to 1K, or at least complain??
+ write_file($bootblock + 3072/WORDSPERBLK, @buf);
+}
+dump_image( $format, $output );
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# sdump: Dump the contents of a filesystem in SimH format
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Fcntl qw(:flock SEEK_SET);
+
+### read a word from a file in SimH format
+### return -1 on EOF
+sub read_word {
+ my $F = shift;
+
+ # Convert four bytes into one 18-bit word
+ return -1 if ( read( $F, my $four, 4 ) != 4 ); # Not enough bytes read
+ my ( $b1, $b2, $b3, $b4 ) = unpack( "CCCC", $four );
+ return (
+ ( $b1 & 0xff ) | ( ( $b2 & 0xff ) << 8 ) | ( ( $b3 & 0xff ) << 16 ) |
+ ( ( $b4 & 0xff ) << 24 ) );
+}
+
+### Main program
+die("Usage: $0 imagefile\n") if ( @ARGV != 1 );
+
+open( my $IN, "<", $ARGV[0] ) || die("Couldn't open $ARGV[0]: $!\n");
+
+use constant NUMBLOCKS => 8000; # Number of blocks on a surface
+use constant WORDSPERBLK => 64; # 64 words per block
+use constant BYTESPERWORD => 4; # We encode each word into 4 bytes
+
+# Skip the first surface
+seek( $IN, NUMBLOCKS * WORDSPERBLK * BYTESPERWORD, SEEK_SET )
+ || die("Cannot seek: $!\n");
+
+foreach my $blocknum ( 0 .. NUMBLOCKS * 2 - 1 ) {
+ printf( "Block %d (%06o)\n", $blocknum, $blocknum );
+ foreach my $line ( 0 .. 7 ) {
+
+ # Print out the words in octal
+ my @buf;
+ foreach my $offset ( 0 .. 7 ) {
+
+ # Get a word
+ my $word = read_word($IN);
+ exit(0) if ( $word == -1 );
+ $buf[$offset] = $word;
+ }
+ foreach my $offset ( 0 .. 7 ) {
+ printf( "%06o ", $buf[$offset] );
+ }
+ print(" ");
+ foreach my $offset ( 0 .. 7 ) {
+ my $c1 = ( $buf[$offset] >> 9 ) & 0777;
+ $c1 = ( ( $c1 >= 32 ) && ( $c1 <= 126 ) ) ? chr($c1) : ' ';
+ my $c2 = $buf[$offset] & 0777;
+ $c2 = ( ( $c2 >= 32 ) && ( $c2 <= 126 ) ) ? chr($c2) : ' ';
+ print("$c1$c2");
+ }
+ print("\n");
+ }
+ print("\n");
+}
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# Read in files of PDP-7 assembly code in Ken Thompson's as format
+# and output cross-reference and other details on the files.
+# It's very rough and ready.
+#
+# (c) 2016 Warren Toomey, GPL3
+use strict;
+use warnings;
+
+#use Data::Dumper;
+
+my %Label; # Hash of labels found
+
+# Instructions that use the MQ register but don't modify it
+my %UseMQ = ( omq => 1, lacq => 1 );
+
+# Instructions that use and modify the MQ register
+my %ModMQ = (
+ lrs => 1,
+ lrss => 1,
+ lls => 1,
+ llss => 1,
+ norm => 1,
+ norms => 1,
+ mul => 1,
+ muls => 1,
+ div => 1,
+ divs => 1,
+ idiv => 1,
+ frdiv => 1,
+ frdivs => 1,
+ clq => 1,
+ cmq => 1
+);
+
+# Instructions that use memory locations
+my %UseMem = (
+ lac => 1,
+ xor => 1,
+ add => 1,
+ tad => 1,
+ xct => 1,
+ and => 1,
+ law => 1
+);
+
+# Instructions that modify memory
+my %ModMem = ( dac => 1, dzm => 1, isz => 1 );
+
+# Kernel-mode instructions
+my %Kmode = (
+ dscs => 'Uses disk: yes',
+ dslw => 'Uses disk: yes',
+ dslm => 'Uses disk: yes',
+ dsld => 'Uses disk: yes',
+ dsls => 'Uses disk: yes',
+ dssf => 'Uses disk: yes',
+ dsrs => 'Uses disk: yes',
+ iof => 'Uses interrupts: yes',
+ ion => 'Uses interrupts: yes',
+ caf => 'Uses CPU: yes',
+ clon => 'Uses clock: yes',
+ clsf => 'Uses clock: yes',
+ clof => 'Uses clock: yes',
+ ksf => 'Uses keyboard: yes',
+ krb => 'Uses keyboard: yes',
+ tsf => 'Uses tty: yes',
+ tcf => 'Uses tty: yes',
+ tls => 'Uses tty: yes',
+ sck => 'Uses G2: yes',
+ cck => 'Uses G2: yes',
+ lck => 'Uses G2: yes',
+ rsf => 'Uses ptr: yes',
+ rsa => 'Uses ptr: yes',
+ rrb => 'Uses ptr: yes',
+ psf => 'Uses ptr: yes',
+ pcf => 'Uses ptr: yes',
+ psa => 'Uses ptr: yes',
+ lds => 'Uses G2: yes',
+ lda => 'Uses G2: yes',
+ wcga => 'Uses G2: yes',
+ raef => 'Uses G2: yes',
+ rlpd => 'Uses G2: yes',
+ beg => 'Uses G2: yes',
+ spb => 'Uses G2: yes',
+ cpb => 'Uses G2: yes',
+ lpb => 'Uses G2: yes',
+ wbl => 'Uses G2: yes',
+ dprs => 'Uses dataphone: yes',
+ dpsf => 'Uses dataphone: yes',
+ dpcf => 'Uses dataphone: yes',
+ dprc => 'Uses dataphone: yes',
+ crsf => 'Uses cdr: yes',
+ crrb => 'Uses cdr: yes',
+);
+
+# Parse all the files for labels only
+my $stage = 1;
+my $curlabel = ""; # Last defined label
+foreach my $file (@ARGV) {
+ parse_file($file);
+}
+
+# Now go back and find the details about things
+$stage = 2;
+$curlabel = ""; # Last defined label
+foreach my $file (@ARGV) {
+ parse_file($file);
+}
+
+#print Dumper(\%Label);
+print_output();
+print_callgraph();
+exit(0);
+
+sub parse_file {
+ my $file = shift;
+ open( my $IN, "<", $file ) || die("Cannot read $file: $!\n");
+ while ( my $line = <$IN> ) {
+ chomp($line); # Lose the end of line
+ parse_line( $file, $line );
+ }
+ close($IN);
+}
+
+sub parse_line {
+ my ( $file, $line ) = @_;
+ $file =~ s{.*/}{};
+
+ # Lose leading whitespace and comments
+ $line =~ s{^\s+}{};
+ $line =~ s{\s*".*}{};
+ return if ( $line =~ m{^$} ); # Ignore empty lines
+ return if ( $line =~ m{=} ); # Ignore assignments
+ #print("$line\n") if ($stage==2);
+
+ # Capture and define useful labels
+ if ( $line =~ s{^([a-z0-9\.]+):\s*}{} ) {
+ my $label = $1;
+
+ # Only do non-numeric labels
+ if ( !( $label =~ m{^\d+$} ) ) {
+
+ # Define the label in stage 1
+ if ( $stage == 1 ) {
+ $Label{$label}{def} = 1;
+ $Label{$label}{file} = $file;
+ }
+ $curlabel = $label;
+ }
+ }
+ return if ( $stage == 1 ); # Only labels in stage 1
+
+ # Stage 2: break the remainder up into statements
+ foreach my $statement ( split( /\s*;\s*/, $line ) ) {
+ my @expr = split( /\s+/, $statement );
+
+ # Does it use the MQ?
+ $Label{$curlabel}{usemq} = 1 if ( $UseMQ{ $expr[0] } );
+
+ # Does it modify the MQ?
+ if ( $ModMQ{ $expr[0] } ) {
+ $Label{$curlabel}{usemq} = 1;
+ $Label{$curlabel}{modmq} = 1;
+ }
+
+ # Does it modify memory
+ if ( $ModMem{ $expr[0] } ) {
+ die("ModMem but no argument\n") if ( !defined( $expr[1] ) );
+ $Label{$curlabel}{modmem}{ $expr[1] } = 1;
+ }
+
+ # Does it use memory
+ if ( $UseMem{ $expr[0] } ) {
+
+ # We should die if no expr[1], but there's one use of
+ # law in the kernel that stops us doing this
+ $Label{$curlabel}{usemem}{ $expr[1] } = 1
+ if ( defined( $expr[1] ) );
+ }
+
+ # Routine calls
+ $Label{$curlabel}{calls}{ $expr[1] } = 1
+ if ( ( $expr[0] eq "jms" ) && defined( $expr[1] ) );
+
+ # Any kernel mode instructions?
+ $Label{$curlabel}{kmode}{ $Kmode{ $expr[0] } } = 1
+ if ( $Kmode{ $expr[0] } );
+ }
+}
+
+sub print_output {
+ foreach $curlabel ( sort( keys(%Label) ) ) {
+
+ # Does it have anything useful?
+ my $count = keys( %{ $Label{$curlabel} } );
+ next if ( $count == 2 ); # Nope
+
+ print("Function $curlabel\n");
+ print("==============\n");
+ print("File: $Label{$curlabel}{file}\n");
+ print("Purpose:\n");
+ print("Arguments:\n");
+ print("Returns:\n");
+
+ print("Uses MQ: yes\n")
+ if ( defined( $Label{$curlabel}{usemq} )
+ && !defined( $Label{$curlabel}{usemq} ) );
+ print("Modifies MQ: yes\n")
+ if ( defined( $Label{$curlabel}{usemq} ) );
+
+ my $usemem =
+ join( ', ', sort( keys( %{ $Label{$curlabel}{usemem} } ) ) );
+ print("Uses memory: $usemem\n") if ( $usemem ne '' );
+ my $modmem =
+ join( ', ', sort( keys( %{ $Label{$curlabel}{modmem} } ) ) );
+ print("Modifies memory: $modmem\n") if ( $modmem ne '' );
+ my $calls = join( ', ', sort( keys( %{ $Label{$curlabel}{calls} } ) ) );
+ print("Calls: $calls\n") if ( $calls ne '' );
+
+ foreach my $kmode ( sort( keys( %{ $Label{$curlabel}{kmode} } ) ) ) {
+ print("$kmode\n");
+ }
+
+ print("Comments:\n");
+ print("\n\n");
+ }
+}
+
+# Print a graphview call graph file
+sub print_callgraph {
+ open(my $OUT, ">", "kernel_calls.gv")
+ || die("Can't write kernel_calls.gv: $!\n");
+ print $OUT <<EOF;
+digraph callgraph {
+ratio=compress; size="16.53,11.69";
+{rank=same; ".capt" ".chdir" ".chmod" ".chown" ".close" ".creat" ".exit"
+ ".fork" ".halt" ".link" ".open" ".read" ".rele" ".rename" ".rmes"
+ ".save" ".seek" ".setuid" ".smes" ".status" ".sysloc" ".tell"
+ ".unlink" ".write"}
+EOF
+ foreach $curlabel ( sort( keys(%Label) ) ) {
+ my $count = keys( %{ $Label{$curlabel} } );
+ next if ( $count == 2 );
+
+ my $calls = join( '"; "', sort( keys( %{ $Label{$curlabel}{calls} } ) ) );
+ if ( $calls ne '' ) {
+ print($OUT "\"$curlabel\" -> { \"$calls\" ; }\n");
+ }
+ }
+ print($OUT "}\n");
+ close($OUT);
+}
public / perl_to_python.git / commitdiff