3 # Copyright (c) 1996 Malcolm Beattie
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.
10 use B::Asmdata qw(%insn_data @insn_name);
13 @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
14 parse_statement uncstring);
19 for ($i = 0; defined($opname = ppname($i)); $i++) {
20 $opnumber{$opname} = $i;
23 my ($linenum, $errors);
27 warn "$linenum: $str\n";
32 sub debug { $debug = shift }
35 # First define all the data conversion subs to which Asmdata will refer
38 sub B::Asmdata::PUT_U8 {
40 my $c = uncstring($arg);
42 if (length($c) != 1) {
43 error "argument for U8 is too long: $c";
44 $c = substr($c, 0, 1);
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 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
57 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
59 sub B::Asmdata::PUT_strconst {
61 $arg = uncstring($arg);
63 error "bad string constant: $arg";
66 if ($arg =~ s/\0//g) {
67 error "string constant argument contains NUL: $arg";
72 sub B::Asmdata::PUT_pvcontents {
74 error "extraneous argument: $arg" if defined $arg;
77 sub B::Asmdata::PUT_PV {
79 $arg = uncstring($arg);
80 error "bad string argument: $arg" unless defined($arg);
81 return pack("N", length($arg)) . $arg;
83 sub B::Asmdata::PUT_comment_t {
85 $arg = uncstring($arg);
86 error "bad string argument: $arg" unless defined($arg);
87 if ($arg =~ s/\n//g) {
88 error "comment argument contains linefeed: $arg";
92 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
93 sub B::Asmdata::PUT_none {
95 error "extraneous argument: $arg" if defined $arg;
98 sub B::Asmdata::PUT_op_tr_array {
100 my @ary = split(/\s*,\s*/, $arg);
102 error "wrong number of arguments to op_tr_array";
105 return pack("n256", @ary);
107 # XXX Check this works
108 sub B::Asmdata::PUT_IV64 {
110 return pack("NN", $arg >> 32, $arg & 0xffffffff);
113 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
114 b => "\b", f => "\f", v => "\013");
118 $s =~ s/^"// and $s =~ s/"$// or return undef;
119 $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
125 # Comments only allowed in instructions which don't take string arguments
127 (?sx) # Snazzy extended regexp coming up. Also, treat
128 # string as a single line so .* eats \n characters.
129 ^\s* # Ignore leading whitespace
131 [^"]* # A double quote '"' indicates a string argument. If we
132 # find a double quote, the match fails and we strip nothing.
134 \s*\# # Any amount of whitespace plus the comment marker...
135 .*$ # ...which carries on to end-of-string.
136 }{$1}; # Keep only the instruction and optional argument.
140 sub parse_statement {
142 my ($insn, $arg) = $stmt =~ m{
144 ^\s* # allow (but ignore) leading whitespace
145 (.*?) # Instruction continues up until...
146 (?: # ...an optional whitespace+argument group
147 \s+ # first whitespace.
148 (.*) # The argument is all the rest (newlines included).
149 )?$ # anchor at end-of-line
152 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
154 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
156 } elsif ($arg =~ /^pp_/) {
157 $arg =~ s/\s*$//; # strip trailing whitespace
158 my $opnum = $opnumber{$arg};
159 if (defined($opnum)) {
162 error qq(No such op type "$arg");
167 return ($insn, $arg);
171 my ($insn, $arg) = @_;
172 my $data = $insn_data{$insn};
173 if (defined($data)) {
174 my ($bytecode, $putsub) = @{$data}[0, 1];
175 my $argcode = &$putsub($arg);
176 return chr($bytecode).$argcode;
178 error qq(no such instruction "$insn");
185 my ($line, $insn, $arg);
188 while ($line = <$fh>) {
192 my $quotedline = $line;
193 $quotedline =~ s/\\/\\\\/g;
194 $quotedline =~ s/"/\\"/g;
195 &$out(assemble_insn("comment", qq("$quotedline")));
197 $line = strip_comments($line) or next;
198 ($insn, $arg) = parse_statement($line);
199 &$out(assemble_insn($insn, $arg));
201 &$out(assemble_insn("nop", undef));
205 die "Assembly failed with $errors error(s)\n";
215 B::Assembler - Assemble Perl bytecode
223 See F<ext/B/B/Assembler.pm>.
227 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>