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
57 sub B::Asmdata::PUT_strconst {
59 $arg = uncstring($arg);
61 error "bad string constant: $arg";
64 if ($arg =~ s/\0//g) {
65 error "string constant argument contains NUL: $arg";
70 sub B::Asmdata::PUT_pvcontents {
72 error "extraneous argument: $arg" if defined $arg;
75 sub B::Asmdata::PUT_PV {
77 $arg = uncstring($arg);
78 error "bad string argument: $arg" unless defined($arg);
79 return pack("N", length($arg)) . $arg;
81 sub B::Asmdata::PUT_comment {
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";
90 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
91 sub B::Asmdata::PUT_none {
93 error "extraneous argument: $arg" if defined $arg;
96 sub B::Asmdata::PUT_op_tr_array {
98 my @ary = split(/\s*,\s*/, $arg);
100 error "wrong number of arguments to op_tr_array";
103 return pack("n256", @ary);
105 # XXX Check this works
106 sub B::Asmdata::PUT_IV64 {
108 return pack("NN", $arg >> 32, $arg & 0xffffffff);
111 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
112 b => "\b", f => "\f", v => "\013");
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;
123 # Comments only allowed in instructions which don't take string arguments
125 (?sx) # Snazzy extended regexp coming up. Also, treat
126 # string as a single line so .* eats \n characters.
127 ^\s* # Ignore leading whitespace
129 [^"]* # A double quote '"' indicates a string argument. If we
130 # find a double quote, the match fails and we strip nothing.
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.
138 sub parse_statement {
140 my ($insn, $arg) = $stmt =~ m{
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
150 if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
152 } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
154 } elsif ($arg =~ /^pp_/) {
155 $arg =~ s/\s*$//; # strip trailing whitespace
156 my $opnum = $opnumber{$arg};
157 if (defined($opnum)) {
160 error qq(No such op type "$arg");
165 return ($insn, $arg);
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;
176 error qq(no such instruction "$insn");
183 my ($line, $insn, $arg);
186 while ($line = <$fh>) {
190 my $quotedline = $line;
191 $quotedline =~ s/\\/\\\\/g;
192 $quotedline =~ s/"/\\"/g;
193 &$out(assemble_insn("comment", qq("$quotedline")));
195 $line = strip_comments($line) or next;
196 ($insn, $arg) = parse_statement($line);
197 &$out(assemble_insn($insn, $arg));
199 &$out(assemble_insn("nop", undef));
203 die "Assembly failed with $errors error(s)\n";