|
996
|
1 package Language::INTERCAL::ByteCode;
|
|
|
2
|
|
|
3 # Definitions of bytecode symbols etc
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 @@DATA ByteCode@@
|
|
|
14
|
|
|
15 use strict;
|
|
|
16 use vars qw($VERSION $PERVERSION);
|
|
|
17 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/ByteCode.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
18
|
|
|
19 use Carp;
|
|
|
20 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
21 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
22 use Language::INTERCAL::Numbers '1.-94.-2';
|
|
|
23 use Language::INTERCAL::DoubleOhSeven '1.-94.-2';
|
|
|
24 use Language::INTERCAL::SharkFin '1.-94.-2';
|
|
|
25 use Language::INTERCAL::Arrays '1.-94.-2';
|
|
|
26 use Language::INTERCAL::Whirlpool '1.-94.-2';
|
|
|
27 use Language::INTERCAL::CrawlingHorror '1.-94.-2';
|
|
|
28 use Language::INTERCAL::GenericIO '1.-94.-2',
|
|
|
29 qw($stdwrite $stdread $stdsplat $devnull);
|
|
|
30
|
|
|
31 use constant BYTE_SIZE => 8; # number of bits per byte (must be == 8)
|
|
|
32 use constant NUM_OPCODES => 0x80; # number of virtual opcodes
|
|
|
33 use constant OPCODE_RANGE => 1 << BYTE_SIZE;
|
|
|
34 use constant BC_MASK => OPCODE_RANGE - 1;
|
|
|
35 use constant BIGNUM_SHIFT => BYTE_SIZE - 1;
|
|
|
36 use constant BIGNUM_RANGE => 1 << BIGNUM_SHIFT;
|
|
|
37 use constant BIGNUM_MASK => (BIGNUM_RANGE - 1) << 1;
|
|
|
38 use constant BYTE_SHIFT => OPCODE_RANGE - NUM_OPCODES;
|
|
|
39
|
|
|
40 use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
|
|
|
41 @EXPORT_OK = qw(
|
|
|
42 bytecode bytedecode bc_list BC BCget bc_bytype bc_match BC_MASK
|
|
|
43 BC_constants is_constant is_multibyte bc_xtype bc_skip bc_forall
|
|
|
44 @@FILL OPCODES BC_ NAME '' 76 ' '@@
|
|
|
45 reg_list reg_name reg_create reg_codetype reg_decode
|
|
|
46 reg_code
|
|
|
47 );
|
|
|
48
|
|
|
49 %EXPORT_TAGS = (
|
|
|
50 BC => [qw(
|
|
|
51 BC BCget BC_MASK bytecode bytedecode
|
|
|
52 @@FILL OPCODES BC_ NAME '' 76 ' '@@
|
|
|
53 )],
|
|
|
54 );
|
|
|
55
|
|
|
56 my %bytecodes = (
|
|
|
57 @@ALL OPCODES NAME@@ => ['@@'DESCR'@@', '@@TYPE@@', '@@NUMBER@@', '@@ARGS@@', @@CONST@@, @@ASSIGNABLE@@],
|
|
|
58 );
|
|
|
59
|
|
|
60 my %bytedecode = (
|
|
|
61 @@ALL OPCODES NUMBER@@ => '@@'NAME'@@',
|
|
|
62 );
|
|
|
63
|
|
|
64 my @bc_list = qw(
|
|
|
65 @@FILL OPCODES '' NAME '' 76 ' '@@
|
|
|
66 );
|
|
|
67
|
|
|
68 sub BC_@@ALL OPCODES NAME@@ () { @@NUMBER@@; }
|
|
|
69
|
|
|
70 my @reg_list = qw(
|
|
|
71 @@FILL SPECIAL '' NAME '' 76 ' '@@
|
|
|
72 );
|
|
|
73
|
|
|
74 my %reg_list = (
|
|
|
75 @@ALL DOUBLE_OH_SEVEN NAME@@ => ['@@'CODE'@@', @@DEFAULT@@, BC_DOS, '%', @@NUMBER@@],
|
|
|
76 @@ALL SHARK_FIN NAME@@ => ['@@'CODE'@@', @@DEFAULT@@, BC_SHF, '^', @@NUMBER@@],
|
|
|
77 @@ALL WHIRLPOOL NAME@@ => ['@@'CODE'@@', @@DEFAULT@@, BC_WHP, '@', @@NUMBER@@],
|
|
|
78 );
|
|
|
79
|
|
|
80 my %reg_names = (
|
|
|
81 '%@@ALL DOUBLE_OH_SEVEN NUMBER@@' => '@@NAME@@',
|
|
|
82 '^@@ALL SHARK_FIN NUMBER@@' => '@@NAME@@',
|
|
|
83 '@@@ALL WHIRLPOOL NUMBER@@' => '@@NAME@@',
|
|
|
84 );
|
|
|
85
|
|
|
86 my %mulmap = map { ( $_ => 1 ) } BC_MUL, BC_STR;
|
|
|
87
|
|
|
88 sub bc_list () {
|
|
|
89 @bc_list;
|
|
|
90 }
|
|
|
91
|
|
|
92 sub BC {
|
|
|
93 @_ == 1 || croak "Usage: BC(value)";
|
|
|
94 my ($val) = @_;
|
|
|
95 croak "Invalid undefined value" unless defined $val;
|
|
|
96 my $orig = $val;
|
|
|
97 $val < BYTE_SHIFT
|
|
|
98 and return ($val + NUM_OPCODES);
|
|
|
99 $val < OPCODE_RANGE
|
|
|
100 and return (BC_HSN, $val);
|
|
|
101 my $div = int($val / OPCODE_RANGE);
|
|
|
102 $div < OPCODE_RANGE
|
|
|
103 and return (BC_OSN, $div, $val % OPCODE_RANGE);
|
|
|
104 croak "Invalid value $orig: does not fit in one spot";
|
|
|
105 }
|
|
|
106
|
|
|
107 sub bytecode ($) {
|
|
|
108 my ($name) = @_;
|
|
|
109 $name =~ /^\d+$/ && $name < BYTE_SHIFT ? ($name + NUM_OPCODES)
|
|
|
110 : $bytecodes{$name}[2];
|
|
|
111 }
|
|
|
112
|
|
|
113 sub bytedecode ($) {
|
|
|
114 my ($b) = @_;
|
|
|
115 if ($b >= NUM_OPCODES) {
|
|
|
116 my $n = $b - NUM_OPCODES;
|
|
|
117 return () if $n >= BYTE_SHIFT;
|
|
|
118 return "#$n" unless wantarray;
|
|
|
119 return ("#$n", 'Constant', '#', $b, '', 1, 1);
|
|
|
120 } else {
|
|
|
121 return () unless exists $bytedecode{$b};
|
|
|
122 return $bytedecode{$b} unless wantarray;
|
|
|
123 return ($bytedecode{$b}, @{$bytecodes{$bytedecode{$b}}});
|
|
|
124 }
|
|
|
125 }
|
|
|
126
|
|
|
127 sub BCget {
|
|
|
128 @_ == 3 or croak "Usage: BCget(CODE, \\POSITION, END)";
|
|
|
129 my ($code, $cp, $ep) = @_;
|
|
|
130 $$cp >= $ep and faint(SP_INVALID, "end of code", "BCget");
|
|
|
131 my $byte = ord(substr($code, $$cp, 1));
|
|
|
132 $$cp++;
|
|
|
133 if ($byte >= NUM_OPCODES) {
|
|
|
134 return $byte - NUM_OPCODES;
|
|
|
135 }
|
|
|
136 if ($byte == BC_HSN) {
|
|
|
137 $$cp >= $ep and faint(SP_INVALID, "end of code", "BCget/HSN");
|
|
|
138 return ord(substr($code, $$cp++, 1));
|
|
|
139 }
|
|
|
140 if ($byte == BC_OSN) {
|
|
|
141 $$cp + 1 >= $ep and faint(SP_INVALID, "end of code", "BCget/OSN");
|
|
|
142 my $nx = unpack('n', substr($code, $$cp, 2));
|
|
|
143 $$cp += 2;
|
|
|
144 return $nx;
|
|
|
145 }
|
|
|
146 faint(SP_INVALID, sprintf("0x%02x", $byte), "BCget")
|
|
|
147 }
|
|
|
148
|
|
|
149 sub BC_constants () {
|
|
|
150 (NUM_OPCODES..BC_MASK);
|
|
|
151 }
|
|
|
152
|
|
|
153 sub is_constant ($) {
|
|
|
154 my ($byte) = @_;
|
|
|
155 return 1 if $byte >= NUM_OPCODES ||
|
|
|
156 $byte == BC_HSN ||
|
|
|
157 $byte == BC_OSN;
|
|
|
158 return 0;
|
|
|
159 }
|
|
|
160
|
|
|
161 sub is_multibyte ($) {
|
|
|
162 my ($byte) = @_;
|
|
|
163 return 1 if $byte == BC_HSN;
|
|
|
164 return 2 if $byte == BC_OSN;
|
|
|
165 0;
|
|
|
166 }
|
|
|
167
|
|
|
168 sub bc_bytype {
|
|
|
169 @_ or croak "Usage: bc_bytype(TYPES)";
|
|
|
170 my %types = ();
|
|
|
171 for my $type (@_) {
|
|
|
172 if ($type eq 'R' || $type eq 'S') {
|
|
|
173 $types{$type} = 0;
|
|
|
174 next;
|
|
|
175 }
|
|
|
176 if ($type =~ /^[CEP<>L\[\]]$/) {
|
|
|
177 $types{E} = $types{R} = $types{'#'} = 0;
|
|
|
178 next;
|
|
|
179 }
|
|
|
180 if ($type eq 'V') {
|
|
|
181 $types{R} = $types{V} = 0;
|
|
|
182 next;
|
|
|
183 }
|
|
|
184 if ($type eq 'O') {
|
|
|
185 $types{S} = 0;
|
|
|
186 next;
|
|
|
187 }
|
|
|
188 }
|
|
|
189 my %values = exists $types{V} ? %mulmap : ();
|
|
|
190 map {
|
|
|
191 my ($desc, $type, $value, $args, $function) = @{$bytecodes{$_}};
|
|
|
192 if (exists $types{$type} || exists $values{$value}) {
|
|
|
193 $value;
|
|
|
194 } else {
|
|
|
195 ();
|
|
|
196 }
|
|
|
197 } keys %bytecodes;
|
|
|
198 }
|
|
|
199
|
|
|
200 sub bc_match {
|
|
|
201 @_ >= 2 && @_ <= 4
|
|
|
202 or croak "Usage: bc_match(PATTERN, CODE [,START [,END]])";
|
|
|
203 my ($pattern, $code, $start, $end) = @_;
|
|
|
204 $start ||= 0;
|
|
|
205 $end = length($code) if not defined $end;
|
|
|
206 _match($pattern, $code, $start, $end, undef);
|
|
|
207 }
|
|
|
208
|
|
|
209 sub bc_skip {
|
|
|
210 @_ >= 1 && @_ <= 3
|
|
|
211 or croak "Usage: bc_skip(CODE [,START [,END]])";
|
|
|
212 my ($code, $start, $end) = @_;
|
|
|
213 $start ||= 0;
|
|
|
214 $end = length($code) if not defined $end;
|
|
|
215 return undef if $start >= $end || $start < 0;
|
|
|
216 my $byte = ord(substr($code, $start, 1));
|
|
|
217 return 1 if $byte >= NUM_OPCODES;
|
|
|
218 return undef if ! exists $bytedecode{$byte};
|
|
|
219 my $name = $bytedecode{$byte};
|
|
|
220 my $pattern = $bytecodes{$name}[1];
|
|
|
221 _match($pattern, $code, $start, $end, undef);
|
|
|
222 }
|
|
|
223
|
|
|
224 sub bc_forall {
|
|
|
225 @_ == 5
|
|
|
226 or croak "Usage: bc_forall(PATTERN, CODE, START, END, CLOSURE)";
|
|
|
227 my ($pattern, $code, $start, $end, $closure) = @_;
|
|
|
228 $start ||= 0;
|
|
|
229 $end = length($code) if not defined $end;
|
|
|
230 return undef if $start >= $end || $start < 0;
|
|
|
231 my $np = '';
|
|
|
232 while ($pattern =~ s/^(.*?)C\(/(/) {
|
|
|
233 my $a = $1;
|
|
|
234 $a =~ s/(.)/$1\x01/g;
|
|
|
235 $np .= $a . 'C';
|
|
|
236 $np .= '(' . _args('forall', \$pattern) . ')';
|
|
|
237 $np .= "\01";
|
|
|
238 }
|
|
|
239 $pattern =~ s/(.)/$1\x01/g;
|
|
|
240 $pattern = "\x01" if $pattern eq '';
|
|
|
241 $np .= $pattern;
|
|
|
242 _match($np, $code, $start, $end, $closure);
|
|
|
243 }
|
|
|
244
|
|
|
245 sub bc_xtype {
|
|
|
246 @_ == 1 or croak "Usage: bc_xtype(\\PATTERN)";
|
|
|
247 my ($pattern) = @_;
|
|
|
248 _args('xtype', $pattern);
|
|
|
249 }
|
|
|
250
|
|
|
251 my %typemap = (
|
|
|
252 'S' => { 'S' => 0 },
|
|
|
253 'O' => { 'S' => 0 },
|
|
|
254 'E' => { 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
255 'A' => { 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
256 'R' => { 'R' => 0 },
|
|
|
257 'V' => { 'R' => 0, 'V' => 0 },
|
|
|
258 '#' => { '#' => 0 },
|
|
|
259 'C' => { '#' => 0 },
|
|
|
260 'Z' => { 'S' => 0, 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
261 '*' => { 'S' => 0, 'E' => 0, 'R' => 0, '#' => 0 },
|
|
|
262 );
|
|
|
263
|
|
|
264 sub _args {
|
|
|
265 my ($name, $pattern) = @_;
|
|
|
266 faint(SP_BCMATCH, $name, 'Missing (') if $$pattern !~ s/^\(//;
|
|
|
267 my $count = 1;
|
|
|
268 my $result = '';
|
|
|
269 while ($count > 0) {
|
|
|
270 $$pattern =~ s/^([^\(\)]*)([\(\)])//
|
|
|
271 or faint(SP_BCMATCH, $name, 'Missing )');
|
|
|
272 $count++ if $2 eq '(';
|
|
|
273 $count-- if $2 eq ')';
|
|
|
274 $result .= $1 . ($count ? $2 : '');
|
|
|
275 }
|
|
|
276 $result;
|
|
|
277 }
|
|
|
278
|
|
|
279 sub _match {
|
|
|
280 my ($pattern, $code, $sc, $ep, $closure) = @_;
|
|
|
281 my $osc = $sc;
|
|
|
282 MATCH: while ($pattern ne '') {
|
|
|
283 my $e = substr($pattern, 0, 1, '');
|
|
|
284 if ($e eq "\x00") {
|
|
|
285 $closure->(undef, '>') if $closure;
|
|
|
286 next MATCH;
|
|
|
287 }
|
|
|
288 if ($e eq "\x01") {
|
|
|
289 $closure->($sc, undef) if $closure;
|
|
|
290 next MATCH;
|
|
|
291 }
|
|
|
292 faint(SP_INVALID, 'end of code', '_match') if $sc >= $ep;
|
|
|
293 my $v = ord(substr($code, $sc, 1));
|
|
|
294 if (exists $typemap{$e}) {
|
|
|
295 # check next opcode is correct type
|
|
|
296 my ($op, $desc, $type, $value, $args, $const) = bytedecode($v);
|
|
|
297 faint(SP_INVALID, $v, "_match: $e")
|
|
|
298 unless defined $type;
|
|
|
299 faint(SP_INVALID, $type, "_match: $e")
|
|
|
300 unless exists $typemap{$e}{$type} ||
|
|
|
301 (exists $mulmap{$v} && exists $typemap{$e}{V});
|
|
|
302 if ($e eq 'O' && $const) {
|
|
|
303 BCget($code, \$sc, $ep);
|
|
|
304 } elsif ($type eq '#' && $e ne '*') {
|
|
|
305 my $num = BCget($code, \$sc, $ep);
|
|
|
306 $closure->($v, "#$num") if $closure;
|
|
|
307 if ($e eq 'C') {
|
|
|
308 $args = _args('count', \$pattern) x $num;
|
|
|
309 $args .= "\x00";
|
|
|
310 $closure->(undef, '<') if $closure;
|
|
|
311 } else {
|
|
|
312 $args = '';
|
|
|
313 }
|
|
|
314 } else {
|
|
|
315 $sc++;
|
|
|
316 $args = '' if $e eq 'O' || $e eq '*';
|
|
|
317 $closure->($v, $op) if $closure;
|
|
|
318 }
|
|
|
319 $pattern = $args . $pattern;
|
|
|
320 next MATCH;
|
|
|
321 } elsif ($e eq 'N') {
|
|
|
322 # any nonzero number
|
|
|
323 return undef if $v == 0;
|
|
|
324 $closure->($v, "N$v") if $closure;
|
|
|
325 $sc++;
|
|
|
326 } elsif ($e eq '<') {
|
|
|
327 # left grammar element
|
|
|
328 my $count = BCget($code, \$sc, $ep);
|
|
|
329 my $num = BCget($code, \$sc, $ep);
|
|
|
330 if ($num == 0) {
|
|
|
331 $closure->(undef, '?<') if $closure;
|
|
|
332 } elsif ($num == 1 || $num == 2) {
|
|
|
333 $closure->(undef, ',<') if $closure;
|
|
|
334 } else {
|
|
|
335 $closure->(undef, ',!<') if $closure;
|
|
|
336 }
|
|
|
337 if ($count && $closure) {
|
|
|
338 $closure->(undef, $count == 65535 ? '*' : $count);
|
|
|
339 }
|
|
|
340 $pattern = "E\x00" . $pattern;
|
|
|
341 next MATCH;
|
|
|
342 } elsif ($e eq '>') {
|
|
|
343 # right grammar element
|
|
|
344 my $num = BCget($code, \$sc, $ep);
|
|
|
345 if ($num == 0 || $num == 6) {
|
|
|
346 my $count = BCget($code, \$sc, $ep);
|
|
|
347 if ($count && $closure) {
|
|
|
348 $closure->(undef, $count);
|
|
|
349 }
|
|
|
350 $closure->($v, $num ? '!<' : '?<') if $closure;
|
|
|
351 $pattern = "E\x00" . $pattern;
|
|
|
352 next MATCH;
|
|
|
353 }
|
|
|
354 if ($num == 1 || $num == 2) {
|
|
|
355 $closure->($v, ',<') if $closure;
|
|
|
356 my $count = BCget($code, \$sc, $ep);
|
|
|
357 if ($count && $closure) {
|
|
|
358 $closure->(undef, $count);
|
|
|
359 }
|
|
|
360 $pattern = "E\x00" . $pattern;
|
|
|
361 next MATCH;
|
|
|
362 }
|
|
|
363 if ($num == 3 || $num == 7) {
|
|
|
364 $closure->($v, ',!<') if $closure;
|
|
|
365 my $count = BCget($code, \$sc, $ep);
|
|
|
366 if ($count && $closure) {
|
|
|
367 $closure->(undef, $count);
|
|
|
368 }
|
|
|
369 $pattern = "E\x00" . $pattern;
|
|
|
370 next MATCH;
|
|
|
371 }
|
|
|
372 if ($num == 4) {
|
|
|
373 $num = BCget($code, \$sc, $ep);
|
|
|
374 my $se = $sc + $num;
|
|
|
375 $se <= $ep
|
|
|
376 or faint(SP_INVALID, '???', '_match: >');
|
|
|
377 if ($closure) {
|
|
|
378 $closure->(undef, '=<');
|
|
|
379 while ($sc < $se) {
|
|
|
380 $sc += _match('*', $code, $sc, $se, $closure);
|
|
|
381 }
|
|
|
382 $closure->(undef, '>');
|
|
|
383 } else {
|
|
|
384 $sc = $se;
|
|
|
385 }
|
|
|
386 next MATCH;
|
|
|
387 }
|
|
|
388 if ($num == 15) {
|
|
|
389 $closure->($v, '*') if $closure;
|
|
|
390 next MATCH;
|
|
|
391 }
|
|
|
392 faint(SP_INVALID, $num, "_match: >");
|
|
|
393 } elsif ($e eq '[') {
|
|
|
394 # XXX left optimise element
|
|
|
395 faint(SP_TODO, 'match on [');
|
|
|
396 } elsif ($e eq ']') {
|
|
|
397 # XXX right optimise element
|
|
|
398 faint(SP_TODO, 'match on ]');
|
|
|
399 } else {
|
|
|
400 faint(SP_BCMATCH, 'type', $e);
|
|
|
401 }
|
|
|
402 }
|
|
|
403 $sc - $osc;
|
|
|
404 }
|
|
|
405
|
|
|
406 sub reg_list () {
|
|
|
407 @reg_list;
|
|
|
408 }
|
|
|
409
|
|
|
410 sub reg_create {
|
|
|
411 @_ == 2 || @_ == 3
|
|
|
412 or croak "Usage: reg_create(REGISTER, OBJECT [, VALUE])";
|
|
|
413 my ($rn, $object, @value) = @_;
|
|
|
414 $rn = $reg_names{$rn} if exists $reg_names{$rn};
|
|
|
415 if (exists $reg_list{$rn}) {
|
|
|
416 @value = $reg_list{$rn}[1] if ! @value;
|
|
|
417 my $rt = $reg_list{$rn}[3];
|
|
|
418 my $dt = $reg_list{$rn}[0];
|
|
|
419 return Language::INTERCAL::DoubleOhSeven->new($dt, $object, @value)
|
|
|
420 if $rt eq '%';
|
|
|
421 return Language::INTERCAL::SharkFin->new($dt, $object, @value)
|
|
|
422 if $rt eq '^';
|
|
|
423 return Language::INTERCAL::Whirlpool->new(@value)
|
|
|
424 if $rt eq '@';
|
|
|
425 }
|
|
|
426 $rn =~ /^\./
|
|
|
427 and return Language::INTERCAL::Numbers::Spot->new(@value || 0);
|
|
|
428 $rn =~ /^:/
|
|
|
429 and return Language::INTERCAL::Numbers::Twospot->new(@value || 0);
|
|
|
430 $rn =~ /^,/
|
|
|
431 and return Language::INTERCAL::Arrays::Tail->new(@value || []);
|
|
|
432 $rn =~ /^;/
|
|
|
433 and return Language::INTERCAL::Arrays::Hybrid->new(@value || []);
|
|
|
434 $rn =~ /^\@/
|
|
|
435 and return Language::INTERCAL::Whirlpool->new();
|
|
|
436 $rn =~ /^\_[12]$/
|
|
|
437 and return Language::INTERCAL::CrawlingHorror->new();
|
|
|
438 faint(SP_SPECIAL, $rn);
|
|
|
439 }
|
|
|
440
|
|
|
441 sub reg_codetype {
|
|
|
442 @_ == 1 or croak "Usage: reg_codetype(REGISTER)";
|
|
|
443 my ($rn) = @_;
|
|
|
444 exists $reg_list{$rn} and return $reg_list{$rn}[0];
|
|
|
445 if (exists $reg_names{$rn}) {
|
|
|
446 $rn = $reg_names{$rn};
|
|
|
447 return $reg_list{$rn}[0];
|
|
|
448 }
|
|
|
449 $rn =~ /^\./ and return 'spot';
|
|
|
450 $rn =~ /^:/ and return 'twospot';
|
|
|
451 $rn =~ /^,/ and return 'tail';
|
|
|
452 $rn =~ /^;/ and return 'hybrid';
|
|
|
453 $rn =~ /^\@/ and return 'whirlpool';
|
|
|
454 faint(SP_SPECIAL, $rn);
|
|
|
455 }
|
|
|
456
|
|
|
457 sub reg_name {
|
|
|
458 @_ == 1 or croak "Usage: reg_name(REGISTER)";
|
|
|
459 my ($rn) = @_;
|
|
|
460 exists $reg_list{$rn}
|
|
|
461 and return $reg_list{$rn}[3] . $reg_list{$rn}[4];
|
|
|
462 if (exists $reg_names{$rn}) {
|
|
|
463 $rn = $reg_names{$rn};
|
|
|
464 return $reg_list{$rn}[3] . $reg_list{$rn}[4];
|
|
|
465 }
|
|
|
466 $rn =~ /^([%^\@])(.*)$/ && exists $reg_list{$2} && $reg_list{$2}[3] eq $1
|
|
|
467 and return $reg_list{$2}[3] . $reg_list{$2}[4];
|
|
|
468 $rn =~ s/^([\.:,;\@^%])0*(\d+)$/$1$2/ and return $rn;
|
|
|
469 undef;
|
|
|
470 }
|
|
|
471
|
|
|
472 sub reg_code {
|
|
|
473 @_ == 1 or croak "Usage: reg_code(REGISTER)";
|
|
|
474 my ($rn) = @_;
|
|
|
475 exists $reg_list{$rn}
|
|
|
476 and return ($reg_list{$rn}[2], BC($reg_list{$rn}[4]));
|
|
|
477 if (exists $reg_names{$rn}) {
|
|
|
478 $rn = $reg_names{$rn};
|
|
|
479 return ($reg_list{$rn}[2], BC($reg_list{$rn}[4]));
|
|
|
480 }
|
|
|
481 $rn =~ /^([%^\@])(.*)$/ && exists $reg_list{$2} && $reg_list{$2}[3] eq $1
|
|
|
482 and return ($reg_list{$2}[2], BC($reg_list{$2}[4]));
|
|
|
483 $rn =~ /^\.(\d+)$/ and return (BC_SPO, BC($1));
|
|
|
484 $rn =~ /^:(\d+)$/ and return (BC_TSP, BC($1));
|
|
|
485 $rn =~ /^,(\d+)$/ and return (BC_TAI, BC($1));
|
|
|
486 $rn =~ /^;(\d+)$/ and return (BC_HYB, BC($1));
|
|
|
487 $rn =~ /^\@(\d+)$/ and return (BC_WHP, BC($1));
|
|
|
488 $rn =~ /^\%(\d+)$/ and return (BC_DOS, BC($1));
|
|
|
489 $rn =~ /^\^(\d+)$/ and return (BC_SHF, BC($1));
|
|
|
490 undef;
|
|
|
491 }
|
|
|
492
|
|
|
493 sub reg_decode {
|
|
|
494 @_ == 1 or croak "Usage: reg_name(REGISTER)";
|
|
|
495 my ($rn) = @_;
|
|
|
496 return $rn if $rn =~ /^[.,:;\@_]/;
|
|
|
497 if ($rn =~ /^[%^]\d+$/) {
|
|
|
498 return undef unless exists $reg_names{$rn};
|
|
|
499 $rn = $reg_names{$rn};
|
|
|
500 } elsif ($rn =~ s/^([%^])//) {
|
|
|
501 return undef unless exists $reg_list{$rn};
|
|
|
502 return undef if $1 ne $reg_list{$rn}[3];
|
|
|
503 } else {
|
|
|
504 return undef unless exists $reg_list{$rn};
|
|
|
505 }
|
|
|
506 $reg_list{$rn}[3] . $rn;
|
|
|
507 }
|
|
|
508
|
|
|
509 1;
|
|
|
510
|
|
|
511 __END__
|
|
|
512
|
|
|
513 =pod
|
|
|
514
|
|
|
515 =head1 TITLE
|
|
|
516
|
|
|
517 Language::INTERCAL::Bytecode - intermediate language
|
|
|
518
|
|
|
519 =head1 DESCRIPTION
|
|
|
520
|
|
|
521 The CLC-INTERCAL compiler works by producing bytecode from the
|
|
|
522 program source; this bytecode can be interpreted to execute the
|
|
|
523 program immediately; alternatively, a backend can produce something
|
|
|
524 else from the bytecode, for example C or Perl source code which can
|
|
|
525 then be compiled to your computer's native object format.
|
|
|
526
|
|
|
527 The compiler itself is just some more bytecode. Thus, to produce the
|
|
|
528 compiler you need a compiler compiler, and to produce that you need
|
|
|
529 a compiler compiler compiler; to produce the latter you would need
|
|
|
530 a compiler compiler compiler compiler, and so on to infinity. To
|
|
|
531 simplify the programmer's life (eh?), the compiler compiler is able
|
|
|
532 to compile itself, and is therefore identical to the compiler compiler
|
|
|
533 compiler (etcetera).
|
|
|
534
|
|
|
535 The programmer can start the process because a pre-compiled compiler
|
|
|
536 compiler, in the form of bytecode, is provided with the CLC-INTERCAL
|
|
|
537 distribution; this compiler compiler then is able to compile all
|
|
|
538 other compilers, as well as to rebuild itself if need be.
|
|
|
539
|
|
|
540 See the online manual or the HTML documentation included with the
|
|
|
541 distribution for more information about this.
|
|
|
542
|
|
|
543 =head1 SEE ALSO
|
|
|
544
|
|
|
545 A qualified psychiatrist
|
|
|
546
|
|
|
547 =head1 AUTHOR
|
|
|
548
|
|
|
549 Claudio Calvelli - intercal (whirlpool) sdf.lonestar.org
|
|
|
550 (Please include the word INTERLEAVING in the subject when emailing that
|
|
|
551 address, or the email may be ignored)
|
|
|
552
|
