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_NV { sprintf("%lf\0", $_[0]) }
56 sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
57 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
58 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
60 sub B::Asmdata::PUT_strconst {
62 $arg = uncstring($arg);
64 error "bad string constant: $arg";
67 if ($arg =~ s/\0//g) {
68 error "string constant argument contains NUL: $arg";
73 sub B::Asmdata::PUT_pvcontents {
75 error "extraneous argument: $arg" if defined $arg;
78 sub B::Asmdata::PUT_PV {
80 $arg = uncstring($arg);
81 error "bad string argument: $arg" unless defined($arg);
82 return pack("N", length($arg)) . $arg;
84 sub B::Asmdata::PUT_comment_t {
86 $arg = uncstring($arg);
87 error "bad string argument: $arg" unless defined($arg);
88 if ($arg =~ s/\n//g) {
89 error "comment argument contains linefeed: $arg";
93 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
94 sub B::Asmdata::PUT_none {
96 error "extraneous argument: $arg" if defined $arg;
99 sub B::Asmdata::PUT_op_tr_array {
101 my @ary = split(/\s*,\s*/, $arg);
103 error "wrong number of arguments to op_tr_array";
106 return pack("n256", @ary);
108 # XXX Check this works
109 sub B::Asmdata::PUT_IV64 {
111 return pack("NN", $arg >> 32, $arg & 0xffffffff);
114 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
115 b => "\b", f => "\f", v => "\013");
119 $s =~ s/^"// and $s =~ s/"$// or return undef;
120 $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
126 # Comments only allowed in instructions which don't take string arguments
128 (?sx) # Snazzy extended regexp coming up. Also, treat
129 # string as a single line so .* eats \n characters.
130 ^\s* # Ignore leading whitespace
132 [^"]* # A double quote '"' indicates a string argument. If we
133 # find a double quote, the match fails and we strip nothing.
135 \s*\# # Any amount of whitespace plus the comment marker...
136 .*$ # ...which carries on to end-of-string.
137 }{$1}; # Keep only the instruction and optional argument.
141 sub parse_statement {
143 my ($insn, $arg) = $stmt =~ m{
145 ^\s* # allow (but ignore) leading whitespace
146 (.*?) # Instruction continues up until...
147 (?: # ...an optional whitespace+argument group
148 \s+ # first whitespace.
149 (.*) # The argument is all the rest (newlines included).
150 )?$ # anchor at end-of-line
153 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
155 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
157 } elsif ($arg =~ /^pp_/) {
158 $arg =~ s/\s*$//; # strip trailing whitespace
159 my $opnum = $opnumber{$arg};
160 if (defined($opnum)) {
163 error qq(No such op type "$arg");
168 return ($insn, $arg);
172 my ($insn, $arg) = @_;
173 my $data = $insn_data{$insn};
174 if (defined($data)) {
175 my ($bytecode, $putsub) = @{$data}[0, 1];
176 my $argcode = &$putsub($arg);
177 return chr($bytecode).$argcode;
179 error qq(no such instruction "$insn");
186 my ($line, $insn, $arg);
189 while ($line = <$fh>) {
193 my $quotedline = $line;
194 $quotedline =~ s/\\/\\\\/g;
195 $quotedline =~ s/"/\\"/g;
196 &$out(assemble_insn("comment", qq("$quotedline")));
198 $line = strip_comments($line) or next;
199 ($insn, $arg) = parse_statement($line);
200 &$out(assemble_insn($insn, $arg));
202 &$out(assemble_insn("nop", undef));
206 die "Assembly failed with $errors error(s)\n";
216 B::Assembler - Assemble Perl bytecode
224 See F<ext/B/B/Assembler.pm>.
228 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>