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);
11 use Config qw(%Config);
14 @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
15 parse_statement uncstring gen_header);
20 for ($i = 0; defined($opname = ppname($i)); $i++) {
21 $opnumber{$opname} = $i;
24 my ($linenum, $errors);
28 warn "$linenum: $str\n";
33 sub debug { $debug = shift }
36 # First define all the data conversion subs to which Asmdata will refer
39 sub B::Asmdata::PUT_U8 {
41 my $c = uncstring($arg);
43 if (length($c) != 1) {
44 error "argument for U8 is too long: $c";
45 $c = substr($c, 0, 1);
53 sub B::Asmdata::PUT_U16 { pack("S", $_[0]) }
54 sub B::Asmdata::PUT_U32 { pack("L", $_[0]) }
55 sub B::Asmdata::PUT_I32 { pack("L", $_[0]) }
56 sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
57 # may not even be portable between compilers
58 sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here
59 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
60 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
62 sub B::Asmdata::PUT_strconst {
64 $arg = uncstring($arg);
66 error "bad string constant: $arg";
69 if ($arg =~ s/\0//g) {
70 error "string constant argument contains NUL: $arg";
75 sub B::Asmdata::PUT_pvcontents {
77 error "extraneous argument: $arg" if defined $arg;
80 sub B::Asmdata::PUT_PV {
82 $arg = uncstring($arg);
83 error "bad string argument: $arg" unless defined($arg);
84 return pack("L", length($arg)) . $arg;
86 sub B::Asmdata::PUT_comment_t {
88 $arg = uncstring($arg);
89 error "bad string argument: $arg" unless defined($arg);
90 if ($arg =~ s/\n//g) {
91 error "comment argument contains linefeed: $arg";
95 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
96 sub B::Asmdata::PUT_none {
98 error "extraneous argument: $arg" if defined $arg;
101 sub B::Asmdata::PUT_op_tr_array {
103 my @ary = split(/\s*,\s*/, $arg);
105 error "wrong number of arguments to op_tr_array";
108 return pack("S256", @ary);
110 # XXX Check this works
111 sub B::Asmdata::PUT_IV64 {
113 return pack("LL", $arg >> 32, $arg & 0xffffffff);
116 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
117 b => "\b", f => "\f", v => "\013");
121 $s =~ s/^"// and $s =~ s/"$// or return undef;
122 $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
128 # Comments only allowed in instructions which don't take string arguments
130 (?sx) # Snazzy extended regexp coming up. Also, treat
131 # string as a single line so .* eats \n characters.
132 ^\s* # Ignore leading whitespace
134 [^"]* # A double quote '"' indicates a string argument. If we
135 # find a double quote, the match fails and we strip nothing.
137 \s*\# # Any amount of whitespace plus the comment marker...
138 .*$ # ...which carries on to end-of-string.
139 }{$1}; # Keep only the instruction and optional argument.
143 sub gen_header { # create the ByteCode header: magic, archname, ivsize, ptrsize,
145 # nvtype irrelevant (floats are stored as strings)
146 my $header = B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
147 $header .= B::Asmdata::PUT_strconst(qq["$Config{archname}"]);
148 $header .= B::Asmdata::PUT_U32($Config{ivsize});
149 $header .= B::Asmdata::PUT_U32($Config{ptrsize});
150 $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder}));
157 sub parse_statement {
159 my ($insn, $arg) = $stmt =~ m{
161 ^\s* # allow (but ignore) leading whitespace
162 (.*?) # Instruction continues up until...
163 (?: # ...an optional whitespace+argument group
164 \s+ # first whitespace.
165 (.*) # The argument is all the rest (newlines included).
166 )?$ # anchor at end-of-line
169 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
171 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
173 } elsif ($arg =~ /^pp_/) {
174 $arg =~ s/\s*$//; # strip trailing whitespace
175 my $opnum = $opnumber{$arg};
176 if (defined($opnum)) {
179 error qq(No such op type "$arg");
184 return ($insn, $arg);
188 my ($insn, $arg) = @_;
189 my $data = $insn_data{$insn};
190 if (defined($data)) {
191 my ($bytecode, $putsub) = @{$data}[0, 1];
192 my $argcode = &$putsub($arg);
193 return chr($bytecode).$argcode;
195 error qq(no such instruction "$insn");
202 my ($line, $insn, $arg);
206 while ($line = <$fh>) {
210 my $quotedline = $line;
211 $quotedline =~ s/\\/\\\\/g;
212 $quotedline =~ s/"/\\"/g;
213 &$out(assemble_insn("comment", qq("$quotedline")));
215 $line = strip_comments($line) or next;
216 ($insn, $arg) = parse_statement($line);
217 &$out(assemble_insn($insn, $arg));
219 &$out(assemble_insn("nop", undef));
223 die "Assembly failed with $errors error(s)\n";
233 B::Assembler - Assemble Perl bytecode
241 See F<ext/B/B/Assembler.pm>.
245 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>