This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial check-in of perl compiler.
[perl5.git] / B / Assembler.pm
1 #      Assembler.pm
2 #
3 #      Copyright (c) 1996 Malcolm Beattie
4 #
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.
7 package B::Assembler;
8 use Exporter;
9 use B qw(ppname);
10 use B::Asmdata qw(%insn_data @insn_name);
11
12 @ISA = qw(Exporter);
13 @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
14                 parse_statement uncstring);
15
16 use strict;
17 my %opnumber;
18 my ($i, $opname);
19 for ($i = 0; defined($opname = ppname($i)); $i++) {
20     $opnumber{$opname} = $i;
21 }
22
23 my ($linenum, $errors);
24
25 sub error {
26     my $str = shift;
27     warn "$linenum: $str\n";
28     $errors++;
29 }
30
31 my $debug = 0;
32 sub debug { $debug = shift }
33
34 #
35 # First define all the data conversion subs to which Asmdata will refer
36 #
37
38 sub B::Asmdata::PUT_U8 {
39     my $arg = shift;
40     my $c = uncstring($arg);
41     if (defined($c)) {
42         if (length($c) != 1) {
43             error "argument for U8 is too long: $c";
44             $c = substr($c, 0, 1);
45         }
46     } else {
47         $c = chr($arg);
48     }
49     return $c;
50 }
51
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
57 sub B::Asmdata::PUT_strconst {
58     my $arg = shift;
59     $arg = uncstring($arg);
60     if (!defined($arg)) {
61         error "bad string constant: $arg";
62         return "";
63     }
64     if ($arg =~ s/\0//g) {
65         error "string constant argument contains NUL: $arg";
66     }
67     return $arg . "\0";
68 }
69
70 sub B::Asmdata::PUT_pvcontents {
71     my $arg = shift;
72     error "extraneous argument: $arg" if defined $arg;
73     return "";
74 }
75 sub B::Asmdata::PUT_PV {
76     my $arg = shift;
77     $arg = uncstring($arg);
78     error "bad string argument: $arg" unless defined($arg);
79     return pack("N", length($arg)) . $arg;
80 }
81 sub B::Asmdata::PUT_comment {
82     my $arg = shift;
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";
87     }
88     return $arg . "\n";
89 }
90 sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
91 sub B::Asmdata::PUT_none {
92     my $arg = shift;
93     error "extraneous argument: $arg" if defined $arg;
94     return "";
95 }
96 sub B::Asmdata::PUT_op_tr_array {
97     my $arg = shift;
98     my @ary = split(/\s*,\s*/, $arg);
99     if (@ary != 256) {
100         error "wrong number of arguments to op_tr_array";
101         @ary = (0) x 256;
102     }
103     return pack("n256", @ary);
104 }
105 # XXX Check this works
106 sub B::Asmdata::PUT_IV64 {
107     my $arg = shift;
108     return pack("NN", $arg >> 32, $arg & 0xffffffff);
109 }
110
111 my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
112              b => "\b", f => "\f", v => "\013");
113
114 sub uncstring {
115     my $s = shift;
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;
118     return $s;
119 }
120
121 sub strip_comments {
122     my $stmt = shift;
123     # Comments only allowed in instructions which don't take string arguments
124     $stmt =~ s{
125         (?sx)   # Snazzy extended regexp coming up. Also, treat
126                 # string as a single line so .* eats \n characters.
127         ^\s*    # Ignore leading whitespace
128         (
129           [^"]* # A double quote '"' indicates a string argument. If we
130                 # find a double quote, the match fails and we strip nothing.
131         )
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.
135     return $stmt;
136 }
137
138 sub parse_statement {
139     my $stmt = shift;
140     my ($insn, $arg) = $stmt =~ m{
141         (?sx)
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
148     };  
149     if (defined($arg)) {
150         if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
151             $arg = hex($arg);
152         } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
153             $arg = oct($arg);
154         } elsif ($arg =~ /^pp_/) {
155             $arg =~ s/\s*$//; # strip trailing whitespace
156             my $opnum = $opnumber{$arg};
157             if (defined($opnum)) {
158                 $arg = $opnum;
159             } else {
160                 error qq(No such op type "$arg");
161                 $arg = 0;
162             }
163         }
164     }
165     return ($insn, $arg);
166 }
167
168 sub assemble_insn {
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;
175     } else {
176         error qq(no such instruction "$insn");
177         return "";
178     }
179 }
180
181 sub assemble_fh {
182     my ($fh, $out) = @_;
183     my ($line, $insn, $arg);
184     $linenum = 0;
185     $errors = 0;
186     while ($line = <$fh>) {
187         $linenum++;
188         chomp $line;
189         if ($debug) {
190             my $quotedline = $line;
191             $quotedline =~ s/\\/\\\\/g;
192             $quotedline =~ s/"/\\"/g;
193             &$out(assemble_insn("comment", qq("$quotedline")));
194         }
195         $line = strip_comments($line) or next;
196         ($insn, $arg) = parse_statement($line);
197         &$out(assemble_insn($insn, $arg));
198         if ($debug) {
199             &$out(assemble_insn("nop", undef));
200         }
201     }
202     if ($errors) {
203         die "Assembly failed with $errors error(s)\n";
204     }
205 }
206
207 1;