|
996
|
1 package Language::INTERCAL::Interpreter;
|
|
|
2
|
|
|
3 # Interpreter and runtime environment
|
|
|
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 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Interpreter.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP splatdescription);
|
|
|
20 use Language::INTERCAL::ByteCode '1.-94.-2',
|
|
|
21 qw(bytecode bytedecode bc_skip bc_match bc_list BCget BC_MASK :BC
|
|
|
22 reg_list reg_name reg_create reg_codetype reg_decode reg_code
|
|
|
23 is_constant);
|
|
|
24 use Language::INTERCAL::Object '1.-94.-2', qw(find_code forall_code make_code);
|
|
|
25 use Language::INTERCAL::GenericIO '1.-94.-2', qw($stdsplat);
|
|
|
26 use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(read_number);
|
|
|
27 use Language::INTERCAL::WriteNumbers '1.-94.-2', qw(write_number);
|
|
|
28 use Language::INTERCAL::ArrayIO '1.-94.-2',
|
|
|
29 qw(read_array_16 read_array_32 write_array_16 write_array_32
|
|
|
30 iotype_default);
|
|
|
31 use Language::INTERCAL::Charset::Baudot '1.-94.-2', qw(baudot2ascii);
|
|
|
32 use Language::INTERCAL::SharkFin '1.-94.-2';
|
|
|
33 use Language::INTERCAL::Server '1.-94.-2';
|
|
|
34
|
|
|
35 use constant MAX_NEXT => 80;
|
|
|
36
|
|
|
37 my %default_opcodes = (
|
|
|
38 ABG => \&_i_abg,
|
|
|
39 ABL => \&_i_abl,
|
|
|
40 AWC => \&_i_awc,
|
|
|
41 # XXX BAW - only used by the (not yet written) optimiser
|
|
|
42 # XXX BBT - only used by the (not yet written) optimiser
|
|
|
43 BUG => \&_i_bug,
|
|
|
44 BUT => \&_i_but,
|
|
|
45 # XXX BSW - only used by the (not yet written) optimiser
|
|
|
46 BWC => \&_i_bwc,
|
|
|
47 CFG => \&_i_cfg,
|
|
|
48 CFL => \&_i_cfl,
|
|
|
49 CHO => \&_i_cho,
|
|
|
50 CON => \&_i_con,
|
|
|
51 CRE => \&_i_cre,
|
|
|
52 CSE => \&_i_cse,
|
|
|
53 CWB => \&_i_cwb,
|
|
|
54 DES => \&_i_des,
|
|
|
55 DOS => \&_i_dos,
|
|
|
56 EBC => \&_i_ebc,
|
|
|
57 ECB => \&_i_ecb,
|
|
|
58 ENR => \&_i_enr,
|
|
|
59 ENS => \&_i_ens,
|
|
|
60 FIN => \&_i_fin,
|
|
|
61 FOR => \&_i_for,
|
|
|
62 FRE => \&_i_fre,
|
|
|
63 FRZ => \&_i_frz,
|
|
|
64 GRA => \&_i_gra,
|
|
|
65 GUP => \&_i_gup,
|
|
|
66 HYB => \&_i_hyb,
|
|
|
67 IGN => \&_i_ign,
|
|
|
68 INT => \&_i_int,
|
|
|
69 LEA => \&_i_lea,
|
|
|
70 MKG => \&_i_mkg,
|
|
|
71 MSP => \&_i_msp,
|
|
|
72 MUL => \&_i_mul,
|
|
|
73 NUM => \&_i_num,
|
|
|
74 NXG => \&_i_cfg,
|
|
|
75 NXL => \&_i_cfl,
|
|
|
76 NXT => \&_i_nxt,
|
|
|
77 # XXX OPT - only used by the (not yet written) optimiser
|
|
|
78 OVM => \&_i_ovm,
|
|
|
79 OVR => \&_i_ovr,
|
|
|
80 OWN => \&_i_own,
|
|
|
81 REG => \&_i_reg,
|
|
|
82 REL => \&_i_rel,
|
|
|
83 REM => \&_i_rem,
|
|
|
84 RES => \&_i_res,
|
|
|
85 RET => \&_i_ret,
|
|
|
86 RIN => \&_i_rin,
|
|
|
87 ROM => \&_i_rom,
|
|
|
88 ROR => \&_i_ror,
|
|
|
89 ROU => \&_i_rou,
|
|
|
90 RSE => \&_i_rse,
|
|
|
91 SEL => \&_i_sel,
|
|
|
92 SHF => \&_i_shf,
|
|
|
93 SMU => \&_i_smu,
|
|
|
94 SPL => \&_i_spl,
|
|
|
95 SPO => \&_i_spo,
|
|
|
96 STA => \&_i_sta,
|
|
|
97 STE => \&_i_ste,
|
|
|
98 STO => \&_i_sto,
|
|
|
99 STU => \&_i_stu,
|
|
|
100 STR => \&_i_str,
|
|
|
101 SUB => \&_i_sub,
|
|
|
102 SWA => \&_i_swa,
|
|
|
103 SWB => \&_i_swb,
|
|
|
104 SYS => \&_i_sys,
|
|
|
105 TAI => \&_i_tai,
|
|
|
106 TSP => \&_i_tsp,
|
|
|
107 TYP => \&_i_typ,
|
|
|
108 UNE => \&_i_unx,
|
|
|
109 UNS => \&_i_unx,
|
|
|
110 UDV => \&_i_udv,
|
|
|
111 USG => \&_i_usg,
|
|
|
112 WHP => \&_i_whp,
|
|
|
113 WIN => \&_i_win,
|
|
|
114 );
|
|
|
115
|
|
|
116 my %causes_recompile = map { ( reg_name($_) => 1 ) } qw(PS SS JS IS);
|
|
|
117 my %come_froms = map { ( $_ => 1 ) } BC_CFL, BC_CFG, BC_NXL, BC_NXG;
|
|
|
118
|
|
|
119 my $reg_ar = reg_name('AR');
|
|
|
120 my $reg_aw = reg_name('AW');
|
|
|
121 my $reg_ba = reg_name('BA');
|
|
|
122 my $reg_cf = reg_name('CF');
|
|
|
123 my $reg_cr = reg_name('CR');
|
|
|
124 my $reg_cw = reg_name('CW');
|
|
|
125 my $reg_dm = reg_name('DM');
|
|
|
126 my $reg_io = reg_name('IO');
|
|
|
127 my $reg_is = reg_name('IS');
|
|
|
128 my $reg_js = reg_name('JS');
|
|
|
129 my $reg_os = reg_name('OS');
|
|
|
130 my $reg_ps = reg_name('PS');
|
|
|
131 my $reg_rm = reg_name('RM');
|
|
|
132 my $reg_rt = reg_name('RT');
|
|
|
133 my $reg_sp = reg_name('SP');
|
|
|
134 my $reg_ss = reg_name('SS');
|
|
|
135 my $reg_th = reg_name('TH');
|
|
|
136 my $reg_tm = reg_name('TM');
|
|
|
137 my $reg_wt = reg_name('WT');
|
|
|
138 my $reg_orfh = reg_name('ORFH');
|
|
|
139 my $reg_osfh = reg_name('OSFH');
|
|
|
140 my $reg_owfh = reg_name('OWFH');
|
|
|
141 my $reg_trfh = reg_name('TRFH');
|
|
|
142
|
|
|
143 sub new {
|
|
|
144 @_ == 2 || @_ == 3
|
|
|
145 or croak "Usage: new Language::INTERCAL::Interpreter(RC [, OBJECT])";
|
|
|
146 my ($class, $rc, $object) = @_;
|
|
|
147 $object ||= Language::INTERCAL::Object->new;
|
|
|
148 my %int = (
|
|
|
149 threads => [],
|
|
|
150 events => [],
|
|
|
151 object => $object,
|
|
|
152 loop_id => 0,
|
|
|
153 ab_count => 0,
|
|
|
154 syscode => {},
|
|
|
155 record_grammar => 0,
|
|
|
156 rc => $rc,
|
|
|
157 verbose => 0,
|
|
|
158 theft_callback => 0,
|
|
|
159 theft_server => 0,
|
|
|
160 server => 0,
|
|
|
161 compiling => 0,
|
|
|
162 stolen => {},
|
|
|
163 );
|
|
|
164 $int{default} = _make_thread($object, undef, \%int);
|
|
|
165 bless \%int, $class;
|
|
|
166 }
|
|
|
167
|
|
|
168 sub theft_callback {
|
|
|
169 @_ == 1 || @_ == 2
|
|
|
170 or croak "Usage: INTERPRETER->theft_callback [(CODE)]";
|
|
|
171 my ($int) = shift;
|
|
|
172 my $rv = $int->{theft_callback};
|
|
|
173 $int->{theft_callback} = shift if @_;
|
|
|
174 $rv;
|
|
|
175 }
|
|
|
176
|
|
|
177 sub verbose_compile {
|
|
|
178 @_ == 1 || @_ == 2
|
|
|
179 or croak "Usage: INTERPRETER->verbose_compile [(VALUE)]";
|
|
|
180 my ($int) = shift;
|
|
|
181 my $rv = $int->{verbose};
|
|
|
182 $int->{verbose} = shift if @_;
|
|
|
183 $rv;
|
|
|
184 }
|
|
|
185
|
|
|
186 sub object {
|
|
|
187 @_ == 1 or croak "Usage: INTERPRETER->object";
|
|
|
188 my ($int) = @_;
|
|
|
189 $int->{object};
|
|
|
190 }
|
|
|
191
|
|
|
192 sub getrules {
|
|
|
193 @_ == 2 or croak "Usage: INTERPRETER->getrules(GRAMMAR)";
|
|
|
194 my ($int, $gra) = @_;
|
|
|
195 return $int->{default}{rules}[$gra - 1] || [];
|
|
|
196 }
|
|
|
197
|
|
|
198 sub getreg {
|
|
|
199 @_ == 2 or croak "Usage: INTERPRETER->getreg(NAME)";
|
|
|
200 my ($int, $name) = @_;
|
|
|
201 $name = reg_name($name) or croak "Invalid register name";
|
|
|
202 exists $int->{default}{registers}{$name}
|
|
|
203 and return $int->{default}{registers}{$name}{value}->value;
|
|
|
204 croak "Invalid register name";
|
|
|
205 }
|
|
|
206
|
|
|
207 sub setreg {
|
|
|
208 @_ == 3 or croak "Usage: INTERPRETER->setreg(NAME, VALUE)";
|
|
|
209 my ($int, $name, $value) = @_;
|
|
|
210 $name = reg_name($name) or croak "Invalid register name";
|
|
|
211 my $tp = $int->{default};
|
|
|
212 _create_register($int, $tp, 'setreg', $name, {});
|
|
|
213 $tp->{registers}{$name}{value}->assign($value);
|
|
|
214 $int;
|
|
|
215 }
|
|
|
216
|
|
|
217 sub allreg {
|
|
|
218 @_ == 2 || @_ == 3
|
|
|
219 or croak "Usage: INTERPRETER->allreg(CODE [, DEFAULT_MODE])";
|
|
|
220 my ($int, $code, $dm) = @_;
|
|
|
221 $dm ||= 'dn';
|
|
|
222 # find all registers
|
|
|
223 my %regs = ();
|
|
|
224 my $tp = $int->{default};
|
|
|
225 my $rp = $tp->{registers};
|
|
|
226 for my $n (keys %$rp) {
|
|
|
227 if (exists $rp->{$n}{default}) {
|
|
|
228 next unless $dm =~ /d/i;
|
|
|
229 } else {
|
|
|
230 next unless $dm =~ /n/i;
|
|
|
231 }
|
|
|
232 my $t = substr($n, 0, 1);
|
|
|
233 my $v = substr($n, 1);
|
|
|
234 $regs{$t}{$v} = $rp->{$n}{value};
|
|
|
235 }
|
|
|
236 # now proceed in order
|
|
|
237 for my $t (sort keys %regs) {
|
|
|
238 for my $v (sort { $a <=> $b } keys %{$regs{$t}}) {
|
|
|
239 $code->($t . $v, $regs{$t}{$v});
|
|
|
240 }
|
|
|
241 }
|
|
|
242 }
|
|
|
243
|
|
|
244 sub record_grammar {
|
|
|
245 @_ == 2 or croak "Usage: INTERPRETER->record_grammar(HOW)";
|
|
|
246 my ($int, $how) = @_;
|
|
|
247 $int->{record_grammar} = $how;
|
|
|
248 $int;
|
|
|
249 }
|
|
|
250
|
|
|
251 sub get_abstains {
|
|
|
252 @_ == 1 or croak "Usage: INTERPRETER->get_abstains";
|
|
|
253 my ($int) = @_;
|
|
|
254 my $tp = $int->{default};
|
|
|
255 my @labels = keys %{$tp->{ab_label}};
|
|
|
256 my @gerunds = keys %{$tp->{ab_gerund}};
|
|
|
257 my $text = "ABR\n";
|
|
|
258 $text .= pack('vvv', $int->{ab_count}, scalar @labels, scalar @gerunds);
|
|
|
259 for my $l (@labels) {
|
|
|
260 $text .= pack('vvv', $l, @{$tp->{ab_label}{$l}});
|
|
|
261 }
|
|
|
262 for my $g (@gerunds) {
|
|
|
263 $text .= pack('vvv', $g, @{$tp->{ab_gerund}{$g}});
|
|
|
264 }
|
|
|
265 $text;
|
|
|
266 }
|
|
|
267
|
|
|
268 sub set_abstains {
|
|
|
269 @_ == 2 or croak "Usage: INTERPRETER->set_abstains(DATA)";
|
|
|
270 my ($int, $text) = @_;
|
|
|
271 $text =~ s/^ABR\n// or croak "Invalid abstain DATA";
|
|
|
272 my ($count, $lc, $gc, @r) = unpack('v*', $text);
|
|
|
273 defined $gc or croak "Invalid abstain DATA";
|
|
|
274 @r == 3 * ($lc + $gc) or croak "Invalid abstain DATA";
|
|
|
275 my $tp = $int->{default};
|
|
|
276 # create new abstain records
|
|
|
277 $tp->{ab_label} = {};
|
|
|
278 $tp->{ab_gerund} = {};
|
|
|
279 $int->{ab_count} = $count;
|
|
|
280 for (my $l = 0; $l < $lc; $l++) {
|
|
|
281 my $n = shift @r;
|
|
|
282 my $a = shift @r;
|
|
|
283 my $c = shift @r;
|
|
|
284 $tp->{ab_label}{$n} = [$a, $c];
|
|
|
285 }
|
|
|
286 for (my $g = 0; $g < $gc; $g++) {
|
|
|
287 my $n = shift @r;
|
|
|
288 my $a = shift @r;
|
|
|
289 my $c = shift @r;
|
|
|
290 $tp->{ab_gerund}{$n} = [$a, $c];
|
|
|
291 }
|
|
|
292 $int;
|
|
|
293 }
|
|
|
294
|
|
|
295 sub get_grammar_record {
|
|
|
296 @_ == 1 or croak "Usage: INTERPRETER->get_grammar_record";
|
|
|
297 my ($int) = @_;
|
|
|
298 my $tp = $int->{default};
|
|
|
299 my $gr = $tp->{grammar_record};
|
|
|
300 my $mr = $tp->{make_record};
|
|
|
301 my $text = "GRR\n";
|
|
|
302 my %smap = ();
|
|
|
303 $text .= pack('vv', scalar(@$gr), scalar(@$mr));
|
|
|
304 for my $g (@$gr) {
|
|
|
305 $text .= chr($g->[0]);
|
|
|
306 if ($g->[0] == BC_CON || $g->[0] == BC_SWA) {
|
|
|
307 $text .= pack('vv', length($g->[1]), length($g->[2]));
|
|
|
308 $text .= $g->[1] . $g->[2];
|
|
|
309 next;
|
|
|
310 }
|
|
|
311 if ($g->[0] == BC_CRE) {
|
|
|
312 $text .= pack('v', $g->[1]);
|
|
|
313 $text .= _pack_symbol($int, $g->[2], \%smap);
|
|
|
314 $text .= _pack_left($int, $g->[3], \%smap);
|
|
|
315 $text .= _pack_right($int, $g->[4], \%smap);
|
|
|
316 next;
|
|
|
317 }
|
|
|
318 if ($g->[0] == BC_DES) {
|
|
|
319 $text .= pack('v', $g->[1]);
|
|
|
320 $text .= _pack_symbol($int, $g->[2], \%smap);
|
|
|
321 $text .= _pack_left($int, $g->[3], \%smap);
|
|
|
322 next;
|
|
|
323 }
|
|
|
324 faint(SP_INTERNAL, "get_grammar_record found invalid record");
|
|
|
325 }
|
|
|
326 for my $g (@$mr) {
|
|
|
327 $text .= pack('vvv', $g->[0], length($g->[1]), length($g->[2]));
|
|
|
328 $text .= $g->[1] . $g->[2];
|
|
|
329 }
|
|
|
330 $text;
|
|
|
331 }
|
|
|
332
|
|
|
333 sub set_grammar_record {
|
|
|
334 @_ == 2 or croak "Usage: INTERPRETER->set_grammar_record(DATA)";
|
|
|
335 my ($int, $text) = @_;
|
|
|
336 $text =~ s/^GRR\n// or croak "Invalid DATA";
|
|
|
337 my ($gcount, $mcount) = unpack('vv', substr($text, 0, 4, ''));
|
|
|
338 defined $mcount or $mcount = 0;
|
|
|
339 my $tp = $int->{default};
|
|
|
340 my @smap = ();
|
|
|
341 my @gr = ();
|
|
|
342 for (my $n = 0; $n < $gcount; $n++) {
|
|
|
343 my $t = ord(substr($text, 0, 1, ''));
|
|
|
344 if ($t == BC_CON || $t == BC_SWA) {
|
|
|
345 my ($lo1, $lo2) = unpack('vv', substr($text, 0, 4, ''));
|
|
|
346 my $o1 = substr($text, 0, $lo1, '');
|
|
|
347 my $o2 = substr($text, 0, $lo2, '');
|
|
|
348 push @gr, [$t, $o1, $o2];
|
|
|
349 if ($t == BC_CON) {
|
|
|
350 $tp->{opcodes}{$o1} = $tp->{opcodes}{$o2};
|
|
|
351 } else {
|
|
|
352 ($tp->{opcodes}{$o1}, $tp->{opcodes}{$o2}) =
|
|
|
353 ($tp->{opcodes}{$o2}, $tp->{opcodes}{$o1});
|
|
|
354 }
|
|
|
355 next;
|
|
|
356 }
|
|
|
357 if ($t == BC_CRE) {
|
|
|
358 my ($gra) = unpack('v', substr($text, 0, 2, ''));
|
|
|
359 my $sym = _unpack_symbol(\$text, $int, \@smap);
|
|
|
360 my $left = _unpack_left(\$text, $int, \@smap);
|
|
|
361 my $right = _unpack_right(\$text, $int, \@smap);
|
|
|
362 push @gr, [$t, $sym, $left, $right];
|
|
|
363 _ii_cre($int, $tp, $gra, $sym, $left, $right, {});
|
|
|
364 next;
|
|
|
365 }
|
|
|
366 if ($t == BC_CRE) {
|
|
|
367 my ($gra) = unpack('v', substr($text, 0, 2, ''));
|
|
|
368 my $sym = _unpack_symbol(\$text, $int, \@smap);
|
|
|
369 my $left = _unpack_left(\$text, $int, \@smap);
|
|
|
370 push @gr, [$t, $sym, $left];
|
|
|
371 _ii_des($int, $tp, $gra, $sym, $left, {});
|
|
|
372 next;
|
|
|
373 }
|
|
|
374 croak "Invalid DATA";
|
|
|
375 }
|
|
|
376 my @mr = ();
|
|
|
377 for (my $n = 0; $n < $mcount; $n++) {
|
|
|
378 my ($op, $tlen, $clen) = unpack('vvv', substr($text, 0, 6, ''));
|
|
|
379 my $template = substr($text, 0, $tlen, '');
|
|
|
380 my $code = substr($text, 0, $clen, '');
|
|
|
381 push @mr, [$op, $template, $code];
|
|
|
382 $tp->{opcodes}{$op} = [$template, $code];
|
|
|
383 }
|
|
|
384 $int->{grammar_record} = \@gr;
|
|
|
385 $int->{make_record} = \@mr;
|
|
|
386 $text eq '' or croak "Invalid DATA";
|
|
|
387 $int;
|
|
|
388 }
|
|
|
389
|
|
|
390 sub _pack_symbol {
|
|
|
391 my ($int, $sym, $smap) = @_;
|
|
|
392 if (exists $smap->{$sym}) {
|
|
|
393 return 'S' . pack('v', $smap->{$sym});
|
|
|
394 }
|
|
|
395 $sym = $int->{object}->symboltable->symbol($sym) || 0;
|
|
|
396 my $num = scalar keys %$smap;
|
|
|
397 $smap->{$sym} = $num;
|
|
|
398 return 'M' . pack('v v/a*', $num, $sym);
|
|
|
399 }
|
|
|
400
|
|
|
401 sub _unpack_symbol {
|
|
|
402 my ($text, $int, $smap) = @_;
|
|
|
403 my $name;
|
|
|
404 if ($$text =~ s/^S//) {
|
|
|
405 my ($snum) = unpack('v', substr($$text, 0, 2, ''));
|
|
|
406 $name = $smap->[$snum];
|
|
|
407 } elsif ($$text =~ s/^M//) {
|
|
|
408 my ($snum, $slen) = unpack('vv', substr($$text, 0, 4, ''));
|
|
|
409 $name = substr($$text, 0, $slen, '');
|
|
|
410 length($name) == $slen or croak "Invalid DATA";
|
|
|
411 $smap->[$snum] = $name;
|
|
|
412 } else {
|
|
|
413 croak "Invalid DATA";
|
|
|
414 }
|
|
|
415 $int->{object}->symboltable->find($name, 0);
|
|
|
416 }
|
|
|
417
|
|
|
418 sub _pack_left {
|
|
|
419 my ($int, $left, $smap) = @_;
|
|
|
420 my $text = pack('v', scalar @$left);
|
|
|
421 for my $prod (@$left) {
|
|
|
422 $text .= $prod->[0];
|
|
|
423 if ($prod->[0] eq 's') {
|
|
|
424 $text .= _pack_symbol($int, $prod->[1], $smap);
|
|
|
425 } else {
|
|
|
426 $text .= pack('v/a*', $prod->[1]);
|
|
|
427 }
|
|
|
428 $text .= pack('v', $prod->[2]);
|
|
|
429 }
|
|
|
430 $text;
|
|
|
431 }
|
|
|
432
|
|
|
433 sub _unpack_left {
|
|
|
434 my ($text, $int, $smap) = @_;
|
|
|
435 my ($num) = unpack('v', substr($$text, 0, 2, ''));
|
|
|
436 my @left = ();
|
|
|
437 while ($num-- > 0) {
|
|
|
438 my $type = substr($$text, 0, 1, '');
|
|
|
439 my $data;
|
|
|
440 if ($type eq 's') {
|
|
|
441 $data = _unpack_symbol($text, $int, $smap);
|
|
|
442 } else {
|
|
|
443 my $l = unpack('v', substr($$text, 0, 2, ''));
|
|
|
444 $data = substr($$text, 0, $l, '');
|
|
|
445 length $data == $l or croak "Invalid DATA";
|
|
|
446 }
|
|
|
447 my $count = unpack('v', substr($$text, 0, 2, ''));
|
|
|
448 push @left, [$type, $data, $count];
|
|
|
449 }
|
|
|
450 \@left;
|
|
|
451 }
|
|
|
452
|
|
|
453 sub _pack_right {
|
|
|
454 my ($int, $right, $smap) = @_;
|
|
|
455 my $text = pack('v', scalar @$right);
|
|
|
456 for my $prod (@$right) {
|
|
|
457 $text .= $prod->[0];
|
|
|
458 if ($prod->[0] eq 's' || $prod->[0] eq 'n') {
|
|
|
459 $text .= pack('v', $prod->[1]);
|
|
|
460 $text .= _pack_symbol($int, $prod->[2], $smap);
|
|
|
461 } elsif ($prod->[0] eq 'c' || $prod->[0] eq 'r') {
|
|
|
462 $text .= pack('v v/a*', $prod->[1], $prod->[2]);
|
|
|
463 } elsif ($prod->[0] eq 'b') {
|
|
|
464 $text .= pack('v/a*', $prod->[1]);
|
|
|
465 }
|
|
|
466 }
|
|
|
467 $text;
|
|
|
468 }
|
|
|
469
|
|
|
470 sub _unpack_right {
|
|
|
471 my ($text, $int, $smap) = @_;
|
|
|
472 my ($num) = unpack('v', substr($$text, 0, 2, ''));
|
|
|
473 my @right = ();
|
|
|
474 while ($num-- > 0) {
|
|
|
475 my $type = substr($$text, 0, 1, '');
|
|
|
476 if ($type eq 's' || $type eq 'n') {
|
|
|
477 my $n = unpack('v', substr($$text, 0, 2, ''));
|
|
|
478 my $s = _unpack_symbol($text, $int, $smap);
|
|
|
479 push @right, [$type, $n, $s];
|
|
|
480 } elsif ($type eq 'c' || $type eq 'r') {
|
|
|
481 my $n = unpack('v', substr($$text, 0, 2, ''));
|
|
|
482 my $l = _unpack_symbol($text, $int, $smap);
|
|
|
483 my $s = substr($$text, 0, $l, '');
|
|
|
484 length $s == $l or croak "Invalid DATA";
|
|
|
485 push @right, [$type, $n, $s];
|
|
|
486 } elsif ($type eq 'b') {
|
|
|
487 my $l = _unpack_symbol($text, $int, $smap);
|
|
|
488 my $s = substr($$text, 0, $l, '');
|
|
|
489 length $s == $l or croak "Invalid DATA";
|
|
|
490 push @right, [$type, $s];
|
|
|
491 }
|
|
|
492 }
|
|
|
493 \@right;
|
|
|
494 }
|
|
|
495
|
|
|
496 sub get_events {
|
|
|
497 @_ == 1 or croak "Usage: INTERPRETER->get_events";
|
|
|
498 my ($int) = @_;
|
|
|
499 my $text = "EVR\n";
|
|
|
500 my $ep = $int->{events} || [];
|
|
|
501 $text .= pack('v', scalar @$ep);
|
|
|
502 for my $ev (@$ep) {
|
|
|
503 my ($code, $cond, $cend, $body, $bend, $bge) = @$ev;
|
|
|
504 $cond = substr($code, $cond, $cend - $cond);
|
|
|
505 $body = substr($code, $body, $bend - $body);
|
|
|
506 $text .= pack('vvv', $bge, length($cond), length($body));
|
|
|
507 $text .= $cond;
|
|
|
508 $text .= $body;
|
|
|
509 }
|
|
|
510 $text;
|
|
|
511 }
|
|
|
512
|
|
|
513 sub set_events {
|
|
|
514 @_ == 2 or croak "Usage: INTERPRETER->set_events(DATA)";
|
|
|
515 my ($int, $text) = @_;
|
|
|
516 $text =~ s/^EVR\n// or croak "Invalid DATA";
|
|
|
517 my ($count) = unpack('v', substr($text, 0, 2, ''));
|
|
|
518 my @ev = ();
|
|
|
519 for (my $i = 0; $i < $count; $i++) {
|
|
|
520 my ($bge, $clen, $blen) = unpack('vvv', substr($text, 0, 6, ''));
|
|
|
521 my $code = substr($text, 0, $blen + $clen, '');
|
|
|
522 length($code) == $blen + $clen or croak "Invalid DATA";
|
|
|
523 push @ev, [$code, 0, $clen, $clen, $clen + $blen, $bge];
|
|
|
524 }
|
|
|
525 $text eq '' or croak "Invalid DATA";
|
|
|
526 $int->{events} = \@ev;
|
|
|
527 $int;
|
|
|
528 }
|
|
|
529
|
|
|
530 sub get_registers {
|
|
|
531 @_ == 1 or croak "Usage: INTERPRETER->get_registers";
|
|
|
532 my ($int) = @_;
|
|
|
533 my $tp = $int->{default};
|
|
|
534 my $rp = $tp->{registers};
|
|
|
535 my %rcode = ();
|
|
|
536 for my $r (keys %$rp) {
|
|
|
537 my $prefix = substr($r, 0, 1);
|
|
|
538 # we assume special registers are restored by re-running extensions
|
|
|
539 # or by using INTERPRETER->read, so we never dump them here
|
|
|
540 next if $prefix eq '%' || $prefix eq '^';
|
|
|
541 my $v = $rp->{$r};
|
|
|
542 next if exists $v->{default};
|
|
|
543 # dump this register
|
|
|
544 my $number = substr($r, 1);
|
|
|
545 my @rv = ();
|
|
|
546 my $sp = exists $tp->{stash}{$r} ? $tp->{stash}{$r} : [];
|
|
|
547 for my $level (@$sp, $rp->{$r}) {
|
|
|
548 my $v = $level->{value};
|
|
|
549 my $code = '';
|
|
|
550 my $overload = $v->get_overload(undef);
|
|
|
551 if (defined $overload) {
|
|
|
552 $code .= 'O' . pack('v/a*', $overload);
|
|
|
553 } else {
|
|
|
554 $code .= 'N';
|
|
|
555 }
|
|
|
556 if ($prefix eq '.' || $prefix eq '%') {
|
|
|
557 $code .= pack('v', $v->number);
|
|
|
558 } elsif ($prefix eq ':') {
|
|
|
559 $code .= pack('V', $v->number);
|
|
|
560 } else {
|
|
|
561 $v = $v->tail if $prefix eq '@';
|
|
|
562 my $pack = $prefix eq ';' ? 'V' : 'v';
|
|
|
563 my @subs = $v->subscripts;
|
|
|
564 my @list = $v->sparse_list;
|
|
|
565 $code .= pack('v*', scalar @subs, scalar @list, @subs);
|
|
|
566 for my $l (@list) {
|
|
|
567 my ($e, @s) = @$l;
|
|
|
568 my $o = $e->get_overload(undef);
|
|
|
569 if (defined $o) {
|
|
|
570 $code .= 'O' . pack('v/a*', $o);
|
|
|
571 } else {
|
|
|
572 $code .= 'N';
|
|
|
573 }
|
|
|
574 $code .= pack($pack . 'v*', $e->number, scalar @s, @s);
|
|
|
575 }
|
|
|
576 # XXX dump filehandle if $prefix eq '@'?
|
|
|
577 }
|
|
|
578 push @rv, $code;
|
|
|
579 }
|
|
|
580 my $len = pack('av*', $prefix, $number,
|
|
|
581 scalar @rv, map { length $_ } @rv);
|
|
|
582 $rcode{$r} = join('', $len, @rv);
|
|
|
583 }
|
|
|
584 my @rcode = keys %rcode;
|
|
|
585 my $text = "REG\n";
|
|
|
586 $text .= pack('v', scalar @rcode);
|
|
|
587 for my $r (@rcode) {
|
|
|
588 $text .= $rcode{$r};
|
|
|
589 }
|
|
|
590 $text;
|
|
|
591 }
|
|
|
592
|
|
|
593 sub set_registers {
|
|
|
594 @_ == 2 || @_ == 3
|
|
|
595 or croak "Usage: INTERPRETER->set_registers(DATA [, OVERRIDE])";
|
|
|
596 my ($int, $text, $over) = @_;
|
|
|
597 $text =~ s/^REG\n// or croak "Invalid DATA";
|
|
|
598 my $tp = $int->{default};
|
|
|
599 my $rp = $tp->{registers};
|
|
|
600 my $sp = $tp->{stash};
|
|
|
601 length $text >= 2 or croak "Invalid DATA";
|
|
|
602 my ($count) = unpack('v', substr($text, 0, 2, ''));
|
|
|
603 while ($count-- > 0) {
|
|
|
604 length $text >= 5 or croak "Invalid DATA";
|
|
|
605 my ($prefix, $number, $cnum) = unpack('avv', substr($text, 0, 5, ''));
|
|
|
606 length $text >= 2 * $cnum or croak "Invalid DATA";
|
|
|
607 my @clen = unpack('v*', substr($text, 0, 2 * $cnum, ''));
|
|
|
608 my $reg = $prefix . $number;
|
|
|
609 my @rv = ();
|
|
|
610 for my $clen (@clen) {
|
|
|
611 length $text >= $clen or croak "Invalid DATA";
|
|
|
612 my $code = substr($text, 0, $clen, '');
|
|
|
613 push @rv, $code;
|
|
|
614 }
|
|
|
615 next if exists $rp->{$reg} && ! exists $rp->{$reg}{default} && ! $over;
|
|
|
616 my $stashit = 0;
|
|
|
617 delete $rp->{$reg};
|
|
|
618 delete $sp->{$reg};
|
|
|
619 _create_register($int, $tp, 'set_registers', $reg, {});
|
|
|
620 for my $code (@rv) {
|
|
|
621 if ($stashit) {
|
|
|
622 _stash_register($int, $tp, 'set_registers', $reg, {});
|
|
|
623 }
|
|
|
624 $stashit = 1;
|
|
|
625 my $v = $tp->{registers}{$reg}{value};
|
|
|
626 delete $tp->{registers}{$reg}{default};
|
|
|
627 my $overload = undef;
|
|
|
628 if ($code =~ s/^O//) {
|
|
|
629 my ($o) = unpack('v', substr($code, 0, 2, ''));
|
|
|
630 $overload = substr($code, 0, $o, '');
|
|
|
631 length $overload == $o or croak "Invalid DATA";
|
|
|
632 } elsif ($code =~ s/^N//) {
|
|
|
633 # no overload
|
|
|
634 } else {
|
|
|
635 croak "Invalid DATA";
|
|
|
636 }
|
|
|
637 if ($prefix eq '.' || $prefix eq '%') {
|
|
|
638 $v->assign(unpack('v', substr($code, 0, 2, '')));
|
|
|
639 } elsif ($prefix eq ':') {
|
|
|
640 $v->assign(unpack('V', substr($code, 0, 4, '')));
|
|
|
641 } else {
|
|
|
642 my $pack = $prefix eq ';' ? 'Vv' : 'vv';
|
|
|
643 my $plen = $prefix eq ';' ? 6 : 4;
|
|
|
644 my ($nsubs, $nvals) = unpack('vv', substr($code, 0, 4, ''));
|
|
|
645 my @subs = unpack('v*', substr($code, 0, 2 * $nsubs, ''));
|
|
|
646 $v->assign(\@subs) if $prefix ne '@';
|
|
|
647 while ($nvals-- > 0) {
|
|
|
648 my $ov = undef;
|
|
|
649 if ($code =~ s/^O//) {
|
|
|
650 my ($o) = unpack('v', substr($code, 0, 2, ''));
|
|
|
651 $ov = substr($code, 0, $o, '');
|
|
|
652 length $ov == $o or croak "Invalid DATA";
|
|
|
653 } elsif ($code =~ s/^N//) {
|
|
|
654 # no overload
|
|
|
655 } else {
|
|
|
656 croak "Invalid DATA";
|
|
|
657 }
|
|
|
658 my ($e, $ns) = unpack($pack, substr($code, 0, $plen, ''));
|
|
|
659 my @s = unpack('v*', substr($code, 0, 2 * $ns, ''));
|
|
|
660 $v->store(\@s, $e);
|
|
|
661 $v->overload(\@s, $ov);
|
|
|
662 }
|
|
|
663 }
|
|
|
664 $v->overload([], $overload);
|
|
|
665 }
|
|
|
666 }
|
|
|
667 $text eq '' or croak "Invalid DATA";
|
|
|
668 $int;
|
|
|
669 }
|
|
|
670
|
|
|
671 sub get_constants {
|
|
|
672 @_ == 1 or croak "Usage: INTERPRETER->get_constants";
|
|
|
673 my ($int) = @_;
|
|
|
674 my $tp = $int->{default};
|
|
|
675 my $ap = $tp->{assign};
|
|
|
676 my @al = grep { ${$ap->{$_}} != $_ } keys %$ap;
|
|
|
677 my @av = map { ($_ => ${$ap->{$_}}) } @al;
|
|
|
678 my $text = "CON\n";
|
|
|
679 $text .= pack('v*', scalar @al, @av);
|
|
|
680 $text;
|
|
|
681 }
|
|
|
682
|
|
|
683 sub set_constants {
|
|
|
684 @_ == 2 or croak "Usage: INTERPRETER->set_constants(DATA)";
|
|
|
685 my ($int, $text) = @_;
|
|
|
686 my $tp = $int->{default};
|
|
|
687 $text =~ s/^CON\n// or croak "Invalid DATA";
|
|
|
688 my ($count, @data) = unpack('v*', $text);
|
|
|
689 @data == 2 * $count or croak "Invalid DATA";
|
|
|
690 my %ap = ();
|
|
|
691 while (@data) {
|
|
|
692 my $c = shift @data;
|
|
|
693 my $v = shift @data;
|
|
|
694 $ap{$c} = \$v;
|
|
|
695 }
|
|
|
696 $tp->{assign} = \%ap;
|
|
|
697 $int;
|
|
|
698 }
|
|
|
699
|
|
|
700 sub get_state {
|
|
|
701 @_ == 1 or croak "Usage: INTERPRETER->get_constants";
|
|
|
702 my ($int) = @_;
|
|
|
703 my $text = "STA\n";
|
|
|
704 for my $v ($int->get_abstains(),
|
|
|
705 $int->get_grammar_record(),
|
|
|
706 $int->get_events(),
|
|
|
707 $int->get_registers(),
|
|
|
708 $int->get_constants())
|
|
|
709 {
|
|
|
710 $text .= pack('v/a*', $v);
|
|
|
711 }
|
|
|
712 $text;
|
|
|
713 }
|
|
|
714
|
|
|
715 sub set_state {
|
|
|
716 @_ == 2 || @_ == 3
|
|
|
717 or croak "Usage: INTERPRETER->set_state(DATA [, OVERRIDE])";
|
|
|
718 my ($int, $text, $over) = @_;
|
|
|
719 $text =~ s/^STA\n// or croak "Invalid DATA";
|
|
|
720 $int->{default}{assign} = {}; # otherwise set_registers fails
|
|
|
721 # set abstains
|
|
|
722 length $text >= 2 or croak "Invalid DATA";
|
|
|
723 my ($len) = unpack('v', substr($text, 0, 2, ''));
|
|
|
724 length $text >= $len or croak "Invalid DATA";
|
|
|
725 $int->set_abstains(substr($text, 0, $len, ''));
|
|
|
726 # replay grammar record
|
|
|
727 length $text >= 2 or croak "Invalid DATA";
|
|
|
728 ($len) = unpack('v', substr($text, 0, 2, ''));
|
|
|
729 length $text >= $len or croak "Invalid DATA";
|
|
|
730 $int->set_grammar_record(substr($text, 0, $len, ''));
|
|
|
731 # set events
|
|
|
732 length $text >= 2 or croak "Invalid DATA";
|
|
|
733 ($len) = unpack('v', substr($text, 0, 2, ''));
|
|
|
734 length $text >= $len or croak "Invalid DATA";
|
|
|
735 $int->set_events(substr($text, 0, $len, ''));
|
|
|
736 # set registers
|
|
|
737 length $text >= 2 or croak "Invalid DATA";
|
|
|
738 ($len) = unpack('v', substr($text, 0, 2, ''));
|
|
|
739 length $text >= $len or croak "Invalid DATA";
|
|
|
740 $int->set_registers(substr($text, 0, $len, ''), $over);
|
|
|
741 # set constants
|
|
|
742 length $text >= 2 or croak "Invalid DATA";
|
|
|
743 ($len) = unpack('v', substr($text, 0, 2, ''));
|
|
|
744 length $text >= $len or croak "Invalid DATA";
|
|
|
745 $int->set_constants(substr($text, 0, $len, ''));
|
|
|
746 # all done
|
|
|
747 $text eq '' or croak "Invalid DATA";
|
|
|
748 $int;
|
|
|
749 }
|
|
|
750
|
|
|
751 sub read {
|
|
|
752 @_ == 2 or croak "Usage: INTERPRETER->read(FILEHANDLE)";
|
|
|
753 my ($int, $fh) = @_;
|
|
|
754 $int->{object}->add_flag('__interpreter_format', 1);
|
|
|
755 $int->{object}->read($fh);
|
|
|
756 # find all registers
|
|
|
757 my $tp = $int->{default};
|
|
|
758 my $rp = $tp->{registers};
|
|
|
759 my @nregs = grep {
|
|
|
760 /^[\^\%]/ &&
|
|
|
761 ! exists $rp->{$_}{default} &&
|
|
|
762 $rp->{$_}{value}->isa('Language::INTERCAL::Numbers')
|
|
|
763 } keys %$rp;
|
|
|
764 my @aregs = grep {
|
|
|
765 /^[\^\%]/ &&
|
|
|
766 ! exists $rp->{$_}{default} &&
|
|
|
767 ! $rp->{$_}{value}->isa('Language::INTERCAL::Numbers')
|
|
|
768 } keys %$rp;
|
|
|
769 my %rtype = ();
|
|
|
770 my @rtype = ();
|
|
|
771 for my $r (@nregs, @aregs) {
|
|
|
772 my $v = $rp->{$r}{value};
|
|
|
773 my $t = $v->can('type') ? $v->type : 'spot';
|
|
|
774 next if exists $rtype{$t};
|
|
|
775 $rtype{$t} = @rtype;
|
|
|
776 push @rtype, $t;
|
|
|
777 }
|
|
|
778 # find all rules
|
|
|
779 my $rules = $tp->{rules};
|
|
|
780 # read all counts
|
|
|
781 $fh->read_binary(pack('v*', scalar @nregs, scalar @aregs, scalar @rtype,
|
|
|
782 scalar @$rules, map { scalar @$_ } @$rules));
|
|
|
783 # read all registers
|
|
|
784 for my $r (@rtype) {
|
|
|
785 $fh->read_binary(pack('v/a*', $r));
|
|
|
786 }
|
|
|
787 for my $r (@nregs) {
|
|
|
788 my $v = $rp->{$r}{value};
|
|
|
789 my $t = $v->can('type') ? $v->type : 'spot';
|
|
|
790 $t = $rtype{$t};
|
|
|
791 $fh->read_binary(pack('avCv', substr($r, 0, 1), substr($r, 1),
|
|
|
792 $t, $v->number));
|
|
|
793 }
|
|
|
794 for my $r (@aregs) {
|
|
|
795 my $v = $rp->{$r}{value};
|
|
|
796 my $t = $r->can('type') ? $v->type : 'spot';
|
|
|
797 $t = $rtype{$t};
|
|
|
798 my @v = $v->as_list;
|
|
|
799 $fh->read_binary(pack('avCv*', substr($r, 0, 1), substr($r, 1),
|
|
|
800 $t, scalar @v, @v));
|
|
|
801 }
|
|
|
802 # read all rules
|
|
|
803 for my $r (@$rules) {
|
|
|
804 $fh->read_binary(pack('C*', map { $_ ? ($$_ ? 2 : 1) : 0 } @$r));
|
|
|
805 }
|
|
|
806 # read all syscode
|
|
|
807 my @sys = keys %{$int->{syscode}};
|
|
|
808 $fh->read_binary(pack('v', scalar @sys));
|
|
|
809 for my $sys (@sys) {
|
|
|
810 $fh->read_binary(pack('v v/a*', $sys, $int->{syscode}{$sys}));
|
|
|
811 }
|
|
|
812 # read all user-created opcodes
|
|
|
813 my $mr = $tp->{make_record};
|
|
|
814 $fh->read_binary(pack('v', scalar @$mr));
|
|
|
815 for my $mre (@$mr) {
|
|
|
816 my ($op, $template, $code) = @$mre;
|
|
|
817 $fh->read_binary(pack('vvv', $op, length($template), length($code)));
|
|
|
818 $fh->read_binary($template);
|
|
|
819 $fh->read_binary($code);
|
|
|
820 }
|
|
|
821 $int;
|
|
|
822 }
|
|
|
823
|
|
|
824 sub write {
|
|
|
825 @_ == 3 || @_ == 4
|
|
|
826 or croak "Usage: Language::INTERCAL::Interpreter->write(RC, "
|
|
|
827 . "FILEHANDLE [, AVOID_SKIP?])";
|
|
|
828 my ($class, $rc, $fh, $ask) = @_;
|
|
|
829 my $object = Language::INTERCAL::Object->write($fh, 0, $ask);
|
|
|
830 my $int = $class->new($rc, $object);
|
|
|
831 # write all counts
|
|
|
832 my ($nregs, $aregs, $ntype, $rcount) = unpack('v4', $fh->write_binary(8));
|
|
|
833 my @rcount = unpack('v*', $fh->write_binary(2 * $rcount));
|
|
|
834 # write all registers
|
|
|
835 my @rtype = ();
|
|
|
836 while (@rtype < $ntype) {
|
|
|
837 my $tlen = unpack('v', $fh->write_binary(2));
|
|
|
838 push @rtype, $fh->write_binary($tlen);
|
|
|
839 }
|
|
|
840 my $ptr = $int->{default};
|
|
|
841 my $rp = $ptr->{registers};
|
|
|
842 while ($nregs-- > 0) {
|
|
|
843 my ($prefix, $num, $type, $val) = unpack('avCv', $fh->write_binary(6));
|
|
|
844 my $name = $prefix . $num;
|
|
|
845 _create_register($int, $ptr, 'write', $name, {});
|
|
|
846 $rp->{$name}{value} =
|
|
|
847 Language::INTERCAL::DoubleOhSeven->new($rtype[$type], $object, $val);
|
|
|
848 delete $rp->{$name}{default};
|
|
|
849 }
|
|
|
850 while ($aregs-- > 0) {
|
|
|
851 my ($prefix, $num, $type, $val) = unpack('avCv', $fh->write_binary(6));
|
|
|
852 my $name = $prefix . $num;
|
|
|
853 _create_register($int, $ptr, 'write', $name, {});
|
|
|
854 my @val = unpack('v*', $fh->write_binary(2 * $val));
|
|
|
855 $rp->{$name}{value} =
|
|
|
856 Language::INTERCAL::SharkFin->new($rtype[$type], \@val);
|
|
|
857 delete $rp->{$name}{default};
|
|
|
858 }
|
|
|
859 # write all rules
|
|
|
860 while ($rcount-- > 0) {
|
|
|
861 my $r = shift @rcount;
|
|
|
862 my @r = ();
|
|
|
863 for my $v (unpack('C*', $fh->write_binary($r))) {
|
|
|
864 if ($v) {
|
|
|
865 my $w = $v > 1 ? 1 : 0;
|
|
|
866 push @r, \$w;
|
|
|
867 } else {
|
|
|
868 push @r, 0;
|
|
|
869 }
|
|
|
870 }
|
|
|
871 push @{$ptr->{rules}}, \@r;
|
|
|
872 }
|
|
|
873 # write all syscode
|
|
|
874 my $sys = unpack('v', $fh->write_binary(2));
|
|
|
875 while ($sys-- > 0) {
|
|
|
876 my ($num, $len) = unpack('vv', $fh->write_binary(4));
|
|
|
877 $int->{syscode}{$num} = $fh->write_binary($len);
|
|
|
878 }
|
|
|
879 # write all user-created opcodes
|
|
|
880 my $mrc = unpack('v', $fh->write_binary(2));
|
|
|
881 my @mr = ();
|
|
|
882 while ($mrc-- > 0) {
|
|
|
883 my ($op, $tl, $cl) = unpack('vvv', $fh->write_binary(6));
|
|
|
884 my $template = $fh->write_binary($tl);
|
|
|
885 my $code = $fh->write_binary($cl);
|
|
|
886 push @mr, [$op, $template, $code];
|
|
|
887 $ptr->{opcodes}{$op} = [$template, $code];
|
|
|
888 }
|
|
|
889 $int->{make_record} = \@mr;
|
|
|
890 $int;
|
|
|
891 }
|
|
|
892
|
|
|
893 sub _dup_thread {
|
|
|
894 my ($int, $tp) = @_;
|
|
|
895 my $dt = _make_thread($int->{object}, $tp, $int);
|
|
|
896 push @{$int->{threads}}, $dt;
|
|
|
897 $dt;
|
|
|
898 }
|
|
|
899
|
|
|
900 sub _make_thread {
|
|
|
901 my ($object, $tp, $int) = @_;
|
|
|
902 my %thread = (
|
|
|
903 registers => {},
|
|
|
904 opcodes => {},
|
|
|
905 assign => {},
|
|
|
906 stash => {},
|
|
|
907 rules => [],
|
|
|
908 next_stack => [],
|
|
|
909 lecture_stack => [],
|
|
|
910 ab_label => {},
|
|
|
911 ab_gerund => {},
|
|
|
912 running => 1,
|
|
|
913 s_pointer => 0,
|
|
|
914 loop_id => {},
|
|
|
915 loop_code => [],
|
|
|
916 in_loop => [],
|
|
|
917 comefrom => [],
|
|
|
918 grammar_record => [],
|
|
|
919 make_record => [],
|
|
|
920 pending_writes => [],
|
|
|
921 newline => 1,
|
|
|
922 );
|
|
|
923 if ($tp) {
|
|
|
924 # copy common pointers
|
|
|
925 $thread{s_pointer} = $tp->{s_pointer};
|
|
|
926 @{$thread{comefrom}} = @{$tp->{comefrom}};
|
|
|
927 # copy the thread's registers
|
|
|
928 for my $r (keys %{$tp->{registers}}) {
|
|
|
929 $thread{registers}{$r} = $tp->{registers}{$r};
|
|
|
930 $thread{stash}{$r} = $tp->{stash}{$r}
|
|
|
931 if exists $tp->{stash}{$r};
|
|
|
932 }
|
|
|
933 # copy the thread's opcodes, assignments, stacks
|
|
|
934 %{$thread{opcodes}} = %{$tp->{opcodes}};
|
|
|
935 %{$thread{assign}} = %{$tp->{assign}};
|
|
|
936 $thread{next_stack} = _deep_copy($tp->{next_stack});
|
|
|
937 $thread{lecture_stack} = _deep_copy($tp->{lecture_stack});
|
|
|
938 # copy the thread's rules
|
|
|
939 for my $ra (@{$tp->{rules}}) {
|
|
|
940 my @ra = @{$ra || []};
|
|
|
941 push @{$thread{rules}}, \@ra;
|
|
|
942 }
|
|
|
943 # copy current abstain status
|
|
|
944 %{$thread{ab_label}} = %{$tp->{ab_label}};
|
|
|
945 %{$thread{ab_gerund}} = %{$tp->{ab_gerund}};
|
|
|
946 # copy any current loop
|
|
|
947 @{$thread{loop_code}} = @{$tp->{loop_code}};
|
|
|
948 %{$thread{loop_id}} = %{$tp->{loop_id}};
|
|
|
949 @{$thread{in_loop}} = @{$tp->{in_loop}};
|
|
|
950 # copy the current records
|
|
|
951 $thread{grammar_record} = $tp->{grammar_record};
|
|
|
952 $thread{make_record} = $tp->{make_record};
|
|
|
953 # undocumented I/O mode
|
|
|
954 $thread{newline} = $tp->{newline};
|
|
|
955 } else {
|
|
|
956 # create an initial set of registers
|
|
|
957 for my $r (reg_list) {
|
|
|
958 my $name = reg_name($r);
|
|
|
959 my $ignore = 0;
|
|
|
960 $thread{registers}{$name} = {
|
|
|
961 value => reg_create($r, $object),
|
|
|
962 ignore => 0,
|
|
|
963 default => 1,
|
|
|
964 };
|
|
|
965 }
|
|
|
966 # creates an initial set of opcodes - copy is intentional
|
|
|
967 %{$thread{opcodes}} = %default_opcodes;
|
|
|
968 }
|
|
|
969 return \%thread;
|
|
|
970 }
|
|
|
971
|
|
|
972 sub _deep_copy {
|
|
|
973 my ($src) = @_;
|
|
|
974 return $src if ! defined $src || ! ref $src;
|
|
|
975 # don't copy filehandles...
|
|
|
976 if (UNIVERSAL::isa($src, 'Language::INTERCAL::GenericIO')) {
|
|
|
977 return $src;
|
|
|
978 }
|
|
|
979 if (ref $src eq 'GLOB' || UNIVERSAL::isa($src, 'GLOB')) {
|
|
|
980 return $src;
|
|
|
981 }
|
|
|
982 if (ref $src eq 'CODE') {
|
|
|
983 # no deep copy of code...
|
|
|
984 return $src;
|
|
|
985 }
|
|
|
986 if (ref $src eq 'SCALAR' || ref $src eq 'REF') {
|
|
|
987 my $c = $$src;
|
|
|
988 return \$c;
|
|
|
989 }
|
|
|
990 if (UNIVERSAL::isa($src, 'SCALAR')) {
|
|
|
991 my $c = $$src;
|
|
|
992 bless \$c, ref $src;
|
|
|
993 return \$c;
|
|
|
994 }
|
|
|
995 if (ref $src eq 'ARRAY') {
|
|
|
996 my $c = [ map { _deep_copy($_) } @$src ];
|
|
|
997 return $c;
|
|
|
998 }
|
|
|
999 if (UNIVERSAL::isa($src, 'ARRAY')) {
|
|
|
1000 my $c = [ map { _deep_copy($_) } @$src ];
|
|
|
1001 bless $c, ref $src;
|
|
|
1002 return $c;
|
|
|
1003 }
|
|
|
1004 if (ref $src eq 'HASH') {
|
|
|
1005 my $c = { map { ( $_ => _deep_copy($src->{$_}) ) } keys %$src };
|
|
|
1006 return $c;
|
|
|
1007 }
|
|
|
1008 if (UNIVERSAL::isa($src, 'HASH')) {
|
|
|
1009 my $c = { map { ( $_ => _deep_copy($src->{$_}) ) } keys %$src };
|
|
|
1010 bless $c, ref $src;
|
|
|
1011 return $c;
|
|
|
1012 }
|
|
|
1013 if (ref $src eq 'Regexp') {
|
|
|
1014 return qr/$src/;
|
|
|
1015 }
|
|
|
1016 if (UNIVERSAL::isa($src, 'Regexp')) {
|
|
|
1017 my $c = qr/$src/;
|
|
|
1018 bless $c, ref $src;
|
|
|
1019 return $c;
|
|
|
1020 }
|
|
|
1021 faint(SP_INTERNAL, "_deep_copy of unrecognised reference");
|
|
|
1022 }
|
|
|
1023
|
|
|
1024 sub start {
|
|
|
1025 @_ == 1 || @_ == 2
|
|
|
1026 or croak "Usage: INTERPRETER->start [(FLAGS)]";
|
|
|
1027 my ($int, $flags) = @_;
|
|
|
1028 $int->{threads} = [];
|
|
|
1029 $int->{compiling} = $flags || 0;
|
|
|
1030 $int->setreg('%SP', 1000);
|
|
|
1031 $int;
|
|
|
1032 }
|
|
|
1033
|
|
|
1034 sub stop {
|
|
|
1035 @_ == 1 or croak "Usage: INTERPRETER->stop";
|
|
|
1036 my ($int) = @_;
|
|
|
1037 $int->{threads} = [];
|
|
|
1038 $int->{loop_id} = 0;
|
|
|
1039 $int;
|
|
|
1040 }
|
|
|
1041
|
|
|
1042 sub splat {
|
|
|
1043 @_ == 1 or croak "Usage: INTERPRETER->splat";
|
|
|
1044 my ($int) = @_;
|
|
|
1045 exists $int->{default}{registers}{$reg_sp} or return undef;
|
|
|
1046 $int->{default}{registers}{$reg_sp}{value}->print;
|
|
|
1047 }
|
|
|
1048
|
|
|
1049 sub theft_server {
|
|
|
1050 @_ == 1 || @_ == 2
|
|
|
1051 or croak "Usage: INTERPRETER->theft_server [(NEW_SERVER)]";
|
|
|
1052 my $int = shift;
|
|
|
1053 my $old_server = $int->{theft_server};
|
|
|
1054 $int->{theft_server} = shift if @_;
|
|
|
1055 $old_server;
|
|
|
1056 }
|
|
|
1057
|
|
|
1058 sub server {
|
|
|
1059 @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->server [(NEW_SERVER)]";
|
|
|
1060 my $int = shift;
|
|
|
1061 my $old_server = $int->{server};
|
|
|
1062 $int->{server} = shift if @_;
|
|
|
1063 $old_server;
|
|
|
1064 }
|
|
|
1065
|
|
|
1066 sub run {
|
|
|
1067 @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->run [(INTERPRETER)]";
|
|
|
1068 my ($int, $ci) = @_;
|
|
|
1069 my $tp = _make_thread($int->{object}, $int->{default}, $int);
|
|
|
1070 $int->{threads} = [$tp];
|
|
|
1071 $int->{loop_id} = 0;
|
|
|
1072 $ci ||= $int;
|
|
|
1073 ($int->{code}, $int->{cptr}) = $ci->{object}->code;
|
|
|
1074 $int->{source} = $ci->{object}->source;
|
|
|
1075 my $cr = $ci->{default}{rules}[0];
|
|
|
1076 if ($cr) {
|
|
|
1077 for (my $r = 0; $r < @$cr; $r++) {
|
|
|
1078 next unless $cr->[$r];
|
|
|
1079 _create_rule($int, $tp, 0, $r, {});
|
|
|
1080 ${$tp->{rules}[0][$r]} = ${$cr->[$r]};
|
|
|
1081 }
|
|
|
1082 }
|
|
|
1083 # are we going to be victims of theft?
|
|
|
1084 $int->{server}
|
|
|
1085 or $int->{server} =
|
|
|
1086 Language::INTERCAL::Server->new;
|
|
|
1087 eval {
|
|
|
1088 require Language::INTERCAL::Theft;
|
|
|
1089 import Language::INTERCAL::Theft '1.-94.-2';
|
|
|
1090 };
|
|
|
1091 unless ($@) {
|
|
|
1092 my $th = $int->{default}{registers}{$reg_th};
|
|
|
1093 if (! ($int->{compiling} & 1) && $th->{value} && $th->{value}->number) {
|
|
|
1094 $int->{theft_server}
|
|
|
1095 or $int->{theft_server} =
|
|
|
1096 Language::INTERCAL::Theft->new($int->{server}, $int->{rc},
|
|
|
1097 \&_theft, $int);
|
|
|
1098 }
|
|
|
1099 }
|
|
|
1100 $tp->{s_pointer} = 0;
|
|
|
1101 $tp = $int->{threads};
|
|
|
1102 @$tp = grep { $_->{running} } @$tp;
|
|
|
1103 while (@$tp) {
|
|
|
1104 $int->{server} and $int->{server}->progress(0);
|
|
|
1105 for (my $n = 0; $n < @$tp; $n++) {
|
|
|
1106 if (@{$tp->[$n]{in_loop}}) {
|
|
|
1107 # if this is a loop condition, stop the body
|
|
|
1108 my $loop_id = pop @{$tp->[$n]{in_loop}};
|
|
|
1109 delete $tp->[$n]{loop_id}{$loop_id};
|
|
|
1110 }
|
|
|
1111 _trace_init($int);
|
|
|
1112 my %runenv = ();
|
|
|
1113 eval { _step($int, $tp->[$n], \%runenv) };
|
|
|
1114 # report a splat if appropriate
|
|
|
1115 _splat($int, $tp->[$n], \%runenv, $@) if $@;
|
|
|
1116 _trace_exit($int, $tp->[$n]);
|
|
|
1117 }
|
|
|
1118 my $ep = $int->{events};
|
|
|
1119 if ($ep && @$ep) {
|
|
|
1120 my $svcode = $int->{code};
|
|
|
1121 for (my $e = 0; $e < @$ep; $e++) {
|
|
|
1122 my $etp = _dup_thread($int, $int->{default});
|
|
|
1123 _trace_init($int);
|
|
|
1124 _stash_register($int, $etp, 'EVENT', $reg_sp, {});
|
|
|
1125 my ($code, $cond, $cend, $body, $bend, $bge) = @{$ep->[$e]};
|
|
|
1126 $int->{code} = $code;
|
|
|
1127 _trace_mark($int, $etp, 'EVENT', $e);
|
|
|
1128 eval {
|
|
|
1129 my $cp = $cond;
|
|
|
1130 _run($int, $etp, {}, \$cp, $cend, 1);
|
|
|
1131 };
|
|
|
1132 _retrieve_register($int, $etp, 'EVENT', $reg_sp, {});
|
|
|
1133 _trace_exit($int, $etp);
|
|
|
1134 if ($@) {
|
|
|
1135 $etp->{running} = 0;
|
|
|
1136 next;
|
|
|
1137 }
|
|
|
1138 # the event might have been scheduled with totally different
|
|
|
1139 # code, add it if necessary
|
|
|
1140 my $bc = substr($code, $body, $bend - $body);
|
|
|
1141 my $bp = index($int->{code}, $bc);
|
|
|
1142 if ($bp < 0) {
|
|
|
1143 $bp = length($int->{code});
|
|
|
1144 $int->{code} .= $bc;
|
|
|
1145 }
|
|
|
1146 my $be = $bp + length($bc);
|
|
|
1147 $etp->{loop_code} = [$bp, $be, $bge, undef, $etp->{comefrom}];
|
|
|
1148 @{$etp->{comefrom}} = ();
|
|
|
1149 splice(@$ep, $e, 1);
|
|
|
1150 $e--;
|
|
|
1151 }
|
|
|
1152 $int->{code} = $svcode;
|
|
|
1153 }
|
|
|
1154 @$tp = grep { $_->{running} } @$tp;
|
|
|
1155 }
|
|
|
1156 $int;
|
|
|
1157 }
|
|
|
1158
|
|
|
1159 sub _splat {
|
|
|
1160 my ($int, $tp, $runenv, $smsg) = @_;
|
|
|
1161 my $scode;
|
|
|
1162 if ($smsg =~ s/^\*?(\d+)\s*//) {
|
|
|
1163 $scode = $1;
|
|
|
1164 $scode =~ s/^0*(\d)/$1/;
|
|
|
1165 $smsg = sprintf("*%03d %s", $scode, $smsg);
|
|
|
1166 } else {
|
|
|
1167 $scode = 0;
|
|
|
1168 $smsg = "*000 $smsg";
|
|
|
1169 }
|
|
|
1170 $smsg =~ s/\n*$/\n/;
|
|
|
1171 my $r = eval {
|
|
|
1172 $tp->{registers}{$reg_osfh}{value}->filehandle;
|
|
|
1173 };
|
|
|
1174 $r = $stdsplat if $@;
|
|
|
1175 eval { $r->read_text($smsg) };
|
|
|
1176 _create_register($int, $tp, '*', $reg_sp, {});
|
|
|
1177 delete $tp->{registers}{$reg_sp}{default};
|
|
|
1178 $tp->{registers}{$reg_sp}{value}->assign($scode);
|
|
|
1179 $tp->{running} = 0 unless $runenv->{quantum};
|
|
|
1180 }
|
|
|
1181
|
|
|
1182 sub _step {
|
|
|
1183 my ($int, $tp, $runenv) = @_;
|
|
|
1184 # find current statement - note that we may try to execute the
|
|
|
1185 # middle of a comment!
|
|
|
1186 my ($qu, $cs, $cl, $ge, $ab, $lab, $ls, $ll, $cp);
|
|
|
1187 if ($tp->{loop_code} && @{$tp->{loop_code}}) {
|
|
|
1188 my $ct;
|
|
|
1189 ($cs, $cl, $ge, $ct) = @{$tp->{loop_code}};
|
|
|
1190 if (defined $ct) {
|
|
|
1191 # check loop condition still exists
|
|
|
1192 my $found = 0;
|
|
|
1193 for my $t (@{$int->{threads}}) {
|
|
|
1194 next if ! exists $t->{loop_id}{$ct};
|
|
|
1195 $found = 1;
|
|
|
1196 last;
|
|
|
1197 }
|
|
|
1198 if (! $found) {
|
|
|
1199 $tp->{running} = 0;
|
|
|
1200 _trace_mark($int, $tp, 'ENDLOOP', $cs, $cl);
|
|
|
1201 return;
|
|
|
1202 }
|
|
|
1203 _trace_mark($int, $tp, 'LOOP', $cs, $cl);
|
|
|
1204 } else {
|
|
|
1205 # event, which must be executed just this once, so next time
|
|
|
1206 # we are going to find an unexistent loop_id
|
|
|
1207 $tp->{loop_code}[3] = -1;
|
|
|
1208 _trace_mark($int, $tp, 'EVENT', $cs, $cl);
|
|
|
1209 }
|
|
|
1210 $qu = $ab = $lab = $ll = $ls = 0;
|
|
|
1211 $cp = undef;
|
|
|
1212 } else {
|
|
|
1213 my ($sl, $ds, $dl);
|
|
|
1214 $cp = $tp->{s_pointer};
|
|
|
1215 ($cs, $cl, $sl, $ab, $ls, $ll, $ds, $dl, $ge, $qu) =
|
|
|
1216 find_code($int->{cptr}, $cp, $tp->{rules}[0]);
|
|
|
1217 if (! defined $cs) {
|
|
|
1218 _trace_mark($int, $tp, 'EOP', $cp, defined $sl ? $sl : '?');
|
|
|
1219 if (! defined $sl && $int->{source} ne '') {
|
|
|
1220 faint(SP_FALL_OFF) if $int->{source} eq '';
|
|
|
1221 $sl = length($int->{source}) - $cp;
|
|
|
1222 } elsif ($int->{source} eq '') {
|
|
|
1223 faint(SP_COMMENT, "Invalid statement");
|
|
|
1224 }
|
|
|
1225 my $line = substr($int->{source}, $cp, $sl);
|
|
|
1226 $line =~ s/^\s+//;
|
|
|
1227 $line =~ s/\s+$//;
|
|
|
1228 faint(SP_COMMENT, $line) if $line =~ /\S/;
|
|
|
1229 faint(SP_COMMENT, "Invalid statement");
|
|
|
1230 }
|
|
|
1231 _trace_mark($int, $tp, 'STS', $cs, $cl, $cp, $sl, $qu);
|
|
|
1232 $lab = $ls;
|
|
|
1233 if ($ll > 0) {
|
|
|
1234 my $xls = $ls;
|
|
|
1235 $lab = _get_number($int, $tp, 'LAB', {}, \$xls, $xls + $ll, 1);
|
|
|
1236 _trace_mark($int, $tp, 'LAB', $lab);
|
|
|
1237 } elsif ($lab > 0) {
|
|
|
1238 # label is a constant, but need to check if the value of the, ehm,
|
|
|
1239 # constant, has changed
|
|
|
1240 if (exists $tp->{assign}{$lab}) {
|
|
|
1241 $lab = ${$tp->{assign}{$lab}};
|
|
|
1242 _trace_mark($int, $tp, 'LAB', $lab, $ls);
|
|
|
1243 } else {
|
|
|
1244 _trace_mark($int, $tp, 'LAB', $lab);
|
|
|
1245 }
|
|
|
1246 }
|
|
|
1247 $cl += $cs;
|
|
|
1248 $tp->{s_pointer} = $cp + $sl;
|
|
|
1249 if ($dl > 0 || $ds > 0) {
|
|
|
1250 my $dsx = $ds - 1;
|
|
|
1251 $dsx = _get_number($int, $tp, '%', {}, \$ds, $ds + $dl, 1)
|
|
|
1252 if $dl > 0;
|
|
|
1253 my $dsa = rand(100) >= $dsx ? 1 : 0;
|
|
|
1254 _trace_mark($int, $tp, 'DSX', $dsx, $dsa);
|
|
|
1255 if ($dsa) {
|
|
|
1256 $tp->{comefrom} = [$ls, $ll, $ge, $cp];
|
|
|
1257 _comefrom($int, $tp);
|
|
|
1258 return;
|
|
|
1259 }
|
|
|
1260 }
|
|
|
1261 # nowadays one can ABSTAIN FROM QUANTUM COMPUTING
|
|
|
1262 if ($qu && exists $tp->{ab_gerund}{&BC_QUA}) {
|
|
|
1263 $qu = ! $tp->{ab_gerund}{&BC_QUA}[0];
|
|
|
1264 }
|
|
|
1265 }
|
|
|
1266 $tp->{comefrom} = [$ls, $ll, $ge, $cp];
|
|
|
1267 # check if an ABSTAIN/REINSTATE applies to this statement
|
|
|
1268 my $abr = 'NOT';
|
|
|
1269 if ($lab && exists $tp->{ab_label}{$lab}) {
|
|
|
1270 if ($ge && $ge != BC_GUP && exists $tp->{ab_gerund}{$ge}) {
|
|
|
1271 if ($tp->{ab_gerund}{$ge}[1] > $tp->{ab_label}{$lab}[1]) {
|
|
|
1272 $ab = $tp->{ab_gerund}{$ge}[0];
|
|
|
1273 $abr = "GER$ge";
|
|
|
1274 } else {
|
|
|
1275 $ab = $tp->{ab_label}{$lab}[0];
|
|
|
1276 $abr = "LAB$lab";
|
|
|
1277 }
|
|
|
1278 } else {
|
|
|
1279 $ab = $tp->{ab_label}{$lab}[0];
|
|
|
1280 $abr = "LAB$lab";
|
|
|
1281 }
|
|
|
1282 } elsif ($ge && $ge != BC_GUP && exists $tp->{ab_gerund}{$ge}) {
|
|
|
1283 $ab = $tp->{ab_gerund}{$ge}[0];
|
|
|
1284 $abr = "GER$ge";
|
|
|
1285 }
|
|
|
1286 if ($ab) {
|
|
|
1287 # ABSTAINed FROM
|
|
|
1288 _trace_mark($int, $tp, 'ABSTAIN', $abr);
|
|
|
1289 _comefrom($int, $tp);
|
|
|
1290 return;
|
|
|
1291 }
|
|
|
1292 my @qu = ();
|
|
|
1293 if ($qu) {
|
|
|
1294 $runenv->{quantum} = \@qu;
|
|
|
1295 }
|
|
|
1296 delete $int->{recompile};
|
|
|
1297 while ($cs < $cl && $tp->{running}) {
|
|
|
1298 _run($int, $tp, $runenv, \$cs, $cl, 1);
|
|
|
1299 }
|
|
|
1300 if (@qu) {
|
|
|
1301 # undo the effects of the statement while not undoing it
|
|
|
1302 my @tc = ();
|
|
|
1303 for my $T (@{$int->{threads}}) {
|
|
|
1304 # do we share anything with this thread?
|
|
|
1305 my $share = 0;
|
|
|
1306 SHARE:
|
|
|
1307 for my $item (@qu) {
|
|
|
1308 my ($undo, @ptr) = @$item;
|
|
|
1309 my $ptr = $tp;
|
|
|
1310 my $spt = $T;
|
|
|
1311 for my $p (@ptr) {
|
|
|
1312 if (! ref $ptr) {
|
|
|
1313 next SHARE;
|
|
|
1314 } elsif (UNIVERSAL::isa($ptr, 'ARRAY')) {
|
|
|
1315 $ptr = $ptr->[$p];
|
|
|
1316 $spt = $spt->[$p];
|
|
|
1317 } else {
|
|
|
1318 $ptr = $ptr->{$p};
|
|
|
1319 $spt = $spt->{$p};
|
|
|
1320 }
|
|
|
1321 defined $ptr && defined $spt or next SHARE;
|
|
|
1322 }
|
|
|
1323 $ptr == $spt or next SHARE;
|
|
|
1324 $share = 1;
|
|
|
1325 last SHARE;
|
|
|
1326 }
|
|
|
1327 next unless $share;
|
|
|
1328 push @tc, $T;
|
|
|
1329 }
|
|
|
1330 for my $T (@tc) {
|
|
|
1331 my $dt = _dup_thread($int, $T);
|
|
|
1332 # do we share anything with this thread?
|
|
|
1333 SHARE:
|
|
|
1334 for my $item (@qu) {
|
|
|
1335 my ($undo, @ptr) = @$item;
|
|
|
1336 my $ptr = $tp;
|
|
|
1337 my $spt = $T;
|
|
|
1338 my $dpt = $dt;
|
|
|
1339 my $lptr = pop @ptr;
|
|
|
1340 for my $p (@ptr) {
|
|
|
1341 if (UNIVERSAL::isa($ptr, 'ARRAY')) {
|
|
|
1342 $ptr = $ptr->[$p];
|
|
|
1343 $spt = $spt->[$p];
|
|
|
1344 $dpt = $dpt->[$p];
|
|
|
1345 } else {
|
|
|
1346 $ptr = $ptr->{$p};
|
|
|
1347 $spt = $spt->{$p};
|
|
|
1348 $dpt = $dpt->{$p};
|
|
|
1349 }
|
|
|
1350 defined $ptr && defined $spt or next SHARE;
|
|
|
1351 }
|
|
|
1352 if (UNIVERSAL::isa($ptr, 'ARRAY')) {
|
|
|
1353 $ptr = $ptr->[$lptr];
|
|
|
1354 $spt = $spt->[$lptr];
|
|
|
1355 defined $ptr && defined $spt or next SHARE;
|
|
|
1356 $dpt->[$lptr] = $undo;
|
|
|
1357 } else {
|
|
|
1358 $ptr = $ptr->{$lptr};
|
|
|
1359 $spt = $spt->{$lptr};
|
|
|
1360 defined $ptr && defined $spt or next SHARE;
|
|
|
1361 $dpt->{$lptr} = $undo;
|
|
|
1362 }
|
|
|
1363 }
|
|
|
1364 _comefrom($int, $dt) if $T == $tp;
|
|
|
1365 }
|
|
|
1366 }
|
|
|
1367 if ($int->{recompile} && ! ($int->{compiling} & 2)) {
|
|
|
1368 _trace_mark($int, $tp, 'RECOMPILE');
|
|
|
1369 _compile($int, $int->{source});
|
|
|
1370 }
|
|
|
1371 delete $int->{recompile};
|
|
|
1372 _comefrom($int, $tp);
|
|
|
1373 }
|
|
|
1374
|
|
|
1375 sub compile {
|
|
|
1376 @_ == 2 or croak "Usage: INTERPRETER->compile(source)";
|
|
|
1377 my ($int, $src) = @_;
|
|
|
1378 _compile($int, $src);
|
|
|
1379 $int->{object}->setcode($int->{code}, $int->{cptr});
|
|
|
1380 $int->{object}->source($src);
|
|
|
1381 $int;
|
|
|
1382 }
|
|
|
1383
|
|
|
1384 sub _compile {
|
|
|
1385 my ($int, $src) = @_;
|
|
|
1386 my $ps = $int->{default}{registers}{$reg_ps}{value}->number;
|
|
|
1387 my $is = $int->{default}{registers}{$reg_is}{value}->number;
|
|
|
1388 my $ss = $int->{default}{registers}{$reg_ss}{value}->number;
|
|
|
1389 my $js = $int->{default}{registers}{$reg_js}{value}->number;
|
|
|
1390 my $parser = $int->{object}->parser(1);
|
|
|
1391 my @code =
|
|
|
1392 $parser->compile_top($ps, $is, $src, 0, $ss, $js, $int->{verbose});
|
|
|
1393 ($int->{code}, $int->{cptr}) = $int->{object}->make_code(\@code);
|
|
|
1394 delete $int->{recompile};
|
|
|
1395 }
|
|
|
1396
|
|
|
1397 sub _comefrom {
|
|
|
1398 my ($int, $tp) = @_;
|
|
|
1399 return unless $tp->{comefrom} && @{$tp->{comefrom}};
|
|
|
1400 my ($clab, $cll, $cger, $here) = @{$tp->{comefrom}};
|
|
|
1401 $cger = 0 if $cger && ! ($tp->{registers}{$reg_cf}{value}->number & 2);
|
|
|
1402 return unless $clab || $cll || $cger;
|
|
|
1403 my $cflab = $clab || bytedecode($cger) || "#$cger";
|
|
|
1404 my $lab_start = $clab;
|
|
|
1405 my $label_change = 0;
|
|
|
1406 if ($cll > 0) {
|
|
|
1407 # computed label might have changed since we last calculated it
|
|
|
1408 my $xls = $lab_start;
|
|
|
1409 $label_change ||= is_constant(ord(substr($int->{code}, $xls, 1)));
|
|
|
1410 $clab = _get_number($int, $tp, 'LAB', {}, \$xls, $xls + $cll, 1);
|
|
|
1411 } elsif (exists $tp->{assign}{$clab}) {
|
|
|
1412 # constant label might have changed too. Happens
|
|
|
1413 $clab = ${$tp->{assign}{$clab}};
|
|
|
1414 }
|
|
|
1415 return unless $clab || $cger;
|
|
|
1416 _trace_mark($int, $tp, 'COMEFROM', $cflab);
|
|
|
1417 my %cf = ();
|
|
|
1418 my %cfl = ();
|
|
|
1419 my $quantum = 0;
|
|
|
1420 my $co = sub {
|
|
|
1421 my ($cs, $cl, $ss, $sl, $ab, $ls, $sll, $ds, $dl, $ge, $qu) = @_;
|
|
|
1422 return if ! exists $come_froms{$ge};
|
|
|
1423 return if exists $cf{$ss};
|
|
|
1424 return if ! $ls && exists $cfl{$ss + $sl} && $cfl{$ss + $sl} <= $ss;
|
|
|
1425 $cfl{$ss + $sl} = $ss;
|
|
|
1426 my $name = bytedecode($ge);
|
|
|
1427 _trace_mark($int, $tp, 'COMEFROM', $name, $ss, $ss + $sl - 1);
|
|
|
1428 my $slab = $ls;
|
|
|
1429 if ($sll > 0) {
|
|
|
1430 $slab = _get_number($int, $tp, 'LAB', {}, \$ls, $ls + $sll, 1);
|
|
|
1431 } elsif (exists $tp->{assign}{$slab}) {
|
|
|
1432 $slab = ${$tp->{assign}{$slab}};
|
|
|
1433 }
|
|
|
1434 # check if an ABSTAIN/REINSTATE applies to this statement
|
|
|
1435 if ($slab && exists $tp->{ab_label}{$slab}) {
|
|
|
1436 if ($ge && exists $tp->{ab_gerund}{$ge}) {
|
|
|
1437 if ($tp->{ab_gerund}{$ge}[1] > $tp->{ab_label}{$slab}[1]) {
|
|
|
1438 $ab = $tp->{ab_gerund}{$ge}[0];
|
|
|
1439 } else {
|
|
|
1440 $ab = $tp->{ab_label}{$slab}[0];
|
|
|
1441 }
|
|
|
1442 } else {
|
|
|
1443 $ab = $tp->{ab_label}{$slab}[0];
|
|
|
1444 }
|
|
|
1445 } elsif ($ge && exists $tp->{ab_gerund}{$ge}) {
|
|
|
1446 $ab = $tp->{ab_gerund}{$ge}[0];
|
|
|
1447 }
|
|
|
1448 return if $ab;
|
|
|
1449 # is there a double-oh-seven?
|
|
|
1450 if ($dl > 0 || $ds > 0) {
|
|
|
1451 my $dsx = $ds - 1;
|
|
|
1452 $label_change ||= is_constant(ord(substr($int->{code}, $ds, 1)));
|
|
|
1453 $dsx = _get_number($int, $tp, '%', {}, \$ds, $ds + $dl, 1)
|
|
|
1454 if $dl > 0;
|
|
|
1455 my $dsa = rand(100) >= $dsx ? 1 : 0;
|
|
|
1456 return if $dsa;
|
|
|
1457 }
|
|
|
1458 _trace($int, $tp, $ge, 0);
|
|
|
1459 $cl += $cs;
|
|
|
1460 $cs++;
|
|
|
1461 # is it a COME/NEXT FROM label or gerund?
|
|
|
1462 if ($ge == BC_CFL || $ge == BC_NXL) {
|
|
|
1463 if ($label_change) {
|
|
|
1464 $label_change = 0;
|
|
|
1465 if ($cll > 0) {
|
|
|
1466 # computed label might have changed again
|
|
|
1467 my $xls = $lab_start;
|
|
|
1468 $label_change ||= is_constant(ord(substr($int->{code},
|
|
|
1469 $xls, 1)));
|
|
|
1470 $clab = _get_number($int, $tp, 'LAB', {},
|
|
|
1471 \$xls, $xls + $cll, 1);
|
|
|
1472 } elsif (exists $tp->{assign}{$lab_start}) {
|
|
|
1473 # constant label might have changed too. Happens
|
|
|
1474 $clab = ${$tp->{assign}{$lab_start}};
|
|
|
1475 }
|
|
|
1476 }
|
|
|
1477 return unless $clab;
|
|
|
1478 $label_change ||= is_constant(ord(substr($int->{code}, $cs, 1)));
|
|
|
1479 my $l = _get_number($int, $tp, $name, {}, \$cs, $cl, 1);
|
|
|
1480 return if $l != $clab;
|
|
|
1481 } else {
|
|
|
1482 return unless $cger;
|
|
|
1483 my $c = _get_number($int, $tp, $name, {}, \$cs, $cl, 0);
|
|
|
1484 $cs + $c <= $cl
|
|
|
1485 or faint(SP_INVALID, "Not enough opcodes", $name);
|
|
|
1486 my $found = 0;
|
|
|
1487 _trace($int, $tp, '<', 1);
|
|
|
1488 while ($c-- > 0) {
|
|
|
1489 my $g = ord(substr($int->{code}, $cs++, 1));
|
|
|
1490 _trace($int, $tp, $g, 0);
|
|
|
1491 next if $g != $cger;
|
|
|
1492 $found = 1;
|
|
|
1493 last;
|
|
|
1494 }
|
|
|
1495 _trace($int, $tp, $found ? '!>' : '>', 1);
|
|
|
1496 return unless $found;
|
|
|
1497 }
|
|
|
1498 $quantum ||= $qu;
|
|
|
1499 $cf{$ss} = $ge == BC_NXL || $ge == BC_NXG;
|
|
|
1500 };
|
|
|
1501 forall_code($int->{cptr}, 0, $co);
|
|
|
1502 # is system call interface enabled?
|
|
|
1503 if ($clab && exists $tp->{registers}{$reg_os}) {
|
|
|
1504 my $os = $tp->{registers}{$reg_os}{value}->number;
|
|
|
1505 if ($os == $clab) {
|
|
|
1506 # we need to check we are not abstaining from NEXT FROM LABEL
|
|
|
1507 my $ab = exists $tp->{ab_gerund}{&BC_NXL}
|
|
|
1508 ? $tp->{ab_gerund}{&BC_NXL}[0]
|
|
|
1509 : 0;
|
|
|
1510 if (! $ab) {
|
|
|
1511 @{$tp->{registers}{$reg_os}{owners}}
|
|
|
1512 or faint(SP_SYSCALL);
|
|
|
1513 my ($t, $n) = @{$tp->{registers}{$reg_os}{owners}[0]};
|
|
|
1514 exists $tp->{registers}{".$n"}
|
|
|
1515 or faint(SP_SYSCALL);
|
|
|
1516 $cf{-1} = $tp->{registers}{".$n"}{value}->number;
|
|
|
1517 }
|
|
|
1518 }
|
|
|
1519 }
|
|
|
1520 my @cf = keys %cf;
|
|
|
1521 return unless @cf;
|
|
|
1522 # nowadays one can ABSTAIN FROM QUANTUM COMPUTING
|
|
|
1523 if ($quantum && exists $tp->{ab_gerund}{&BC_QUA}) {
|
|
|
1524 $quantum = ! $tp->{ab_gerund}{&BC_QUA}[0];
|
|
|
1525 }
|
|
|
1526 if (@cf > 1 && ! ($tp->{registers}{$reg_cf}{value}->number & 1)) {
|
|
|
1527 if ($quantum) {
|
|
|
1528 # we must splat while at the same time not splatting...
|
|
|
1529 _splat($int, $tp, {quantum => []},
|
|
|
1530 splatdescription(SP_COMEFROM, $cflab));
|
|
|
1531 # and then we don't actually take the COME FROMs
|
|
|
1532 return;
|
|
|
1533 }
|
|
|
1534 faint(SP_COMEFROM, $cflab);
|
|
|
1535 }
|
|
|
1536 my $loops = 0;
|
|
|
1537 while (@cf) {
|
|
|
1538 my $cf = shift @cf;
|
|
|
1539 my $mode = $cf{$cf};
|
|
|
1540 if ($cf < 0) {
|
|
|
1541 # system call - determine system call number
|
|
|
1542 exists $int->{syscode}{$mode}
|
|
|
1543 or faint(SP_NOSYSCALL, '#' . $mode);
|
|
|
1544 my $c = $int->{syscode}{$mode};
|
|
|
1545 my $sv = $int->{code};
|
|
|
1546 $int->{code} = $c;
|
|
|
1547 eval {
|
|
|
1548 my $cp = 0;
|
|
|
1549 while ($cp < length $c) {
|
|
|
1550 _run($int, $tp, {}, \$cp, length $c, 1);
|
|
|
1551 }
|
|
|
1552 };
|
|
|
1553 $int->{code} = $sv;
|
|
|
1554 die $@ if $@;
|
|
|
1555 next;
|
|
|
1556 }
|
|
|
1557 # not a system call - do we need to create a new thread?
|
|
|
1558 my $nt = @cf || $quantum ? _dup_thread($int, $tp) : $tp;
|
|
|
1559 if ($mode) {
|
|
|
1560 # this is a NEXT FROM
|
|
|
1561 @{$nt->{next_stack}} >= MAX_NEXT and faint(SP_NEXTING, MAX_NEXT);
|
|
|
1562 push @{$nt->{next_stack}}, [
|
|
|
1563 $nt->{s_pointer},
|
|
|
1564 [@{$nt->{loop_code}}],
|
|
|
1565 [@{$nt->{in_loop}}],
|
|
|
1566 [], # otherwise we get a NEXT FROM loop when we RESUME
|
|
|
1567 ];
|
|
|
1568 }
|
|
|
1569 $nt->{s_pointer} = $cf;
|
|
|
1570 @{$nt->{loop_code}} = ();
|
|
|
1571 @{$nt->{comefrom}} = ();
|
|
|
1572 @{$nt->{in_loop}} = ();
|
|
|
1573 $loops = 1 if defined $here && $cf == $here;
|
|
|
1574 }
|
|
|
1575 $loops or return;
|
|
|
1576 # avoid wasting CPU time on a tight loop - see if there's something useful
|
|
|
1577 # we can do instead
|
|
|
1578 if ($int->{server}) {
|
|
|
1579 $int->{server}->progress(0.1);
|
|
|
1580 } else {
|
|
|
1581 select undef, undef, undef, 0.1;
|
|
|
1582 }
|
|
|
1583 }
|
|
|
1584
|
|
|
1585 sub _run {
|
|
|
1586 my ($int, $tp, $runenv, $cp, $ep, $varconst) = @_;
|
|
|
1587 faint(SP_FALL_OFF) if $$cp >= $ep;
|
|
|
1588 my $code = $int->{code};
|
|
|
1589 my $byte = ord(substr($code, $$cp, 1));
|
|
|
1590 my ($name, $descr, $type, $number, $args, $const, $assignable) =
|
|
|
1591 bytedecode($byte);
|
|
|
1592 my $ocp = $$cp;
|
|
|
1593 _trace($int, $tp, $byte, 0);
|
|
|
1594 faint(SP_INVALID, $byte, 'run') if ! defined $name;
|
|
|
1595 faint(SP_INVALID, $name, 'assignment')
|
|
|
1596 if $runenv->{assign} && ! $assignable;
|
|
|
1597 if ($const) {
|
|
|
1598 # constant (which may be variable)
|
|
|
1599 my $ocp = $$cp;
|
|
|
1600 my $val = BCget($code, $cp, $ep);
|
|
|
1601 $$cp == $ocp + 1
|
|
|
1602 or _trace($int, $tp, "#" . $val, 1,
|
|
|
1603 unpack('C*', substr($code, $ocp + 1, $$cp - $ocp - 1)));
|
|
|
1604 faint(SP_INVALID, "arguments", $name)
|
|
|
1605 if $$cp > $ep;
|
|
|
1606 if ($varconst && exists $tp->{assign}{$val}) {
|
|
|
1607 $val = ${$tp->{assign}{$val}};
|
|
|
1608 }
|
|
|
1609 if ($runenv->{assign}) {
|
|
|
1610 my $assign = $runenv->{assign};
|
|
|
1611 if (ref $assign eq 'CODE') {
|
|
|
1612 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
1613 }
|
|
|
1614 _assign_constant($int, $tp, $runenv, $val, $assign);
|
|
|
1615 }
|
|
|
1616 return new Language::INTERCAL::Numbers::Spot($val);
|
|
|
1617 } else {
|
|
|
1618 # any other type of opcode
|
|
|
1619 faint(SP_TODO, $name) if ! exists $tp->{opcodes}{$name};
|
|
|
1620 faint(SP_INVALID, $name, '_run')
|
|
|
1621 if ref $tp->{opcodes}{$name} ne 'CODE';
|
|
|
1622 $$cp++;
|
|
|
1623 return &{$tp->{opcodes}{$name}}($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
1624 }
|
|
|
1625 }
|
|
|
1626
|
|
|
1627 sub _create_register {
|
|
|
1628 # create/separate register if necessary
|
|
|
1629 my ($int, $tp, $name, $reg, $runenv, $undo) = @_;
|
|
|
1630 if (! exists $tp->{registers}{$reg}) {
|
|
|
1631 my $value;
|
|
|
1632 my %newreg = (
|
|
|
1633 value => reg_create($reg, $int->{object}),
|
|
|
1634 ignore => 0,
|
|
|
1635 default => 0,
|
|
|
1636 );
|
|
|
1637 my @newstash = ();
|
|
|
1638 for my $t (@{$int->{threads}}, $int->{default}, $tp) {
|
|
|
1639 $t->{registers}{$reg} = \%newreg
|
|
|
1640 if ! exists $t->{registers}{$reg};
|
|
|
1641 $t->{stash}{$reg} = \@newstash
|
|
|
1642 if ! exists $t->{stash}{$reg};
|
|
|
1643 }
|
|
|
1644 }
|
|
|
1645 if ($runenv->{quantum}) {
|
|
|
1646 $undo ||= \&_deep_copy;
|
|
|
1647 push @{$runenv->{quantum}},
|
|
|
1648 [$undo->($tp->{registers}{$reg}), 'registers', $reg],
|
|
|
1649 [_deep_copy($tp->{stash}{$reg}), 'stash', $reg];
|
|
|
1650 }
|
|
|
1651 }
|
|
|
1652
|
|
|
1653 sub _stash_register {
|
|
|
1654 my ($int, $tp, $name, $reg, $runenv) = @_;
|
|
|
1655 _create_register($int, $tp, $name, $reg, $runenv);
|
|
|
1656 push @{$tp->{stash}{$reg}}, _deep_copy($tp->{registers}{$reg});
|
|
|
1657 undef;
|
|
|
1658 }
|
|
|
1659
|
|
|
1660 sub _retrieve_register {
|
|
|
1661 my ($int, $tp, $name, $reg, $runenv) = @_;
|
|
|
1662 _create_register($int, $tp, $name, $reg, $runenv);
|
|
|
1663 $tp->{stash}{$reg} && @{$tp->{stash}{$reg}}
|
|
|
1664 or faint(SP_HIDDEN, $reg);
|
|
|
1665 my $pop = pop @{$tp->{stash}{$reg}};
|
|
|
1666 # we must copy the hash rather than the ref otherwise any other threads
|
|
|
1667 # sharing this register don't get the retrieve
|
|
|
1668 %{$tp->{registers}{$reg}} = %$pop
|
|
|
1669 if ! $tp->{registers}{$reg}{ignore} ||
|
|
|
1670 $tp->{registers}{$reg_rm}{value}->number;
|
|
|
1671 undef;
|
|
|
1672 }
|
|
|
1673
|
|
|
1674 sub _q {
|
|
|
1675 my ($runenv) = @_;
|
|
|
1676 return {
|
|
|
1677 quantum => $runenv->{quantum},
|
|
|
1678 };
|
|
|
1679 }
|
|
|
1680
|
|
|
1681 sub _a {
|
|
|
1682 my ($runenv, %rest) = @_;
|
|
|
1683 my %runenv = %$runenv;
|
|
|
1684 $runenv{$_} = $rest{$_} for keys %rest;
|
|
|
1685 \%runenv;
|
|
|
1686 }
|
|
|
1687
|
|
|
1688 sub _i_register {
|
|
|
1689 my ($int, $tp, $name, $type, $runenv, $cp, $ep) = @_;
|
|
|
1690 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
1691 _ii_register($int, $tp, $name, $type, $num, $runenv, $cp, $ep);
|
|
|
1692 }
|
|
|
1693
|
|
|
1694 sub _ii_register {
|
|
|
1695 my ($int, $tp, $name, $type, $num, $runenv, $cp, $ep) = @_;
|
|
|
1696 # check for valid register - note that @0 will be valid at this point
|
|
|
1697 my $reg = $type . $num;
|
|
|
1698 exists $tp->{registers}{$reg} || ($num > 0 && $num <= 0xffff)
|
|
|
1699 or faint(SP_REGISTER, $reg);
|
|
|
1700 # check for owners
|
|
|
1701 if ($runenv->{owners} && @{$runenv->{owners}}) {
|
|
|
1702 exists $tp->{registers}{$reg} &&
|
|
|
1703 exists $tp->{registers}{$reg}{owners} &&
|
|
|
1704 @{$tp->{registers}{$reg}{owners}}
|
|
|
1705 or faint(SP_FREE, $reg);
|
|
|
1706 my $own = shift @{$runenv->{owners}};
|
|
|
1707 $own > 0 or faint(SP_OWNER, $own);
|
|
|
1708 $own <= @{$tp->{registers}{$reg}{owners}}
|
|
|
1709 or faint(SP_NOOWNER, $reg, $own,
|
|
|
1710 scalar @{$tp->{registers}{$reg}{owners}});
|
|
|
1711 my ($mtype, $mnum) = @{$tp->{registers}{$reg}{owners}[$own - 1]};
|
|
|
1712 return _ii_register($int, $tp, $name, $mtype, $mnum,
|
|
|
1713 $runenv, $cp, $ep);
|
|
|
1714 }
|
|
|
1715 my $assign = $runenv->{assign};
|
|
|
1716 if ($assign) {
|
|
|
1717 # check for special "assignment" code - really used for STASH,
|
|
|
1718 # RETRIEVE, IGNORE, REMEMBER, WRITE IN - note that WRITE IN will
|
|
|
1719 # need to check if the register is IGNOREd
|
|
|
1720 if (ref $assign eq 'CODE') {
|
|
|
1721 return &$assign($int, $tp, $runenv, $cp, $ep, 'R', $reg);
|
|
|
1722 }
|
|
|
1723 if (exists $causes_recompile{$reg} && $runenv->{quantum}) {
|
|
|
1724 # can't do that (yet), sorry
|
|
|
1725 faint(SP_QUANTUM, "Assignment to grammar registers");
|
|
|
1726 }
|
|
|
1727 _create_register($int, $tp, $name, $reg, $runenv);
|
|
|
1728 # special treatment for system call interface
|
|
|
1729 if (exists $tp->{registers}{$reg_os}) {
|
|
|
1730 _create_register($int, $tp, $name, $reg_os, $runenv);
|
|
|
1731 @{$tp->{registers}{$reg_os}{owners}} = [$type, $num];
|
|
|
1732 }
|
|
|
1733 # check if a register is ignored
|
|
|
1734 $tp->{registers}{$reg}{ignore}
|
|
|
1735 and return undef;
|
|
|
1736 my $oldval;
|
|
|
1737 delete $tp->{registers}{$reg}{default};
|
|
|
1738 $oldval = $tp->{registers}{$reg}{value}->number
|
|
|
1739 if exists $causes_recompile{$reg};
|
|
|
1740 $tp->{registers}{$reg}{value}->use($runenv->{subscripts}, $assign);
|
|
|
1741 return undef unless exists $causes_recompile{$reg};
|
|
|
1742 return undef if $oldval == $tp->{registers}{$reg}{value}->number;
|
|
|
1743 if ($int->{source} ne '') {
|
|
|
1744 $int->{recompile} = 1;
|
|
|
1745 return undef;
|
|
|
1746 }
|
|
|
1747 faint(SP_CONTEXT, 'Frozen object cannot change ' . reg_decode($reg));
|
|
|
1748 }
|
|
|
1749 _create_register($int, $tp, $name, $reg, _a($runenv, quantum => undef));
|
|
|
1750 return $tp->{registers}{$reg}{value}->use($runenv->{subscripts});
|
|
|
1751 }
|
|
|
1752
|
|
|
1753 sub _i_spo {
|
|
|
1754 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1755 _i_register($int, $tp, $name, '.', $runenv, $cp, $ep);
|
|
|
1756 }
|
|
|
1757
|
|
|
1758 sub _i_tsp {
|
|
|
1759 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1760 _i_register($int, $tp, $name, ':', $runenv, $cp, $ep);
|
|
|
1761 }
|
|
|
1762
|
|
|
1763 sub _i_tai {
|
|
|
1764 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1765 _i_register($int, $tp, $name, ',', $runenv, $cp, $ep);
|
|
|
1766 }
|
|
|
1767
|
|
|
1768 sub _i_hyb {
|
|
|
1769 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1770 _i_register($int, $tp, $name, ';', $runenv, $cp, $ep);
|
|
|
1771 }
|
|
|
1772
|
|
|
1773 sub _i_whp {
|
|
|
1774 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1775 _i_register($int, $tp, $name, '@', $runenv, $cp, $ep);
|
|
|
1776 }
|
|
|
1777
|
|
|
1778 sub _i_dos {
|
|
|
1779 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1780 _i_register($int, $tp, $name, '%', $runenv, $cp, $ep);
|
|
|
1781 }
|
|
|
1782
|
|
|
1783 sub _i_shf {
|
|
|
1784 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1785 _i_register($int, $tp, $name, '^', $runenv, $cp, $ep);
|
|
|
1786 }
|
|
|
1787
|
|
|
1788 sub _i_cho {
|
|
|
1789 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1790 _i_register($int, $tp, $name, '_', $runenv, $cp, $ep);
|
|
|
1791 }
|
|
|
1792
|
|
|
1793 sub _i_typ {
|
|
|
1794 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1795 push @{$runenv->{asshist}}, $runenv->{assign} || 0;
|
|
|
1796 _run($int, $tp, _a($runenv, assign => \&_x_typ), $cp, $ep, 1);
|
|
|
1797 }
|
|
|
1798
|
|
|
1799 sub _x_typ {
|
|
|
1800 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
1801 $type eq 'R' or faint(SP_NOREGISTER, 'get TYPE of');
|
|
|
1802 if ($runenv->{asshist} && @{$runenv->{asshist}}) {
|
|
|
1803 $runenv->{assign} = pop @{$runenv->{asshist}};
|
|
|
1804 }
|
|
|
1805 _i_register($int, $tp, 'TYP', substr($reg, 0, 1), $runenv, $cp, $ep);
|
|
|
1806 undef;
|
|
|
1807 }
|
|
|
1808
|
|
|
1809 sub _i_num {
|
|
|
1810 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1811 push @{$runenv->{asshist}}, $runenv->{assign} || 0;
|
|
|
1812 _run($int, $tp, _a($runenv, assign => \&_x_num), $cp, $ep, 1);
|
|
|
1813 }
|
|
|
1814
|
|
|
1815 sub _x_num {
|
|
|
1816 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
1817 $type eq 'R' or faint(SP_NOREGISTER, 'get NUMBER of');
|
|
|
1818 my $val = substr($reg, 1);
|
|
|
1819 if ($runenv->{asshist} && @{$runenv->{asshist}}) {
|
|
|
1820 $runenv->{assign} = pop @{$runenv->{asshist}};
|
|
|
1821 }
|
|
|
1822 my $assign = $runenv->{assign};
|
|
|
1823 if ($assign) {
|
|
|
1824 # assigning to a register number is equivalent to assigning to constant
|
|
|
1825 if (ref $assign eq 'CODE') {
|
|
|
1826 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
1827 }
|
|
|
1828 _assign_constant($int, $tp, $runenv, $val, $assign);
|
|
|
1829 }
|
|
|
1830 Language::INTERCAL::Numbers::Spot->new($val);
|
|
|
1831 }
|
|
|
1832
|
|
|
1833 sub _assign_constant {
|
|
|
1834 my ($int, $tp, $runenv, $val, $assign) = @_;
|
|
|
1835 # next line guarantees we don't assign arrays to numbers
|
|
|
1836 $assign = $assign->spot->number;
|
|
|
1837 _trace($int, $tp, "[#$val <- #$assign]", 1);
|
|
|
1838 if (! exists $tp->{assign}{$val}) {
|
|
|
1839 for my $t (@{$int->{threads}}, $int->{default}) {
|
|
|
1840 $t->{assign}{$val} = \$assign;
|
|
|
1841 }
|
|
|
1842 }
|
|
|
1843 if ($runenv->{quantum}) {
|
|
|
1844 push @{$runenv->{quantum}},
|
|
|
1845 [_deep_copy($tp->{assign}{$val}), 'assign', $val];
|
|
|
1846 }
|
|
|
1847 ${$tp->{assign}{$val}} = $assign;
|
|
|
1848 }
|
|
|
1849
|
|
|
1850 sub _i_sub {
|
|
|
1851 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1852 my $sub = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
1853 my $ps = [$sub, $runenv->{subscripts} ? @{$runenv->{subscripts}} : ()];
|
|
|
1854 _run($int, $tp, _a($runenv, subscripts => $ps), $cp, $ep, 1);
|
|
|
1855 }
|
|
|
1856
|
|
|
1857 sub _i_own {
|
|
|
1858 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1859 my $own = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
1860 my $po = [$own, $runenv->{owners} ? @{$runenv->{owners}} : ()];
|
|
|
1861 _run($int, $tp, _a($runenv, owners => $po), $cp, $ep, 1);
|
|
|
1862 }
|
|
|
1863
|
|
|
1864 sub _i_ovr {
|
|
|
1865 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1866 my $expr = $$cp;
|
|
|
1867 my $elen = bc_skip($int->{code}, $expr, $ep)
|
|
|
1868 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
1869 $$cp = $expr + $elen;
|
|
|
1870 _run($int, $tp,
|
|
|
1871 _a($runenv, assign => \&_x_ovr, overloading => [$expr, $elen]),
|
|
|
1872 $cp, $ep, 1);
|
|
|
1873 }
|
|
|
1874
|
|
|
1875 sub _x_ovr {
|
|
|
1876 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
1877 $type eq 'R' or faint(SP_NOREGISTER, 'OVR');
|
|
|
1878 _create_register($int, $tp, 'OVR', $reg, $runenv);
|
|
|
1879 my ($expr, $elen) = @{$runenv->{overloading}};
|
|
|
1880 my $S = $runenv->{subscripts} || [];
|
|
|
1881 # remove overload
|
|
|
1882 $tp->{registers}{$reg}{value}->overload($S);
|
|
|
1883 my $unov = $tp->{registers}{$reg}{value};
|
|
|
1884 my $code = substr($int->{code}, $expr, $elen);
|
|
|
1885 if ($code eq reg_code($reg) ||
|
|
|
1886 $code eq pack('C*', BC_OWN, BC(1), BC_WHP, BC(0)))
|
|
|
1887 {
|
|
|
1888 return $unov;
|
|
|
1889 }
|
|
|
1890 # create a closure containing the overload code
|
|
|
1891 my $closure = sub {
|
|
|
1892 my %runenv = ();
|
|
|
1893 my $subs = shift;
|
|
|
1894 $runenv{subscripts} = $subs if $subs && @$subs;
|
|
|
1895 if (@_) {
|
|
|
1896 my $value = shift;
|
|
|
1897 $runenv{assign} = $value;
|
|
|
1898 }
|
|
|
1899 # must save the code and use our old one - because in intercalc
|
|
|
1900 # the overload may have been created in a completely different
|
|
|
1901 # context and the code no longer applies
|
|
|
1902 my $svcode = $int->{code};
|
|
|
1903 $int->{code} = $code;
|
|
|
1904 my $x = 0;
|
|
|
1905 my $r = eval { _run($int, $tp, \%runenv, \$x, $elen, 1) };
|
|
|
1906 $int->{code} = $svcode;
|
|
|
1907 die $@ if $@;
|
|
|
1908 return $r;
|
|
|
1909 };
|
|
|
1910 $tp->{registers}{$reg}{value}->overload($S, $closure);
|
|
|
1911 $unov;
|
|
|
1912 }
|
|
|
1913
|
|
|
1914 sub _i_ovm {
|
|
|
1915 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1916 my $expr = $$cp;
|
|
|
1917 my $elen = bc_skip($int->{code}, $expr, $ep)
|
|
|
1918 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
1919 $$cp = $expr + $elen;
|
|
|
1920 my $N = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
1921 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
1922 my ($first, $last) = _uninterleave($ba, $N);
|
|
|
1923 $first = $first->number;
|
|
|
1924 $last = $last->number;
|
|
|
1925 $runenv = _a($runenv, overloading => [$expr, $elen]);
|
|
|
1926 while ($first <= $last) {
|
|
|
1927 for my $p ('.', ',', ':', ';') {
|
|
|
1928 _x_ovr($int, $tp, $runenv, $cp, $ep, 'R', $p . $first);
|
|
|
1929 }
|
|
|
1930 $first++;
|
|
|
1931 }
|
|
|
1932 $N;
|
|
|
1933 }
|
|
|
1934
|
|
|
1935 sub _i_ror {
|
|
|
1936 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1937 _run($int, $tp, _a($runenv, assign => \&_x_ror), $cp, $ep, 1);
|
|
|
1938 }
|
|
|
1939
|
|
|
1940 sub _x_ror {
|
|
|
1941 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
1942 $type eq 'R' or faint(SP_NOREGISTER, 'OVR');
|
|
|
1943 _create_register($int, $tp, 'OVR', $reg, $runenv);
|
|
|
1944 my $S = $runenv->{subscripts} || [];
|
|
|
1945 $tp->{registers}{$reg}{value}->overload($S);
|
|
|
1946 $tp->{registers}{$reg}{value};
|
|
|
1947 }
|
|
|
1948
|
|
|
1949 sub _i_rom {
|
|
|
1950 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1951 my $N = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
1952 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
1953 my ($first, $last) = _uninterleave($ba, $N);
|
|
|
1954 my $S = $runenv->{subscripts} || [];
|
|
|
1955 $first = $first->number;
|
|
|
1956 $last = $last->number;
|
|
|
1957 while ($first <= $last) {
|
|
|
1958 for my $p ('.', ',', ':', ';') {
|
|
|
1959 $tp->{registers}{$p . $first}{value}->overload($S);
|
|
|
1960 }
|
|
|
1961 $first++;
|
|
|
1962 }
|
|
|
1963 $N;
|
|
|
1964 }
|
|
|
1965
|
|
|
1966 sub _i_sto {
|
|
|
1967 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1968 my $assign = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
1969 _run($int, $tp, _a($runenv, assign => $assign), $cp, $ep, 1);
|
|
|
1970 }
|
|
|
1971
|
|
|
1972 sub _i_spl {
|
|
|
1973 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1974 my $assign = $runenv->{assign};
|
|
|
1975 if ($assign) {
|
|
|
1976 if (ref $assign eq 'CODE') {
|
|
|
1977 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
1978 }
|
|
|
1979 # what do you expect?
|
|
|
1980 faint($assign->number);
|
|
|
1981 } else {
|
|
|
1982 exists $int->{default}{registers}{$reg_sp} or faint(SP_SPLAT);
|
|
|
1983 defined $int->{default}{registers}{$reg_sp}{value}->print
|
|
|
1984 or faint(SP_SPLAT);
|
|
|
1985 return $int->{default}{registers}{$reg_sp}{value};
|
|
|
1986 }
|
|
|
1987 }
|
|
|
1988
|
|
|
1989 sub _i_udv {
|
|
|
1990 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
1991 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
1992 if ($runenv->{assign}) {
|
|
|
1993 my $assign = $runenv->{assign};
|
|
|
1994 if (ref $assign eq 'CODE') {
|
|
|
1995 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
1996 }
|
|
|
1997 my $bits = $assign->bits;
|
|
|
1998 my $digits = $assign->num_digits($ba);
|
|
|
1999 my $value = $assign->number;
|
|
|
2000 # $limit = 0r1000...000
|
|
|
2001 my $limit = 1;
|
|
|
2002 for (my $d = 1; $d < $digits; $d++) {
|
|
|
2003 $limit *= $ba;
|
|
|
2004 }
|
|
|
2005 if ($tp->{registers}{$reg_dm}{value}->number) {
|
|
|
2006 # bitwise unary divide
|
|
|
2007 my @range = ();
|
|
|
2008 my $range = 0;
|
|
|
2009 if ($value == 0) {
|
|
|
2010 for (my $x = 0; $x < $ba; $x++) {
|
|
|
2011 my $min = 1 + int($x * ($limit - 1) / ($ba - 1));
|
|
|
2012 my $d = $limit - $min;
|
|
|
2013 next if $d < 1;
|
|
|
2014 push @range, [$x, $min, $d];
|
|
|
2015 $range += $d;
|
|
|
2016 }
|
|
|
2017 } else {
|
|
|
2018 for (my $x = 1; $x < $ba; $x++) {
|
|
|
2019 my $min = $x * ($limit - $value - 1) / ($value * $ba + $ba - 1);
|
|
|
2020 my $max = 1 + int($x * ($limit - $value) / ($value * $ba - 1));
|
|
|
2021 if ($min < 0) {
|
|
|
2022 $min = 0;
|
|
|
2023 } else {
|
|
|
2024 $min = int(1 + $min);
|
|
|
2025 }
|
|
|
2026 $max = $limit * $ba if $max > $limit * $ba;
|
|
|
2027 next if $min >= $max;
|
|
|
2028 $max -= $min;
|
|
|
2029 push @range, [$x, $min, $max];
|
|
|
2030 $range += $max;
|
|
|
2031 }
|
|
|
2032 }
|
|
|
2033 $range > 0
|
|
|
2034 or faint(SP_ASSIGN, $ba, '-', $value);
|
|
|
2035 my $rnd = int(rand $range);
|
|
|
2036 for my $rg (@range) {
|
|
|
2037 my ($x, $low, $r) = @$rg;
|
|
|
2038 if ($rnd < $r) {
|
|
|
2039 $value = ($rnd + $low) * $ba + $x;
|
|
|
2040 last;
|
|
|
2041 }
|
|
|
2042 $rnd -= $r;
|
|
|
2043 }
|
|
|
2044 } else {
|
|
|
2045 # arithmetic unary divide
|
|
|
2046 my (@gives_plus_1, @gives_plus_2, @gives_plus_3);
|
|
|
2047 if ($ba == 2) {
|
|
|
2048 @gives_plus_1 = (3);
|
|
|
2049 } elsif ($ba == 3) {
|
|
|
2050 @gives_plus_1 = (4, 8);
|
|
|
2051 } elsif ($ba == 4) {
|
|
|
2052 @gives_plus_1 = (5, 10, 11, 15);
|
|
|
2053 } elsif ($ba == 5) {
|
|
|
2054 @gives_plus_1 = (6, 12, 13, 18, 19, 24);
|
|
|
2055 @gives_plus_2 = (14);
|
|
|
2056 } elsif ($ba == 6) {
|
|
|
2057 @gives_plus_1 = (7, 14, 15, 21, 22, 23, 28, 29, 35);
|
|
|
2058 @gives_plus_2 = (16, 17);
|
|
|
2059 } elsif ($ba == 7) {
|
|
|
2060 @gives_plus_1 = (8, 16, 17, 24, 25, 26, 32, 33, 34, 40, 41, 48);
|
|
|
2061 @gives_plus_2 = (18, 19, 27);
|
|
|
2062 @gives_plus_3 = (20);
|
|
|
2063 }
|
|
|
2064 if ($value == $ba) {
|
|
|
2065 my @values = (@gives_plus_1, @gives_plus_2, @gives_plus_3);
|
|
|
2066 # any value > 2 * $ba will do except the ones in @values
|
|
|
2067 $limit *= $ba;
|
|
|
2068 $limit -= @values;
|
|
|
2069 my %avoid = ();
|
|
|
2070 for (my $i = 0; $i < @values; $i++) {
|
|
|
2071 $avoid{$values[$i]} = $limit + $i;
|
|
|
2072 }
|
|
|
2073 $limit -= 1 + 2 * $ba;
|
|
|
2074 $value = int(2 * $ba + 1 + int(rand($limit)));
|
|
|
2075 $value = $avoid{$value} if exists $avoid{$value};
|
|
|
2076 } elsif ($value == $ba + 1 && @gives_plus_1) {
|
|
|
2077 $value = $gives_plus_1[int(rand scalar @gives_plus_1)];
|
|
|
2078 } elsif ($value == $ba + 2 && @gives_plus_2) {
|
|
|
2079 $value = $gives_plus_2[int(rand scalar @gives_plus_2)];
|
|
|
2080 } elsif ($value == $ba + 3 && @gives_plus_3) {
|
|
|
2081 $value = $gives_plus_3[int(rand scalar @gives_plus_3)];
|
|
|
2082 } elsif ($value < $ba || $value >= 2 * $ba) {
|
|
|
2083 faint(SP_ASSIGN, $ba, '-', $value);
|
|
|
2084 }
|
|
|
2085 }
|
|
|
2086 $assign = Language::INTERCAL::Numbers->new($bits, $value);
|
|
|
2087 _run($int, $tp, _a($runenv, assign => $assign), $cp, $ep, 1);
|
|
|
2088 } else {
|
|
|
2089 my $num =
|
|
|
2090 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2091 if ($tp->{registers}{$reg_dm}{value}->number) {
|
|
|
2092 # bitwise unary divide
|
|
|
2093 my $val = $num->number;
|
|
|
2094 faint(SP_DIVIDE) if $val < 1;
|
|
|
2095 my @digs = $num->digits($ba);
|
|
|
2096 my $ld = pop @digs;
|
|
|
2097 unshift @digs, $ld;
|
|
|
2098 my $div =
|
|
|
2099 Language::INTERCAL::Numbers->from_digits($ba, @digs)->number;
|
|
|
2100 my $class = ref $num;
|
|
|
2101 return $class->new(int($div / $val));
|
|
|
2102 } else {
|
|
|
2103 # arithmetic unary divide
|
|
|
2104 $num = $num->number;
|
|
|
2105 my $div = int($num / $ba);
|
|
|
2106 faint(SP_DIVIDE) if $div < 1;
|
|
|
2107 $num = int($num / $div);
|
|
|
2108 return Language::INTERCAL::Numbers::Spot->new($num);
|
|
|
2109 }
|
|
|
2110 }
|
|
|
2111 }
|
|
|
2112
|
|
|
2113 sub _i_msp {
|
|
|
2114 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2115 my $splat = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2116 my $narg = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2117 my @arg = ();
|
|
|
2118 while (@arg < $narg) {
|
|
|
2119 push @arg, _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2120 }
|
|
|
2121 faint($splat, @arg);
|
|
|
2122 }
|
|
|
2123
|
|
|
2124 sub _i_sta {
|
|
|
2125 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2126 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2127 while ($num-- > 0) {
|
|
|
2128 _run($int, $tp, _a($runenv, assign => \&_x_sta), $cp, $ep, 1);
|
|
|
2129 }
|
|
|
2130 }
|
|
|
2131
|
|
|
2132 sub _x_sta {
|
|
|
2133 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
2134 $type eq 'R' or faint(SP_NOREGISTER, 'STASH');
|
|
|
2135 _stash_register($int, $tp, 'STA', $reg, $runenv);
|
|
|
2136 undef;
|
|
|
2137 }
|
|
|
2138
|
|
|
2139 sub _i_ret {
|
|
|
2140 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2141 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2142 while ($num-- > 0) {
|
|
|
2143 _run($int, $tp, _a($runenv, assign => \&_x_ret), $cp, $ep, 1);
|
|
|
2144 }
|
|
|
2145 }
|
|
|
2146
|
|
|
2147 sub _x_ret {
|
|
|
2148 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
2149 $type eq 'R' or faint(SP_NOREGISTER, 'RETRIEVE');
|
|
|
2150 _retrieve_register($int, $tp, 'RET', $reg, $runenv);
|
|
|
2151 undef;
|
|
|
2152 }
|
|
|
2153
|
|
|
2154 sub _i_ign {
|
|
|
2155 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2156 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2157 while ($num-- > 0) {
|
|
|
2158 _run($int, $tp, _a($runenv, assign => \&_x_ign), $cp, $ep, 1);
|
|
|
2159 }
|
|
|
2160 }
|
|
|
2161
|
|
|
2162 sub _x_ign {
|
|
|
2163 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
2164 $type eq 'R' or faint(SP_NOREGISTER, 'IGNORE');
|
|
|
2165 _create_register($int, $tp, 'IGN', $reg, $runenv, \&_y_ign);
|
|
|
2166 $tp->{registers}{$reg}{ignore} = 1;
|
|
|
2167 undef;
|
|
|
2168 }
|
|
|
2169
|
|
|
2170 sub _y_ign {
|
|
|
2171 my ($reg) = @_;
|
|
|
2172 $reg = _deep_copy($reg);
|
|
|
2173 $reg->{ignore} = 0;
|
|
|
2174 $reg;
|
|
|
2175 }
|
|
|
2176
|
|
|
2177 sub _i_rem {
|
|
|
2178 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2179 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2180 while ($num-- > 0) {
|
|
|
2181 _run($int, $tp, _a($runenv, assign => \&_x_rem), $cp, $ep, 1);
|
|
|
2182 }
|
|
|
2183 }
|
|
|
2184
|
|
|
2185 sub _x_rem {
|
|
|
2186 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
2187 $type eq 'R' or faint(SP_NOREGISTER, 'REMEMBER');
|
|
|
2188 _create_register($int, $tp, 'REM', $reg, $runenv, \&_y_rem);
|
|
|
2189 $tp->{registers}{$reg}{ignore} = 0;
|
|
|
2190 undef;
|
|
|
2191 }
|
|
|
2192
|
|
|
2193 sub _y_rem {
|
|
|
2194 my ($reg) = @_;
|
|
|
2195 $reg = _deep_copy($reg);
|
|
|
2196 $reg->{ignore} = 1;
|
|
|
2197 $reg;
|
|
|
2198 }
|
|
|
2199
|
|
|
2200 sub _abstain_reinstate {
|
|
|
2201 my ($int, $tp, $runenv, $abstain, $label, @gerunds) = @_;
|
|
|
2202 my $count = ++$int->{ab_count};
|
|
|
2203 my $qp = $runenv->{quantum};
|
|
|
2204 if ($label) {
|
|
|
2205 push @$qp, [[! $abstain, $count], 'ab_label', $label] if ($qp);
|
|
|
2206 if (exists $tp->{ab_label}{$label}) {
|
|
|
2207 @{$tp->{ab_label}{$label}} = ($abstain, $count);
|
|
|
2208 } else {
|
|
|
2209 for my $t (@{$int->{threads}}, $int->{default}) {
|
|
|
2210 next if exists $t->{ab_label}{$label};
|
|
|
2211 $t->{ab_label}{$label} = [$abstain, $count];
|
|
|
2212 }
|
|
|
2213 }
|
|
|
2214 }
|
|
|
2215 for my $ger (@gerunds) {
|
|
|
2216 push @$qp, [[! $abstain, $count], 'ab_gerund', $ger] if ($qp);
|
|
|
2217 if (exists $tp->{ab_gerund}{$ger}) {
|
|
|
2218 @{$tp->{ab_gerund}{$ger}} = ($abstain, $count);
|
|
|
2219 } else {
|
|
|
2220 for my $t (@{$int->{threads}}, $int->{default}) {
|
|
|
2221 next if exists $t->{ab_gerund}{$ger};
|
|
|
2222 $t->{ab_gerund}{$ger} = [$abstain, $count];
|
|
|
2223 }
|
|
|
2224 }
|
|
|
2225 }
|
|
|
2226 }
|
|
|
2227
|
|
|
2228 sub _i_abl {
|
|
|
2229 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2230 my $lab = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2231 faint(SP_INVLABEL, $lab) if $lab < 1 || $lab > 0xffff;
|
|
|
2232 _abstain_reinstate($int, $tp, $runenv, 1, $lab);
|
|
|
2233 undef;
|
|
|
2234 }
|
|
|
2235
|
|
|
2236 sub _i_abg {
|
|
|
2237 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2238 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2239 $$cp + $num <= $ep
|
|
|
2240 or faint(SP_INVALID, "Not enough opcodes", $name);
|
|
|
2241 my @ger = unpack('C*', substr($int->{code}, $$cp, $num));
|
|
|
2242 $$cp += $num;
|
|
|
2243 _abstain_reinstate($int, $tp, $runenv, 1, 0, @ger);
|
|
|
2244 undef;
|
|
|
2245 }
|
|
|
2246
|
|
|
2247 sub _i_rel {
|
|
|
2248 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2249 my $lab = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2250 faint(SP_INVLABEL, $lab) if $lab < 1 || $lab > 0xffff;
|
|
|
2251 _abstain_reinstate($int, $tp, $runenv, 0, $lab);
|
|
|
2252 undef;
|
|
|
2253 }
|
|
|
2254
|
|
|
2255 sub _i_reg {
|
|
|
2256 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2257 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2258 $$cp + $num <= $ep
|
|
|
2259 or faint(SP_INVALID, "Not enough opcodes", $name);
|
|
|
2260 my @ger = unpack('C*', substr($int->{code}, $$cp, $num));
|
|
|
2261 $$cp += $num;
|
|
|
2262 _abstain_reinstate($int, $tp, $runenv, 0, 0, @ger);
|
|
|
2263 undef;
|
|
|
2264 }
|
|
|
2265
|
|
|
2266 sub _i_cfl {
|
|
|
2267 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2268 _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2269 undef;
|
|
|
2270 }
|
|
|
2271
|
|
|
2272 sub _i_cfg {
|
|
|
2273 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2274 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2275 $$cp + $num <= $ep
|
|
|
2276 or faint(SP_INVALID, "Not enough opcodes", $name);
|
|
|
2277 $$cp += $num;
|
|
|
2278 undef;
|
|
|
2279 }
|
|
|
2280
|
|
|
2281 sub _i_bug {
|
|
|
2282 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2283 my $t = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2284 faint($t ? SP_UBUG : SP_BUG);
|
|
|
2285 }
|
|
|
2286
|
|
|
2287 sub _i_rou {
|
|
|
2288 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2289 faint(SP_QUANTUM, 'READ OUT') if $runenv->{quantum};
|
|
|
2290 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2291 my $fh = $tp->{registers}{$reg_orfh}{value}->filehandle;
|
|
|
2292 _set_read_charset($int, $tp, $fh);
|
|
|
2293 while ($num-- > 0) {
|
|
|
2294 my $e = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2295 ref $e or faint(SP_INVALID, "Not an expression", $name);
|
|
|
2296 if (UNIVERSAL::isa($e, 'Language::INTERCAL::Numbers')) {
|
|
|
2297 my $rt = $tp->{registers}{$reg_rt}{value}->number;
|
|
|
2298 read_number($e->number, $rt, $fh);
|
|
|
2299 } elsif (ref $e eq 'ARRAY') {
|
|
|
2300 # assume it is a tail array
|
|
|
2301 my $io = $tp->{registers}{$reg_io}{value}->number;
|
|
|
2302 _create_register($int, $tp, $name, $reg_ar, $runenv);
|
|
|
2303 my $ar = $tp->{registers}{$reg_ar}{value}->number;
|
|
|
2304 read_array_16($io, \$ar, $fh, $e, 1);
|
|
|
2305 $tp->{registers}{$reg_ar}{value}->assign($ar);
|
|
|
2306 } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Arrays')) {
|
|
|
2307 my $io = $tp->{registers}{$reg_io}{value}->number;
|
|
|
2308 _create_register($int, $tp, $name, $reg_ar, $runenv);
|
|
|
2309 my $ar = $tp->{registers}{$reg_ar}{value}->number;
|
|
|
2310 my @v = map { $_->number } $e->as_list;
|
|
|
2311 @v or faint(SP_NODIM);
|
|
|
2312 if ($e->bits <= 16) {
|
|
|
2313 my $nl = $tp->{newline} && ($io == 0 || $io == iotype_default);
|
|
|
2314 read_array_16($io, \$ar, $fh, \@v, $nl);
|
|
|
2315 } else {
|
|
|
2316 read_array_32($io, \$ar, $fh, \@v, 0);
|
|
|
2317 }
|
|
|
2318 $tp->{registers}{$reg_ar}{value}->assign($ar);
|
|
|
2319 } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Whirlpool')) {
|
|
|
2320 $fh = $e->filehandle;
|
|
|
2321 _set_read_charset($int, $tp, $fh);
|
|
|
2322 # $tp->{registers}{$reg_owfh}{value}->assign($fh);
|
|
|
2323 } else {
|
|
|
2324 faint(SP_READ, 'READ OUT');
|
|
|
2325 }
|
|
|
2326 }
|
|
|
2327 }
|
|
|
2328
|
|
|
2329 sub _newline {
|
|
|
2330 my ($tp) = @_;
|
|
|
2331 $tp->{newline} = ! $tp->{newline};
|
|
|
2332 }
|
|
|
2333
|
|
|
2334 sub _i_win {
|
|
|
2335 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2336 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2337 my $fh = $tp->{registers}{$reg_owfh}{value}->filehandle;
|
|
|
2338 _set_write_charset($int, $tp, $fh);
|
|
|
2339 $tp->{_filehandle} = $fh;
|
|
|
2340 while ($num-- > 0) {
|
|
|
2341 _run($int, $tp, _a($runenv, assign => \&_x_win), $cp, $ep, 1);
|
|
|
2342 }
|
|
|
2343 delete $tp->{_filehandle};
|
|
|
2344 undef;
|
|
|
2345 }
|
|
|
2346
|
|
|
2347 sub _x_win {
|
|
|
2348 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
2349 if ($type eq 'N') {
|
|
|
2350 # treat this as numeric WRITE
|
|
|
2351 my $wimp = $tp->{registers}{$reg_wt}{value}->number;
|
|
|
2352 my $val = write_number($tp->{_filehandle}, $wimp);
|
|
|
2353 my $bits = $val < 0x10000 ? 16 : 32;
|
|
|
2354 return Language::INTERCAL::Numbers->new($bits, $val);
|
|
|
2355 }
|
|
|
2356 $type eq 'R'
|
|
|
2357 or faint(SP_INVALID, 'Neither a number nor a register?', 'WIN');
|
|
|
2358 _create_register($int, $tp, 'WIN', $reg, $runenv);
|
|
|
2359 my $i = $tp->{registers}{$reg}{ignore};
|
|
|
2360 my $e = $tp->{registers}{$reg}{value};
|
|
|
2361 if (UNIVERSAL::isa($e, 'Language::INTERCAL::Numbers')) {
|
|
|
2362 my $wimp = $tp->{registers}{$reg_wt}{value}->number;
|
|
|
2363 my $val = write_number($tp->{_filehandle}, $wimp);
|
|
|
2364 $e->assign($val) unless $i;
|
|
|
2365 } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Arrays')) {
|
|
|
2366 my $io = $tp->{registers}{$reg_io}{value}->number;
|
|
|
2367 _create_register($int, $tp, 'WIN', $reg_aw, $runenv);
|
|
|
2368 my $aw = $tp->{registers}{$reg_aw}{value}->number;
|
|
|
2369 my @v;
|
|
|
2370 if ($e->bits <= 16) {
|
|
|
2371 @v = write_array_16($io, \$aw, $tp->{_filehandle}, $e->elements);
|
|
|
2372 } else {
|
|
|
2373 @v = write_array_32($io, \$aw, $tp->{_filehandle}, $e->elements);
|
|
|
2374 }
|
|
|
2375 $e->replace(\@v) unless $i;
|
|
|
2376 $tp->{registers}{$reg_aw}{value}->assign($aw);
|
|
|
2377 } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Whirlpool')) {
|
|
|
2378 my $fh = $e->filehandle;
|
|
|
2379 _set_write_charset($int, $tp, $fh);
|
|
|
2380 $tp->{_filehandle} = $fh;
|
|
|
2381 # $tp->{registers}{$reg_owfh}{value}->assign($fh);
|
|
|
2382 } else {
|
|
|
2383 faint(SP_READ, 'WRITE IN');
|
|
|
2384 }
|
|
|
2385 }
|
|
|
2386
|
|
|
2387 sub _interleave {
|
|
|
2388 my ($base, $num1, $num2) = @_;
|
|
|
2389 my @num1 = $num1->spot->digits($base);
|
|
|
2390 my @num2 = $num2->spot->digits($base);
|
|
|
2391 my @num = ();
|
|
|
2392 while (@num1) {
|
|
|
2393 push @num, shift @num1;
|
|
|
2394 push @num, shift @num2;
|
|
|
2395 }
|
|
|
2396 return Language::INTERCAL::Numbers->from_digits($base, @num);
|
|
|
2397 }
|
|
|
2398
|
|
|
2399 sub _i_int {
|
|
|
2400 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2401 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2402 if ($runenv->{assign}) {
|
|
|
2403 my $assign = $runenv->{assign};
|
|
|
2404 if (ref $assign eq 'CODE') {
|
|
|
2405 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2406 }
|
|
|
2407 my ($num1, $num2) = _uninterleave($ba, $assign);
|
|
|
2408 _run($int, $tp, _a($runenv, assign => $num1), $cp, $ep, 1);
|
|
|
2409 _run($int, $tp, _a($runenv, assign => $num2), $cp, $ep, 1);
|
|
|
2410 return undef;
|
|
|
2411 } else {
|
|
|
2412 my $num1 =
|
|
|
2413 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2414 my $num2 =
|
|
|
2415 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2416 return _interleave($ba, $num1, $num2);
|
|
|
2417 }
|
|
|
2418 }
|
|
|
2419
|
|
|
2420 sub _i_rin {
|
|
|
2421 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2422 # we must execute the operands in reverse order, or side-effects won't
|
|
|
2423 # work as advertised.
|
|
|
2424 my $firstop = $$cp;
|
|
|
2425 $$cp += bc_skip($int->{code}, $firstop, $ep);
|
|
|
2426 my $firstend = $$cp;
|
|
|
2427 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2428 if ($runenv->{assign}) {
|
|
|
2429 my $assign = $runenv->{assign};
|
|
|
2430 if (ref $assign eq 'CODE') {
|
|
|
2431 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2432 }
|
|
|
2433 my ($num1, $num2) = _uninterleave($ba, $assign);
|
|
|
2434 _run($int, $tp, _a($runenv, assign => $num1), $cp, $ep, 1);
|
|
|
2435 _run($int, $tp, _a($runenv, assign => $num2), \$firstop, $firstend, 1);
|
|
|
2436 return undef;
|
|
|
2437 } else {
|
|
|
2438 my $num1 =
|
|
|
2439 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2440 my $num2 =
|
|
|
2441 _get_expression($int, $tp, $name, $runenv, \$firstop, $firstend, 1);
|
|
|
2442 return _interleave($ba, $num1, $num2);
|
|
|
2443 }
|
|
|
2444 }
|
|
|
2445
|
|
|
2446 sub _i_smu {
|
|
|
2447 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2448 _ii_ste($int, $tp, $name, $runenv, $cp, $ep, 'SMUGGLE');
|
|
|
2449 }
|
|
|
2450
|
|
|
2451 sub _i_ste {
|
|
|
2452 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2453 _ii_ste($int, $tp, $name, $runenv, $cp, $ep, 'STEAL');
|
|
|
2454 }
|
|
|
2455
|
|
|
2456 sub _ii_ste {
|
|
|
2457 my ($int, $tp, $name, $runenv, $cp, $ep, $operation) = @_;
|
|
|
2458 $int->{theft_server}
|
|
|
2459 or faint(SP_INVALID,
|
|
|
2460 "This program is not allowed to $operation",
|
|
|
2461 $name);
|
|
|
2462 my $theft = $int->{theft_server};
|
|
|
2463 my $type = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2464 faint(SP_INVALID, "$type expressions", $name)
|
|
|
2465 if $type < 0 || $type > 1;
|
|
|
2466 my $server;
|
|
|
2467 if ($type) {
|
|
|
2468 $server = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2469 $server = join('.', $server >> 24,
|
|
|
2470 ($server >> 16) & 0xff,
|
|
|
2471 ($server >> 8) & 0xff,
|
|
|
2472 $server & 0xff);
|
|
|
2473 } else {
|
|
|
2474 # broadcast for a server
|
|
|
2475 my @ips = $theft->find_theft_servers;
|
|
|
2476 $server = $ips[int(rand(scalar @ips))];
|
|
|
2477 }
|
|
|
2478 my $pid;
|
|
|
2479 $type = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2480 faint(SP_INVALID, "$type expressions", $name)
|
|
|
2481 if $type < 0 || $type > 1;
|
|
|
2482 if ($type) {
|
|
|
2483 $pid = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2484 } else {
|
|
|
2485 # get a random pid from server
|
|
|
2486 my @pids = $theft->pids($server);
|
|
|
2487 $pid = $pids[int(rand(scalar @pids))];
|
|
|
2488 }
|
|
|
2489 $theft->start_request($server, $pid, $operation);
|
|
|
2490 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2491 while ($num-- > 0) {
|
|
|
2492 _run($int, $tp,
|
|
|
2493 _a($runenv, assign => \&_x_ste, name => $name, server => $server),
|
|
|
2494 $cp, $ep, 1);
|
|
|
2495 }
|
|
|
2496 $theft->finish_request;
|
|
|
2497 }
|
|
|
2498
|
|
|
2499 sub _x_ste {
|
|
|
2500 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
2501 $type eq 'R'
|
|
|
2502 or faint(SP_INVALID, 'Not a register', $runenv->{name});
|
|
|
2503 _create_register($int, $tp, $runenv->{name}, $reg, $runenv);
|
|
|
2504 my @v = $int->{theft_server}->request($reg);
|
|
|
2505 my $r = $tp->{registers}{$reg};
|
|
|
2506 my $i = $r->{ignore};
|
|
|
2507 return if $i;
|
|
|
2508 my @ops = ();
|
|
|
2509 for my $v (@v) {
|
|
|
2510 $v =~ s/\s+//g;
|
|
|
2511 substr($v, 0, length($reg)) eq $reg
|
|
|
2512 or faint(SP_INVALID, 'Wrong register received', $runenv->{name});
|
|
|
2513 substr($v, 0, length($reg)) = '';
|
|
|
2514 $v =~ s/^(.*)<-//
|
|
|
2515 or faint(SP_INVALID, 'Not an assignment', $runenv->{name});
|
|
|
2516 my $d = $1;
|
|
|
2517 if ($v =~ /^#(\d+)BY\?(\S+)BY\?(\S+)BY\?(\S+)$/) {
|
|
|
2518 substr($reg, 0, 1) eq '@'
|
|
|
2519 or faint(SP_INVALID, 'Not a class register', $runenv->{name});
|
|
|
2520 my $port = $runenv->{server} . ':' . $1;
|
|
|
2521 my $rcs = $2;
|
|
|
2522 my $wcs = $3;
|
|
|
2523 my $mode = $4;
|
|
|
2524 $v = Language::INTERCAL::GenericIO->new('REMOTE', $mode, $port,
|
|
|
2525 $int->{server});
|
|
|
2526 $v->read_charset($rcs);
|
|
|
2527 $v->write_charset($wcs);
|
|
|
2528 } elsif ($v =~ /^#(\d+)$/) {
|
|
|
2529 $v = Language::INTERCAL::Numbers::Spot->new($1);
|
|
|
2530 } elsif ($v =~ /^#(\d+)¢#(\d+)$/) {
|
|
|
2531 my ($v1, $v2) = ($1, $2);
|
|
|
2532 $v = _interleave(2,
|
|
|
2533 Language::INTERCAL::Numbers::Spot->new($v1),
|
|
|
2534 Language::INTERCAL::Numbers::Spot->new($v2));
|
|
|
2535 } else {
|
|
|
2536 faint(SP_INVALID, "Value ($v) syntax error", $runenv->{name});
|
|
|
2537 }
|
|
|
2538 if ($d eq '') {
|
|
|
2539 push @ops, [$v, undef];
|
|
|
2540 } else {
|
|
|
2541 my @s = split(/SUB/, $d);
|
|
|
2542 my @t = grep { /^#\d+$/ } @s;
|
|
|
2543 @t == @s
|
|
|
2544 or faint(SP_INVALID, 'Subscript syntax error', $runenv->{name});
|
|
|
2545 push @ops, [$v, [map { substr($_, 2) } @t]];
|
|
|
2546 }
|
|
|
2547 }
|
|
|
2548 $r->{value}->nuke if $r->{value}->can('nuke');
|
|
|
2549 for my $op (@ops) {
|
|
|
2550 my ($v, $s) = @$op;
|
|
|
2551 $r->{value}->use($s, $v);
|
|
|
2552 }
|
|
|
2553 undef;
|
|
|
2554 }
|
|
|
2555
|
|
|
2556 sub _theft {
|
|
|
2557 my ($type, $reg, $id, $theft, $int) = @_;
|
|
|
2558 $reg =~ /^[\.,:;\@]/
|
|
|
2559 or return '551 Invalid register type';
|
|
|
2560 exists $int->{default}{registers}{$reg}
|
|
|
2561 or return '552 No such register';
|
|
|
2562 my $rp = $int->{default}{registers}{$reg};
|
|
|
2563 # check if they are allowed to steal it
|
|
|
2564 my $stealing = uc($type) eq 'STEAL';
|
|
|
2565 $stealing && $rp->{ignore}
|
|
|
2566 and return '553 Cannot steal this, try smuggling';
|
|
|
2567 ! $stealing && ! $rp->{ignore}
|
|
|
2568 and return '554 Cannot smuggle this, try stealing';
|
|
|
2569 if ($int->{theft_callback}) {
|
|
|
2570 &{$int->{theft_callback}}($int, $type, $reg)
|
|
|
2571 or return '555 Failed due to internal policy';
|
|
|
2572 }
|
|
|
2573 my @val = ();
|
|
|
2574 my $value = $rp->{value};
|
|
|
2575 if ($value->isa('Language::INTERCAL::Whirlpool')) {
|
|
|
2576 # export filehandle
|
|
|
2577 my $fh = $value->filehandle;
|
|
|
2578 if ($fh) {
|
|
|
2579 my $rcs = $fh->read_charset;
|
|
|
2580 my $wcs = $fh->write_charset;
|
|
|
2581 my $mode = $fh->mode;
|
|
|
2582 my $port = $fh->export($theft->server);
|
|
|
2583 push @val, "$reg <- #$port BY ?$rcs BY ?$wcs BY ?$mode";
|
|
|
2584 # the following prevents the filehandle being garbage-collected
|
|
|
2585 # after being stolen
|
|
|
2586 $int->{stolen}{$fh} = $fh if $stealing;
|
|
|
2587 }
|
|
|
2588 for my $elem ($value->tail->sparse_list) {
|
|
|
2589 my ($n, $e) = @$elem;
|
|
|
2590 push @val, "$reg SUB #$e <- #" . ($n->number);
|
|
|
2591 }
|
|
|
2592 $value->nuke if $stealing;
|
|
|
2593 } elsif ($value->isa('Language::INTERCAL::Arrays')) {
|
|
|
2594 # export array
|
|
|
2595 my @s = $value->subscripts;
|
|
|
2596 @s = (0) unless @s;
|
|
|
2597 push @val, "$reg <- " . join(' BY ', map { "#$_" } @s);
|
|
|
2598 for my $elem ($value->sparse_list) {
|
|
|
2599 my ($n, @e) = @$elem;
|
|
|
2600 if ($n->number > 65535) {
|
|
|
2601 my ($n1, $n2) = _uninterleave(2, $n);
|
|
|
2602 $n1 = $n1->number;
|
|
|
2603 $n2 = $n2->number;
|
|
|
2604 $n = "#$n1 ¢ #$n2";
|
|
|
2605 } else {
|
|
|
2606 $n = '#' . ($n->number);
|
|
|
2607 }
|
|
|
2608 push @val, "$reg " . join(' ', map { "SUB #$_" } @e) . " <- $n";
|
|
|
2609 }
|
|
|
2610 $value->assign([]) if $stealing;
|
|
|
2611 } else {
|
|
|
2612 # export number
|
|
|
2613 my $n;
|
|
|
2614 if ($value->number > 65535) {
|
|
|
2615 my ($n1, $n2) = _uninterleave(2, $value);
|
|
|
2616 $n1 = $n1->number;
|
|
|
2617 $n2 = $n2->number;
|
|
|
2618 $n = "#$n1 ¢ #$n2";
|
|
|
2619 } else {
|
|
|
2620 $n = '#' . ($value->number);
|
|
|
2621 }
|
|
|
2622 push @val, "$reg <- $n";
|
|
|
2623 $value->assign(0) if $stealing;
|
|
|
2624 }
|
|
|
2625 return ('250 Here it is', @val, '.');
|
|
|
2626 }
|
|
|
2627
|
|
|
2628 sub _i_cse {
|
|
|
2629 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2630 $int->{theft_server}
|
|
|
2631 or faint(SP_INVALID, "This program is not allowed to CASE", $name);
|
|
|
2632 my $e = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2633 ref $e or faint(SP_INVALID, "Not an expression", $name);
|
|
|
2634 my @l = ();
|
|
|
2635 if (UNIVERSAL::isa($e, 'Language::INTERCAL::Numbers')) {
|
|
|
2636 my $addr = $e->number;
|
|
|
2637 $addr = join('.', $addr >> 24,
|
|
|
2638 ($addr >> 16) & 0xff,
|
|
|
2639 ($addr >> 8) & 0xff,
|
|
|
2640 $addr & 0xff);
|
|
|
2641 my $bc = $int->{theft_server}->make_broadcast($addr);
|
|
|
2642 if (defined $bc) {
|
|
|
2643 my @ips = $int->{theft_server}->find_theft_servers($bc);
|
|
|
2644 @l = map { unpack('N', inet_aton($_)) } @ips;
|
|
|
2645 } else {
|
|
|
2646 @l = $int->{theft_server}->pids($addr);
|
|
|
2647 }
|
|
|
2648 } elsif (ref $e eq 'ARRAY') {
|
|
|
2649 # assume it is a tail array
|
|
|
2650 my $io = $tp->{registers}{$reg_io}{value}->number;
|
|
|
2651 _create_register($int, $tp, $name, $reg_ar, $runenv);
|
|
|
2652 my $ar = $tp->{registers}{$reg_ar}{value}->number;
|
|
|
2653 my $data = '';
|
|
|
2654 my $fh = Language::INTERCAL::GenericIO->new('STRING', 'r', \$data);
|
|
|
2655 _set_read_charset($int, $tp, $fh);
|
|
|
2656 read_array_16($io, \$ar, $fh, $e, 1);
|
|
|
2657 $tp->{registers}{$reg_ar}{value}->assign($ar);
|
|
|
2658 my ($name, $aliases, $addrtype, $length, @addrs) =
|
|
|
2659 gethostbyname($data);
|
|
|
2660 @l = map { inet_ntoa($_) } @addrs;
|
|
|
2661 } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Arrays')) {
|
|
|
2662 my $io = $tp->{registers}{$reg_io}{value}->number;
|
|
|
2663 _create_register($int, $tp, $name, $reg_ar, $runenv);
|
|
|
2664 my $ar = $tp->{registers}{$reg_ar}{value}->number;
|
|
|
2665 my @v = map { $_->number } $e->as_list;
|
|
|
2666 @v or faint(SP_NODIM);
|
|
|
2667 my $data = '';
|
|
|
2668 my $fh = Language::INTERCAL::GenericIO->new('STRING', 'r', \$data);
|
|
|
2669 _set_read_charset($int, $tp, $fh);
|
|
|
2670 if ($e->bits <= 16) {
|
|
|
2671 read_array_16($io, \$ar, $fh, \@v, 0);
|
|
|
2672 } else {
|
|
|
2673 read_array_32($io, \$ar, $fh, \@v, 0);
|
|
|
2674 }
|
|
|
2675 $tp->{registers}{$reg_ar}{value}->assign($ar);
|
|
|
2676 my ($name, $aliases, $addrtype, $length, @addrs) =
|
|
|
2677 gethostbyname($data);
|
|
|
2678 @l = map { unpack('N', $_) } @addrs;
|
|
|
2679 } else {
|
|
|
2680 faint(SP_INVALID, 'Expression type', $name);
|
|
|
2681 }
|
|
|
2682 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2683 $num > 0 or return undef;
|
|
|
2684 # make sure @l has the correct number of elements
|
|
|
2685 if (@l < 1) {
|
|
|
2686 @l = (0) x $num;
|
|
|
2687 } elsif (@l > $num) {
|
|
|
2688 # take a random sample of @l
|
|
|
2689 @l = (sort { rand(200) - 100 } @l)[1..$num];
|
|
|
2690 } elsif (@l < $num) {
|
|
|
2691 # add a random selection of elements
|
|
|
2692 while (@l < $num) {
|
|
|
2693 my $add = $num - @l;
|
|
|
2694 $add = @l if $add > @l;
|
|
|
2695 @l = sort { rand(200) - 100 } @l;
|
|
|
2696 push @l, @l[0..$add-1];
|
|
|
2697 }
|
|
|
2698 }
|
|
|
2699 while ($num-- > 0) {
|
|
|
2700 # first assign to expression
|
|
|
2701 my $l = Language::INTERCAL::Numbers::Twospot->new(shift @l);
|
|
|
2702 _run($int, $tp, _a($runenv, assign => $l), $cp, $ep, 1);
|
|
|
2703 # then execute statement (if not ABSTAINed FROM)
|
|
|
2704 my $len = bc_skip($int->{code}, $$cp, $ep)
|
|
|
2705 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
2706 $len > 0 or faint(SP_INVALID, 'empty statement', $name);
|
|
|
2707 my $ge = ord(substr($int->{code}, $$cp, 1));
|
|
|
2708 my $ab = $ge != BC_GUP && exists $tp->{ab_gerund}{$ge}
|
|
|
2709 ? $tp->{ab_gerund}{$ge}
|
|
|
2710 : 0;
|
|
|
2711 if ($ab) {
|
|
|
2712 $$cp += $len;
|
|
|
2713 } else {
|
|
|
2714 _run($int, $tp, $runenv, $cp, $ep, 1);
|
|
|
2715 }
|
|
|
2716 }
|
|
|
2717 undef;
|
|
|
2718 }
|
|
|
2719
|
|
|
2720 sub _uninterleave {
|
|
|
2721 my ($base, $value) = @_;
|
|
|
2722 my @value = $value->twospot->digits($base);
|
|
|
2723 my @val1 = ();
|
|
|
2724 my @val2 = ();
|
|
|
2725 while (@value) {
|
|
|
2726 push @val1, shift @value;
|
|
|
2727 push @val2, shift @value;
|
|
|
2728 }
|
|
|
2729 return (Language::INTERCAL::Numbers->from_digits($base, @val1),
|
|
|
2730 Language::INTERCAL::Numbers->from_digits($base, @val2));
|
|
|
2731 }
|
|
|
2732
|
|
|
2733 sub _i_sel {
|
|
|
2734 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2735 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2736 if ($runenv->{assign}) {
|
|
|
2737 # assign to select
|
|
|
2738 my $assign = $runenv->{assign};
|
|
|
2739 if (ref $assign eq 'CODE') {
|
|
|
2740 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2741 }
|
|
|
2742 _run($int, $tp, $runenv, $cp, $ep, 1);
|
|
|
2743 my @num = $assign->digits($ba);
|
|
|
2744 my $num = 0;
|
|
|
2745 for my $n (@num) {
|
|
|
2746 $num = 1 if $n;
|
|
|
2747 $n = $num;
|
|
|
2748 }
|
|
|
2749 $num = Language::INTERCAL::Numbers->from_digits($ba, @num);
|
|
|
2750 _run($int, $tp, _a($runenv, assign => $num), $cp, $ep, 1);
|
|
|
2751 return undef;
|
|
|
2752 } else {
|
|
|
2753 my $num1 =
|
|
|
2754 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2755 my $num2 =
|
|
|
2756 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2757 my @num1 = $num1->digits($ba);
|
|
|
2758 my @num2 = $num2->digits($ba);
|
|
|
2759 # make sure @num1 is a twospot if @num2 is
|
|
|
2760 unshift @num1, 0 while @num1 < @num2;
|
|
|
2761 my @num = map { [] } (0..$ba - 1);
|
|
|
2762 while (@num2) {
|
|
|
2763 my $val1 = pop @num1;
|
|
|
2764 my $val2 = pop @num2;
|
|
|
2765 if ($val1 && $val2) {
|
|
|
2766 unshift @{$num[$val2]}, $val1 > $val2 ? $val1 : $val2;
|
|
|
2767 } else {
|
|
|
2768 unshift @{$num[$val2]}, 0;
|
|
|
2769 }
|
|
|
2770 }
|
|
|
2771 @num = map { @{ $num[$_] } } (0..$ba - 1);
|
|
|
2772 return Language::INTERCAL::Numbers->from_digits($ba, @num);
|
|
|
2773 }
|
|
|
2774 }
|
|
|
2775
|
|
|
2776 sub _i_rse {
|
|
|
2777 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2778 # we must execute the operands in reverse order, or side-effects won't
|
|
|
2779 # work as advertised.
|
|
|
2780 my $firstop = $$cp;
|
|
|
2781 $$cp += bc_skip($int->{code}, $firstop, $ep);
|
|
|
2782 my $firstend = $$cp;
|
|
|
2783 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2784 if ($runenv->{assign}) {
|
|
|
2785 # assign to select
|
|
|
2786 my $assign = $runenv->{assign};
|
|
|
2787 if (ref $assign eq 'CODE') {
|
|
|
2788 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2789 }
|
|
|
2790 _run($int, $tp, $runenv, $cp, $ep, 1);
|
|
|
2791 my @num = $assign->digits($ba);
|
|
|
2792 my $num = 0;
|
|
|
2793 for my $n (@num) {
|
|
|
2794 $num = 1 if $n;
|
|
|
2795 $n = $num;
|
|
|
2796 }
|
|
|
2797 $num = Language::INTERCAL::Numbers->from_digits($ba, @num);
|
|
|
2798 _run($int, $tp, _a($runenv, assign => $num), \$firstop, $firstend, 1);
|
|
|
2799 return undef;
|
|
|
2800 } else {
|
|
|
2801 my $num1 =
|
|
|
2802 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2803 my $num2 =
|
|
|
2804 _get_expression($int, $tp, $name, $runenv, \$firstop, $firstend, 1);
|
|
|
2805 my @num1 = $num1->digits($ba);
|
|
|
2806 my @num2 = $num2->digits($ba);
|
|
|
2807 # make sure @num1 is a twospot if @num2 is
|
|
|
2808 unshift @num1, 0 while @num1 < @num2;
|
|
|
2809 my @num = map { [] } (0..$ba - 1);
|
|
|
2810 while (@num2) {
|
|
|
2811 my $val1 = pop @num1;
|
|
|
2812 my $val2 = pop @num2;
|
|
|
2813 if ($val1 && $val2) {
|
|
|
2814 unshift @{$num[$val2]}, $val1 > $val2 ? $val1 : $val2;
|
|
|
2815 } else {
|
|
|
2816 unshift @{$num[$val2]}, 0;
|
|
|
2817 }
|
|
|
2818 }
|
|
|
2819 @num = map { @{ $num[$_] } } (0..$ba - 1);
|
|
|
2820 return Language::INTERCAL::Numbers->from_digits($ba, @num);
|
|
|
2821 }
|
|
|
2822 }
|
|
|
2823
|
|
|
2824 sub _i_swb {
|
|
|
2825 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2826 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2827 my $assign = $runenv->{assign};
|
|
|
2828 if ($assign) {
|
|
|
2829 if (ref $assign eq 'CODE') {
|
|
|
2830 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2831 }
|
|
|
2832 my @num = $assign->digits($ba);
|
|
|
2833 my @check = @num;
|
|
|
2834 my $carry = 0;
|
|
|
2835 for my $v (reverse @num) {
|
|
|
2836 ($v, $carry) = ($carry, ($carry + $v) % $ba);
|
|
|
2837 }
|
|
|
2838 my $new_value = Language::INTERCAL::Numbers->from_digits($ba, @num);
|
|
|
2839 $assign = $assign->number;
|
|
|
2840 unshift @num, $num[-1];
|
|
|
2841 while (@num > 1) {
|
|
|
2842 my $dig = shift @num;
|
|
|
2843 $dig = ($dig - $num[0]) % $ba;
|
|
|
2844 if ($dig != shift @check) {
|
|
|
2845 faint(SP_ASSIGN, $ba, '|', $assign);
|
|
|
2846 }
|
|
|
2847 }
|
|
|
2848 _run($int, $tp, _a($runenv, assign => $new_value), $cp, $ep, 1);
|
|
|
2849 return undef;
|
|
|
2850 } else {
|
|
|
2851 my $num =
|
|
|
2852 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2853 my @num = $num->digits($ba);
|
|
|
2854 unshift @num, $num[-1];
|
|
|
2855 my @result = ();
|
|
|
2856 while (@num > 1) {
|
|
|
2857 my $dig = shift @num;
|
|
|
2858 push @result, ($dig - $num[0]) % $ba;
|
|
|
2859 }
|
|
|
2860 return Language::INTERCAL::Numbers->from_digits($ba, @result);
|
|
|
2861 }
|
|
|
2862 }
|
|
|
2863
|
|
|
2864 sub _i_awc {
|
|
|
2865 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2866 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2867 my $assign = $runenv->{assign};
|
|
|
2868 if ($assign) {
|
|
|
2869 if (ref $assign eq 'CODE') {
|
|
|
2870 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2871 }
|
|
|
2872 my @check = $assign->digits($ba);
|
|
|
2873 $assign = $assign->number;
|
|
|
2874 # unlike swb, undoing awc requires to look for the right
|
|
|
2875 # first digit...
|
|
|
2876 TRY:
|
|
|
2877 for (my $try = 0; $try < $ba; $try++) {
|
|
|
2878 my @num = @check;
|
|
|
2879 my $carry = $try;
|
|
|
2880 for my $v (reverse @num) {
|
|
|
2881 ($v, $carry) = ($carry, ($v - $carry) % $ba);
|
|
|
2882 }
|
|
|
2883 my $new_value = Language::INTERCAL::Numbers->from_digits($ba, @num);
|
|
|
2884 unshift @num, $num[-1];
|
|
|
2885 my @c = @check;
|
|
|
2886 while (@num > 1) {
|
|
|
2887 my $dig = shift @num;
|
|
|
2888 $dig = ($num[0] + $dig) % $ba;
|
|
|
2889 if ($dig != shift @c) {
|
|
|
2890 next TRY;
|
|
|
2891 }
|
|
|
2892 }
|
|
|
2893 _run($int, $tp, _a($runenv, assign => $new_value), $cp, $ep, 1);
|
|
|
2894 return undef;
|
|
|
2895 }
|
|
|
2896 faint(SP_ASSIGN, $ba, '¥', $assign);
|
|
|
2897 } else {
|
|
|
2898 my $num =
|
|
|
2899 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2900 my @num = $num->digits($ba);
|
|
|
2901 unshift @num, $num[-1];
|
|
|
2902 my @result = ();
|
|
|
2903 while (@num > 1) {
|
|
|
2904 my $dig = shift @num;
|
|
|
2905 push @result, ($num[0] + $dig) % $ba;
|
|
|
2906 }
|
|
|
2907 return Language::INTERCAL::Numbers->from_digits($ba, @result);
|
|
|
2908 }
|
|
|
2909 }
|
|
|
2910
|
|
|
2911 sub _i_but {
|
|
|
2912 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2913 my $ba = $tp->{registers}{$reg_ba}{value}->number;
|
|
|
2914 my $prefer = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
2915 faint(SP_ILLEGAL, $prefer . $name, $ba)
|
|
|
2916 if $prefer != 7 && $prefer > $ba - 2;
|
|
|
2917 my $assign = $runenv->{assign};
|
|
|
2918 if ($assign) {
|
|
|
2919 if (ref $assign eq 'CODE') {
|
|
|
2920 $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N');
|
|
|
2921 }
|
|
|
2922 my @num = $assign->digits($ba);
|
|
|
2923 my @check = @num;
|
|
|
2924 push @num, $num[0];
|
|
|
2925 my @result = ();
|
|
|
2926 while (@num > 1) {
|
|
|
2927 my $num1 = shift @num;
|
|
|
2928 my $num2 = $num[0];
|
|
|
2929 if ($num1 == $prefer && $num2 == $prefer) {
|
|
|
2930 push @result, $prefer;
|
|
|
2931 } elsif ($num1 == $prefer) {
|
|
|
2932 push @result, $num2;
|
|
|
2933 } elsif ($num2 == $prefer) {
|
|
|
2934 push @result, $num1;
|
|
|
2935 } elsif ($num1 > $prefer || $num2 > $prefer) {
|
|
|
2936 push @result, $num1 > $num2 ? $num1 : $num2;
|
|
|
2937 } elsif ($num1 > $num2) {
|
|
|
2938 push @result, $num2;
|
|
|
2939 } else {
|
|
|
2940 push @result, $num1;
|
|
|
2941 }
|
|
|
2942 }
|
|
|
2943 my $new_value = Language::INTERCAL::Numbers->from_digits($ba, @result);
|
|
|
2944 $assign = $assign->number;
|
|
|
2945 unshift @result, $result[-1];
|
|
|
2946 while (@result > 1) {
|
|
|
2947 my $num1 = shift @result;
|
|
|
2948 my $num2 = $result[0];
|
|
|
2949 my $result;
|
|
|
2950 if ($num1 <= $prefer) {
|
|
|
2951 if ($num2 < $num1 || $num2 > $prefer) {
|
|
|
2952 $result = $num1;
|
|
|
2953 } else {
|
|
|
2954 $result = $num2;
|
|
|
2955 }
|
|
|
2956 } else {
|
|
|
2957 if ($num2 < $num1 && $num2 > $prefer) {
|
|
|
2958 $result = $num1;
|
|
|
2959 } else {
|
|
|
2960 $result = $num2;
|
|
|
2961 }
|
|
|
2962 }
|
|
|
2963 if ($result != shift @check) {
|
|
|
2964 faint(SP_ASSIGN, $ba, $prefer . '?', $assign)
|
|
|
2965 }
|
|
|
2966 }
|
|
|
2967 _run($int, $tp, _a($runenv, assign => $new_value), $cp, $ep, 1);
|
|
|
2968 return undef;
|
|
|
2969 } else {
|
|
|
2970 my $num =
|
|
|
2971 _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
2972 my @num = $num->digits($ba);
|
|
|
2973 unshift @num, $num[-1];
|
|
|
2974 my @result = ();
|
|
|
2975 while (@num > 1) {
|
|
|
2976 my $num1 = shift @num;
|
|
|
2977 my $num2 = $num[0];
|
|
|
2978 if ($num1 <= $prefer) {
|
|
|
2979 if ($num2 < $num1 || $num2 > $prefer) {
|
|
|
2980 push @result, $num1;
|
|
|
2981 } else {
|
|
|
2982 push @result, $num2;
|
|
|
2983 }
|
|
|
2984 } else {
|
|
|
2985 if ($num2 < $num1 && $num2 > $prefer) {
|
|
|
2986 push @result, $num1;
|
|
|
2987 } else {
|
|
|
2988 push @result, $num2;
|
|
|
2989 }
|
|
|
2990 }
|
|
|
2991 }
|
|
|
2992 return Language::INTERCAL::Numbers->from_digits($ba, @result);
|
|
|
2993 }
|
|
|
2994 }
|
|
|
2995
|
|
|
2996 sub _i_con {
|
|
|
2997 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
2998 my ($o1, $o2) =
|
|
|
2999 _opcode_pair($int, $tp, $cp, $ep, $name, $runenv, SP_CONVERT);
|
|
|
3000 if ($int->{record_grammar}) {
|
|
|
3001 push @{$tp->{grammar_record}}, [BC_CON, $o1, $o2];
|
|
|
3002 }
|
|
|
3003 $tp->{opcodes}{$o1} = $tp->{opcodes}{$o2};
|
|
|
3004 undef;
|
|
|
3005 }
|
|
|
3006
|
|
|
3007 sub _i_swa {
|
|
|
3008 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3009 my ($o1, $o2) = _opcode_pair($int, $tp, $cp, $ep, $name, $runenv, SP_SWAP);
|
|
|
3010 if ($int->{record_grammar}) {
|
|
|
3011 push @{$tp->{grammar_record}}, [BC_SWA, $o1, $o2];
|
|
|
3012 }
|
|
|
3013 ($tp->{opcodes}{$o1}, $tp->{opcodes}{$o2}) =
|
|
|
3014 ($tp->{opcodes}{$o2}, $tp->{opcodes}{$o1});
|
|
|
3015 undef;
|
|
|
3016 }
|
|
|
3017
|
|
|
3018 sub _opcode_pair {
|
|
|
3019 my ($int, $tp, $cp, $ep, $name, $runenv, $splat) = @_;
|
|
|
3020 $$cp + 2 > $ep and faint(SP_INVALID, "Missing opcodes", $name);
|
|
|
3021 my $o1 = ord(substr($int->{code}, $$cp++, 1));
|
|
|
3022 my @d1 = bytedecode($o1) or faint(SP_INVALID, $o1, $name);
|
|
|
3023 if ($d1[5]) {
|
|
|
3024 $$cp--;
|
|
|
3025 $o1 = BCget($int->{code}, $cp, $ep);
|
|
|
3026 my $args = '';
|
|
|
3027 exists $tp->{opcodes}{$o1} && ref $tp->{opcodes}{$o1} eq 'ARRAY'
|
|
|
3028 and $args = $tp->{opcodes}{$o1}[0];
|
|
|
3029 @d1 = ($o1, '', '', $o1, $args, 0, 0);
|
|
|
3030 }
|
|
|
3031 my $o2 = ord(substr($int->{code}, $$cp++, 1));
|
|
|
3032 my @d2 = bytedecode($o2) or faint(SP_INVALID, $o2, $name);
|
|
|
3033 if ($d2[5]) {
|
|
|
3034 $$cp--;
|
|
|
3035 $o2 = BCget($int->{code}, $cp, $ep);
|
|
|
3036 my $args = '';
|
|
|
3037 exists $tp->{opcodes}{$o2} && ref $tp->{opcodes}{$o2} eq 'ARRAY'
|
|
|
3038 and $args = $tp->{opcodes}{$o2}[0];
|
|
|
3039 @d2 = ($o2, '', '', $o2, $args, 0, 0);
|
|
|
3040 }
|
|
|
3041 exists $tp->{opcodes}{$d1[0]} &&
|
|
|
3042 exists $tp->{opcodes}{$d2[0]} &&
|
|
|
3043 $d1[4] eq $d2[4]
|
|
|
3044 or faint($splat, $d1[0], $d2[0]);
|
|
|
3045 if ($runenv->{quantum}) {
|
|
|
3046 push @{$runenv->{quantum}},
|
|
|
3047 [$tp->{opcodes}{$d1[0]}, 'opcodes', $d1[0]],
|
|
|
3048 [$tp->{opcodes}{$d2[0]}, 'opcodes', $d2[0]];
|
|
|
3049 }
|
|
|
3050 ($d1[0], $d2[0]);
|
|
|
3051 }
|
|
|
3052
|
|
|
3053 sub _i_frz {
|
|
|
3054 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3055 faint(SP_QUANTUM, 'FREEZE') if $runenv->{quantum};
|
|
|
3056 $int->{source} eq '' and return undef;
|
|
|
3057 $int->{source} = '';
|
|
|
3058 $int->{object}->shift_parsers;
|
|
|
3059 for my $thr (@{$int->{threads}}, $int->{default}) {
|
|
|
3060 shift @{$thr->{rules}};
|
|
|
3061 }
|
|
|
3062 undef;
|
|
|
3063 }
|
|
|
3064
|
|
|
3065 sub _i_mul {
|
|
|
3066 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3067 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3068 _trace($int, $tp, "<", 1);
|
|
|
3069 my @vec = ();
|
|
|
3070 while (@vec < $num) {
|
|
|
3071 my $v = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3072 $v or faint(SP_INVALID, "Not an expression", $name);
|
|
|
3073 push @vec, $v;
|
|
|
3074 }
|
|
|
3075 _trace($int, $tp, ">", 1);
|
|
|
3076 Language::INTERCAL::Arrays::Tail->from_list(\@vec);
|
|
|
3077 }
|
|
|
3078
|
|
|
3079 sub _i_str {
|
|
|
3080 # treat STR as a compact form of MUL - if internal optimisations are
|
|
|
3081 # possible, they will be done instead of calling _i_str
|
|
|
3082 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3083 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3084 $$cp + $num <= $ep
|
|
|
3085 or faint(SP_INVALID, "Not enough constants", $name);
|
|
|
3086 my $str = substr($int->{code}, $$cp, $num);
|
|
|
3087 $$cp += $num;
|
|
|
3088 my @vec = unpack('C*', $str);
|
|
|
3089 if ($tp->{registers}{$reg_tm}{value} &&
|
|
|
3090 $tp->{registers}{$reg_tm}{value}->number &&
|
|
|
3091 $tp->{registers}{$reg_trfh}{value})
|
|
|
3092 {
|
|
|
3093 $str =~ s/([\\<>\P{IsPrint}])/sprintf("\\x%02x", ord($1))/ge;
|
|
|
3094 $str = "<$str>";
|
|
|
3095 while (length $str > 40) {
|
|
|
3096 my $x = substr($str, 0, 40, '');
|
|
|
3097 _trace($int, $tp, $x, 1);
|
|
|
3098 }
|
|
|
3099 _trace($int, $tp, $str, 1);
|
|
|
3100 }
|
|
|
3101 Language::INTERCAL::Arrays::Tail->from_list(\@vec);
|
|
|
3102 }
|
|
|
3103
|
|
|
3104 sub _i_cre {
|
|
|
3105 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3106 $int->{object} or faint(SP_CONTEXT, "Creation without a grammar");
|
|
|
3107 my $gra = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3108 $gra >= 1 && $gra <= $int->{object}->num_parsers
|
|
|
3109 or faint(SP_EVOLUTION, 'Invalid grammar number');
|
|
|
3110 my $sym = _get_symbol($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3111 my $left = _get_left($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3112 my $right = _get_right($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3113 if ($int->{record_grammar}) {
|
|
|
3114 push @{$tp->{grammar_record}}, [BC_CRE, $gra, $sym, $left, $right];
|
|
|
3115 }
|
|
|
3116 _ii_cre($int, $tp, $gra, $sym, $left, $right, $runenv);
|
|
|
3117 undef;
|
|
|
3118 }
|
|
|
3119
|
|
|
3120 sub _ii_cre {
|
|
|
3121 my ($int, $tp, $gra, $sym, $left, $right, $runenv) = @_;
|
|
|
3122 my $r = $int->{object}->parser($gra)->add($sym, $left, $right);
|
|
|
3123 # if they have modified the other grammar, that's all we need to do
|
|
|
3124 # if the rule was already in the grammar just enable it
|
|
|
3125 if ($r < 0) {
|
|
|
3126 $r = -$r;
|
|
|
3127 _trace($int, $tp, "o$r", 1);
|
|
|
3128 _create_rule($int, $tp, $gra - 1, $r, $runenv);
|
|
|
3129 ${$tp->{rules}[$gra - 1][$r]} = 1;
|
|
|
3130 return undef;
|
|
|
3131 }
|
|
|
3132 _trace($int, $tp, "n$r", 1);
|
|
|
3133 _create_rule($int, $tp, $gra - 1, $r, $runenv);
|
|
|
3134 # a new rule - must recompile the program if $gra == 1
|
|
|
3135 $int->{source} ne ''
|
|
|
3136 or faint(SP_CONTEXT,
|
|
|
3137 "CREATE requires recompile, but there is no source");
|
|
|
3138 ${$tp->{rules}[$gra - 1][$r]} = 1;
|
|
|
3139 $int->{recompile} = 1 if $gra == 1;
|
|
|
3140 undef;
|
|
|
3141 }
|
|
|
3142
|
|
|
3143 sub _create_rule {
|
|
|
3144 my ($int, $tp, $gra, $r, $runenv) = @_;
|
|
|
3145 my $rv = 0;
|
|
|
3146 for my $thr (@{$int->{threads}}, $int->{default}) {
|
|
|
3147 next if $thr->{rules}[$gra][$r];
|
|
|
3148 $thr->{rules}[$gra][$r] = \$rv;
|
|
|
3149 }
|
|
|
3150 if ($runenv->{quantum}) {
|
|
|
3151 push @{$runenv->{quantum}},
|
|
|
3152 [_deep_copy($tp->{rules}[$gra][$r]), 'rules', $gra, $r];
|
|
|
3153 }
|
|
|
3154 }
|
|
|
3155
|
|
|
3156 sub _i_des {
|
|
|
3157 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3158 $int->{object} or faint(SP_CONTEXT, "Destruction without a grammar");
|
|
|
3159 my $gra = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3160 $gra >= 1 && $gra <= $int->{object}->num_parsers
|
|
|
3161 or faint(SP_EVOLUTION, 'Invalid grammar number');
|
|
|
3162 my $sym = _get_symbol($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3163 my $left = _get_left($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3164 if ($int->{record_grammar}) {
|
|
|
3165 push @{$tp->{grammar_record}}, [BC_DES, $gra, $sym, $left];
|
|
|
3166 }
|
|
|
3167 _ii_des($int, $tp, $gra, $sym, $left, $runenv);
|
|
|
3168 undef;
|
|
|
3169 }
|
|
|
3170
|
|
|
3171 sub _ii_des {
|
|
|
3172 my ($int, $tp, $gra, $sym, $left, $runenv) = @_;
|
|
|
3173 my @r = $int->{object}->parser($gra)->find_rule($sym, $left);
|
|
|
3174 for my $r (@r) {
|
|
|
3175 _trace($int, $tp, "r$r", 1);
|
|
|
3176 _create_rule($int, $tp, $gra - 1, $r, $runenv);
|
|
|
3177 ${$tp->{rules}[$gra - 1][$r]} = 0;
|
|
|
3178 }
|
|
|
3179 }
|
|
|
3180
|
|
|
3181 sub _i_usg {
|
|
|
3182 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3183 my $op = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3184 exists $tp->{opcodes}{$op} or faint(SP_TODO, $op);
|
|
|
3185 ref $tp->{opcodes}{$op} eq 'ARRAY' or faint(SP_INVALID, $op, $name);
|
|
|
3186 # now we need to execute this opcode...
|
|
|
3187 my $savecode = $int->{code};
|
|
|
3188 my $prefix = $tp->{opcodes}{$op}[1];
|
|
|
3189 my $suffix = substr($savecode, $$cp, $ep - $$cp);
|
|
|
3190 my $ptr = 0;
|
|
|
3191 $int->{code} = $prefix . $suffix;
|
|
|
3192 $@ = '';
|
|
|
3193 eval {
|
|
|
3194 _run($int, $tp, $runenv, \$ptr, length($int->{code}), 1);
|
|
|
3195 $ptr < length($prefix)
|
|
|
3196 and faint(SP_INVALID, 'did not complete prefix', $name);
|
|
|
3197 };
|
|
|
3198 $int->{code} = $savecode;
|
|
|
3199 $@ and die $@;
|
|
|
3200 # the amount of code we executed is $ptr - length($prefix)...
|
|
|
3201 $$cp += $ptr - length($prefix);
|
|
|
3202 undef;
|
|
|
3203 }
|
|
|
3204
|
|
|
3205 sub _i_mkg {
|
|
|
3206 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3207 faint(SP_QUANTUM, $name) if $runenv->{quantum};
|
|
|
3208 my $op = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3209 my $template = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3210 my $code = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3211 if (exists $tp->{opcodes}{$op}) {
|
|
|
3212 # duplicates are OK, because the MAKE NEW OPCODE may get
|
|
|
3213 # re-executed; however duplicates which change the template
|
|
|
3214 # are not OK because they screw up CONVERT and SWAP
|
|
|
3215 ref $tp->{opcodes}{$op} ne 'ARRAY'
|
|
|
3216 and faint(SP_MAKE_NEW, $op);
|
|
|
3217 $tp->{opcodes}{$op}[0] ne $template
|
|
|
3218 and faint(SP_MAKE_NEW, $op);
|
|
|
3219 # we don't want to create it again though - it may have already
|
|
|
3220 # been CONVERTed or SWAPped and that would silently undo it!
|
|
|
3221 return;
|
|
|
3222 }
|
|
|
3223 push @{$tp->{make_record}}, [$op, $template, $code];
|
|
|
3224 $tp->{opcodes}{$op} = [$template, $code];
|
|
|
3225 for my $thread (@{$int->{threads}}) {
|
|
|
3226 exists $thread->{opcodes}{$op}
|
|
|
3227 or $thread->{opcodes}{$op} = $tp->{opcodes}{$op};
|
|
|
3228 }
|
|
|
3229 }
|
|
|
3230
|
|
|
3231 sub _i_cwb {
|
|
|
3232 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3233 faint(SP_QUANTUM, 'LOOP') if $runenv->{quantum};
|
|
|
3234 my $body = $$cp;
|
|
|
3235 my $blen = bc_skip($int->{code}, $body, $ep)
|
|
|
3236 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3237 $blen > 0 or faint(SP_INVALID, 'empty body', $name);
|
|
|
3238 my $bge = ord(substr($int->{code}, $body, 1));
|
|
|
3239 $$cp = $body + $blen;
|
|
|
3240 my $clen = bc_skip($int->{code}, $$cp, $ep)
|
|
|
3241 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3242 $clen > 0 or faint(SP_INVALID, 'empty condition', $name);
|
|
|
3243 my $here = $$cp;
|
|
|
3244 my $cge = ord(substr($int->{code}, $$cp, 1));
|
|
|
3245 my $cab = $cge != BC_GUP && exists $tp->{ab_gerund}{$cge}
|
|
|
3246 ? $tp->{ab_gerund}{$cge}
|
|
|
3247 : 0;
|
|
|
3248 my $bt = _dup_thread($int, $tp);
|
|
|
3249 my $loop_id = ++$int->{loop_id};
|
|
|
3250 $bt->{loop_code} = [$body, $$cp, $bge, $loop_id, $bt->{comefrom}];
|
|
|
3251 @{$bt->{comefrom}} = ();
|
|
|
3252 $tp->{loop_id}{$loop_id} = 1;
|
|
|
3253 push @{$tp->{in_loop}}, $loop_id;
|
|
|
3254 if ($cab) {
|
|
|
3255 $$cp += $clen;
|
|
|
3256 } else {
|
|
|
3257 _run($int, $tp, $runenv, $cp, $ep, 1);
|
|
|
3258 }
|
|
|
3259 # there may be a COME FROM gerund here
|
|
|
3260 my $sv = $tp->{comefrom};
|
|
|
3261 $tp->{comefrom} = [0, 0, $cge, $here];
|
|
|
3262 _comefrom($int, $tp);
|
|
|
3263 $tp->{comefrom} = $sv;
|
|
|
3264 }
|
|
|
3265
|
|
|
3266 sub _i_bwc {
|
|
|
3267 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3268 faint(SP_QUANTUM, 'LOOP') if $runenv->{quantum};
|
|
|
3269 my $cond = $$cp;
|
|
|
3270 my $clen = bc_skip($int->{code}, $cond, $ep)
|
|
|
3271 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3272 my $cge = ord(substr($int->{code}, $cond, 1));
|
|
|
3273 my $cab = $cge != BC_GUP && exists $tp->{ab_gerund}{$cge}
|
|
|
3274 ? $tp->{ab_gerund}{$cge}
|
|
|
3275 : 0;
|
|
|
3276 my $body = $cond + $clen;
|
|
|
3277 my $blen = bc_skip($int->{code}, $body, $ep)
|
|
|
3278 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3279 my $bge = ord(substr($int->{code}, $body, 1));
|
|
|
3280 $$cp = $body + $blen;
|
|
|
3281 my $bt = _dup_thread($int, $tp);
|
|
|
3282 my $loop_id = ++$int->{loop_id};
|
|
|
3283 $bt->{loop_code} = [$body, $$cp, $bge, $loop_id, $bt->{comefrom}];
|
|
|
3284 @{$bt->{comefrom}} = ();
|
|
|
3285 $tp->{loop_id}{$loop_id} = 1;
|
|
|
3286 push @{$tp->{in_loop}}, $loop_id;
|
|
|
3287 $cab or _run($int, $tp, $runenv, \$cond, $body, 1);
|
|
|
3288 # there may be a COME FROM gerund here
|
|
|
3289 my $sv = $tp->{comefrom};
|
|
|
3290 $tp->{comefrom} = [0, 0, $cge, $cond];
|
|
|
3291 _comefrom($int, $tp);
|
|
|
3292 $tp->{comefrom} = $sv;
|
|
|
3293 }
|
|
|
3294
|
|
|
3295 sub _i_ebc {
|
|
|
3296 faint(SP_EVENT);
|
|
|
3297 }
|
|
|
3298
|
|
|
3299 sub _i_ecb {
|
|
|
3300 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3301 faint(SP_QUANTUM, 'EVENT') if $runenv->{quantum};
|
|
|
3302 my $cond = $$cp;
|
|
|
3303 my $clen = bc_skip($int->{code}, $cond, $ep)
|
|
|
3304 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3305 my $body = $cond + $clen;
|
|
|
3306 my $blen = bc_skip($int->{code}, $body, $ep)
|
|
|
3307 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3308 my $bge = ord(substr($int->{code}, $body, 1));
|
|
|
3309 $$cp = $body + $blen;
|
|
|
3310 push @{$int->{events}},
|
|
|
3311 [$int->{code}, $cond, $cond + $clen, $body, $body + $blen, $bge];
|
|
|
3312 }
|
|
|
3313
|
|
|
3314 sub _i_sys {
|
|
|
3315 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3316 faint(SP_QUANTUM, 'System call definition') if $runenv->{quantum};
|
|
|
3317 my $sysnum = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3318 my $count = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3319 my $base = $$cp;
|
|
|
3320 while ($count-- > 0) {
|
|
|
3321 $$cp += bc_skip($int->{code}, $$cp, $ep)
|
|
|
3322 or faint(SP_INVALID, '(unknown)', $name);
|
|
|
3323 }
|
|
|
3324 $int->{syscode}{$sysnum} = substr($int->{code}, $base, $$cp - $base);
|
|
|
3325 undef;
|
|
|
3326 }
|
|
|
3327
|
|
|
3328 sub _i_gup {
|
|
|
3329 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3330 $tp->{running} = 0 unless $runenv->{quantum};
|
|
|
3331 undef;
|
|
|
3332 }
|
|
|
3333
|
|
|
3334 sub _i_nxt {
|
|
|
3335 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3336 my $lab = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3337 if ($runenv->{quantum}) {
|
|
|
3338 push @{$runenv->{quantum}},
|
|
|
3339 [_deep_copy($tp->{next_stack}), 'next_stack'],
|
|
|
3340 [$tp->{s_pointer}, 's_pointer'],
|
|
|
3341 [_deep_copy($tp->{loop_code}), 'loop_code'],
|
|
|
3342 [_deep_copy($tp->{in_loop}), 'in_loop'],
|
|
|
3343 [_deep_copy($tp->{comefrom}), 'comefrom'];
|
|
|
3344 }
|
|
|
3345 @{$tp->{next_stack}} >= MAX_NEXT and faint(SP_NEXTING, MAX_NEXT);
|
|
|
3346 push @{$tp->{next_stack}}, [
|
|
|
3347 $tp->{s_pointer},
|
|
|
3348 [@{$tp->{loop_code}}],
|
|
|
3349 [@{$tp->{in_loop}}],
|
|
|
3350 [@{$tp->{comefrom}}],
|
|
|
3351 ];
|
|
|
3352 @{$tp->{loop_code}} = ();
|
|
|
3353 @{$tp->{comefrom}} = ();
|
|
|
3354 @{$tp->{in_loop}} = ();
|
|
|
3355 $tp->{s_pointer} = _find_label($int, $tp, $name, $lab);
|
|
|
3356 undef;
|
|
|
3357 }
|
|
|
3358
|
|
|
3359 sub _i_stu {
|
|
|
3360 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3361 my $subject = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3362 my $lecture = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3363 _run($int, $tp,
|
|
|
3364 _a($runenv, assign => \&_x_stu, class => [$subject, $lecture]),
|
|
|
3365 $cp, $ep, 1);
|
|
|
3366 undef;
|
|
|
3367 }
|
|
|
3368
|
|
|
3369 sub _x_stu {
|
|
|
3370 my ($int, $tp, $runenv, $cp, $ep, $type, $class) = @_;
|
|
|
3371 $type eq 'R' or faint(SP_ISNUMBER, 'STUDY');
|
|
|
3372 _create_register($int, $tp, 'STU', $class, $runenv);
|
|
|
3373 $tp->{registers}{$class}{value}->isa('Language::INTERCAL::Whirlpool')
|
|
|
3374 or faint(SP_NOTCLASS);
|
|
|
3375 my ($subject, $lecture) = @{$runenv->{class}};
|
|
|
3376 $tp->{registers}{$class}{value}->store([$subject], $lecture);
|
|
|
3377 undef;
|
|
|
3378 }
|
|
|
3379
|
|
|
3380 sub _i_enr {
|
|
|
3381 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3382 my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3383 my @subjects = ();
|
|
|
3384 while (@subjects < $num) {
|
|
|
3385 push @subjects, _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3386 }
|
|
|
3387 # now look for a class teaching them all
|
|
|
3388 my @classes = ();
|
|
|
3389 for my $class (keys %{$tp->{registers}}) {
|
|
|
3390 $tp->{registers}{$class}{value}->isa('Language::INTERCAL::Whirlpool')
|
|
|
3391 or next;
|
|
|
3392 eval {
|
|
|
3393 $tp->{registers}{$class}{value}->get([$_]) for @subjects;
|
|
|
3394 };
|
|
|
3395 $@ and next;
|
|
|
3396 push @classes, $class;
|
|
|
3397 }
|
|
|
3398 @classes or faint(SP_HOLIDAY, join(' + ', map { "#$_" } @subjects ));
|
|
|
3399 @classes == 1 or faint(SP_CLASSWAR, (sort @classes)[0, 1]);
|
|
|
3400 _run($int, $tp, _a($runenv, assign => \&_x_enr, class => $classes[0]),
|
|
|
3401 $cp, $ep, 1);
|
|
|
3402 undef;
|
|
|
3403 }
|
|
|
3404
|
|
|
3405 sub _x_enr {
|
|
|
3406 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3407 $type eq 'R' or faint(SP_ISNUMBER, 'ENROL');
|
|
|
3408 _create_register($int, $tp, 'ENR', $reg, $runenv);
|
|
|
3409 my $class = $runenv->{class};
|
|
|
3410 grep { $_ eq $class } @{$tp->{registers}{$reg}{enrol}}
|
|
|
3411 or push @{$tp->{registers}{$reg}{enrol}}, $class;
|
|
|
3412 undef;
|
|
|
3413 }
|
|
|
3414
|
|
|
3415 sub _i_lea {
|
|
|
3416 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3417 my $subject = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3418 _run($int, $tp, _a($runenv, assign => \&_x_lea, subject => $subject),
|
|
|
3419 $cp, $ep, 1);
|
|
|
3420 undef;
|
|
|
3421 }
|
|
|
3422
|
|
|
3423 sub _x_lea {
|
|
|
3424 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3425 $type eq 'R' or faint(SP_ISNUMBER, 'LEARN');
|
|
|
3426 _create_register($int, $tp, 'LEA', $reg, $runenv);
|
|
|
3427 exists $tp->{registers}{$reg}{enrol}
|
|
|
3428 or faint(SP_NOSTUDENT, $reg);
|
|
|
3429 my @classes = ();
|
|
|
3430 my $subject = $runenv->{subject};
|
|
|
3431 for my $class (@{$tp->{registers}{$reg}{enrol}}) {
|
|
|
3432 eval {
|
|
|
3433 my $lab = $tp->{registers}{$class}{value}->get([$subject]);
|
|
|
3434 push @classes, [$class, $lab->number];
|
|
|
3435 };
|
|
|
3436 }
|
|
|
3437 faint(SP_NOCURRICULUM, '#' . $subject, $reg) unless @classes;
|
|
|
3438 faint(SP_CLASSWAR, map { $_->[0] }
|
|
|
3439 (sort { $a->[0] cmp $b->[0] } @classes)[0, 1])
|
|
|
3440 if @classes > 1;
|
|
|
3441 if ($runenv->{quantum}) {
|
|
|
3442 push @{$runenv->{quantum}},
|
|
|
3443 [_deep_copy($tp->{lecture_stack}), 'lecture_stack'],
|
|
|
3444 [$tp->{s_pointer}, 's_pointer'],
|
|
|
3445 [_deep_copy($tp->{loop_code}), 'loop_code'],
|
|
|
3446 [_deep_copy($tp->{in_loop}), 'in_loop'],
|
|
|
3447 [_deep_copy($tp->{comefrom}), 'comefrom'];
|
|
|
3448 }
|
|
|
3449 push @{$tp->{lecture_stack}}, [
|
|
|
3450 $tp->{s_pointer},
|
|
|
3451 $classes[0][0],
|
|
|
3452 $reg,
|
|
|
3453 [@{$tp->{loop_code}}],
|
|
|
3454 [@{$tp->{in_loop}}],
|
|
|
3455 [@{$tp->{comefrom}}],
|
|
|
3456 ];
|
|
|
3457 @{$tp->{loop_code}} = ();
|
|
|
3458 @{$tp->{comefrom}} = ();
|
|
|
3459 @{$tp->{in_loop}} = ();
|
|
|
3460 my $sc = _find_label($int, $tp, 'LEA', $classes[0][1]);
|
|
|
3461 _enslave_register($int, $tp, $runenv, 'LEA', $classes[0][0], $reg);
|
|
|
3462 $tp->{s_pointer} = $sc;
|
|
|
3463 undef;
|
|
|
3464 }
|
|
|
3465
|
|
|
3466 sub _i_gra {
|
|
|
3467 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3468 _run($int, $tp, _a($runenv, assign => \&_x_gra), $cp, $ep, 1);
|
|
|
3469 undef;
|
|
|
3470 }
|
|
|
3471
|
|
|
3472 sub _x_gra {
|
|
|
3473 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3474 $type eq 'R' or faint(SP_ISNUMBER, 'GRADUATE');
|
|
|
3475 _create_register($int, $tp, 'GRA', $reg, $runenv);
|
|
|
3476 exists $tp->{registers}{$reg}{enrol}
|
|
|
3477 or faint(SP_NOSTUDENT, $reg);
|
|
|
3478 delete $tp->{registers}{$reg}{enrol};
|
|
|
3479 undef;
|
|
|
3480 }
|
|
|
3481
|
|
|
3482 sub _i_fin {
|
|
|
3483 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3484 if ($runenv->{quantum}) {
|
|
|
3485 push @{$runenv->{quantum}},
|
|
|
3486 [_deep_copy($tp->{lecture_stack}), 'lecture_stack'],
|
|
|
3487 [$tp->{s_pointer}, 's_pointer'],
|
|
|
3488 [_deep_copy($tp->{loop_code}), 'loop_code'],
|
|
|
3489 [_deep_copy($tp->{in_loop}), 'in_loop'],
|
|
|
3490 [_deep_copy($tp->{comefrom}), 'comefrom'];
|
|
|
3491 }
|
|
|
3492 @{$tp->{lecture_stack}} or faint(SP_LECTURE);
|
|
|
3493 delete $tp->{loop_id}{$_} for @{$tp->{in_loop}};
|
|
|
3494 my ($class, $student, $lc, $il, $cf);
|
|
|
3495 ($tp->{s_pointer}, $class, $student, $lc, $il, $cf) =
|
|
|
3496 @{pop @{$tp->{lecture_stack}}};
|
|
|
3497 @{$tp->{loop_code}} = @$lc;
|
|
|
3498 @{$tp->{in_loop}} = @$il;
|
|
|
3499 @{$tp->{comefrom}} = @$cf;
|
|
|
3500 _free_register($int, $tp, $runenv, $name, $class, $student);
|
|
|
3501 undef;
|
|
|
3502 }
|
|
|
3503
|
|
|
3504 sub _i_ens {
|
|
|
3505 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3506 _run($int, $tp, _a($runenv, assign => \&_x_ens), $cp, $ep, 1);
|
|
|
3507 undef;
|
|
|
3508 }
|
|
|
3509
|
|
|
3510 sub _x_ens {
|
|
|
3511 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3512 $type eq 'R' or faint(SP_NOREGISTER, 'ENSLAVE');
|
|
|
3513 _run($int, $tp, _a($runenv, assign => \&_y_ens, slave => $reg),
|
|
|
3514 $cp, $ep, 1);
|
|
|
3515 undef;
|
|
|
3516 }
|
|
|
3517
|
|
|
3518 sub _y_ens {
|
|
|
3519 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3520 my $slave = $runenv->{slave};
|
|
|
3521 _enslave_register($int, $tp, $runenv, 'ENS', $slave, $reg);
|
|
|
3522 undef;
|
|
|
3523 }
|
|
|
3524
|
|
|
3525 sub _i_fre {
|
|
|
3526 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3527 _run($int, $tp, _a($runenv, assign => \&_x_fre), $cp, $ep, 1);
|
|
|
3528 undef;
|
|
|
3529 }
|
|
|
3530
|
|
|
3531 sub _x_fre {
|
|
|
3532 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3533 $type eq 'R' or faint(SP_NOREGISTER, 'FREE');
|
|
|
3534 _run($int, $tp, _a($runenv, assign => \&_y_fre, slave => $reg),
|
|
|
3535 $cp, $ep, 1);
|
|
|
3536 undef;
|
|
|
3537 }
|
|
|
3538
|
|
|
3539 sub _y_fre {
|
|
|
3540 my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_;
|
|
|
3541 my $slave = $runenv->{slave};
|
|
|
3542 _free_register($int, $tp, $runenv, 'FRE', $slave, $reg);
|
|
|
3543 undef;
|
|
|
3544 }
|
|
|
3545
|
|
|
3546 sub _enslave_register {
|
|
|
3547 my ($int, $tp, $runenv, $name, $slave, $master) = @_;
|
|
|
3548 _create_register($int, $tp, $name, $slave, $runenv);
|
|
|
3549 my $mtype = substr($master, 0, 1, '');
|
|
|
3550 unshift @{$tp->{registers}{$slave}{owners}}, [$mtype, $master];
|
|
|
3551 }
|
|
|
3552
|
|
|
3553 sub _free_register {
|
|
|
3554 my ($int, $tp, $runenv, $name, $slave, $master) = @_;
|
|
|
3555 _create_register($int, $tp, $name, $slave, $runenv);
|
|
|
3556 exists $tp->{registers}{$slave}{owners} &&
|
|
|
3557 @{$tp->{registers}{$slave}{owners}}
|
|
|
3558 or faint(SP_FREE, $slave);
|
|
|
3559 my @no = ();
|
|
|
3560 my $found = 0;
|
|
|
3561 my $mtype = substr($master, 0, 1, '');
|
|
|
3562 for my $o (@{$tp->{registers}{$slave}{owners}}) {
|
|
|
3563 if ($found || $o->[0] ne $mtype || $o->[1] != $master) {
|
|
|
3564 push @no, $o;
|
|
|
3565 } else {
|
|
|
3566 $found = 1;
|
|
|
3567 }
|
|
|
3568 }
|
|
|
3569 $found or faint(SP_NOBELONG, $slave, $mtype . $master);
|
|
|
3570 $tp->{registers}{$slave}{owners} = \@no;
|
|
|
3571 }
|
|
|
3572
|
|
|
3573 sub _find_label {
|
|
|
3574 my ($int, $tp, $name, $lab) = @_;
|
|
|
3575 faint(SP_INVLABEL, $lab) if $lab < 1 || $lab > 0xffff;
|
|
|
3576 my %lab = ();
|
|
|
3577 my $co = sub {
|
|
|
3578 my ($cs, $cl, $ss, $sl, $ab, $ls, $ll, $ds, $dl, $ge, $qu) = @_;
|
|
|
3579 return unless $ll || $ls;
|
|
|
3580 my $n = $ls;
|
|
|
3581 $n = _get_number($int, $tp, 'label', {}, \$ls, $ls + $ll, 1) if $ll;
|
|
|
3582 return if $n != $lab;
|
|
|
3583 $lab{$ss} = 1;
|
|
|
3584 };
|
|
|
3585 forall_code($int->{cptr}, $tp->{rules}[0], $co);
|
|
|
3586 my @lab = keys %lab;
|
|
|
3587 @lab or faint(SP_NOSUCHLABEL, $lab);
|
|
|
3588 @lab == 1 or faint(SP_TOOMANYLABS, scalar @lab, $lab);
|
|
|
3589 $lab[0];
|
|
|
3590 }
|
|
|
3591
|
|
|
3592 sub _i_res {
|
|
|
3593 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3594 my $size = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3595 if ($runenv->{quantum}) {
|
|
|
3596 push @{$runenv->{quantum}},
|
|
|
3597 [_deep_copy($tp->{next_stack}), 'next_stack'],
|
|
|
3598 [$tp->{s_pointer}, 's_pointer'],
|
|
|
3599 [_deep_copy($tp->{loop_code}), 'loop_code'],
|
|
|
3600 [_deep_copy($tp->{in_loop}), 'in_loop'],
|
|
|
3601 [_deep_copy($tp->{comefrom}), 'comefrom'];
|
|
|
3602 }
|
|
|
3603 $size > 0 or faint(SP_NORESUME);
|
|
|
3604 if (@{$tp->{next_stack}} < $size) {
|
|
|
3605 @{$tp->{next_stack}} = ();
|
|
|
3606 faint(SP_RESUME);
|
|
|
3607 }
|
|
|
3608 if ($size > 1) {
|
|
|
3609 splice(@{$tp->{next_stack}}, 1 - $size);
|
|
|
3610 }
|
|
|
3611 delete $tp->{loop_id}{$_} for @{$tp->{in_loop}};
|
|
|
3612 my ($lc, $il, $cf);
|
|
|
3613 ($tp->{s_pointer}, $lc, $il, $cf) = @{pop @{$tp->{next_stack}}};
|
|
|
3614 @{$tp->{loop_code}} = @$lc;
|
|
|
3615 @{$tp->{in_loop}} = @$il;
|
|
|
3616 @{$tp->{comefrom}} = @$cf;
|
|
|
3617 undef;
|
|
|
3618 }
|
|
|
3619
|
|
|
3620 sub _i_for {
|
|
|
3621 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3622 my $size = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3623 if ($runenv->{quantum}) {
|
|
|
3624 push @{$runenv->{quantum}},
|
|
|
3625 [_deep_copy($tp->{next_stack}), 'next_stack'];
|
|
|
3626 }
|
|
|
3627 $size > 0 or return undef;
|
|
|
3628 if (@{$tp->{next_stack}} < $size) {
|
|
|
3629 @{$tp->{next_stack}} = ();
|
|
|
3630 } else {
|
|
|
3631 splice(@{$tp->{next_stack}}, -$size);
|
|
|
3632 }
|
|
|
3633 undef;
|
|
|
3634 }
|
|
|
3635
|
|
|
3636 sub _i_unx {
|
|
|
3637 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3638 if ($runenv->{quantum}) {
|
|
|
3639 $name =~ s/^UN/Undocumented /;
|
|
|
3640 $name =~ s/E$/Expression/;
|
|
|
3641 $name =~ s/S$/Statement/;
|
|
|
3642 faint(SP_QUANTUM, $name);
|
|
|
3643 }
|
|
|
3644 my $m = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3645 my $f = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3646 my $count = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3647 my @args = ();
|
|
|
3648 while (@args < $count) {
|
|
|
3649 my $arg = _get_str_or_fh($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3650 if (! ref $arg) {
|
|
|
3651 if ($arg eq '[[INT]]') {
|
|
|
3652 $arg = $int;
|
|
|
3653 } elsif ($arg eq '[[TP]]') {
|
|
|
3654 $arg = $tp;
|
|
|
3655 } elsif ($arg eq '[[THEFT]]') {
|
|
|
3656 $arg = $int->{theft_server};
|
|
|
3657 } elsif ($arg eq '[[SERVER]]') {
|
|
|
3658 $arg = $int->{server};
|
|
|
3659 }
|
|
|
3660 }
|
|
|
3661 push @args, $arg;
|
|
|
3662 }
|
|
|
3663 my $c;
|
|
|
3664 if ($m) {
|
|
|
3665 $c = "require Language::INTERCAL::${m}; " .
|
|
|
3666 "Language::INTERCAL::${m}->${f}(\@args)";
|
|
|
3667 } else {
|
|
|
3668 $c = "${f}(\@args)";
|
|
|
3669 }
|
|
|
3670 my $r = eval $c;
|
|
|
3671 die $@ if $@;
|
|
|
3672 $r;
|
|
|
3673 }
|
|
|
3674
|
|
|
3675 sub _get_left {
|
|
|
3676 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3677 my $lcount = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3678 my @left = ();
|
|
|
3679 while (@left < $lcount) {
|
|
|
3680 my $count = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3681 my $tn = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3682 if ($tn == 0) {
|
|
|
3683 # symbol
|
|
|
3684 my $s = _get_symbol($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3685 push @left, ['s', $s, $count];
|
|
|
3686 next;
|
|
|
3687 }
|
|
|
3688 if ($tn == 1 || $tn == 3) {
|
|
|
3689 # tn == 1 => constant / 2 => reggrim
|
|
|
3690 my $d = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3691 my $type = ($tn == 1 || $tn == 2) ? 'c' : 'r';
|
|
|
3692 push @left, [$type, $d, $count];
|
|
|
3693 next;
|
|
|
3694 }
|
|
|
3695 faint(SP_CREATION, "Invalid left type $tn");
|
|
|
3696 }
|
|
|
3697 \@left;
|
|
|
3698 }
|
|
|
3699
|
|
|
3700 sub _get_right {
|
|
|
3701 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3702 my $rcount = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3703 my @right = ();
|
|
|
3704 while (@right < $rcount) {
|
|
|
3705 my $tn = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3706 if ($tn == 0 || $tn == 6) {
|
|
|
3707 # tn == 0 ? symbol : count(symbol)
|
|
|
3708 my $n = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3709 my $s = _get_symbol($int, $tp, $name, $runenv, $cp, $ep);
|
|
|
3710 push @right, [$tn == 0 ? 's' : 'n', $n, $s];
|
|
|
3711 next;
|
|
|
3712 }
|
|
|
3713 if ($tn == 1 || $tn == 3) {
|
|
|
3714 # tn == 1 => constant / 3 => reggrim
|
|
|
3715 my $n = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3716 my $d = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3717 my $type = ($tn == 1) ? 'c' : 'r';
|
|
|
3718 push @right, [$type, $n, $d];
|
|
|
3719 next;
|
|
|
3720 }
|
|
|
3721 if ($tn == 4) {
|
|
|
3722 # block of bytecode
|
|
|
3723 my $len =
|
|
|
3724 _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3725 $len + $$cp <= $ep
|
|
|
3726 or faint(SP_CREATION, "Block extends after end of code");
|
|
|
3727 my $block = substr($int->{code}, $$cp, $len);
|
|
|
3728 _trace($int, $tp, '<', 1);
|
|
|
3729 _trace($int, $tp, $_, 0) for unpack('C*', $block);
|
|
|
3730 _trace($int, $tp, '>', 1);
|
|
|
3731 $$cp += $len;
|
|
|
3732 push @right, ['b', $block];
|
|
|
3733 next;
|
|
|
3734 }
|
|
|
3735 if ($tn == 15) {
|
|
|
3736 # "*"
|
|
|
3737 push @right, ['*'];
|
|
|
3738 next;
|
|
|
3739 }
|
|
|
3740 faint(SP_CREATION, "Invalid right type $tn");
|
|
|
3741 }
|
|
|
3742 \@right;
|
|
|
3743 }
|
|
|
3744
|
|
|
3745 sub _get_expression {
|
|
|
3746 my ($int, $tp, $name, $runenv, $cp, $ep, $vc) = @_;
|
|
|
3747 my $ex = _run($int, $tp, _q($runenv), $cp, $ep, $vc);
|
|
|
3748 $ex or faint(SP_INVALID, "Not an expression", $name);
|
|
|
3749 $ex;
|
|
|
3750 }
|
|
|
3751
|
|
|
3752 sub _get_number {
|
|
|
3753 my ($int, $tp, $name, $runenv, $cp, $ep, $vc) = @_;
|
|
|
3754 my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, $vc);
|
|
|
3755 $num or faint(SP_INVALID, "Not an expression", $name);
|
|
|
3756 ref $num && UNIVERSAL::isa($num, 'Language::INTERCAL::Numbers')
|
|
|
3757 or faint(SP_NUMBER, "Array or class");
|
|
|
3758 $num->number;
|
|
|
3759 }
|
|
|
3760
|
|
|
3761 sub _get_symbol {
|
|
|
3762 my ($int, $tp, $name, $runenv, $cp, $ep) = @_;
|
|
|
3763 my $num;
|
|
|
3764 # special optimisation for STR
|
|
|
3765 if ($$cp < $ep && ord(substr($int->{code}, $$cp, 1)) == BC_STR) {
|
|
|
3766 _trace($int, $tp, BC_STR, 0);
|
|
|
3767 $$cp++;
|
|
|
3768 my $l = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3769 $$cp + $l <= $ep
|
|
|
3770 or faint(SP_INVALID, "Not enough constants", $name);
|
|
|
3771 $num = substr($int->{code}, $$cp, $l);
|
|
|
3772 $$cp += $l;
|
|
|
3773 my $s = $num;
|
|
|
3774 $s =~ s/([%\[\]\P{IsPrint}])/sprintf("%%%02X", ord($1))/ge;
|
|
|
3775 _trace($int, $tp, "[$s]", 1);
|
|
|
3776 } else {
|
|
|
3777 $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3778 }
|
|
|
3779 # just validate it as if assigning to '%PS'
|
|
|
3780 reg_create('PS', $int->{object}, $num)->number;
|
|
|
3781 }
|
|
|
3782
|
|
|
3783 sub _get_string {
|
|
|
3784 my ($int, $tp, $name, $runenv, $cp, $ep, $baudot) = @_;
|
|
|
3785 my $string;
|
|
|
3786 # special optimisation for STR
|
|
|
3787 if ($$cp < $ep && ord(substr($int->{code}, $$cp, 1)) == BC_STR) {
|
|
|
3788 _trace($int, $tp, BC_STR, 0);
|
|
|
3789 $$cp++;
|
|
|
3790 my $l = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3791 $$cp + $l <= $ep
|
|
|
3792 or faint(SP_INVALID, "Not enough constants", $name);
|
|
|
3793 $string = substr($int->{code}, $$cp, $l);
|
|
|
3794 $$cp += $l;
|
|
|
3795 } else {
|
|
|
3796 my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3797 ref $num or faint(SP_INVALID, "Not an expression", $name);
|
|
|
3798 if (ref $num eq 'ARRAY') {
|
|
|
3799 $string = pack('C*', map { $_ & 0xff } @$num);
|
|
|
3800 } elsif (UNIVERSAL::isa($num, 'Language::INTERCAL::Arrays')) {
|
|
|
3801 $string = $num->tail->as_string;
|
|
|
3802 } else {
|
|
|
3803 faint(SP_NOARRAY);
|
|
|
3804 }
|
|
|
3805 }
|
|
|
3806 $string = baudot2ascii($string) if $baudot;
|
|
|
3807 my $s = $string;
|
|
|
3808 $s =~ s/([%\[\]\P{IsPrint}])/sprintf("%%%02X", ord($1))/ge;
|
|
|
3809 _trace($int, $tp, "[$s]", 1);
|
|
|
3810 $string;
|
|
|
3811 }
|
|
|
3812
|
|
|
3813 sub _get_str_or_fh {
|
|
|
3814 my ($int, $tp, $name, $runenv, $cp, $ep, $baudot) = @_;
|
|
|
3815 my $string;
|
|
|
3816 my $s;
|
|
|
3817 # special optimisation for STR
|
|
|
3818 if ($$cp < $ep && ord(substr($int->{code}, $$cp, 1)) == BC_STR) {
|
|
|
3819 _trace($int, $tp, BC_STR, 0);
|
|
|
3820 $$cp++;
|
|
|
3821 my $l = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0);
|
|
|
3822 $$cp + $l <= $ep
|
|
|
3823 or faint(SP_INVALID, "Not enough constants", $name);
|
|
|
3824 $string = substr($int->{code}, $$cp, $l);
|
|
|
3825 $$cp += $l;
|
|
|
3826 } else {
|
|
|
3827 my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1);
|
|
|
3828 ref $num or faint(SP_INVALID, "Not an expression", $name);
|
|
|
3829 if (UNIVERSAL::isa($num, 'Language::INTERCAL::Numbers')) {
|
|
|
3830 $string = $num->number;
|
|
|
3831 $baudot = 0;
|
|
|
3832 } elsif (ref $num eq 'ARRAY') {
|
|
|
3833 $string = pack('C*', map { $_ & 0xff } @$num);
|
|
|
3834 } elsif (UNIVERSAL::isa($num, 'Language::INTERCAL::Whirlpool')) {
|
|
|
3835 $string = $num->filehandle or faint(SP_NOTCLASS);
|
|
|
3836 $s = $string->describe;
|
|
|
3837 $baudot = 0;
|
|
|
3838 } elsif (UNIVERSAL::isa($num, 'Language::INTERCAL::Arrays')) {
|
|
|
3839 $string = $num->tail->as_string;
|
|
|
3840 $string =~ s/\0+$//;
|
|
|
3841 } else {
|
|
|
3842 faint(SP_NOARRAY);
|
|
|
3843 }
|
|
|
3844 }
|
|
|
3845 $string = baudot2ascii($string) if $baudot;
|
|
|
3846 $s = $string if ! defined $s;
|
|
|
3847 $s =~ s/([%\[\]\P{IsPrint}])/sprintf("%%%02X", ord($1))/ge;
|
|
|
3848 _trace($int, $tp, "[$s]", 1);
|
|
|
3849 $string;
|
|
|
3850 }
|
|
|
3851
|
|
|
3852 sub _set_read_charset {
|
|
|
3853 my ($int, $tp, $fh) = @_;
|
|
|
3854 my $cs = $tp->{registers}{$reg_cr}{value}->number;
|
|
|
3855 $fh->read_charset($cs);
|
|
|
3856 }
|
|
|
3857
|
|
|
3858 sub _set_write_charset {
|
|
|
3859 my ($int, $tp, $fh) = @_;
|
|
|
3860 my $cs = $tp->{registers}{$reg_cw}{value}->number;
|
|
|
3861 $fh->write_charset($cs);
|
|
|
3862 }
|
|
|
3863
|
|
|
3864 sub _trace_init {
|
|
|
3865 my ($int) = @_;
|
|
|
3866 $int->{trace} = [];
|
|
|
3867 }
|
|
|
3868
|
|
|
3869 sub _trace_exit {
|
|
|
3870 my ($int, $tp) = @_;
|
|
|
3871 my $trace_fh = $tp->{registers}{$reg_trfh}{value};
|
|
|
3872 return _trace_init($int) unless $trace_fh;
|
|
|
3873 $trace_fh = $trace_fh->filehandle;
|
|
|
3874 return _trace_init($int) unless $trace_fh;
|
|
|
3875 _set_read_charset($int, $tp, $trace_fh);
|
|
|
3876 my $hex = '';
|
|
|
3877 my $asc = '';
|
|
|
3878 for my $trace (@{$int->{trace}}) {
|
|
|
3879 my ($byte, $special, @etc) = @$trace;
|
|
|
3880 my ($h, $a);
|
|
|
3881 if ($special) {
|
|
|
3882 $h = join('', map { sprintf(" %02X", $_) } @etc);
|
|
|
3883 $a = ' ' . $byte;
|
|
|
3884 } else {
|
|
|
3885 $h = defined $byte ? sprintf(" %02X", $byte) : '';
|
|
|
3886 $a = ' ' . (bytedecode($byte) || '???');
|
|
|
3887 }
|
|
|
3888 if (length($hex) + length($h) > 33 || length($asc) + length($a) > 46) {
|
|
|
3889 $hex =~ s/^\s+//;
|
|
|
3890 $trace_fh->read_text(sprintf("%-33s|%s\n", $hex, $asc));
|
|
|
3891 $hex = $asc = '';
|
|
|
3892 }
|
|
|
3893 $hex .= $h;
|
|
|
3894 $asc .= $a;
|
|
|
3895 }
|
|
|
3896 $hex =~ s/^\s+//;
|
|
|
3897 $trace_fh->read_text(sprintf("%-33s|%s\n", $hex, $asc)) if $asc ne '';
|
|
|
3898 _trace_init($int);
|
|
|
3899 }
|
|
|
3900
|
|
|
3901 sub _trace {
|
|
|
3902 my ($int, $tp, $byte, $special, @etc) = @_;
|
|
|
3903 return unless $tp->{registers}{$reg_tm}{value} &&
|
|
|
3904 $tp->{registers}{$reg_tm}{value}->number &&
|
|
|
3905 $tp->{registers}{$reg_trfh}{value};
|
|
|
3906 push @{$int->{trace}}, [$byte, $special, @etc];
|
|
|
3907 }
|
|
|
3908
|
|
|
3909 sub _trace_mark {
|
|
|
3910 my ($int, $tp, @data) = @_;
|
|
|
3911 return _trace_init($int)
|
|
|
3912 unless $tp->{registers}{$reg_tm}{value} &&
|
|
|
3913 $tp->{registers}{$reg_tm}{value}->number &&
|
|
|
3914 $tp->{registers}{$reg_trfh}{value};
|
|
|
3915 my $trace_fh = $tp->{registers}{$reg_trfh}{value};
|
|
|
3916 $trace_fh = $trace_fh->filehandle;
|
|
|
3917 return _trace_init($int) unless $trace_fh;
|
|
|
3918 _trace_exit($int, $tp);
|
|
|
3919 $trace_fh->read_text('@' . join(' ', @data) . "\n");
|
|
|
3920 _trace_exit($int, $tp);
|
|
|
3921 }
|
|
|
3922
|
|
|
3923 1;
|
