ext/B/B/Assembler.pm

   1 #      Assembler.pm
   2 #
   3 #      Copyright (c) 1996 Malcolm Beattie
   4 #
   5 #      You may distribute under the terms of either the GNU General Public
   6 #      License or the Artistic License, as specified in the README file.
   7 package B::Assembler;
   8 use Exporter;
   9 use B qw(ppname);
  10 use B::Asmdata qw(%insn_data @insn_name);
  11
  12 @ISA = qw(Exporter);
  13 @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
  14                 parse_statement uncstring);
  15
  16 use strict;
  17 my %opnumber;
  18 my ($i, $opname);
  19 for ($i = 0; defined($opname = ppname($i)); $i++) {
  20     $opnumber{$opname} = $i;
  21 }
  22
  23 my ($linenum, $errors);
  24
  25 sub error {
  26     my $str = shift;
  27     warn "$linenum: $str\n";
  28     $errors++;
  29 }
  30
  31 my $debug = 0;
  32 sub debug { $debug = shift }
  33
  34 #
  35 # First define all the data conversion subs to which Asmdata will refer
  36 #
  37
  38 sub B::Asmdata::PUT_U8 {
  39     my $arg = shift;
  40     my $c = uncstring($arg);
  41     if (defined($c)) {
  42         if (length($c) != 1) {
  43             error "argument for U8 is too long: $c";
  44             $c = substr($c, 0, 1);
  45         }
  46     } else {
  47         $c = chr($arg);
  48     }
  49     return $c;
  50 }
  51
  52 sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
  53 sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
  54 sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
  55 sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
  56
  57 sub B::Asmdata::PUT_strconst {
  58     my $arg = shift;
  59     $arg = uncstring($arg);
  60     if (!defined($arg)) {
  61         error "bad string constant: $arg";
  62         return "";
  63     }
  64     if ($arg =~ s/\0//g) {
  65         error "string constant argument contains NUL: $arg";
  66     }
  67     return $arg . "\0";
  68 }
  69
  70 sub B::Asmdata::PUT_pvcontents {
  71     my $arg = shift;
  72     error "extraneous argument: $arg" if defined $arg;
  73     return "";
  74 }
  75 sub B::Asmdata::PUT_PV {
  76     my $arg = shift;
  77     $arg = uncstring($arg);
  78     error "bad string argument: $arg" unless defined($arg);
  79     return pack("N", length($arg)) . $arg;
  80 }
  81 sub B::Asmdata::PUT_comment {
  82     my $arg = shift;
  83     $arg = uncstring($arg);
  84     error "bad string argument: $arg" unless defined($arg);
  85     if ($arg =~ s/\n//g) {
  86         error "comment argument contains linefeed: $arg";
  87     }
  88     return $arg . "\n";
  89 }
  90 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
  91 sub B::Asmdata::PUT_none {
  92     my $arg = shift;
  93     error "extraneous argument: $arg" if defined $arg;
  94     return "";
  95 }
  96 sub B::Asmdata::PUT_op_tr_array {
  97     my $arg = shift;
  98     my @ary = split(/\s*,\s*/, $arg);
  99     if (@ary != 256) {
 100         error "wrong number of arguments to op_tr_array";
 101         @ary = (0) x 256;
 102     }
 103     return pack("n256", @ary);
 104 }
 105 # XXX Check this works
 106 sub B::Asmdata::PUT_IV64 {
 107     my $arg = shift;
 108     return pack("NN", $arg >> 32, $arg & 0xffffffff);
 109 }
 110
 111 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
 112              b => "\b", f => "\f", v => "\013");
 113
 114 sub uncstring {
 115     my $s = shift;
 116     $s =~ s/^"// and $s =~ s/"$// or return undef;
 117     $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
 118     return $s;
 119 }
 120
 121 sub strip_comments {
 122     my $stmt = shift;
 123     # Comments only allowed in instructions which don't take string arguments
 124     $stmt =~ s{
 125         (?sx)   # Snazzy extended regexp coming up. Also, treat
 126                 # string as a single line so .* eats \n characters.
 127         ^\s*    # Ignore leading whitespace
 128         (
 129           [^"]* # A double quote '"' indicates a string argument. If we
 130                 # find a double quote, the match fails and we strip nothing.
 131         )
 132         \s*\#   # Any amount of whitespace plus the comment marker...
 133         .*$     # ...which carries on to end-of-string.
 134     }{$1};      # Keep only the instruction and optional argument.
 135     return $stmt;
 136 }
 137
 138 sub parse_statement {
 139     my $stmt = shift;
 140     my ($insn, $arg) = $stmt =~ m{
 141         (?sx)
 142         ^\s*    # allow (but ignore) leading whitespace
 143         (.*?)   # Instruction continues up until...
 144         (?:     # ...an optional whitespace+argument group
 145             \s+         # first whitespace.
 146             (.*)        # The argument is all the rest (newlines included).
 147         )?$     # anchor at end-of-line
 148     };
 149     if (defined($arg)) {
 150         if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
 151             $arg = hex($arg);
 152         } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
 153             $arg = oct($arg);
 154         } elsif ($arg =~ /^pp_/) {
 155             $arg =~ s/\s*$//; # strip trailing whitespace
 156             my $opnum = $opnumber{$arg};
 157             if (defined($opnum)) {
 158                 $arg = $opnum;
 159             } else {
 160                 error qq(No such op type "$arg");
 161                 $arg = 0;
 162             }
 163         }
 164     }
 165     return ($insn, $arg);
 166 }
 167
 168 sub assemble_insn {
 169     my ($insn, $arg) = @_;
 170     my $data = $insn_data{$insn};
 171     if (defined($data)) {
 172         my ($bytecode, $putsub) = @{$data}[0, 1];
 173         my $argcode = &$putsub($arg);
 174         return chr($bytecode).$argcode;
 175     } else {
 176         error qq(no such instruction "$insn");
 177         return "";
 178     }
 179 }
 180
 181 sub assemble_fh {
 182     my ($fh, $out) = @_;
 183     my ($line, $insn, $arg);
 184     $linenum = 0;
 185     $errors = 0;
 186     while ($line = <$fh>) {
 187         $linenum++;
 188         chomp $line;
 189         if ($debug) {
 190             my $quotedline = $line;
 191             $quotedline =~ s/\\/\\\\/g;
 192             $quotedline =~ s/"/\\"/g;
 193             &$out(assemble_insn("comment", qq("$quotedline")));
 194         }
 195         $line = strip_comments($line) or next;
 196         ($insn, $arg) = parse_statement($line);
 197         &$out(assemble_insn($insn, $arg));
 198         if ($debug) {
 199             &$out(assemble_insn("nop", undef));
 200         }
 201     }
 202     if ($errors) {
 203         die "Assembly failed with $errors error(s)\n";
 204     }
 205 }
 206
 207 1;
 208
 209 __END__
 210
 211 =head1 NAME
 212
 213 B::Assembler - Assemble Perl bytecode
 214
 215 =head1 SYNOPSIS
 216
 217         use Assembler;
 218
 219 =head1 DESCRIPTION
 220
 221 See F<ext/B/B/Assembler.pm>.
 222
 223 =head1 AUTHOR
 224
 225 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 226
 227 =cut