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;