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
144 my $header = B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
145 $header .= B::Asmdata::PUT_strconst($Config{archname});
146 $header .= B::Asmdata::PUT_U32($Config{ivsize});
147 $header .= B::Asmdata::PUT_U32($Config{nvsize});
148 $header .= B::Asmdata::PUT_U32($Config{ptrsize});
149 $header .= B::Asmdata::PUT_strconst($Config{byteorder}); # PV not U32 because
153 sub parse_statement {
155 my ($insn, $arg) = $stmt =~ m{
157 ^\s* # allow (but ignore) leading whitespace
158 (.*?) # Instruction continues up until...
159 (?: # ...an optional whitespace+argument group
160 \s+ # first whitespace.
161 (.*) # The argument is all the rest (newlines included).
162 )?$ # anchor at end-of-line
165 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
167 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
169 } elsif ($arg =~ /^pp_/) {
170 $arg =~ s/\s*$//; # strip trailing whitespace
171 my $opnum = $opnumber{$arg};
172 if (defined($opnum)) {
175 error qq(No such op type "$arg");
180 return ($insn, $arg);
184 my ($insn, $arg) = @_;
185 my $data = $insn_data{$insn};
186 if (defined($data)) {
187 my ($bytecode, $putsub) = @{$data}[0, 1];
188 my $argcode = &$putsub($arg);
189 return chr($bytecode).$argcode;
191 error qq(no such instruction "$insn");
198 my ($line, $insn, $arg);
202 while ($line = <$fh>) {
206 my $quotedline = $line;
207 $quotedline =~ s/\\/\\\\/g;
208 $quotedline =~ s/"/\\"/g;
209 &$out(assemble_insn("comment", qq("$quotedline")));
211 $line = strip_comments($line) or next;
212 ($insn, $arg) = parse_statement($line);
213 &$out(assemble_insn($insn, $arg));
215 &$out(assemble_insn("nop", undef));
219 die "Assembly failed with $errors error(s)\n";
229 B::Assembler - Assemble Perl bytecode
237 See F<ext/B/B/Assembler.pm>.
241 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>