Mercurial > repo
view interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/Interpreter.pm @ 9071:581584df6d82
<fizzie> revert 942e964c81c1
author | HackBot |
---|---|
date | Sun, 25 Sep 2016 20:17:31 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Interpreter; # Interpreter and runtime environment # This file is part of CLC-INTERCAL # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. # CLC-INTERCAL is copyrighted software. However, permission to use, modify, # and distribute it is granted provided that the conditions set out in the # licence agreement are met. See files README and COPYING in the distribution. use strict; use vars qw($VERSION $PERVERSION); ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Interpreter.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use Language::INTERCAL::Exporter '1.-94.-2'; use Language::INTERCAL::Splats '1.-94.-2', qw(:SP splatdescription); use Language::INTERCAL::ByteCode '1.-94.-2', qw(bytecode bytedecode bc_skip bc_match bc_list BCget BC_MASK :BC reg_list reg_name reg_create reg_codetype reg_decode reg_code is_constant); use Language::INTERCAL::Object '1.-94.-2', qw(find_code forall_code make_code); use Language::INTERCAL::GenericIO '1.-94.-2', qw($stdsplat); use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(read_number); use Language::INTERCAL::WriteNumbers '1.-94.-2', qw(write_number); use Language::INTERCAL::ArrayIO '1.-94.-2', qw(read_array_16 read_array_32 write_array_16 write_array_32 iotype_default); use Language::INTERCAL::Charset::Baudot '1.-94.-2', qw(baudot2ascii); use Language::INTERCAL::SharkFin '1.-94.-2'; use Language::INTERCAL::Server '1.-94.-2'; use constant MAX_NEXT => 80; my %default_opcodes = ( ABG => \&_i_abg, ABL => \&_i_abl, AWC => \&_i_awc, # XXX BAW - only used by the (not yet written) optimiser # XXX BBT - only used by the (not yet written) optimiser BUG => \&_i_bug, BUT => \&_i_but, # XXX BSW - only used by the (not yet written) optimiser BWC => \&_i_bwc, CFG => \&_i_cfg, CFL => \&_i_cfl, CHO => \&_i_cho, CON => \&_i_con, CRE => \&_i_cre, CSE => \&_i_cse, CWB => \&_i_cwb, DES => \&_i_des, DOS => \&_i_dos, EBC => \&_i_ebc, ECB => \&_i_ecb, ENR => \&_i_enr, ENS => \&_i_ens, FIN => \&_i_fin, FOR => \&_i_for, FRE => \&_i_fre, FRZ => \&_i_frz, GRA => \&_i_gra, GUP => \&_i_gup, HYB => \&_i_hyb, IGN => \&_i_ign, INT => \&_i_int, LEA => \&_i_lea, MKG => \&_i_mkg, MSP => \&_i_msp, MUL => \&_i_mul, NUM => \&_i_num, NXG => \&_i_cfg, NXL => \&_i_cfl, NXT => \&_i_nxt, # XXX OPT - only used by the (not yet written) optimiser OVM => \&_i_ovm, OVR => \&_i_ovr, OWN => \&_i_own, REG => \&_i_reg, REL => \&_i_rel, REM => \&_i_rem, RES => \&_i_res, RET => \&_i_ret, RIN => \&_i_rin, ROM => \&_i_rom, ROR => \&_i_ror, ROU => \&_i_rou, RSE => \&_i_rse, SEL => \&_i_sel, SHF => \&_i_shf, SMU => \&_i_smu, SPL => \&_i_spl, SPO => \&_i_spo, STA => \&_i_sta, STE => \&_i_ste, STO => \&_i_sto, STU => \&_i_stu, STR => \&_i_str, SUB => \&_i_sub, SWA => \&_i_swa, SWB => \&_i_swb, SYS => \&_i_sys, TAI => \&_i_tai, TSP => \&_i_tsp, TYP => \&_i_typ, UNE => \&_i_unx, UNS => \&_i_unx, UDV => \&_i_udv, USG => \&_i_usg, WHP => \&_i_whp, WIN => \&_i_win, ); my %causes_recompile = map { ( reg_name($_) => 1 ) } qw(PS SS JS IS); my %come_froms = map { ( $_ => 1 ) } BC_CFL, BC_CFG, BC_NXL, BC_NXG; my $reg_ar = reg_name('AR'); my $reg_aw = reg_name('AW'); my $reg_ba = reg_name('BA'); my $reg_cf = reg_name('CF'); my $reg_cr = reg_name('CR'); my $reg_cw = reg_name('CW'); my $reg_dm = reg_name('DM'); my $reg_io = reg_name('IO'); my $reg_is = reg_name('IS'); my $reg_js = reg_name('JS'); my $reg_os = reg_name('OS'); my $reg_ps = reg_name('PS'); my $reg_rm = reg_name('RM'); my $reg_rt = reg_name('RT'); my $reg_sp = reg_name('SP'); my $reg_ss = reg_name('SS'); my $reg_th = reg_name('TH'); my $reg_tm = reg_name('TM'); my $reg_wt = reg_name('WT'); my $reg_orfh = reg_name('ORFH'); my $reg_osfh = reg_name('OSFH'); my $reg_owfh = reg_name('OWFH'); my $reg_trfh = reg_name('TRFH'); sub new { @_ == 2 || @_ == 3 or croak "Usage: new Language::INTERCAL::Interpreter(RC [, OBJECT])"; my ($class, $rc, $object) = @_; $object ||= Language::INTERCAL::Object->new; my %int = ( threads => [], events => [], object => $object, loop_id => 0, ab_count => 0, syscode => {}, record_grammar => 0, rc => $rc, verbose => 0, theft_callback => 0, theft_server => 0, server => 0, compiling => 0, stolen => {}, ); $int{default} = _make_thread($object, undef, \%int); bless \%int, $class; } sub theft_callback { @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->theft_callback [(CODE)]"; my ($int) = shift; my $rv = $int->{theft_callback}; $int->{theft_callback} = shift if @_; $rv; } sub verbose_compile { @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->verbose_compile [(VALUE)]"; my ($int) = shift; my $rv = $int->{verbose}; $int->{verbose} = shift if @_; $rv; } sub object { @_ == 1 or croak "Usage: INTERPRETER->object"; my ($int) = @_; $int->{object}; } sub getrules { @_ == 2 or croak "Usage: INTERPRETER->getrules(GRAMMAR)"; my ($int, $gra) = @_; return $int->{default}{rules}[$gra - 1] || []; } sub getreg { @_ == 2 or croak "Usage: INTERPRETER->getreg(NAME)"; my ($int, $name) = @_; $name = reg_name($name) or croak "Invalid register name"; exists $int->{default}{registers}{$name} and return $int->{default}{registers}{$name}{value}->value; croak "Invalid register name"; } sub setreg { @_ == 3 or croak "Usage: INTERPRETER->setreg(NAME, VALUE)"; my ($int, $name, $value) = @_; $name = reg_name($name) or croak "Invalid register name"; my $tp = $int->{default}; _create_register($int, $tp, 'setreg', $name, {}); $tp->{registers}{$name}{value}->assign($value); $int; } sub allreg { @_ == 2 || @_ == 3 or croak "Usage: INTERPRETER->allreg(CODE [, DEFAULT_MODE])"; my ($int, $code, $dm) = @_; $dm ||= 'dn'; # find all registers my %regs = (); my $tp = $int->{default}; my $rp = $tp->{registers}; for my $n (keys %$rp) { if (exists $rp->{$n}{default}) { next unless $dm =~ /d/i; } else { next unless $dm =~ /n/i; } my $t = substr($n, 0, 1); my $v = substr($n, 1); $regs{$t}{$v} = $rp->{$n}{value}; } # now proceed in order for my $t (sort keys %regs) { for my $v (sort { $a <=> $b } keys %{$regs{$t}}) { $code->($t . $v, $regs{$t}{$v}); } } } sub record_grammar { @_ == 2 or croak "Usage: INTERPRETER->record_grammar(HOW)"; my ($int, $how) = @_; $int->{record_grammar} = $how; $int; } sub get_abstains { @_ == 1 or croak "Usage: INTERPRETER->get_abstains"; my ($int) = @_; my $tp = $int->{default}; my @labels = keys %{$tp->{ab_label}}; my @gerunds = keys %{$tp->{ab_gerund}}; my $text = "ABR\n"; $text .= pack('vvv', $int->{ab_count}, scalar @labels, scalar @gerunds); for my $l (@labels) { $text .= pack('vvv', $l, @{$tp->{ab_label}{$l}}); } for my $g (@gerunds) { $text .= pack('vvv', $g, @{$tp->{ab_gerund}{$g}}); } $text; } sub set_abstains { @_ == 2 or croak "Usage: INTERPRETER->set_abstains(DATA)"; my ($int, $text) = @_; $text =~ s/^ABR\n// or croak "Invalid abstain DATA"; my ($count, $lc, $gc, @r) = unpack('v*', $text); defined $gc or croak "Invalid abstain DATA"; @r == 3 * ($lc + $gc) or croak "Invalid abstain DATA"; my $tp = $int->{default}; # create new abstain records $tp->{ab_label} = {}; $tp->{ab_gerund} = {}; $int->{ab_count} = $count; for (my $l = 0; $l < $lc; $l++) { my $n = shift @r; my $a = shift @r; my $c = shift @r; $tp->{ab_label}{$n} = [$a, $c]; } for (my $g = 0; $g < $gc; $g++) { my $n = shift @r; my $a = shift @r; my $c = shift @r; $tp->{ab_gerund}{$n} = [$a, $c]; } $int; } sub get_grammar_record { @_ == 1 or croak "Usage: INTERPRETER->get_grammar_record"; my ($int) = @_; my $tp = $int->{default}; my $gr = $tp->{grammar_record}; my $mr = $tp->{make_record}; my $text = "GRR\n"; my %smap = (); $text .= pack('vv', scalar(@$gr), scalar(@$mr)); for my $g (@$gr) { $text .= chr($g->[0]); if ($g->[0] == BC_CON || $g->[0] == BC_SWA) { $text .= pack('vv', length($g->[1]), length($g->[2])); $text .= $g->[1] . $g->[2]; next; } if ($g->[0] == BC_CRE) { $text .= pack('v', $g->[1]); $text .= _pack_symbol($int, $g->[2], \%smap); $text .= _pack_left($int, $g->[3], \%smap); $text .= _pack_right($int, $g->[4], \%smap); next; } if ($g->[0] == BC_DES) { $text .= pack('v', $g->[1]); $text .= _pack_symbol($int, $g->[2], \%smap); $text .= _pack_left($int, $g->[3], \%smap); next; } faint(SP_INTERNAL, "get_grammar_record found invalid record"); } for my $g (@$mr) { $text .= pack('vvv', $g->[0], length($g->[1]), length($g->[2])); $text .= $g->[1] . $g->[2]; } $text; } sub set_grammar_record { @_ == 2 or croak "Usage: INTERPRETER->set_grammar_record(DATA)"; my ($int, $text) = @_; $text =~ s/^GRR\n// or croak "Invalid DATA"; my ($gcount, $mcount) = unpack('vv', substr($text, 0, 4, '')); defined $mcount or $mcount = 0; my $tp = $int->{default}; my @smap = (); my @gr = (); for (my $n = 0; $n < $gcount; $n++) { my $t = ord(substr($text, 0, 1, '')); if ($t == BC_CON || $t == BC_SWA) { my ($lo1, $lo2) = unpack('vv', substr($text, 0, 4, '')); my $o1 = substr($text, 0, $lo1, ''); my $o2 = substr($text, 0, $lo2, ''); push @gr, [$t, $o1, $o2]; if ($t == BC_CON) { $tp->{opcodes}{$o1} = $tp->{opcodes}{$o2}; } else { ($tp->{opcodes}{$o1}, $tp->{opcodes}{$o2}) = ($tp->{opcodes}{$o2}, $tp->{opcodes}{$o1}); } next; } if ($t == BC_CRE) { my ($gra) = unpack('v', substr($text, 0, 2, '')); my $sym = _unpack_symbol(\$text, $int, \@smap); my $left = _unpack_left(\$text, $int, \@smap); my $right = _unpack_right(\$text, $int, \@smap); push @gr, [$t, $sym, $left, $right]; _ii_cre($int, $tp, $gra, $sym, $left, $right, {}); next; } if ($t == BC_CRE) { my ($gra) = unpack('v', substr($text, 0, 2, '')); my $sym = _unpack_symbol(\$text, $int, \@smap); my $left = _unpack_left(\$text, $int, \@smap); push @gr, [$t, $sym, $left]; _ii_des($int, $tp, $gra, $sym, $left, {}); next; } croak "Invalid DATA"; } my @mr = (); for (my $n = 0; $n < $mcount; $n++) { my ($op, $tlen, $clen) = unpack('vvv', substr($text, 0, 6, '')); my $template = substr($text, 0, $tlen, ''); my $code = substr($text, 0, $clen, ''); push @mr, [$op, $template, $code]; $tp->{opcodes}{$op} = [$template, $code]; } $int->{grammar_record} = \@gr; $int->{make_record} = \@mr; $text eq '' or croak "Invalid DATA"; $int; } sub _pack_symbol { my ($int, $sym, $smap) = @_; if (exists $smap->{$sym}) { return 'S' . pack('v', $smap->{$sym}); } $sym = $int->{object}->symboltable->symbol($sym) || 0; my $num = scalar keys %$smap; $smap->{$sym} = $num; return 'M' . pack('v v/a*', $num, $sym); } sub _unpack_symbol { my ($text, $int, $smap) = @_; my $name; if ($$text =~ s/^S//) { my ($snum) = unpack('v', substr($$text, 0, 2, '')); $name = $smap->[$snum]; } elsif ($$text =~ s/^M//) { my ($snum, $slen) = unpack('vv', substr($$text, 0, 4, '')); $name = substr($$text, 0, $slen, ''); length($name) == $slen or croak "Invalid DATA"; $smap->[$snum] = $name; } else { croak "Invalid DATA"; } $int->{object}->symboltable->find($name, 0); } sub _pack_left { my ($int, $left, $smap) = @_; my $text = pack('v', scalar @$left); for my $prod (@$left) { $text .= $prod->[0]; if ($prod->[0] eq 's') { $text .= _pack_symbol($int, $prod->[1], $smap); } else { $text .= pack('v/a*', $prod->[1]); } $text .= pack('v', $prod->[2]); } $text; } sub _unpack_left { my ($text, $int, $smap) = @_; my ($num) = unpack('v', substr($$text, 0, 2, '')); my @left = (); while ($num-- > 0) { my $type = substr($$text, 0, 1, ''); my $data; if ($type eq 's') { $data = _unpack_symbol($text, $int, $smap); } else { my $l = unpack('v', substr($$text, 0, 2, '')); $data = substr($$text, 0, $l, ''); length $data == $l or croak "Invalid DATA"; } my $count = unpack('v', substr($$text, 0, 2, '')); push @left, [$type, $data, $count]; } \@left; } sub _pack_right { my ($int, $right, $smap) = @_; my $text = pack('v', scalar @$right); for my $prod (@$right) { $text .= $prod->[0]; if ($prod->[0] eq 's' || $prod->[0] eq 'n') { $text .= pack('v', $prod->[1]); $text .= _pack_symbol($int, $prod->[2], $smap); } elsif ($prod->[0] eq 'c' || $prod->[0] eq 'r') { $text .= pack('v v/a*', $prod->[1], $prod->[2]); } elsif ($prod->[0] eq 'b') { $text .= pack('v/a*', $prod->[1]); } } $text; } sub _unpack_right { my ($text, $int, $smap) = @_; my ($num) = unpack('v', substr($$text, 0, 2, '')); my @right = (); while ($num-- > 0) { my $type = substr($$text, 0, 1, ''); if ($type eq 's' || $type eq 'n') { my $n = unpack('v', substr($$text, 0, 2, '')); my $s = _unpack_symbol($text, $int, $smap); push @right, [$type, $n, $s]; } elsif ($type eq 'c' || $type eq 'r') { my $n = unpack('v', substr($$text, 0, 2, '')); my $l = _unpack_symbol($text, $int, $smap); my $s = substr($$text, 0, $l, ''); length $s == $l or croak "Invalid DATA"; push @right, [$type, $n, $s]; } elsif ($type eq 'b') { my $l = _unpack_symbol($text, $int, $smap); my $s = substr($$text, 0, $l, ''); length $s == $l or croak "Invalid DATA"; push @right, [$type, $s]; } } \@right; } sub get_events { @_ == 1 or croak "Usage: INTERPRETER->get_events"; my ($int) = @_; my $text = "EVR\n"; my $ep = $int->{events} || []; $text .= pack('v', scalar @$ep); for my $ev (@$ep) { my ($code, $cond, $cend, $body, $bend, $bge) = @$ev; $cond = substr($code, $cond, $cend - $cond); $body = substr($code, $body, $bend - $body); $text .= pack('vvv', $bge, length($cond), length($body)); $text .= $cond; $text .= $body; } $text; } sub set_events { @_ == 2 or croak "Usage: INTERPRETER->set_events(DATA)"; my ($int, $text) = @_; $text =~ s/^EVR\n// or croak "Invalid DATA"; my ($count) = unpack('v', substr($text, 0, 2, '')); my @ev = (); for (my $i = 0; $i < $count; $i++) { my ($bge, $clen, $blen) = unpack('vvv', substr($text, 0, 6, '')); my $code = substr($text, 0, $blen + $clen, ''); length($code) == $blen + $clen or croak "Invalid DATA"; push @ev, [$code, 0, $clen, $clen, $clen + $blen, $bge]; } $text eq '' or croak "Invalid DATA"; $int->{events} = \@ev; $int; } sub get_registers { @_ == 1 or croak "Usage: INTERPRETER->get_registers"; my ($int) = @_; my $tp = $int->{default}; my $rp = $tp->{registers}; my %rcode = (); for my $r (keys %$rp) { my $prefix = substr($r, 0, 1); # we assume special registers are restored by re-running extensions # or by using INTERPRETER->read, so we never dump them here next if $prefix eq '%' || $prefix eq '^'; my $v = $rp->{$r}; next if exists $v->{default}; # dump this register my $number = substr($r, 1); my @rv = (); my $sp = exists $tp->{stash}{$r} ? $tp->{stash}{$r} : []; for my $level (@$sp, $rp->{$r}) { my $v = $level->{value}; my $code = ''; my $overload = $v->get_overload(undef); if (defined $overload) { $code .= 'O' . pack('v/a*', $overload); } else { $code .= 'N'; } if ($prefix eq '.' || $prefix eq '%') { $code .= pack('v', $v->number); } elsif ($prefix eq ':') { $code .= pack('V', $v->number); } else { $v = $v->tail if $prefix eq '@'; my $pack = $prefix eq ';' ? 'V' : 'v'; my @subs = $v->subscripts; my @list = $v->sparse_list; $code .= pack('v*', scalar @subs, scalar @list, @subs); for my $l (@list) { my ($e, @s) = @$l; my $o = $e->get_overload(undef); if (defined $o) { $code .= 'O' . pack('v/a*', $o); } else { $code .= 'N'; } $code .= pack($pack . 'v*', $e->number, scalar @s, @s); } # XXX dump filehandle if $prefix eq '@'? } push @rv, $code; } my $len = pack('av*', $prefix, $number, scalar @rv, map { length $_ } @rv); $rcode{$r} = join('', $len, @rv); } my @rcode = keys %rcode; my $text = "REG\n"; $text .= pack('v', scalar @rcode); for my $r (@rcode) { $text .= $rcode{$r}; } $text; } sub set_registers { @_ == 2 || @_ == 3 or croak "Usage: INTERPRETER->set_registers(DATA [, OVERRIDE])"; my ($int, $text, $over) = @_; $text =~ s/^REG\n// or croak "Invalid DATA"; my $tp = $int->{default}; my $rp = $tp->{registers}; my $sp = $tp->{stash}; length $text >= 2 or croak "Invalid DATA"; my ($count) = unpack('v', substr($text, 0, 2, '')); while ($count-- > 0) { length $text >= 5 or croak "Invalid DATA"; my ($prefix, $number, $cnum) = unpack('avv', substr($text, 0, 5, '')); length $text >= 2 * $cnum or croak "Invalid DATA"; my @clen = unpack('v*', substr($text, 0, 2 * $cnum, '')); my $reg = $prefix . $number; my @rv = (); for my $clen (@clen) { length $text >= $clen or croak "Invalid DATA"; my $code = substr($text, 0, $clen, ''); push @rv, $code; } next if exists $rp->{$reg} && ! exists $rp->{$reg}{default} && ! $over; my $stashit = 0; delete $rp->{$reg}; delete $sp->{$reg}; _create_register($int, $tp, 'set_registers', $reg, {}); for my $code (@rv) { if ($stashit) { _stash_register($int, $tp, 'set_registers', $reg, {}); } $stashit = 1; my $v = $tp->{registers}{$reg}{value}; delete $tp->{registers}{$reg}{default}; my $overload = undef; if ($code =~ s/^O//) { my ($o) = unpack('v', substr($code, 0, 2, '')); $overload = substr($code, 0, $o, ''); length $overload == $o or croak "Invalid DATA"; } elsif ($code =~ s/^N//) { # no overload } else { croak "Invalid DATA"; } if ($prefix eq '.' || $prefix eq '%') { $v->assign(unpack('v', substr($code, 0, 2, ''))); } elsif ($prefix eq ':') { $v->assign(unpack('V', substr($code, 0, 4, ''))); } else { my $pack = $prefix eq ';' ? 'Vv' : 'vv'; my $plen = $prefix eq ';' ? 6 : 4; my ($nsubs, $nvals) = unpack('vv', substr($code, 0, 4, '')); my @subs = unpack('v*', substr($code, 0, 2 * $nsubs, '')); $v->assign(\@subs) if $prefix ne '@'; while ($nvals-- > 0) { my $ov = undef; if ($code =~ s/^O//) { my ($o) = unpack('v', substr($code, 0, 2, '')); $ov = substr($code, 0, $o, ''); length $ov == $o or croak "Invalid DATA"; } elsif ($code =~ s/^N//) { # no overload } else { croak "Invalid DATA"; } my ($e, $ns) = unpack($pack, substr($code, 0, $plen, '')); my @s = unpack('v*', substr($code, 0, 2 * $ns, '')); $v->store(\@s, $e); $v->overload(\@s, $ov); } } $v->overload([], $overload); } } $text eq '' or croak "Invalid DATA"; $int; } sub get_constants { @_ == 1 or croak "Usage: INTERPRETER->get_constants"; my ($int) = @_; my $tp = $int->{default}; my $ap = $tp->{assign}; my @al = grep { ${$ap->{$_}} != $_ } keys %$ap; my @av = map { ($_ => ${$ap->{$_}}) } @al; my $text = "CON\n"; $text .= pack('v*', scalar @al, @av); $text; } sub set_constants { @_ == 2 or croak "Usage: INTERPRETER->set_constants(DATA)"; my ($int, $text) = @_; my $tp = $int->{default}; $text =~ s/^CON\n// or croak "Invalid DATA"; my ($count, @data) = unpack('v*', $text); @data == 2 * $count or croak "Invalid DATA"; my %ap = (); while (@data) { my $c = shift @data; my $v = shift @data; $ap{$c} = \$v; } $tp->{assign} = \%ap; $int; } sub get_state { @_ == 1 or croak "Usage: INTERPRETER->get_constants"; my ($int) = @_; my $text = "STA\n"; for my $v ($int->get_abstains(), $int->get_grammar_record(), $int->get_events(), $int->get_registers(), $int->get_constants()) { $text .= pack('v/a*', $v); } $text; } sub set_state { @_ == 2 || @_ == 3 or croak "Usage: INTERPRETER->set_state(DATA [, OVERRIDE])"; my ($int, $text, $over) = @_; $text =~ s/^STA\n// or croak "Invalid DATA"; $int->{default}{assign} = {}; # otherwise set_registers fails # set abstains length $text >= 2 or croak "Invalid DATA"; my ($len) = unpack('v', substr($text, 0, 2, '')); length $text >= $len or croak "Invalid DATA"; $int->set_abstains(substr($text, 0, $len, '')); # replay grammar record length $text >= 2 or croak "Invalid DATA"; ($len) = unpack('v', substr($text, 0, 2, '')); length $text >= $len or croak "Invalid DATA"; $int->set_grammar_record(substr($text, 0, $len, '')); # set events length $text >= 2 or croak "Invalid DATA"; ($len) = unpack('v', substr($text, 0, 2, '')); length $text >= $len or croak "Invalid DATA"; $int->set_events(substr($text, 0, $len, '')); # set registers length $text >= 2 or croak "Invalid DATA"; ($len) = unpack('v', substr($text, 0, 2, '')); length $text >= $len or croak "Invalid DATA"; $int->set_registers(substr($text, 0, $len, ''), $over); # set constants length $text >= 2 or croak "Invalid DATA"; ($len) = unpack('v', substr($text, 0, 2, '')); length $text >= $len or croak "Invalid DATA"; $int->set_constants(substr($text, 0, $len, '')); # all done $text eq '' or croak "Invalid DATA"; $int; } sub read { @_ == 2 or croak "Usage: INTERPRETER->read(FILEHANDLE)"; my ($int, $fh) = @_; $int->{object}->add_flag('__interpreter_format', 1); $int->{object}->read($fh); # find all registers my $tp = $int->{default}; my $rp = $tp->{registers}; my @nregs = grep { /^[\^\%]/ && ! exists $rp->{$_}{default} && $rp->{$_}{value}->isa('Language::INTERCAL::Numbers') } keys %$rp; my @aregs = grep { /^[\^\%]/ && ! exists $rp->{$_}{default} && ! $rp->{$_}{value}->isa('Language::INTERCAL::Numbers') } keys %$rp; my %rtype = (); my @rtype = (); for my $r (@nregs, @aregs) { my $v = $rp->{$r}{value}; my $t = $v->can('type') ? $v->type : 'spot'; next if exists $rtype{$t}; $rtype{$t} = @rtype; push @rtype, $t; } # find all rules my $rules = $tp->{rules}; # read all counts $fh->read_binary(pack('v*', scalar @nregs, scalar @aregs, scalar @rtype, scalar @$rules, map { scalar @$_ } @$rules)); # read all registers for my $r (@rtype) { $fh->read_binary(pack('v/a*', $r)); } for my $r (@nregs) { my $v = $rp->{$r}{value}; my $t = $v->can('type') ? $v->type : 'spot'; $t = $rtype{$t}; $fh->read_binary(pack('avCv', substr($r, 0, 1), substr($r, 1), $t, $v->number)); } for my $r (@aregs) { my $v = $rp->{$r}{value}; my $t = $r->can('type') ? $v->type : 'spot'; $t = $rtype{$t}; my @v = $v->as_list; $fh->read_binary(pack('avCv*', substr($r, 0, 1), substr($r, 1), $t, scalar @v, @v)); } # read all rules for my $r (@$rules) { $fh->read_binary(pack('C*', map { $_ ? ($$_ ? 2 : 1) : 0 } @$r)); } # read all syscode my @sys = keys %{$int->{syscode}}; $fh->read_binary(pack('v', scalar @sys)); for my $sys (@sys) { $fh->read_binary(pack('v v/a*', $sys, $int->{syscode}{$sys})); } # read all user-created opcodes my $mr = $tp->{make_record}; $fh->read_binary(pack('v', scalar @$mr)); for my $mre (@$mr) { my ($op, $template, $code) = @$mre; $fh->read_binary(pack('vvv', $op, length($template), length($code))); $fh->read_binary($template); $fh->read_binary($code); } $int; } sub write { @_ == 3 || @_ == 4 or croak "Usage: Language::INTERCAL::Interpreter->write(RC, " . "FILEHANDLE [, AVOID_SKIP?])"; my ($class, $rc, $fh, $ask) = @_; my $object = Language::INTERCAL::Object->write($fh, 0, $ask); my $int = $class->new($rc, $object); # write all counts my ($nregs, $aregs, $ntype, $rcount) = unpack('v4', $fh->write_binary(8)); my @rcount = unpack('v*', $fh->write_binary(2 * $rcount)); # write all registers my @rtype = (); while (@rtype < $ntype) { my $tlen = unpack('v', $fh->write_binary(2)); push @rtype, $fh->write_binary($tlen); } my $ptr = $int->{default}; my $rp = $ptr->{registers}; while ($nregs-- > 0) { my ($prefix, $num, $type, $val) = unpack('avCv', $fh->write_binary(6)); my $name = $prefix . $num; _create_register($int, $ptr, 'write', $name, {}); $rp->{$name}{value} = Language::INTERCAL::DoubleOhSeven->new($rtype[$type], $object, $val); delete $rp->{$name}{default}; } while ($aregs-- > 0) { my ($prefix, $num, $type, $val) = unpack('avCv', $fh->write_binary(6)); my $name = $prefix . $num; _create_register($int, $ptr, 'write', $name, {}); my @val = unpack('v*', $fh->write_binary(2 * $val)); $rp->{$name}{value} = Language::INTERCAL::SharkFin->new($rtype[$type], \@val); delete $rp->{$name}{default}; } # write all rules while ($rcount-- > 0) { my $r = shift @rcount; my @r = (); for my $v (unpack('C*', $fh->write_binary($r))) { if ($v) { my $w = $v > 1 ? 1 : 0; push @r, \$w; } else { push @r, 0; } } push @{$ptr->{rules}}, \@r; } # write all syscode my $sys = unpack('v', $fh->write_binary(2)); while ($sys-- > 0) { my ($num, $len) = unpack('vv', $fh->write_binary(4)); $int->{syscode}{$num} = $fh->write_binary($len); } # write all user-created opcodes my $mrc = unpack('v', $fh->write_binary(2)); my @mr = (); while ($mrc-- > 0) { my ($op, $tl, $cl) = unpack('vvv', $fh->write_binary(6)); my $template = $fh->write_binary($tl); my $code = $fh->write_binary($cl); push @mr, [$op, $template, $code]; $ptr->{opcodes}{$op} = [$template, $code]; } $int->{make_record} = \@mr; $int; } sub _dup_thread { my ($int, $tp) = @_; my $dt = _make_thread($int->{object}, $tp, $int); push @{$int->{threads}}, $dt; $dt; } sub _make_thread { my ($object, $tp, $int) = @_; my %thread = ( registers => {}, opcodes => {}, assign => {}, stash => {}, rules => [], next_stack => [], lecture_stack => [], ab_label => {}, ab_gerund => {}, running => 1, s_pointer => 0, loop_id => {}, loop_code => [], in_loop => [], comefrom => [], grammar_record => [], make_record => [], pending_writes => [], newline => 1, ); if ($tp) { # copy common pointers $thread{s_pointer} = $tp->{s_pointer}; @{$thread{comefrom}} = @{$tp->{comefrom}}; # copy the thread's registers for my $r (keys %{$tp->{registers}}) { $thread{registers}{$r} = $tp->{registers}{$r}; $thread{stash}{$r} = $tp->{stash}{$r} if exists $tp->{stash}{$r}; } # copy the thread's opcodes, assignments, stacks %{$thread{opcodes}} = %{$tp->{opcodes}}; %{$thread{assign}} = %{$tp->{assign}}; $thread{next_stack} = _deep_copy($tp->{next_stack}); $thread{lecture_stack} = _deep_copy($tp->{lecture_stack}); # copy the thread's rules for my $ra (@{$tp->{rules}}) { my @ra = @{$ra || []}; push @{$thread{rules}}, \@ra; } # copy current abstain status %{$thread{ab_label}} = %{$tp->{ab_label}}; %{$thread{ab_gerund}} = %{$tp->{ab_gerund}}; # copy any current loop @{$thread{loop_code}} = @{$tp->{loop_code}}; %{$thread{loop_id}} = %{$tp->{loop_id}}; @{$thread{in_loop}} = @{$tp->{in_loop}}; # copy the current records $thread{grammar_record} = $tp->{grammar_record}; $thread{make_record} = $tp->{make_record}; # undocumented I/O mode $thread{newline} = $tp->{newline}; } else { # create an initial set of registers for my $r (reg_list) { my $name = reg_name($r); my $ignore = 0; $thread{registers}{$name} = { value => reg_create($r, $object), ignore => 0, default => 1, }; } # creates an initial set of opcodes - copy is intentional %{$thread{opcodes}} = %default_opcodes; } return \%thread; } sub _deep_copy { my ($src) = @_; return $src if ! defined $src || ! ref $src; # don't copy filehandles... if (UNIVERSAL::isa($src, 'Language::INTERCAL::GenericIO')) { return $src; } if (ref $src eq 'GLOB' || UNIVERSAL::isa($src, 'GLOB')) { return $src; } if (ref $src eq 'CODE') { # no deep copy of code... return $src; } if (ref $src eq 'SCALAR' || ref $src eq 'REF') { my $c = $$src; return \$c; } if (UNIVERSAL::isa($src, 'SCALAR')) { my $c = $$src; bless \$c, ref $src; return \$c; } if (ref $src eq 'ARRAY') { my $c = [ map { _deep_copy($_) } @$src ]; return $c; } if (UNIVERSAL::isa($src, 'ARRAY')) { my $c = [ map { _deep_copy($_) } @$src ]; bless $c, ref $src; return $c; } if (ref $src eq 'HASH') { my $c = { map { ( $_ => _deep_copy($src->{$_}) ) } keys %$src }; return $c; } if (UNIVERSAL::isa($src, 'HASH')) { my $c = { map { ( $_ => _deep_copy($src->{$_}) ) } keys %$src }; bless $c, ref $src; return $c; } if (ref $src eq 'Regexp') { return qr/$src/; } if (UNIVERSAL::isa($src, 'Regexp')) { my $c = qr/$src/; bless $c, ref $src; return $c; } faint(SP_INTERNAL, "_deep_copy of unrecognised reference"); } sub start { @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->start [(FLAGS)]"; my ($int, $flags) = @_; $int->{threads} = []; $int->{compiling} = $flags || 0; $int->setreg('%SP', 1000); $int; } sub stop { @_ == 1 or croak "Usage: INTERPRETER->stop"; my ($int) = @_; $int->{threads} = []; $int->{loop_id} = 0; $int; } sub splat { @_ == 1 or croak "Usage: INTERPRETER->splat"; my ($int) = @_; exists $int->{default}{registers}{$reg_sp} or return undef; $int->{default}{registers}{$reg_sp}{value}->print; } sub theft_server { @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->theft_server [(NEW_SERVER)]"; my $int = shift; my $old_server = $int->{theft_server}; $int->{theft_server} = shift if @_; $old_server; } sub server { @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->server [(NEW_SERVER)]"; my $int = shift; my $old_server = $int->{server}; $int->{server} = shift if @_; $old_server; } sub run { @_ == 1 || @_ == 2 or croak "Usage: INTERPRETER->run [(INTERPRETER)]"; my ($int, $ci) = @_; my $tp = _make_thread($int->{object}, $int->{default}, $int); $int->{threads} = [$tp]; $int->{loop_id} = 0; $ci ||= $int; ($int->{code}, $int->{cptr}) = $ci->{object}->code; $int->{source} = $ci->{object}->source; my $cr = $ci->{default}{rules}[0]; if ($cr) { for (my $r = 0; $r < @$cr; $r++) { next unless $cr->[$r]; _create_rule($int, $tp, 0, $r, {}); ${$tp->{rules}[0][$r]} = ${$cr->[$r]}; } } # are we going to be victims of theft? $int->{server} or $int->{server} = Language::INTERCAL::Server->new; eval { require Language::INTERCAL::Theft; import Language::INTERCAL::Theft '1.-94.-2'; }; unless ($@) { my $th = $int->{default}{registers}{$reg_th}; if (! ($int->{compiling} & 1) && $th->{value} && $th->{value}->number) { $int->{theft_server} or $int->{theft_server} = Language::INTERCAL::Theft->new($int->{server}, $int->{rc}, \&_theft, $int); } } $tp->{s_pointer} = 0; $tp = $int->{threads}; @$tp = grep { $_->{running} } @$tp; while (@$tp) { $int->{server} and $int->{server}->progress(0); for (my $n = 0; $n < @$tp; $n++) { if (@{$tp->[$n]{in_loop}}) { # if this is a loop condition, stop the body my $loop_id = pop @{$tp->[$n]{in_loop}}; delete $tp->[$n]{loop_id}{$loop_id}; } _trace_init($int); my %runenv = (); eval { _step($int, $tp->[$n], \%runenv) }; # report a splat if appropriate _splat($int, $tp->[$n], \%runenv, $@) if $@; _trace_exit($int, $tp->[$n]); } my $ep = $int->{events}; if ($ep && @$ep) { my $svcode = $int->{code}; for (my $e = 0; $e < @$ep; $e++) { my $etp = _dup_thread($int, $int->{default}); _trace_init($int); _stash_register($int, $etp, 'EVENT', $reg_sp, {}); my ($code, $cond, $cend, $body, $bend, $bge) = @{$ep->[$e]}; $int->{code} = $code; _trace_mark($int, $etp, 'EVENT', $e); eval { my $cp = $cond; _run($int, $etp, {}, \$cp, $cend, 1); }; _retrieve_register($int, $etp, 'EVENT', $reg_sp, {}); _trace_exit($int, $etp); if ($@) { $etp->{running} = 0; next; } # the event might have been scheduled with totally different # code, add it if necessary my $bc = substr($code, $body, $bend - $body); my $bp = index($int->{code}, $bc); if ($bp < 0) { $bp = length($int->{code}); $int->{code} .= $bc; } my $be = $bp + length($bc); $etp->{loop_code} = [$bp, $be, $bge, undef, $etp->{comefrom}]; @{$etp->{comefrom}} = (); splice(@$ep, $e, 1); $e--; } $int->{code} = $svcode; } @$tp = grep { $_->{running} } @$tp; } $int; } sub _splat { my ($int, $tp, $runenv, $smsg) = @_; my $scode; if ($smsg =~ s/^\*?(\d+)\s*//) { $scode = $1; $scode =~ s/^0*(\d)/$1/; $smsg = sprintf("*%03d %s", $scode, $smsg); } else { $scode = 0; $smsg = "*000 $smsg"; } $smsg =~ s/\n*$/\n/; my $r = eval { $tp->{registers}{$reg_osfh}{value}->filehandle; }; $r = $stdsplat if $@; eval { $r->read_text($smsg) }; _create_register($int, $tp, '*', $reg_sp, {}); delete $tp->{registers}{$reg_sp}{default}; $tp->{registers}{$reg_sp}{value}->assign($scode); $tp->{running} = 0 unless $runenv->{quantum}; } sub _step { my ($int, $tp, $runenv) = @_; # find current statement - note that we may try to execute the # middle of a comment! my ($qu, $cs, $cl, $ge, $ab, $lab, $ls, $ll, $cp); if ($tp->{loop_code} && @{$tp->{loop_code}}) { my $ct; ($cs, $cl, $ge, $ct) = @{$tp->{loop_code}}; if (defined $ct) { # check loop condition still exists my $found = 0; for my $t (@{$int->{threads}}) { next if ! exists $t->{loop_id}{$ct}; $found = 1; last; } if (! $found) { $tp->{running} = 0; _trace_mark($int, $tp, 'ENDLOOP', $cs, $cl); return; } _trace_mark($int, $tp, 'LOOP', $cs, $cl); } else { # event, which must be executed just this once, so next time # we are going to find an unexistent loop_id $tp->{loop_code}[3] = -1; _trace_mark($int, $tp, 'EVENT', $cs, $cl); } $qu = $ab = $lab = $ll = $ls = 0; $cp = undef; } else { my ($sl, $ds, $dl); $cp = $tp->{s_pointer}; ($cs, $cl, $sl, $ab, $ls, $ll, $ds, $dl, $ge, $qu) = find_code($int->{cptr}, $cp, $tp->{rules}[0]); if (! defined $cs) { _trace_mark($int, $tp, 'EOP', $cp, defined $sl ? $sl : '?'); if (! defined $sl && $int->{source} ne '') { faint(SP_FALL_OFF) if $int->{source} eq ''; $sl = length($int->{source}) - $cp; } elsif ($int->{source} eq '') { faint(SP_COMMENT, "Invalid statement"); } my $line = substr($int->{source}, $cp, $sl); $line =~ s/^\s+//; $line =~ s/\s+$//; faint(SP_COMMENT, $line) if $line =~ /\S/; faint(SP_COMMENT, "Invalid statement"); } _trace_mark($int, $tp, 'STS', $cs, $cl, $cp, $sl, $qu); $lab = $ls; if ($ll > 0) { my $xls = $ls; $lab = _get_number($int, $tp, 'LAB', {}, \$xls, $xls + $ll, 1); _trace_mark($int, $tp, 'LAB', $lab); } elsif ($lab > 0) { # label is a constant, but need to check if the value of the, ehm, # constant, has changed if (exists $tp->{assign}{$lab}) { $lab = ${$tp->{assign}{$lab}}; _trace_mark($int, $tp, 'LAB', $lab, $ls); } else { _trace_mark($int, $tp, 'LAB', $lab); } } $cl += $cs; $tp->{s_pointer} = $cp + $sl; if ($dl > 0 || $ds > 0) { my $dsx = $ds - 1; $dsx = _get_number($int, $tp, '%', {}, \$ds, $ds + $dl, 1) if $dl > 0; my $dsa = rand(100) >= $dsx ? 1 : 0; _trace_mark($int, $tp, 'DSX', $dsx, $dsa); if ($dsa) { $tp->{comefrom} = [$ls, $ll, $ge, $cp]; _comefrom($int, $tp); return; } } # nowadays one can ABSTAIN FROM QUANTUM COMPUTING if ($qu && exists $tp->{ab_gerund}{&BC_QUA}) { $qu = ! $tp->{ab_gerund}{&BC_QUA}[0]; } } $tp->{comefrom} = [$ls, $ll, $ge, $cp]; # check if an ABSTAIN/REINSTATE applies to this statement my $abr = 'NOT'; if ($lab && exists $tp->{ab_label}{$lab}) { if ($ge && $ge != BC_GUP && exists $tp->{ab_gerund}{$ge}) { if ($tp->{ab_gerund}{$ge}[1] > $tp->{ab_label}{$lab}[1]) { $ab = $tp->{ab_gerund}{$ge}[0]; $abr = "GER$ge"; } else { $ab = $tp->{ab_label}{$lab}[0]; $abr = "LAB$lab"; } } else { $ab = $tp->{ab_label}{$lab}[0]; $abr = "LAB$lab"; } } elsif ($ge && $ge != BC_GUP && exists $tp->{ab_gerund}{$ge}) { $ab = $tp->{ab_gerund}{$ge}[0]; $abr = "GER$ge"; } if ($ab) { # ABSTAINed FROM _trace_mark($int, $tp, 'ABSTAIN', $abr); _comefrom($int, $tp); return; } my @qu = (); if ($qu) { $runenv->{quantum} = \@qu; } delete $int->{recompile}; while ($cs < $cl && $tp->{running}) { _run($int, $tp, $runenv, \$cs, $cl, 1); } if (@qu) { # undo the effects of the statement while not undoing it my @tc = (); for my $T (@{$int->{threads}}) { # do we share anything with this thread? my $share = 0; SHARE: for my $item (@qu) { my ($undo, @ptr) = @$item; my $ptr = $tp; my $spt = $T; for my $p (@ptr) { if (! ref $ptr) { next SHARE; } elsif (UNIVERSAL::isa($ptr, 'ARRAY')) { $ptr = $ptr->[$p]; $spt = $spt->[$p]; } else { $ptr = $ptr->{$p}; $spt = $spt->{$p}; } defined $ptr && defined $spt or next SHARE; } $ptr == $spt or next SHARE; $share = 1; last SHARE; } next unless $share; push @tc, $T; } for my $T (@tc) { my $dt = _dup_thread($int, $T); # do we share anything with this thread? SHARE: for my $item (@qu) { my ($undo, @ptr) = @$item; my $ptr = $tp; my $spt = $T; my $dpt = $dt; my $lptr = pop @ptr; for my $p (@ptr) { if (UNIVERSAL::isa($ptr, 'ARRAY')) { $ptr = $ptr->[$p]; $spt = $spt->[$p]; $dpt = $dpt->[$p]; } else { $ptr = $ptr->{$p}; $spt = $spt->{$p}; $dpt = $dpt->{$p}; } defined $ptr && defined $spt or next SHARE; } if (UNIVERSAL::isa($ptr, 'ARRAY')) { $ptr = $ptr->[$lptr]; $spt = $spt->[$lptr]; defined $ptr && defined $spt or next SHARE; $dpt->[$lptr] = $undo; } else { $ptr = $ptr->{$lptr}; $spt = $spt->{$lptr}; defined $ptr && defined $spt or next SHARE; $dpt->{$lptr} = $undo; } } _comefrom($int, $dt) if $T == $tp; } } if ($int->{recompile} && ! ($int->{compiling} & 2)) { _trace_mark($int, $tp, 'RECOMPILE'); _compile($int, $int->{source}); } delete $int->{recompile}; _comefrom($int, $tp); } sub compile { @_ == 2 or croak "Usage: INTERPRETER->compile(source)"; my ($int, $src) = @_; _compile($int, $src); $int->{object}->setcode($int->{code}, $int->{cptr}); $int->{object}->source($src); $int; } sub _compile { my ($int, $src) = @_; my $ps = $int->{default}{registers}{$reg_ps}{value}->number; my $is = $int->{default}{registers}{$reg_is}{value}->number; my $ss = $int->{default}{registers}{$reg_ss}{value}->number; my $js = $int->{default}{registers}{$reg_js}{value}->number; my $parser = $int->{object}->parser(1); my @code = $parser->compile_top($ps, $is, $src, 0, $ss, $js, $int->{verbose}); ($int->{code}, $int->{cptr}) = $int->{object}->make_code(\@code); delete $int->{recompile}; } sub _comefrom { my ($int, $tp) = @_; return unless $tp->{comefrom} && @{$tp->{comefrom}}; my ($clab, $cll, $cger, $here) = @{$tp->{comefrom}}; $cger = 0 if $cger && ! ($tp->{registers}{$reg_cf}{value}->number & 2); return unless $clab || $cll || $cger; my $cflab = $clab || bytedecode($cger) || "#$cger"; my $lab_start = $clab; my $label_change = 0; if ($cll > 0) { # computed label might have changed since we last calculated it my $xls = $lab_start; $label_change ||= is_constant(ord(substr($int->{code}, $xls, 1))); $clab = _get_number($int, $tp, 'LAB', {}, \$xls, $xls + $cll, 1); } elsif (exists $tp->{assign}{$clab}) { # constant label might have changed too. Happens $clab = ${$tp->{assign}{$clab}}; } return unless $clab || $cger; _trace_mark($int, $tp, 'COMEFROM', $cflab); my %cf = (); my %cfl = (); my $quantum = 0; my $co = sub { my ($cs, $cl, $ss, $sl, $ab, $ls, $sll, $ds, $dl, $ge, $qu) = @_; return if ! exists $come_froms{$ge}; return if exists $cf{$ss}; return if ! $ls && exists $cfl{$ss + $sl} && $cfl{$ss + $sl} <= $ss; $cfl{$ss + $sl} = $ss; my $name = bytedecode($ge); _trace_mark($int, $tp, 'COMEFROM', $name, $ss, $ss + $sl - 1); my $slab = $ls; if ($sll > 0) { $slab = _get_number($int, $tp, 'LAB', {}, \$ls, $ls + $sll, 1); } elsif (exists $tp->{assign}{$slab}) { $slab = ${$tp->{assign}{$slab}}; } # check if an ABSTAIN/REINSTATE applies to this statement if ($slab && exists $tp->{ab_label}{$slab}) { if ($ge && exists $tp->{ab_gerund}{$ge}) { if ($tp->{ab_gerund}{$ge}[1] > $tp->{ab_label}{$slab}[1]) { $ab = $tp->{ab_gerund}{$ge}[0]; } else { $ab = $tp->{ab_label}{$slab}[0]; } } else { $ab = $tp->{ab_label}{$slab}[0]; } } elsif ($ge && exists $tp->{ab_gerund}{$ge}) { $ab = $tp->{ab_gerund}{$ge}[0]; } return if $ab; # is there a double-oh-seven? if ($dl > 0 || $ds > 0) { my $dsx = $ds - 1; $label_change ||= is_constant(ord(substr($int->{code}, $ds, 1))); $dsx = _get_number($int, $tp, '%', {}, \$ds, $ds + $dl, 1) if $dl > 0; my $dsa = rand(100) >= $dsx ? 1 : 0; return if $dsa; } _trace($int, $tp, $ge, 0); $cl += $cs; $cs++; # is it a COME/NEXT FROM label or gerund? if ($ge == BC_CFL || $ge == BC_NXL) { if ($label_change) { $label_change = 0; if ($cll > 0) { # computed label might have changed again my $xls = $lab_start; $label_change ||= is_constant(ord(substr($int->{code}, $xls, 1))); $clab = _get_number($int, $tp, 'LAB', {}, \$xls, $xls + $cll, 1); } elsif (exists $tp->{assign}{$lab_start}) { # constant label might have changed too. Happens $clab = ${$tp->{assign}{$lab_start}}; } } return unless $clab; $label_change ||= is_constant(ord(substr($int->{code}, $cs, 1))); my $l = _get_number($int, $tp, $name, {}, \$cs, $cl, 1); return if $l != $clab; } else { return unless $cger; my $c = _get_number($int, $tp, $name, {}, \$cs, $cl, 0); $cs + $c <= $cl or faint(SP_INVALID, "Not enough opcodes", $name); my $found = 0; _trace($int, $tp, '<', 1); while ($c-- > 0) { my $g = ord(substr($int->{code}, $cs++, 1)); _trace($int, $tp, $g, 0); next if $g != $cger; $found = 1; last; } _trace($int, $tp, $found ? '!>' : '>', 1); return unless $found; } $quantum ||= $qu; $cf{$ss} = $ge == BC_NXL || $ge == BC_NXG; }; forall_code($int->{cptr}, 0, $co); # is system call interface enabled? if ($clab && exists $tp->{registers}{$reg_os}) { my $os = $tp->{registers}{$reg_os}{value}->number; if ($os == $clab) { # we need to check we are not abstaining from NEXT FROM LABEL my $ab = exists $tp->{ab_gerund}{&BC_NXL} ? $tp->{ab_gerund}{&BC_NXL}[0] : 0; if (! $ab) { @{$tp->{registers}{$reg_os}{owners}} or faint(SP_SYSCALL); my ($t, $n) = @{$tp->{registers}{$reg_os}{owners}[0]}; exists $tp->{registers}{".$n"} or faint(SP_SYSCALL); $cf{-1} = $tp->{registers}{".$n"}{value}->number; } } } my @cf = keys %cf; return unless @cf; # nowadays one can ABSTAIN FROM QUANTUM COMPUTING if ($quantum && exists $tp->{ab_gerund}{&BC_QUA}) { $quantum = ! $tp->{ab_gerund}{&BC_QUA}[0]; } if (@cf > 1 && ! ($tp->{registers}{$reg_cf}{value}->number & 1)) { if ($quantum) { # we must splat while at the same time not splatting... _splat($int, $tp, {quantum => []}, splatdescription(SP_COMEFROM, $cflab)); # and then we don't actually take the COME FROMs return; } faint(SP_COMEFROM, $cflab); } my $loops = 0; while (@cf) { my $cf = shift @cf; my $mode = $cf{$cf}; if ($cf < 0) { # system call - determine system call number exists $int->{syscode}{$mode} or faint(SP_NOSYSCALL, '#' . $mode); my $c = $int->{syscode}{$mode}; my $sv = $int->{code}; $int->{code} = $c; eval { my $cp = 0; while ($cp < length $c) { _run($int, $tp, {}, \$cp, length $c, 1); } }; $int->{code} = $sv; die $@ if $@; next; } # not a system call - do we need to create a new thread? my $nt = @cf || $quantum ? _dup_thread($int, $tp) : $tp; if ($mode) { # this is a NEXT FROM @{$nt->{next_stack}} >= MAX_NEXT and faint(SP_NEXTING, MAX_NEXT); push @{$nt->{next_stack}}, [ $nt->{s_pointer}, [@{$nt->{loop_code}}], [@{$nt->{in_loop}}], [], # otherwise we get a NEXT FROM loop when we RESUME ]; } $nt->{s_pointer} = $cf; @{$nt->{loop_code}} = (); @{$nt->{comefrom}} = (); @{$nt->{in_loop}} = (); $loops = 1 if defined $here && $cf == $here; } $loops or return; # avoid wasting CPU time on a tight loop - see if there's something useful # we can do instead if ($int->{server}) { $int->{server}->progress(0.1); } else { select undef, undef, undef, 0.1; } } sub _run { my ($int, $tp, $runenv, $cp, $ep, $varconst) = @_; faint(SP_FALL_OFF) if $$cp >= $ep; my $code = $int->{code}; my $byte = ord(substr($code, $$cp, 1)); my ($name, $descr, $type, $number, $args, $const, $assignable) = bytedecode($byte); my $ocp = $$cp; _trace($int, $tp, $byte, 0); faint(SP_INVALID, $byte, 'run') if ! defined $name; faint(SP_INVALID, $name, 'assignment') if $runenv->{assign} && ! $assignable; if ($const) { # constant (which may be variable) my $ocp = $$cp; my $val = BCget($code, $cp, $ep); $$cp == $ocp + 1 or _trace($int, $tp, "#" . $val, 1, unpack('C*', substr($code, $ocp + 1, $$cp - $ocp - 1))); faint(SP_INVALID, "arguments", $name) if $$cp > $ep; if ($varconst && exists $tp->{assign}{$val}) { $val = ${$tp->{assign}{$val}}; } if ($runenv->{assign}) { my $assign = $runenv->{assign}; if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } _assign_constant($int, $tp, $runenv, $val, $assign); } return new Language::INTERCAL::Numbers::Spot($val); } else { # any other type of opcode faint(SP_TODO, $name) if ! exists $tp->{opcodes}{$name}; faint(SP_INVALID, $name, '_run') if ref $tp->{opcodes}{$name} ne 'CODE'; $$cp++; return &{$tp->{opcodes}{$name}}($int, $tp, $name, $runenv, $cp, $ep); } } sub _create_register { # create/separate register if necessary my ($int, $tp, $name, $reg, $runenv, $undo) = @_; if (! exists $tp->{registers}{$reg}) { my $value; my %newreg = ( value => reg_create($reg, $int->{object}), ignore => 0, default => 0, ); my @newstash = (); for my $t (@{$int->{threads}}, $int->{default}, $tp) { $t->{registers}{$reg} = \%newreg if ! exists $t->{registers}{$reg}; $t->{stash}{$reg} = \@newstash if ! exists $t->{stash}{$reg}; } } if ($runenv->{quantum}) { $undo ||= \&_deep_copy; push @{$runenv->{quantum}}, [$undo->($tp->{registers}{$reg}), 'registers', $reg], [_deep_copy($tp->{stash}{$reg}), 'stash', $reg]; } } sub _stash_register { my ($int, $tp, $name, $reg, $runenv) = @_; _create_register($int, $tp, $name, $reg, $runenv); push @{$tp->{stash}{$reg}}, _deep_copy($tp->{registers}{$reg}); undef; } sub _retrieve_register { my ($int, $tp, $name, $reg, $runenv) = @_; _create_register($int, $tp, $name, $reg, $runenv); $tp->{stash}{$reg} && @{$tp->{stash}{$reg}} or faint(SP_HIDDEN, $reg); my $pop = pop @{$tp->{stash}{$reg}}; # we must copy the hash rather than the ref otherwise any other threads # sharing this register don't get the retrieve %{$tp->{registers}{$reg}} = %$pop if ! $tp->{registers}{$reg}{ignore} || $tp->{registers}{$reg_rm}{value}->number; undef; } sub _q { my ($runenv) = @_; return { quantum => $runenv->{quantum}, }; } sub _a { my ($runenv, %rest) = @_; my %runenv = %$runenv; $runenv{$_} = $rest{$_} for keys %rest; \%runenv; } sub _i_register { my ($int, $tp, $name, $type, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); _ii_register($int, $tp, $name, $type, $num, $runenv, $cp, $ep); } sub _ii_register { my ($int, $tp, $name, $type, $num, $runenv, $cp, $ep) = @_; # check for valid register - note that @0 will be valid at this point my $reg = $type . $num; exists $tp->{registers}{$reg} || ($num > 0 && $num <= 0xffff) or faint(SP_REGISTER, $reg); # check for owners if ($runenv->{owners} && @{$runenv->{owners}}) { exists $tp->{registers}{$reg} && exists $tp->{registers}{$reg}{owners} && @{$tp->{registers}{$reg}{owners}} or faint(SP_FREE, $reg); my $own = shift @{$runenv->{owners}}; $own > 0 or faint(SP_OWNER, $own); $own <= @{$tp->{registers}{$reg}{owners}} or faint(SP_NOOWNER, $reg, $own, scalar @{$tp->{registers}{$reg}{owners}}); my ($mtype, $mnum) = @{$tp->{registers}{$reg}{owners}[$own - 1]}; return _ii_register($int, $tp, $name, $mtype, $mnum, $runenv, $cp, $ep); } my $assign = $runenv->{assign}; if ($assign) { # check for special "assignment" code - really used for STASH, # RETRIEVE, IGNORE, REMEMBER, WRITE IN - note that WRITE IN will # need to check if the register is IGNOREd if (ref $assign eq 'CODE') { return &$assign($int, $tp, $runenv, $cp, $ep, 'R', $reg); } if (exists $causes_recompile{$reg} && $runenv->{quantum}) { # can't do that (yet), sorry faint(SP_QUANTUM, "Assignment to grammar registers"); } _create_register($int, $tp, $name, $reg, $runenv); # special treatment for system call interface if (exists $tp->{registers}{$reg_os}) { _create_register($int, $tp, $name, $reg_os, $runenv); @{$tp->{registers}{$reg_os}{owners}} = [$type, $num]; } # check if a register is ignored $tp->{registers}{$reg}{ignore} and return undef; my $oldval; delete $tp->{registers}{$reg}{default}; $oldval = $tp->{registers}{$reg}{value}->number if exists $causes_recompile{$reg}; $tp->{registers}{$reg}{value}->use($runenv->{subscripts}, $assign); return undef unless exists $causes_recompile{$reg}; return undef if $oldval == $tp->{registers}{$reg}{value}->number; if ($int->{source} ne '') { $int->{recompile} = 1; return undef; } faint(SP_CONTEXT, 'Frozen object cannot change ' . reg_decode($reg)); } _create_register($int, $tp, $name, $reg, _a($runenv, quantum => undef)); return $tp->{registers}{$reg}{value}->use($runenv->{subscripts}); } sub _i_spo { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, '.', $runenv, $cp, $ep); } sub _i_tsp { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, ':', $runenv, $cp, $ep); } sub _i_tai { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, ',', $runenv, $cp, $ep); } sub _i_hyb { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, ';', $runenv, $cp, $ep); } sub _i_whp { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, '@', $runenv, $cp, $ep); } sub _i_dos { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, '%', $runenv, $cp, $ep); } sub _i_shf { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, '^', $runenv, $cp, $ep); } sub _i_cho { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _i_register($int, $tp, $name, '_', $runenv, $cp, $ep); } sub _i_typ { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; push @{$runenv->{asshist}}, $runenv->{assign} || 0; _run($int, $tp, _a($runenv, assign => \&_x_typ), $cp, $ep, 1); } sub _x_typ { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'get TYPE of'); if ($runenv->{asshist} && @{$runenv->{asshist}}) { $runenv->{assign} = pop @{$runenv->{asshist}}; } _i_register($int, $tp, 'TYP', substr($reg, 0, 1), $runenv, $cp, $ep); undef; } sub _i_num { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; push @{$runenv->{asshist}}, $runenv->{assign} || 0; _run($int, $tp, _a($runenv, assign => \&_x_num), $cp, $ep, 1); } sub _x_num { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'get NUMBER of'); my $val = substr($reg, 1); if ($runenv->{asshist} && @{$runenv->{asshist}}) { $runenv->{assign} = pop @{$runenv->{asshist}}; } my $assign = $runenv->{assign}; if ($assign) { # assigning to a register number is equivalent to assigning to constant if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } _assign_constant($int, $tp, $runenv, $val, $assign); } Language::INTERCAL::Numbers::Spot->new($val); } sub _assign_constant { my ($int, $tp, $runenv, $val, $assign) = @_; # next line guarantees we don't assign arrays to numbers $assign = $assign->spot->number; _trace($int, $tp, "[#$val <- #$assign]", 1); if (! exists $tp->{assign}{$val}) { for my $t (@{$int->{threads}}, $int->{default}) { $t->{assign}{$val} = \$assign; } } if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{assign}{$val}), 'assign', $val]; } ${$tp->{assign}{$val}} = $assign; } sub _i_sub { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $sub = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $ps = [$sub, $runenv->{subscripts} ? @{$runenv->{subscripts}} : ()]; _run($int, $tp, _a($runenv, subscripts => $ps), $cp, $ep, 1); } sub _i_own { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $own = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $po = [$own, $runenv->{owners} ? @{$runenv->{owners}} : ()]; _run($int, $tp, _a($runenv, owners => $po), $cp, $ep, 1); } sub _i_ovr { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $expr = $$cp; my $elen = bc_skip($int->{code}, $expr, $ep) or faint(SP_INVALID, '(unknown)', $name); $$cp = $expr + $elen; _run($int, $tp, _a($runenv, assign => \&_x_ovr, overloading => [$expr, $elen]), $cp, $ep, 1); } sub _x_ovr { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'OVR'); _create_register($int, $tp, 'OVR', $reg, $runenv); my ($expr, $elen) = @{$runenv->{overloading}}; my $S = $runenv->{subscripts} || []; # remove overload $tp->{registers}{$reg}{value}->overload($S); my $unov = $tp->{registers}{$reg}{value}; my $code = substr($int->{code}, $expr, $elen); if ($code eq reg_code($reg) || $code eq pack('C*', BC_OWN, BC(1), BC_WHP, BC(0))) { return $unov; } # create a closure containing the overload code my $closure = sub { my %runenv = (); my $subs = shift; $runenv{subscripts} = $subs if $subs && @$subs; if (@_) { my $value = shift; $runenv{assign} = $value; } # must save the code and use our old one - because in intercalc # the overload may have been created in a completely different # context and the code no longer applies my $svcode = $int->{code}; $int->{code} = $code; my $x = 0; my $r = eval { _run($int, $tp, \%runenv, \$x, $elen, 1) }; $int->{code} = $svcode; die $@ if $@; return $r; }; $tp->{registers}{$reg}{value}->overload($S, $closure); $unov; } sub _i_ovm { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $expr = $$cp; my $elen = bc_skip($int->{code}, $expr, $ep) or faint(SP_INVALID, '(unknown)', $name); $$cp = $expr + $elen; my $N = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my $ba = $tp->{registers}{$reg_ba}{value}->number; my ($first, $last) = _uninterleave($ba, $N); $first = $first->number; $last = $last->number; $runenv = _a($runenv, overloading => [$expr, $elen]); while ($first <= $last) { for my $p ('.', ',', ':', ';') { _x_ovr($int, $tp, $runenv, $cp, $ep, 'R', $p . $first); } $first++; } $N; } sub _i_ror { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _run($int, $tp, _a($runenv, assign => \&_x_ror), $cp, $ep, 1); } sub _x_ror { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'OVR'); _create_register($int, $tp, 'OVR', $reg, $runenv); my $S = $runenv->{subscripts} || []; $tp->{registers}{$reg}{value}->overload($S); $tp->{registers}{$reg}{value}; } sub _i_rom { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $N = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my $ba = $tp->{registers}{$reg_ba}{value}->number; my ($first, $last) = _uninterleave($ba, $N); my $S = $runenv->{subscripts} || []; $first = $first->number; $last = $last->number; while ($first <= $last) { for my $p ('.', ',', ':', ';') { $tp->{registers}{$p . $first}{value}->overload($S); } $first++; } $N; } sub _i_sto { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $assign = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); _run($int, $tp, _a($runenv, assign => $assign), $cp, $ep, 1); } sub _i_spl { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $assign = $runenv->{assign}; if ($assign) { if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } # what do you expect? faint($assign->number); } else { exists $int->{default}{registers}{$reg_sp} or faint(SP_SPLAT); defined $int->{default}{registers}{$reg_sp}{value}->print or faint(SP_SPLAT); return $int->{default}{registers}{$reg_sp}{value}; } } sub _i_udv { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $ba = $tp->{registers}{$reg_ba}{value}->number; if ($runenv->{assign}) { my $assign = $runenv->{assign}; if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } my $bits = $assign->bits; my $digits = $assign->num_digits($ba); my $value = $assign->number; # $limit = 0r1000...000 my $limit = 1; for (my $d = 1; $d < $digits; $d++) { $limit *= $ba; } if ($tp->{registers}{$reg_dm}{value}->number) { # bitwise unary divide my @range = (); my $range = 0; if ($value == 0) { for (my $x = 0; $x < $ba; $x++) { my $min = 1 + int($x * ($limit - 1) / ($ba - 1)); my $d = $limit - $min; next if $d < 1; push @range, [$x, $min, $d]; $range += $d; } } else { for (my $x = 1; $x < $ba; $x++) { my $min = $x * ($limit - $value - 1) / ($value * $ba + $ba - 1); my $max = 1 + int($x * ($limit - $value) / ($value * $ba - 1)); if ($min < 0) { $min = 0; } else { $min = int(1 + $min); } $max = $limit * $ba if $max > $limit * $ba; next if $min >= $max; $max -= $min; push @range, [$x, $min, $max]; $range += $max; } } $range > 0 or faint(SP_ASSIGN, $ba, '-', $value); my $rnd = int(rand $range); for my $rg (@range) { my ($x, $low, $r) = @$rg; if ($rnd < $r) { $value = ($rnd + $low) * $ba + $x; last; } $rnd -= $r; } } else { # arithmetic unary divide my (@gives_plus_1, @gives_plus_2, @gives_plus_3); if ($ba == 2) { @gives_plus_1 = (3); } elsif ($ba == 3) { @gives_plus_1 = (4, 8); } elsif ($ba == 4) { @gives_plus_1 = (5, 10, 11, 15); } elsif ($ba == 5) { @gives_plus_1 = (6, 12, 13, 18, 19, 24); @gives_plus_2 = (14); } elsif ($ba == 6) { @gives_plus_1 = (7, 14, 15, 21, 22, 23, 28, 29, 35); @gives_plus_2 = (16, 17); } elsif ($ba == 7) { @gives_plus_1 = (8, 16, 17, 24, 25, 26, 32, 33, 34, 40, 41, 48); @gives_plus_2 = (18, 19, 27); @gives_plus_3 = (20); } if ($value == $ba) { my @values = (@gives_plus_1, @gives_plus_2, @gives_plus_3); # any value > 2 * $ba will do except the ones in @values $limit *= $ba; $limit -= @values; my %avoid = (); for (my $i = 0; $i < @values; $i++) { $avoid{$values[$i]} = $limit + $i; } $limit -= 1 + 2 * $ba; $value = int(2 * $ba + 1 + int(rand($limit))); $value = $avoid{$value} if exists $avoid{$value}; } elsif ($value == $ba + 1 && @gives_plus_1) { $value = $gives_plus_1[int(rand scalar @gives_plus_1)]; } elsif ($value == $ba + 2 && @gives_plus_2) { $value = $gives_plus_2[int(rand scalar @gives_plus_2)]; } elsif ($value == $ba + 3 && @gives_plus_3) { $value = $gives_plus_3[int(rand scalar @gives_plus_3)]; } elsif ($value < $ba || $value >= 2 * $ba) { faint(SP_ASSIGN, $ba, '-', $value); } } $assign = Language::INTERCAL::Numbers->new($bits, $value); _run($int, $tp, _a($runenv, assign => $assign), $cp, $ep, 1); } else { my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); if ($tp->{registers}{$reg_dm}{value}->number) { # bitwise unary divide my $val = $num->number; faint(SP_DIVIDE) if $val < 1; my @digs = $num->digits($ba); my $ld = pop @digs; unshift @digs, $ld; my $div = Language::INTERCAL::Numbers->from_digits($ba, @digs)->number; my $class = ref $num; return $class->new(int($div / $val)); } else { # arithmetic unary divide $num = $num->number; my $div = int($num / $ba); faint(SP_DIVIDE) if $div < 1; $num = int($num / $div); return Language::INTERCAL::Numbers::Spot->new($num); } } } sub _i_msp { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $splat = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $narg = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my @arg = (); while (@arg < $narg) { push @arg, _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); } faint($splat, @arg); } sub _i_sta { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); while ($num-- > 0) { _run($int, $tp, _a($runenv, assign => \&_x_sta), $cp, $ep, 1); } } sub _x_sta { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'STASH'); _stash_register($int, $tp, 'STA', $reg, $runenv); undef; } sub _i_ret { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); while ($num-- > 0) { _run($int, $tp, _a($runenv, assign => \&_x_ret), $cp, $ep, 1); } } sub _x_ret { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'RETRIEVE'); _retrieve_register($int, $tp, 'RET', $reg, $runenv); undef; } sub _i_ign { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); while ($num-- > 0) { _run($int, $tp, _a($runenv, assign => \&_x_ign), $cp, $ep, 1); } } sub _x_ign { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'IGNORE'); _create_register($int, $tp, 'IGN', $reg, $runenv, \&_y_ign); $tp->{registers}{$reg}{ignore} = 1; undef; } sub _y_ign { my ($reg) = @_; $reg = _deep_copy($reg); $reg->{ignore} = 0; $reg; } sub _i_rem { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); while ($num-- > 0) { _run($int, $tp, _a($runenv, assign => \&_x_rem), $cp, $ep, 1); } } sub _x_rem { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'REMEMBER'); _create_register($int, $tp, 'REM', $reg, $runenv, \&_y_rem); $tp->{registers}{$reg}{ignore} = 0; undef; } sub _y_rem { my ($reg) = @_; $reg = _deep_copy($reg); $reg->{ignore} = 1; $reg; } sub _abstain_reinstate { my ($int, $tp, $runenv, $abstain, $label, @gerunds) = @_; my $count = ++$int->{ab_count}; my $qp = $runenv->{quantum}; if ($label) { push @$qp, [[! $abstain, $count], 'ab_label', $label] if ($qp); if (exists $tp->{ab_label}{$label}) { @{$tp->{ab_label}{$label}} = ($abstain, $count); } else { for my $t (@{$int->{threads}}, $int->{default}) { next if exists $t->{ab_label}{$label}; $t->{ab_label}{$label} = [$abstain, $count]; } } } for my $ger (@gerunds) { push @$qp, [[! $abstain, $count], 'ab_gerund', $ger] if ($qp); if (exists $tp->{ab_gerund}{$ger}) { @{$tp->{ab_gerund}{$ger}} = ($abstain, $count); } else { for my $t (@{$int->{threads}}, $int->{default}) { next if exists $t->{ab_gerund}{$ger}; $t->{ab_gerund}{$ger} = [$abstain, $count]; } } } } sub _i_abl { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $lab = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); faint(SP_INVLABEL, $lab) if $lab < 1 || $lab > 0xffff; _abstain_reinstate($int, $tp, $runenv, 1, $lab); undef; } sub _i_abg { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $num <= $ep or faint(SP_INVALID, "Not enough opcodes", $name); my @ger = unpack('C*', substr($int->{code}, $$cp, $num)); $$cp += $num; _abstain_reinstate($int, $tp, $runenv, 1, 0, @ger); undef; } sub _i_rel { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $lab = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); faint(SP_INVLABEL, $lab) if $lab < 1 || $lab > 0xffff; _abstain_reinstate($int, $tp, $runenv, 0, $lab); undef; } sub _i_reg { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $num <= $ep or faint(SP_INVALID, "Not enough opcodes", $name); my @ger = unpack('C*', substr($int->{code}, $$cp, $num)); $$cp += $num; _abstain_reinstate($int, $tp, $runenv, 0, 0, @ger); undef; } sub _i_cfl { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); undef; } sub _i_cfg { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $num <= $ep or faint(SP_INVALID, "Not enough opcodes", $name); $$cp += $num; undef; } sub _i_bug { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $t = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); faint($t ? SP_UBUG : SP_BUG); } sub _i_rou { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, 'READ OUT') if $runenv->{quantum}; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my $fh = $tp->{registers}{$reg_orfh}{value}->filehandle; _set_read_charset($int, $tp, $fh); while ($num-- > 0) { my $e = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); ref $e or faint(SP_INVALID, "Not an expression", $name); if (UNIVERSAL::isa($e, 'Language::INTERCAL::Numbers')) { my $rt = $tp->{registers}{$reg_rt}{value}->number; read_number($e->number, $rt, $fh); } elsif (ref $e eq 'ARRAY') { # assume it is a tail array my $io = $tp->{registers}{$reg_io}{value}->number; _create_register($int, $tp, $name, $reg_ar, $runenv); my $ar = $tp->{registers}{$reg_ar}{value}->number; read_array_16($io, \$ar, $fh, $e, 1); $tp->{registers}{$reg_ar}{value}->assign($ar); } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Arrays')) { my $io = $tp->{registers}{$reg_io}{value}->number; _create_register($int, $tp, $name, $reg_ar, $runenv); my $ar = $tp->{registers}{$reg_ar}{value}->number; my @v = map { $_->number } $e->as_list; @v or faint(SP_NODIM); if ($e->bits <= 16) { my $nl = $tp->{newline} && ($io == 0 || $io == iotype_default); read_array_16($io, \$ar, $fh, \@v, $nl); } else { read_array_32($io, \$ar, $fh, \@v, 0); } $tp->{registers}{$reg_ar}{value}->assign($ar); } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Whirlpool')) { $fh = $e->filehandle; _set_read_charset($int, $tp, $fh); # $tp->{registers}{$reg_owfh}{value}->assign($fh); } else { faint(SP_READ, 'READ OUT'); } } } sub _newline { my ($tp) = @_; $tp->{newline} = ! $tp->{newline}; } sub _i_win { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my $fh = $tp->{registers}{$reg_owfh}{value}->filehandle; _set_write_charset($int, $tp, $fh); $tp->{_filehandle} = $fh; while ($num-- > 0) { _run($int, $tp, _a($runenv, assign => \&_x_win), $cp, $ep, 1); } delete $tp->{_filehandle}; undef; } sub _x_win { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; if ($type eq 'N') { # treat this as numeric WRITE my $wimp = $tp->{registers}{$reg_wt}{value}->number; my $val = write_number($tp->{_filehandle}, $wimp); my $bits = $val < 0x10000 ? 16 : 32; return Language::INTERCAL::Numbers->new($bits, $val); } $type eq 'R' or faint(SP_INVALID, 'Neither a number nor a register?', 'WIN'); _create_register($int, $tp, 'WIN', $reg, $runenv); my $i = $tp->{registers}{$reg}{ignore}; my $e = $tp->{registers}{$reg}{value}; if (UNIVERSAL::isa($e, 'Language::INTERCAL::Numbers')) { my $wimp = $tp->{registers}{$reg_wt}{value}->number; my $val = write_number($tp->{_filehandle}, $wimp); $e->assign($val) unless $i; } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Arrays')) { my $io = $tp->{registers}{$reg_io}{value}->number; _create_register($int, $tp, 'WIN', $reg_aw, $runenv); my $aw = $tp->{registers}{$reg_aw}{value}->number; my @v; if ($e->bits <= 16) { @v = write_array_16($io, \$aw, $tp->{_filehandle}, $e->elements); } else { @v = write_array_32($io, \$aw, $tp->{_filehandle}, $e->elements); } $e->replace(\@v) unless $i; $tp->{registers}{$reg_aw}{value}->assign($aw); } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Whirlpool')) { my $fh = $e->filehandle; _set_write_charset($int, $tp, $fh); $tp->{_filehandle} = $fh; # $tp->{registers}{$reg_owfh}{value}->assign($fh); } else { faint(SP_READ, 'WRITE IN'); } } sub _interleave { my ($base, $num1, $num2) = @_; my @num1 = $num1->spot->digits($base); my @num2 = $num2->spot->digits($base); my @num = (); while (@num1) { push @num, shift @num1; push @num, shift @num2; } return Language::INTERCAL::Numbers->from_digits($base, @num); } sub _i_int { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $ba = $tp->{registers}{$reg_ba}{value}->number; if ($runenv->{assign}) { my $assign = $runenv->{assign}; if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } my ($num1, $num2) = _uninterleave($ba, $assign); _run($int, $tp, _a($runenv, assign => $num1), $cp, $ep, 1); _run($int, $tp, _a($runenv, assign => $num2), $cp, $ep, 1); return undef; } else { my $num1 = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my $num2 = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); return _interleave($ba, $num1, $num2); } } sub _i_rin { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; # we must execute the operands in reverse order, or side-effects won't # work as advertised. my $firstop = $$cp; $$cp += bc_skip($int->{code}, $firstop, $ep); my $firstend = $$cp; my $ba = $tp->{registers}{$reg_ba}{value}->number; if ($runenv->{assign}) { my $assign = $runenv->{assign}; if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } my ($num1, $num2) = _uninterleave($ba, $assign); _run($int, $tp, _a($runenv, assign => $num1), $cp, $ep, 1); _run($int, $tp, _a($runenv, assign => $num2), \$firstop, $firstend, 1); return undef; } else { my $num1 = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my $num2 = _get_expression($int, $tp, $name, $runenv, \$firstop, $firstend, 1); return _interleave($ba, $num1, $num2); } } sub _i_smu { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _ii_ste($int, $tp, $name, $runenv, $cp, $ep, 'SMUGGLE'); } sub _i_ste { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _ii_ste($int, $tp, $name, $runenv, $cp, $ep, 'STEAL'); } sub _ii_ste { my ($int, $tp, $name, $runenv, $cp, $ep, $operation) = @_; $int->{theft_server} or faint(SP_INVALID, "This program is not allowed to $operation", $name); my $theft = $int->{theft_server}; my $type = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); faint(SP_INVALID, "$type expressions", $name) if $type < 0 || $type > 1; my $server; if ($type) { $server = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $server = join('.', $server >> 24, ($server >> 16) & 0xff, ($server >> 8) & 0xff, $server & 0xff); } else { # broadcast for a server my @ips = $theft->find_theft_servers; $server = $ips[int(rand(scalar @ips))]; } my $pid; $type = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); faint(SP_INVALID, "$type expressions", $name) if $type < 0 || $type > 1; if ($type) { $pid = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); } else { # get a random pid from server my @pids = $theft->pids($server); $pid = $pids[int(rand(scalar @pids))]; } $theft->start_request($server, $pid, $operation); my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); while ($num-- > 0) { _run($int, $tp, _a($runenv, assign => \&_x_ste, name => $name, server => $server), $cp, $ep, 1); } $theft->finish_request; } sub _x_ste { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_INVALID, 'Not a register', $runenv->{name}); _create_register($int, $tp, $runenv->{name}, $reg, $runenv); my @v = $int->{theft_server}->request($reg); my $r = $tp->{registers}{$reg}; my $i = $r->{ignore}; return if $i; my @ops = (); for my $v (@v) { $v =~ s/\s+//g; substr($v, 0, length($reg)) eq $reg or faint(SP_INVALID, 'Wrong register received', $runenv->{name}); substr($v, 0, length($reg)) = ''; $v =~ s/^(.*)<-// or faint(SP_INVALID, 'Not an assignment', $runenv->{name}); my $d = $1; if ($v =~ /^#(\d+)BY\?(\S+)BY\?(\S+)BY\?(\S+)$/) { substr($reg, 0, 1) eq '@' or faint(SP_INVALID, 'Not a class register', $runenv->{name}); my $port = $runenv->{server} . ':' . $1; my $rcs = $2; my $wcs = $3; my $mode = $4; $v = Language::INTERCAL::GenericIO->new('REMOTE', $mode, $port, $int->{server}); $v->read_charset($rcs); $v->write_charset($wcs); } elsif ($v =~ /^#(\d+)$/) { $v = Language::INTERCAL::Numbers::Spot->new($1); } elsif ($v =~ /^#(\d+)¢#(\d+)$/) { my ($v1, $v2) = ($1, $2); $v = _interleave(2, Language::INTERCAL::Numbers::Spot->new($v1), Language::INTERCAL::Numbers::Spot->new($v2)); } else { faint(SP_INVALID, "Value ($v) syntax error", $runenv->{name}); } if ($d eq '') { push @ops, [$v, undef]; } else { my @s = split(/SUB/, $d); my @t = grep { /^#\d+$/ } @s; @t == @s or faint(SP_INVALID, 'Subscript syntax error', $runenv->{name}); push @ops, [$v, [map { substr($_, 2) } @t]]; } } $r->{value}->nuke if $r->{value}->can('nuke'); for my $op (@ops) { my ($v, $s) = @$op; $r->{value}->use($s, $v); } undef; } sub _theft { my ($type, $reg, $id, $theft, $int) = @_; $reg =~ /^[\.,:;\@]/ or return '551 Invalid register type'; exists $int->{default}{registers}{$reg} or return '552 No such register'; my $rp = $int->{default}{registers}{$reg}; # check if they are allowed to steal it my $stealing = uc($type) eq 'STEAL'; $stealing && $rp->{ignore} and return '553 Cannot steal this, try smuggling'; ! $stealing && ! $rp->{ignore} and return '554 Cannot smuggle this, try stealing'; if ($int->{theft_callback}) { &{$int->{theft_callback}}($int, $type, $reg) or return '555 Failed due to internal policy'; } my @val = (); my $value = $rp->{value}; if ($value->isa('Language::INTERCAL::Whirlpool')) { # export filehandle my $fh = $value->filehandle; if ($fh) { my $rcs = $fh->read_charset; my $wcs = $fh->write_charset; my $mode = $fh->mode; my $port = $fh->export($theft->server); push @val, "$reg <- #$port BY ?$rcs BY ?$wcs BY ?$mode"; # the following prevents the filehandle being garbage-collected # after being stolen $int->{stolen}{$fh} = $fh if $stealing; } for my $elem ($value->tail->sparse_list) { my ($n, $e) = @$elem; push @val, "$reg SUB #$e <- #" . ($n->number); } $value->nuke if $stealing; } elsif ($value->isa('Language::INTERCAL::Arrays')) { # export array my @s = $value->subscripts; @s = (0) unless @s; push @val, "$reg <- " . join(' BY ', map { "#$_" } @s); for my $elem ($value->sparse_list) { my ($n, @e) = @$elem; if ($n->number > 65535) { my ($n1, $n2) = _uninterleave(2, $n); $n1 = $n1->number; $n2 = $n2->number; $n = "#$n1 ¢ #$n2"; } else { $n = '#' . ($n->number); } push @val, "$reg " . join(' ', map { "SUB #$_" } @e) . " <- $n"; } $value->assign([]) if $stealing; } else { # export number my $n; if ($value->number > 65535) { my ($n1, $n2) = _uninterleave(2, $value); $n1 = $n1->number; $n2 = $n2->number; $n = "#$n1 ¢ #$n2"; } else { $n = '#' . ($value->number); } push @val, "$reg <- $n"; $value->assign(0) if $stealing; } return ('250 Here it is', @val, '.'); } sub _i_cse { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; $int->{theft_server} or faint(SP_INVALID, "This program is not allowed to CASE", $name); my $e = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); ref $e or faint(SP_INVALID, "Not an expression", $name); my @l = (); if (UNIVERSAL::isa($e, 'Language::INTERCAL::Numbers')) { my $addr = $e->number; $addr = join('.', $addr >> 24, ($addr >> 16) & 0xff, ($addr >> 8) & 0xff, $addr & 0xff); my $bc = $int->{theft_server}->make_broadcast($addr); if (defined $bc) { my @ips = $int->{theft_server}->find_theft_servers($bc); @l = map { unpack('N', inet_aton($_)) } @ips; } else { @l = $int->{theft_server}->pids($addr); } } elsif (ref $e eq 'ARRAY') { # assume it is a tail array my $io = $tp->{registers}{$reg_io}{value}->number; _create_register($int, $tp, $name, $reg_ar, $runenv); my $ar = $tp->{registers}{$reg_ar}{value}->number; my $data = ''; my $fh = Language::INTERCAL::GenericIO->new('STRING', 'r', \$data); _set_read_charset($int, $tp, $fh); read_array_16($io, \$ar, $fh, $e, 1); $tp->{registers}{$reg_ar}{value}->assign($ar); my ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($data); @l = map { inet_ntoa($_) } @addrs; } elsif (UNIVERSAL::isa($e, 'Language::INTERCAL::Arrays')) { my $io = $tp->{registers}{$reg_io}{value}->number; _create_register($int, $tp, $name, $reg_ar, $runenv); my $ar = $tp->{registers}{$reg_ar}{value}->number; my @v = map { $_->number } $e->as_list; @v or faint(SP_NODIM); my $data = ''; my $fh = Language::INTERCAL::GenericIO->new('STRING', 'r', \$data); _set_read_charset($int, $tp, $fh); if ($e->bits <= 16) { read_array_16($io, \$ar, $fh, \@v, 0); } else { read_array_32($io, \$ar, $fh, \@v, 0); } $tp->{registers}{$reg_ar}{value}->assign($ar); my ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($data); @l = map { unpack('N', $_) } @addrs; } else { faint(SP_INVALID, 'Expression type', $name); } my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $num > 0 or return undef; # make sure @l has the correct number of elements if (@l < 1) { @l = (0) x $num; } elsif (@l > $num) { # take a random sample of @l @l = (sort { rand(200) - 100 } @l)[1..$num]; } elsif (@l < $num) { # add a random selection of elements while (@l < $num) { my $add = $num - @l; $add = @l if $add > @l; @l = sort { rand(200) - 100 } @l; push @l, @l[0..$add-1]; } } while ($num-- > 0) { # first assign to expression my $l = Language::INTERCAL::Numbers::Twospot->new(shift @l); _run($int, $tp, _a($runenv, assign => $l), $cp, $ep, 1); # then execute statement (if not ABSTAINed FROM) my $len = bc_skip($int->{code}, $$cp, $ep) or faint(SP_INVALID, '(unknown)', $name); $len > 0 or faint(SP_INVALID, 'empty statement', $name); my $ge = ord(substr($int->{code}, $$cp, 1)); my $ab = $ge != BC_GUP && exists $tp->{ab_gerund}{$ge} ? $tp->{ab_gerund}{$ge} : 0; if ($ab) { $$cp += $len; } else { _run($int, $tp, $runenv, $cp, $ep, 1); } } undef; } sub _uninterleave { my ($base, $value) = @_; my @value = $value->twospot->digits($base); my @val1 = (); my @val2 = (); while (@value) { push @val1, shift @value; push @val2, shift @value; } return (Language::INTERCAL::Numbers->from_digits($base, @val1), Language::INTERCAL::Numbers->from_digits($base, @val2)); } sub _i_sel { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $ba = $tp->{registers}{$reg_ba}{value}->number; if ($runenv->{assign}) { # assign to select my $assign = $runenv->{assign}; if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } _run($int, $tp, $runenv, $cp, $ep, 1); my @num = $assign->digits($ba); my $num = 0; for my $n (@num) { $num = 1 if $n; $n = $num; } $num = Language::INTERCAL::Numbers->from_digits($ba, @num); _run($int, $tp, _a($runenv, assign => $num), $cp, $ep, 1); return undef; } else { my $num1 = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my $num2 = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my @num1 = $num1->digits($ba); my @num2 = $num2->digits($ba); # make sure @num1 is a twospot if @num2 is unshift @num1, 0 while @num1 < @num2; my @num = map { [] } (0..$ba - 1); while (@num2) { my $val1 = pop @num1; my $val2 = pop @num2; if ($val1 && $val2) { unshift @{$num[$val2]}, $val1 > $val2 ? $val1 : $val2; } else { unshift @{$num[$val2]}, 0; } } @num = map { @{ $num[$_] } } (0..$ba - 1); return Language::INTERCAL::Numbers->from_digits($ba, @num); } } sub _i_rse { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; # we must execute the operands in reverse order, or side-effects won't # work as advertised. my $firstop = $$cp; $$cp += bc_skip($int->{code}, $firstop, $ep); my $firstend = $$cp; my $ba = $tp->{registers}{$reg_ba}{value}->number; if ($runenv->{assign}) { # assign to select my $assign = $runenv->{assign}; if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } _run($int, $tp, $runenv, $cp, $ep, 1); my @num = $assign->digits($ba); my $num = 0; for my $n (@num) { $num = 1 if $n; $n = $num; } $num = Language::INTERCAL::Numbers->from_digits($ba, @num); _run($int, $tp, _a($runenv, assign => $num), \$firstop, $firstend, 1); return undef; } else { my $num1 = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my $num2 = _get_expression($int, $tp, $name, $runenv, \$firstop, $firstend, 1); my @num1 = $num1->digits($ba); my @num2 = $num2->digits($ba); # make sure @num1 is a twospot if @num2 is unshift @num1, 0 while @num1 < @num2; my @num = map { [] } (0..$ba - 1); while (@num2) { my $val1 = pop @num1; my $val2 = pop @num2; if ($val1 && $val2) { unshift @{$num[$val2]}, $val1 > $val2 ? $val1 : $val2; } else { unshift @{$num[$val2]}, 0; } } @num = map { @{ $num[$_] } } (0..$ba - 1); return Language::INTERCAL::Numbers->from_digits($ba, @num); } } sub _i_swb { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $ba = $tp->{registers}{$reg_ba}{value}->number; my $assign = $runenv->{assign}; if ($assign) { if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } my @num = $assign->digits($ba); my @check = @num; my $carry = 0; for my $v (reverse @num) { ($v, $carry) = ($carry, ($carry + $v) % $ba); } my $new_value = Language::INTERCAL::Numbers->from_digits($ba, @num); $assign = $assign->number; unshift @num, $num[-1]; while (@num > 1) { my $dig = shift @num; $dig = ($dig - $num[0]) % $ba; if ($dig != shift @check) { faint(SP_ASSIGN, $ba, '|', $assign); } } _run($int, $tp, _a($runenv, assign => $new_value), $cp, $ep, 1); return undef; } else { my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my @num = $num->digits($ba); unshift @num, $num[-1]; my @result = (); while (@num > 1) { my $dig = shift @num; push @result, ($dig - $num[0]) % $ba; } return Language::INTERCAL::Numbers->from_digits($ba, @result); } } sub _i_awc { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $ba = $tp->{registers}{$reg_ba}{value}->number; my $assign = $runenv->{assign}; if ($assign) { if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } my @check = $assign->digits($ba); $assign = $assign->number; # unlike swb, undoing awc requires to look for the right # first digit... TRY: for (my $try = 0; $try < $ba; $try++) { my @num = @check; my $carry = $try; for my $v (reverse @num) { ($v, $carry) = ($carry, ($v - $carry) % $ba); } my $new_value = Language::INTERCAL::Numbers->from_digits($ba, @num); unshift @num, $num[-1]; my @c = @check; while (@num > 1) { my $dig = shift @num; $dig = ($num[0] + $dig) % $ba; if ($dig != shift @c) { next TRY; } } _run($int, $tp, _a($runenv, assign => $new_value), $cp, $ep, 1); return undef; } faint(SP_ASSIGN, $ba, '¥', $assign); } else { my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my @num = $num->digits($ba); unshift @num, $num[-1]; my @result = (); while (@num > 1) { my $dig = shift @num; push @result, ($num[0] + $dig) % $ba; } return Language::INTERCAL::Numbers->from_digits($ba, @result); } } sub _i_but { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $ba = $tp->{registers}{$reg_ba}{value}->number; my $prefer = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); faint(SP_ILLEGAL, $prefer . $name, $ba) if $prefer != 7 && $prefer > $ba - 2; my $assign = $runenv->{assign}; if ($assign) { if (ref $assign eq 'CODE') { $assign = &$assign($int, $tp, $runenv, $cp, $ep, 'N'); } my @num = $assign->digits($ba); my @check = @num; push @num, $num[0]; my @result = (); while (@num > 1) { my $num1 = shift @num; my $num2 = $num[0]; if ($num1 == $prefer && $num2 == $prefer) { push @result, $prefer; } elsif ($num1 == $prefer) { push @result, $num2; } elsif ($num2 == $prefer) { push @result, $num1; } elsif ($num1 > $prefer || $num2 > $prefer) { push @result, $num1 > $num2 ? $num1 : $num2; } elsif ($num1 > $num2) { push @result, $num2; } else { push @result, $num1; } } my $new_value = Language::INTERCAL::Numbers->from_digits($ba, @result); $assign = $assign->number; unshift @result, $result[-1]; while (@result > 1) { my $num1 = shift @result; my $num2 = $result[0]; my $result; if ($num1 <= $prefer) { if ($num2 < $num1 || $num2 > $prefer) { $result = $num1; } else { $result = $num2; } } else { if ($num2 < $num1 && $num2 > $prefer) { $result = $num1; } else { $result = $num2; } } if ($result != shift @check) { faint(SP_ASSIGN, $ba, $prefer . '?', $assign) } } _run($int, $tp, _a($runenv, assign => $new_value), $cp, $ep, 1); return undef; } else { my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); my @num = $num->digits($ba); unshift @num, $num[-1]; my @result = (); while (@num > 1) { my $num1 = shift @num; my $num2 = $num[0]; if ($num1 <= $prefer) { if ($num2 < $num1 || $num2 > $prefer) { push @result, $num1; } else { push @result, $num2; } } else { if ($num2 < $num1 && $num2 > $prefer) { push @result, $num1; } else { push @result, $num2; } } } return Language::INTERCAL::Numbers->from_digits($ba, @result); } } sub _i_con { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my ($o1, $o2) = _opcode_pair($int, $tp, $cp, $ep, $name, $runenv, SP_CONVERT); if ($int->{record_grammar}) { push @{$tp->{grammar_record}}, [BC_CON, $o1, $o2]; } $tp->{opcodes}{$o1} = $tp->{opcodes}{$o2}; undef; } sub _i_swa { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my ($o1, $o2) = _opcode_pair($int, $tp, $cp, $ep, $name, $runenv, SP_SWAP); if ($int->{record_grammar}) { push @{$tp->{grammar_record}}, [BC_SWA, $o1, $o2]; } ($tp->{opcodes}{$o1}, $tp->{opcodes}{$o2}) = ($tp->{opcodes}{$o2}, $tp->{opcodes}{$o1}); undef; } sub _opcode_pair { my ($int, $tp, $cp, $ep, $name, $runenv, $splat) = @_; $$cp + 2 > $ep and faint(SP_INVALID, "Missing opcodes", $name); my $o1 = ord(substr($int->{code}, $$cp++, 1)); my @d1 = bytedecode($o1) or faint(SP_INVALID, $o1, $name); if ($d1[5]) { $$cp--; $o1 = BCget($int->{code}, $cp, $ep); my $args = ''; exists $tp->{opcodes}{$o1} && ref $tp->{opcodes}{$o1} eq 'ARRAY' and $args = $tp->{opcodes}{$o1}[0]; @d1 = ($o1, '', '', $o1, $args, 0, 0); } my $o2 = ord(substr($int->{code}, $$cp++, 1)); my @d2 = bytedecode($o2) or faint(SP_INVALID, $o2, $name); if ($d2[5]) { $$cp--; $o2 = BCget($int->{code}, $cp, $ep); my $args = ''; exists $tp->{opcodes}{$o2} && ref $tp->{opcodes}{$o2} eq 'ARRAY' and $args = $tp->{opcodes}{$o2}[0]; @d2 = ($o2, '', '', $o2, $args, 0, 0); } exists $tp->{opcodes}{$d1[0]} && exists $tp->{opcodes}{$d2[0]} && $d1[4] eq $d2[4] or faint($splat, $d1[0], $d2[0]); if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [$tp->{opcodes}{$d1[0]}, 'opcodes', $d1[0]], [$tp->{opcodes}{$d2[0]}, 'opcodes', $d2[0]]; } ($d1[0], $d2[0]); } sub _i_frz { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, 'FREEZE') if $runenv->{quantum}; $int->{source} eq '' and return undef; $int->{source} = ''; $int->{object}->shift_parsers; for my $thr (@{$int->{threads}}, $int->{default}) { shift @{$thr->{rules}}; } undef; } sub _i_mul { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); _trace($int, $tp, "<", 1); my @vec = (); while (@vec < $num) { my $v = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); $v or faint(SP_INVALID, "Not an expression", $name); push @vec, $v; } _trace($int, $tp, ">", 1); Language::INTERCAL::Arrays::Tail->from_list(\@vec); } sub _i_str { # treat STR as a compact form of MUL - if internal optimisations are # possible, they will be done instead of calling _i_str my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $num <= $ep or faint(SP_INVALID, "Not enough constants", $name); my $str = substr($int->{code}, $$cp, $num); $$cp += $num; my @vec = unpack('C*', $str); if ($tp->{registers}{$reg_tm}{value} && $tp->{registers}{$reg_tm}{value}->number && $tp->{registers}{$reg_trfh}{value}) { $str =~ s/([\\<>\P{IsPrint}])/sprintf("\\x%02x", ord($1))/ge; $str = "<$str>"; while (length $str > 40) { my $x = substr($str, 0, 40, ''); _trace($int, $tp, $x, 1); } _trace($int, $tp, $str, 1); } Language::INTERCAL::Arrays::Tail->from_list(\@vec); } sub _i_cre { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; $int->{object} or faint(SP_CONTEXT, "Creation without a grammar"); my $gra = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $gra >= 1 && $gra <= $int->{object}->num_parsers or faint(SP_EVOLUTION, 'Invalid grammar number'); my $sym = _get_symbol($int, $tp, $name, $runenv, $cp, $ep); my $left = _get_left($int, $tp, $name, $runenv, $cp, $ep); my $right = _get_right($int, $tp, $name, $runenv, $cp, $ep); if ($int->{record_grammar}) { push @{$tp->{grammar_record}}, [BC_CRE, $gra, $sym, $left, $right]; } _ii_cre($int, $tp, $gra, $sym, $left, $right, $runenv); undef; } sub _ii_cre { my ($int, $tp, $gra, $sym, $left, $right, $runenv) = @_; my $r = $int->{object}->parser($gra)->add($sym, $left, $right); # if they have modified the other grammar, that's all we need to do # if the rule was already in the grammar just enable it if ($r < 0) { $r = -$r; _trace($int, $tp, "o$r", 1); _create_rule($int, $tp, $gra - 1, $r, $runenv); ${$tp->{rules}[$gra - 1][$r]} = 1; return undef; } _trace($int, $tp, "n$r", 1); _create_rule($int, $tp, $gra - 1, $r, $runenv); # a new rule - must recompile the program if $gra == 1 $int->{source} ne '' or faint(SP_CONTEXT, "CREATE requires recompile, but there is no source"); ${$tp->{rules}[$gra - 1][$r]} = 1; $int->{recompile} = 1 if $gra == 1; undef; } sub _create_rule { my ($int, $tp, $gra, $r, $runenv) = @_; my $rv = 0; for my $thr (@{$int->{threads}}, $int->{default}) { next if $thr->{rules}[$gra][$r]; $thr->{rules}[$gra][$r] = \$rv; } if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{rules}[$gra][$r]), 'rules', $gra, $r]; } } sub _i_des { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; $int->{object} or faint(SP_CONTEXT, "Destruction without a grammar"); my $gra = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $gra >= 1 && $gra <= $int->{object}->num_parsers or faint(SP_EVOLUTION, 'Invalid grammar number'); my $sym = _get_symbol($int, $tp, $name, $runenv, $cp, $ep); my $left = _get_left($int, $tp, $name, $runenv, $cp, $ep); if ($int->{record_grammar}) { push @{$tp->{grammar_record}}, [BC_DES, $gra, $sym, $left]; } _ii_des($int, $tp, $gra, $sym, $left, $runenv); undef; } sub _ii_des { my ($int, $tp, $gra, $sym, $left, $runenv) = @_; my @r = $int->{object}->parser($gra)->find_rule($sym, $left); for my $r (@r) { _trace($int, $tp, "r$r", 1); _create_rule($int, $tp, $gra - 1, $r, $runenv); ${$tp->{rules}[$gra - 1][$r]} = 0; } } sub _i_usg { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $op = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); exists $tp->{opcodes}{$op} or faint(SP_TODO, $op); ref $tp->{opcodes}{$op} eq 'ARRAY' or faint(SP_INVALID, $op, $name); # now we need to execute this opcode... my $savecode = $int->{code}; my $prefix = $tp->{opcodes}{$op}[1]; my $suffix = substr($savecode, $$cp, $ep - $$cp); my $ptr = 0; $int->{code} = $prefix . $suffix; $@ = ''; eval { _run($int, $tp, $runenv, \$ptr, length($int->{code}), 1); $ptr < length($prefix) and faint(SP_INVALID, 'did not complete prefix', $name); }; $int->{code} = $savecode; $@ and die $@; # the amount of code we executed is $ptr - length($prefix)... $$cp += $ptr - length($prefix); undef; } sub _i_mkg { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, $name) if $runenv->{quantum}; my $op = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my $template = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); my $code = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); if (exists $tp->{opcodes}{$op}) { # duplicates are OK, because the MAKE NEW OPCODE may get # re-executed; however duplicates which change the template # are not OK because they screw up CONVERT and SWAP ref $tp->{opcodes}{$op} ne 'ARRAY' and faint(SP_MAKE_NEW, $op); $tp->{opcodes}{$op}[0] ne $template and faint(SP_MAKE_NEW, $op); # we don't want to create it again though - it may have already # been CONVERTed or SWAPped and that would silently undo it! return; } push @{$tp->{make_record}}, [$op, $template, $code]; $tp->{opcodes}{$op} = [$template, $code]; for my $thread (@{$int->{threads}}) { exists $thread->{opcodes}{$op} or $thread->{opcodes}{$op} = $tp->{opcodes}{$op}; } } sub _i_cwb { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, 'LOOP') if $runenv->{quantum}; my $body = $$cp; my $blen = bc_skip($int->{code}, $body, $ep) or faint(SP_INVALID, '(unknown)', $name); $blen > 0 or faint(SP_INVALID, 'empty body', $name); my $bge = ord(substr($int->{code}, $body, 1)); $$cp = $body + $blen; my $clen = bc_skip($int->{code}, $$cp, $ep) or faint(SP_INVALID, '(unknown)', $name); $clen > 0 or faint(SP_INVALID, 'empty condition', $name); my $here = $$cp; my $cge = ord(substr($int->{code}, $$cp, 1)); my $cab = $cge != BC_GUP && exists $tp->{ab_gerund}{$cge} ? $tp->{ab_gerund}{$cge} : 0; my $bt = _dup_thread($int, $tp); my $loop_id = ++$int->{loop_id}; $bt->{loop_code} = [$body, $$cp, $bge, $loop_id, $bt->{comefrom}]; @{$bt->{comefrom}} = (); $tp->{loop_id}{$loop_id} = 1; push @{$tp->{in_loop}}, $loop_id; if ($cab) { $$cp += $clen; } else { _run($int, $tp, $runenv, $cp, $ep, 1); } # there may be a COME FROM gerund here my $sv = $tp->{comefrom}; $tp->{comefrom} = [0, 0, $cge, $here]; _comefrom($int, $tp); $tp->{comefrom} = $sv; } sub _i_bwc { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, 'LOOP') if $runenv->{quantum}; my $cond = $$cp; my $clen = bc_skip($int->{code}, $cond, $ep) or faint(SP_INVALID, '(unknown)', $name); my $cge = ord(substr($int->{code}, $cond, 1)); my $cab = $cge != BC_GUP && exists $tp->{ab_gerund}{$cge} ? $tp->{ab_gerund}{$cge} : 0; my $body = $cond + $clen; my $blen = bc_skip($int->{code}, $body, $ep) or faint(SP_INVALID, '(unknown)', $name); my $bge = ord(substr($int->{code}, $body, 1)); $$cp = $body + $blen; my $bt = _dup_thread($int, $tp); my $loop_id = ++$int->{loop_id}; $bt->{loop_code} = [$body, $$cp, $bge, $loop_id, $bt->{comefrom}]; @{$bt->{comefrom}} = (); $tp->{loop_id}{$loop_id} = 1; push @{$tp->{in_loop}}, $loop_id; $cab or _run($int, $tp, $runenv, \$cond, $body, 1); # there may be a COME FROM gerund here my $sv = $tp->{comefrom}; $tp->{comefrom} = [0, 0, $cge, $cond]; _comefrom($int, $tp); $tp->{comefrom} = $sv; } sub _i_ebc { faint(SP_EVENT); } sub _i_ecb { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, 'EVENT') if $runenv->{quantum}; my $cond = $$cp; my $clen = bc_skip($int->{code}, $cond, $ep) or faint(SP_INVALID, '(unknown)', $name); my $body = $cond + $clen; my $blen = bc_skip($int->{code}, $body, $ep) or faint(SP_INVALID, '(unknown)', $name); my $bge = ord(substr($int->{code}, $body, 1)); $$cp = $body + $blen; push @{$int->{events}}, [$int->{code}, $cond, $cond + $clen, $body, $body + $blen, $bge]; } sub _i_sys { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; faint(SP_QUANTUM, 'System call definition') if $runenv->{quantum}; my $sysnum = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $count = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $base = $$cp; while ($count-- > 0) { $$cp += bc_skip($int->{code}, $$cp, $ep) or faint(SP_INVALID, '(unknown)', $name); } $int->{syscode}{$sysnum} = substr($int->{code}, $base, $$cp - $base); undef; } sub _i_gup { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; $tp->{running} = 0 unless $runenv->{quantum}; undef; } sub _i_nxt { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $lab = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{next_stack}), 'next_stack'], [$tp->{s_pointer}, 's_pointer'], [_deep_copy($tp->{loop_code}), 'loop_code'], [_deep_copy($tp->{in_loop}), 'in_loop'], [_deep_copy($tp->{comefrom}), 'comefrom']; } @{$tp->{next_stack}} >= MAX_NEXT and faint(SP_NEXTING, MAX_NEXT); push @{$tp->{next_stack}}, [ $tp->{s_pointer}, [@{$tp->{loop_code}}], [@{$tp->{in_loop}}], [@{$tp->{comefrom}}], ]; @{$tp->{loop_code}} = (); @{$tp->{comefrom}} = (); @{$tp->{in_loop}} = (); $tp->{s_pointer} = _find_label($int, $tp, $name, $lab); undef; } sub _i_stu { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $subject = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $lecture = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); _run($int, $tp, _a($runenv, assign => \&_x_stu, class => [$subject, $lecture]), $cp, $ep, 1); undef; } sub _x_stu { my ($int, $tp, $runenv, $cp, $ep, $type, $class) = @_; $type eq 'R' or faint(SP_ISNUMBER, 'STUDY'); _create_register($int, $tp, 'STU', $class, $runenv); $tp->{registers}{$class}{value}->isa('Language::INTERCAL::Whirlpool') or faint(SP_NOTCLASS); my ($subject, $lecture) = @{$runenv->{class}}; $tp->{registers}{$class}{value}->store([$subject], $lecture); undef; } sub _i_enr { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my @subjects = (); while (@subjects < $num) { push @subjects, _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); } # now look for a class teaching them all my @classes = (); for my $class (keys %{$tp->{registers}}) { $tp->{registers}{$class}{value}->isa('Language::INTERCAL::Whirlpool') or next; eval { $tp->{registers}{$class}{value}->get([$_]) for @subjects; }; $@ and next; push @classes, $class; } @classes or faint(SP_HOLIDAY, join(' + ', map { "#$_" } @subjects )); @classes == 1 or faint(SP_CLASSWAR, (sort @classes)[0, 1]); _run($int, $tp, _a($runenv, assign => \&_x_enr, class => $classes[0]), $cp, $ep, 1); undef; } sub _x_enr { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_ISNUMBER, 'ENROL'); _create_register($int, $tp, 'ENR', $reg, $runenv); my $class = $runenv->{class}; grep { $_ eq $class } @{$tp->{registers}{$reg}{enrol}} or push @{$tp->{registers}{$reg}{enrol}}, $class; undef; } sub _i_lea { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $subject = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); _run($int, $tp, _a($runenv, assign => \&_x_lea, subject => $subject), $cp, $ep, 1); undef; } sub _x_lea { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_ISNUMBER, 'LEARN'); _create_register($int, $tp, 'LEA', $reg, $runenv); exists $tp->{registers}{$reg}{enrol} or faint(SP_NOSTUDENT, $reg); my @classes = (); my $subject = $runenv->{subject}; for my $class (@{$tp->{registers}{$reg}{enrol}}) { eval { my $lab = $tp->{registers}{$class}{value}->get([$subject]); push @classes, [$class, $lab->number]; }; } faint(SP_NOCURRICULUM, '#' . $subject, $reg) unless @classes; faint(SP_CLASSWAR, map { $_->[0] } (sort { $a->[0] cmp $b->[0] } @classes)[0, 1]) if @classes > 1; if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{lecture_stack}), 'lecture_stack'], [$tp->{s_pointer}, 's_pointer'], [_deep_copy($tp->{loop_code}), 'loop_code'], [_deep_copy($tp->{in_loop}), 'in_loop'], [_deep_copy($tp->{comefrom}), 'comefrom']; } push @{$tp->{lecture_stack}}, [ $tp->{s_pointer}, $classes[0][0], $reg, [@{$tp->{loop_code}}], [@{$tp->{in_loop}}], [@{$tp->{comefrom}}], ]; @{$tp->{loop_code}} = (); @{$tp->{comefrom}} = (); @{$tp->{in_loop}} = (); my $sc = _find_label($int, $tp, 'LEA', $classes[0][1]); _enslave_register($int, $tp, $runenv, 'LEA', $classes[0][0], $reg); $tp->{s_pointer} = $sc; undef; } sub _i_gra { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _run($int, $tp, _a($runenv, assign => \&_x_gra), $cp, $ep, 1); undef; } sub _x_gra { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_ISNUMBER, 'GRADUATE'); _create_register($int, $tp, 'GRA', $reg, $runenv); exists $tp->{registers}{$reg}{enrol} or faint(SP_NOSTUDENT, $reg); delete $tp->{registers}{$reg}{enrol}; undef; } sub _i_fin { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{lecture_stack}), 'lecture_stack'], [$tp->{s_pointer}, 's_pointer'], [_deep_copy($tp->{loop_code}), 'loop_code'], [_deep_copy($tp->{in_loop}), 'in_loop'], [_deep_copy($tp->{comefrom}), 'comefrom']; } @{$tp->{lecture_stack}} or faint(SP_LECTURE); delete $tp->{loop_id}{$_} for @{$tp->{in_loop}}; my ($class, $student, $lc, $il, $cf); ($tp->{s_pointer}, $class, $student, $lc, $il, $cf) = @{pop @{$tp->{lecture_stack}}}; @{$tp->{loop_code}} = @$lc; @{$tp->{in_loop}} = @$il; @{$tp->{comefrom}} = @$cf; _free_register($int, $tp, $runenv, $name, $class, $student); undef; } sub _i_ens { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _run($int, $tp, _a($runenv, assign => \&_x_ens), $cp, $ep, 1); undef; } sub _x_ens { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'ENSLAVE'); _run($int, $tp, _a($runenv, assign => \&_y_ens, slave => $reg), $cp, $ep, 1); undef; } sub _y_ens { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; my $slave = $runenv->{slave}; _enslave_register($int, $tp, $runenv, 'ENS', $slave, $reg); undef; } sub _i_fre { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; _run($int, $tp, _a($runenv, assign => \&_x_fre), $cp, $ep, 1); undef; } sub _x_fre { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; $type eq 'R' or faint(SP_NOREGISTER, 'FREE'); _run($int, $tp, _a($runenv, assign => \&_y_fre, slave => $reg), $cp, $ep, 1); undef; } sub _y_fre { my ($int, $tp, $runenv, $cp, $ep, $type, $reg) = @_; my $slave = $runenv->{slave}; _free_register($int, $tp, $runenv, 'FRE', $slave, $reg); undef; } sub _enslave_register { my ($int, $tp, $runenv, $name, $slave, $master) = @_; _create_register($int, $tp, $name, $slave, $runenv); my $mtype = substr($master, 0, 1, ''); unshift @{$tp->{registers}{$slave}{owners}}, [$mtype, $master]; } sub _free_register { my ($int, $tp, $runenv, $name, $slave, $master) = @_; _create_register($int, $tp, $name, $slave, $runenv); exists $tp->{registers}{$slave}{owners} && @{$tp->{registers}{$slave}{owners}} or faint(SP_FREE, $slave); my @no = (); my $found = 0; my $mtype = substr($master, 0, 1, ''); for my $o (@{$tp->{registers}{$slave}{owners}}) { if ($found || $o->[0] ne $mtype || $o->[1] != $master) { push @no, $o; } else { $found = 1; } } $found or faint(SP_NOBELONG, $slave, $mtype . $master); $tp->{registers}{$slave}{owners} = \@no; } sub _find_label { my ($int, $tp, $name, $lab) = @_; faint(SP_INVLABEL, $lab) if $lab < 1 || $lab > 0xffff; my %lab = (); my $co = sub { my ($cs, $cl, $ss, $sl, $ab, $ls, $ll, $ds, $dl, $ge, $qu) = @_; return unless $ll || $ls; my $n = $ls; $n = _get_number($int, $tp, 'label', {}, \$ls, $ls + $ll, 1) if $ll; return if $n != $lab; $lab{$ss} = 1; }; forall_code($int->{cptr}, $tp->{rules}[0], $co); my @lab = keys %lab; @lab or faint(SP_NOSUCHLABEL, $lab); @lab == 1 or faint(SP_TOOMANYLABS, scalar @lab, $lab); $lab[0]; } sub _i_res { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $size = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{next_stack}), 'next_stack'], [$tp->{s_pointer}, 's_pointer'], [_deep_copy($tp->{loop_code}), 'loop_code'], [_deep_copy($tp->{in_loop}), 'in_loop'], [_deep_copy($tp->{comefrom}), 'comefrom']; } $size > 0 or faint(SP_NORESUME); if (@{$tp->{next_stack}} < $size) { @{$tp->{next_stack}} = (); faint(SP_RESUME); } if ($size > 1) { splice(@{$tp->{next_stack}}, 1 - $size); } delete $tp->{loop_id}{$_} for @{$tp->{in_loop}}; my ($lc, $il, $cf); ($tp->{s_pointer}, $lc, $il, $cf) = @{pop @{$tp->{next_stack}}}; @{$tp->{loop_code}} = @$lc; @{$tp->{in_loop}} = @$il; @{$tp->{comefrom}} = @$cf; undef; } sub _i_for { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $size = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); if ($runenv->{quantum}) { push @{$runenv->{quantum}}, [_deep_copy($tp->{next_stack}), 'next_stack']; } $size > 0 or return undef; if (@{$tp->{next_stack}} < $size) { @{$tp->{next_stack}} = (); } else { splice(@{$tp->{next_stack}}, -$size); } undef; } sub _i_unx { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; if ($runenv->{quantum}) { $name =~ s/^UN/Undocumented /; $name =~ s/E$/Expression/; $name =~ s/S$/Statement/; faint(SP_QUANTUM, $name); } my $m = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); my $f = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); my $count = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my @args = (); while (@args < $count) { my $arg = _get_str_or_fh($int, $tp, $name, $runenv, $cp, $ep, 1); if (! ref $arg) { if ($arg eq '[[INT]]') { $arg = $int; } elsif ($arg eq '[[TP]]') { $arg = $tp; } elsif ($arg eq '[[THEFT]]') { $arg = $int->{theft_server}; } elsif ($arg eq '[[SERVER]]') { $arg = $int->{server}; } } push @args, $arg; } my $c; if ($m) { $c = "require Language::INTERCAL::${m}; " . "Language::INTERCAL::${m}->${f}(\@args)"; } else { $c = "${f}(\@args)"; } my $r = eval $c; die $@ if $@; $r; } sub _get_left { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $lcount = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my @left = (); while (@left < $lcount) { my $count = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $tn = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); if ($tn == 0) { # symbol my $s = _get_symbol($int, $tp, $name, $runenv, $cp, $ep); push @left, ['s', $s, $count]; next; } if ($tn == 1 || $tn == 3) { # tn == 1 => constant / 2 => reggrim my $d = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); my $type = ($tn == 1 || $tn == 2) ? 'c' : 'r'; push @left, [$type, $d, $count]; next; } faint(SP_CREATION, "Invalid left type $tn"); } \@left; } sub _get_right { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $rcount = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); my @right = (); while (@right < $rcount) { my $tn = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); if ($tn == 0 || $tn == 6) { # tn == 0 ? symbol : count(symbol) my $n = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $s = _get_symbol($int, $tp, $name, $runenv, $cp, $ep); push @right, [$tn == 0 ? 's' : 'n', $n, $s]; next; } if ($tn == 1 || $tn == 3) { # tn == 1 => constant / 3 => reggrim my $n = _get_number($int, $tp, $name, $runenv, $cp, $ep, 1); my $d = _get_string($int, $tp, $name, $runenv, $cp, $ep, 0); my $type = ($tn == 1) ? 'c' : 'r'; push @right, [$type, $n, $d]; next; } if ($tn == 4) { # block of bytecode my $len = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $len + $$cp <= $ep or faint(SP_CREATION, "Block extends after end of code"); my $block = substr($int->{code}, $$cp, $len); _trace($int, $tp, '<', 1); _trace($int, $tp, $_, 0) for unpack('C*', $block); _trace($int, $tp, '>', 1); $$cp += $len; push @right, ['b', $block]; next; } if ($tn == 15) { # "*" push @right, ['*']; next; } faint(SP_CREATION, "Invalid right type $tn"); } \@right; } sub _get_expression { my ($int, $tp, $name, $runenv, $cp, $ep, $vc) = @_; my $ex = _run($int, $tp, _q($runenv), $cp, $ep, $vc); $ex or faint(SP_INVALID, "Not an expression", $name); $ex; } sub _get_number { my ($int, $tp, $name, $runenv, $cp, $ep, $vc) = @_; my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, $vc); $num or faint(SP_INVALID, "Not an expression", $name); ref $num && UNIVERSAL::isa($num, 'Language::INTERCAL::Numbers') or faint(SP_NUMBER, "Array or class"); $num->number; } sub _get_symbol { my ($int, $tp, $name, $runenv, $cp, $ep) = @_; my $num; # special optimisation for STR if ($$cp < $ep && ord(substr($int->{code}, $$cp, 1)) == BC_STR) { _trace($int, $tp, BC_STR, 0); $$cp++; my $l = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $l <= $ep or faint(SP_INVALID, "Not enough constants", $name); $num = substr($int->{code}, $$cp, $l); $$cp += $l; my $s = $num; $s =~ s/([%\[\]\P{IsPrint}])/sprintf("%%%02X", ord($1))/ge; _trace($int, $tp, "[$s]", 1); } else { $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); } # just validate it as if assigning to '%PS' reg_create('PS', $int->{object}, $num)->number; } sub _get_string { my ($int, $tp, $name, $runenv, $cp, $ep, $baudot) = @_; my $string; # special optimisation for STR if ($$cp < $ep && ord(substr($int->{code}, $$cp, 1)) == BC_STR) { _trace($int, $tp, BC_STR, 0); $$cp++; my $l = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $l <= $ep or faint(SP_INVALID, "Not enough constants", $name); $string = substr($int->{code}, $$cp, $l); $$cp += $l; } else { my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); ref $num or faint(SP_INVALID, "Not an expression", $name); if (ref $num eq 'ARRAY') { $string = pack('C*', map { $_ & 0xff } @$num); } elsif (UNIVERSAL::isa($num, 'Language::INTERCAL::Arrays')) { $string = $num->tail->as_string; } else { faint(SP_NOARRAY); } } $string = baudot2ascii($string) if $baudot; my $s = $string; $s =~ s/([%\[\]\P{IsPrint}])/sprintf("%%%02X", ord($1))/ge; _trace($int, $tp, "[$s]", 1); $string; } sub _get_str_or_fh { my ($int, $tp, $name, $runenv, $cp, $ep, $baudot) = @_; my $string; my $s; # special optimisation for STR if ($$cp < $ep && ord(substr($int->{code}, $$cp, 1)) == BC_STR) { _trace($int, $tp, BC_STR, 0); $$cp++; my $l = _get_number($int, $tp, $name, $runenv, $cp, $ep, 0); $$cp + $l <= $ep or faint(SP_INVALID, "Not enough constants", $name); $string = substr($int->{code}, $$cp, $l); $$cp += $l; } else { my $num = _get_expression($int, $tp, $name, $runenv, $cp, $ep, 1); ref $num or faint(SP_INVALID, "Not an expression", $name); if (UNIVERSAL::isa($num, 'Language::INTERCAL::Numbers')) { $string = $num->number; $baudot = 0; } elsif (ref $num eq 'ARRAY') { $string = pack('C*', map { $_ & 0xff } @$num); } elsif (UNIVERSAL::isa($num, 'Language::INTERCAL::Whirlpool')) { $string = $num->filehandle or faint(SP_NOTCLASS); $s = $string->describe; $baudot = 0; } elsif (UNIVERSAL::isa($num, 'Language::INTERCAL::Arrays')) { $string = $num->tail->as_string; $string =~ s/\0+$//; } else { faint(SP_NOARRAY); } } $string = baudot2ascii($string) if $baudot; $s = $string if ! defined $s; $s =~ s/([%\[\]\P{IsPrint}])/sprintf("%%%02X", ord($1))/ge; _trace($int, $tp, "[$s]", 1); $string; } sub _set_read_charset { my ($int, $tp, $fh) = @_; my $cs = $tp->{registers}{$reg_cr}{value}->number; $fh->read_charset($cs); } sub _set_write_charset { my ($int, $tp, $fh) = @_; my $cs = $tp->{registers}{$reg_cw}{value}->number; $fh->write_charset($cs); } sub _trace_init { my ($int) = @_; $int->{trace} = []; } sub _trace_exit { my ($int, $tp) = @_; my $trace_fh = $tp->{registers}{$reg_trfh}{value}; return _trace_init($int) unless $trace_fh; $trace_fh = $trace_fh->filehandle; return _trace_init($int) unless $trace_fh; _set_read_charset($int, $tp, $trace_fh); my $hex = ''; my $asc = ''; for my $trace (@{$int->{trace}}) { my ($byte, $special, @etc) = @$trace; my ($h, $a); if ($special) { $h = join('', map { sprintf(" %02X", $_) } @etc); $a = ' ' . $byte; } else { $h = defined $byte ? sprintf(" %02X", $byte) : ''; $a = ' ' . (bytedecode($byte) || '???'); } if (length($hex) + length($h) > 33 || length($asc) + length($a) > 46) { $hex =~ s/^\s+//; $trace_fh->read_text(sprintf("%-33s|%s\n", $hex, $asc)); $hex = $asc = ''; } $hex .= $h; $asc .= $a; } $hex =~ s/^\s+//; $trace_fh->read_text(sprintf("%-33s|%s\n", $hex, $asc)) if $asc ne ''; _trace_init($int); } sub _trace { my ($int, $tp, $byte, $special, @etc) = @_; return unless $tp->{registers}{$reg_tm}{value} && $tp->{registers}{$reg_tm}{value}->number && $tp->{registers}{$reg_trfh}{value}; push @{$int->{trace}}, [$byte, $special, @etc]; } sub _trace_mark { my ($int, $tp, @data) = @_; return _trace_init($int) unless $tp->{registers}{$reg_tm}{value} && $tp->{registers}{$reg_tm}{value}->number && $tp->{registers}{$reg_trfh}{value}; my $trace_fh = $tp->{registers}{$reg_trfh}{value}; $trace_fh = $trace_fh->filehandle; return _trace_init($int) unless $trace_fh; _trace_exit($int, $tp); $trace_fh->read_text('@' . join(' ', @data) . "\n"); _trace_exit($int, $tp); } 1;