clc-intercal 1:1.0~4pre1.-94.-2-2 / usr / share / perl5 / Language / INTERCAL / Object.pm

package Language::INTERCAL::Object;

# Object file library

# 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/Object.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use Config;
use POSIX 'strftime';
use Language::INTERCAL::Exporter '1.-94.-2',
	qw(import is_intercal_number compare_version require_version);
use Language::INTERCAL::GenericIO '1.-94.-2',
	qw($stdwrite $stdread $stdsplat $devnull);
use Language::INTERCAL::Optimiser '1.-94.-2';
use Language::INTERCAL::Parser '1.-94.-2';
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
use Language::INTERCAL::ByteCode '1.-94.-2',
	qw(BC_STS BC_CRE BC_DES BC_NOT BC_DSX BC_LAB BC_QUA BC_BUG
	   BC_FLA BC_STR BC_USG
	   BC bc_skip BCget is_constant);
use vars qw(@EXPORT_OK);
@EXPORT_OK = qw(find_code forall_code make_code);

# oldest objects we can read and understand
use constant MIN_VERSION => '1.-94.-4';

sub new {
    @_ == 1 or croak "Usage: new Language::INTERCAL::Object";
    my ($class) = @_;
    my $s = Language::INTERCAL::SymbolTable->new();
    my @p = (
	Language::INTERCAL::Parser->new($s),
	Language::INTERCAL::Parser->new($s),
    );
    my $o = Language::INTERCAL::Optimiser->new();
    my @now = gmtime(time);
    my @ts = map { strftime($_, @now) } qw(%Y %m %d %H %M %S);
    _new($class, $s, \@p, $o, \@ts, $VERSION);
}

sub _new {
    my ($class, $s, $p, $o, $ts, $perv) = @_;
    bless {
	'read_fh' => $stdread,
	'write_fh' => $stdwrite,
	'splat_fh' => $stdsplat,
	'trace_fh' => $stdsplat,
	'rs_fh' => $devnull,
	'optimiser' => $o,
	'thread' => [],
	'flags' => {},
	'code' => ['', {}],
	'source' => '',
	'symbols' => $s,
	'parsers' => $p,
	'bug' => [0, 1],
	'timestamp' => $ts,
	'perversion' => $perv,
    }, $class;
}

sub perversion {
    @_ == 1 or croak "Usage: OBJECT->perversion";
    my ($object) = @_;
    $object->{perversion};
}

sub setbug {
    @_ == 3 or croak "Usage: OBJECT->setbug(TYPE, VALUE)";
    my ($object, $type, $value) = @_;
    $value < 0 || $value > 100 and croak "Invalid BUG value";
    $object->{bug} = [$type ? 1 : 0, $value];
    $object;
}

sub add_flag {
    @_ == 3 or croak "Usage: OBJECT->add_flag(NAME, VALUE)";
    my ($object, $flag, $value) = @_;
    $object->{flags}{$flag} = $value;
    $object;
}

sub has_flag {
    @_ == 2 or croak "Usage: OBJECT->has_flag(NAME)";
    my ($object, $flag) = @_;
    exists $object->{flags}{$flag};
}

sub flag_value {
    @_ == 2 or croak "Usage: OBJECT->flag_value(NAME)";
    my ($object, $flag) = @_;
    $object->{flags}{$flag};
}

sub delete_flag {
    @_ == 2 or croak "Usage: OBJECT->delete_flag(NAME)";
    my ($object, $flag) = @_;
    delete $object->{flags}{$flag};
    $object;
}

sub all_flags {
    @_ == 1 or croak "Usage: OBJECT->all_flags";
    my ($object) = @_;
    keys %{$object->{flags}};
}

sub symboltable {
    @_ == 1 or croak "Usage: OBJECT->symboltable";
    my ($object) = @_;
    $object->{symbols};
}

sub num_parsers {
    @_ == 1 or croak "Usage: OBJECT->num_parsers";
    my ($object) = @_;
    scalar @{$object->{parsers}};
}

sub parser {
    @_ == 2 or croak "Usage: OBJECT->parser(NUMBER)";
    my ($object, $number) = @_;
    $number < 1 || $number > @{$object->{parsers}}
	and croak "Invalid NUMBER";
    $object->{parsers}[$number - 1];
}

sub shift_parsers {
    @_ == 1 or croak "Usage: OBJECT->shift_parsers";
    my ($object) = @_;
    shift @{$object->{parsers}};
    my $p = Language::INTERCAL::Parser->new($object->{symbols});
    push @{$object->{parsers}}, $p;
}

sub write {
    @_ == 2 || @_ == 3 || @_ == 4
	or croak "Usage: write Language::INTERCAL::Object"
	       . "(FILEHANDLE [, JUST_FLAGS [, AVOID_SKIP?]])";
    my ($class, $fh, $fonly, $ask) = @_;
    unless ($ask) {
	while (1) {
	    my $line = $fh->write_text();
	    croak "Invalid Object Format (no __END__)"
		if ! defined $line || $line eq '';
	    last if $line =~ /__END__/ || $line =~ /__DATA__/;
	}
    }
    my $line = $fh->write_text();
    $line =~ /^CLC-INTERCAL (\S+) Object File\n$/
	or croak "Invalid Object Format ($line)";
    my $perversion = $1;
    is_intercal_number($perversion)
	or croak "Invalid Object Perversion ($perversion)";
    compare_version($perversion, MIN_VERSION) >= 0
	or croak "Object too old to load with this perversion of sick";
    require_version Language::INTERCAL::Object $perversion;
    my @timestamp = unpack('vCCCCC', $fh->write_binary(7));
    my $fcount = unpack('v', $fh->write_binary(2));
    my %flags = ();
    while ($fcount-- > 0) {
	my $flen = unpack('v', $fh->write_binary(2));
	my $fname = $fh->write_binary($flen);
	my $fvalue = '';
	$fvalue = $1 if $fname =~ s/=(.*)$//;
	$flags{$fname} = $fvalue;
    }
    my ($o, @p, $code, %code, $syms, $source);
    unless ($fonly) {
	my ($fmask, $fsize);
	if (exists $flags{__object_format}) {
	    $fmask = 'vvvvvvvCCvvv';
	    $fsize = 22;
	} else {
	    $fmask = 'vvvvvvCCCvvv';
	    $fsize = 21;
	}
	my $clen = unpack('v', $fh->write_binary(2));
	$code = $fh->write_binary($clen);
	my $ns = unpack('v', $fh->write_binary(2));
	%code = ();
	while ($ns-- > 0) {
	    my ($sval, $nr) = unpack('vv', $fh->write_binary(4));
	    my @r = ();
	    while (@r < $nr) {
		my ($ju, $sl, $ls, $ll, $ds, $dl, $ge, $ab, $qu, $xs, $xl, $rl) =
		    unpack($fmask, $fh->write_binary($fsize));
		my $ru = $fh->write_binary($rl);
		if ($ge == 255) {
		    $ge = unpack('v', $fh->write_binary(2));
		}
		my @rb = split(//, unpack('b*', $ru));
		my @ru = grep { $rb[$_] } (0..$#rb);
		push @r,
		    [$ju, $sl, $ls, $ll, $ds, $dl, $ge, $ab, $qu, $xs, $xl, @ru];
	    }
	    $code{$sval} = \@r;
	}
	my $slen = unpack('v', $fh->write_binary(2)) || 0;
	$source = $fh->write_binary($slen);
	$syms = Language::INTERCAL::SymbolTable->write($fh);
	my $psize = unpack('v', $fh->write_binary(2)) || 0;
	@p = ();
	while (@p < $psize) {
	    push @p, Language::INTERCAL::Parser->write($fh, $syms);
	}
	$o = Language::INTERCAL::Optimiser->write($fh);
    }
    my $obj = _new($class, $syms, \@p, $o, \@timestamp, $perversion);
    $obj->{code} = [$code, \%code];
    $obj->{source} = $source;
    $obj->{flags} = \%flags;
    $obj;
}

sub read {
    @_ == 2 or croak "Usage: read Language::INTERCAL::Object(FILEHANDLE)";
    my ($obj, $fh) = @_;
    $fh->read_text($Config{startperl} . "\n");
    $fh->read_text('eval \'exec /usr/bin/perl -w -S $0 ${1+"$@"}\'' . "\n");
    $fh->read_text("    if 0; # not running under some shell\n");
    $fh->read_text("# GENERATED BY CLC-INTERCAL $VERSION\n");
    $fh->read_text("# TO MODIFY, EDIT SOURCE AND REPACKAGE\n");
    $fh->read_text("\n");
    $fh->read_text("use Getopt::Long;\n");
    $fh->read_text("use Language::INTERCAL::GenericIO '$VERSION';\n");
    $fh->read_text("use Language::INTERCAL::Interpreter '$VERSION';\n");
    $fh->read_text("use Language::INTERCAL::Server '$VERSION';\n");
    $fh->read_text("use Language::INTERCAL::Rcfile '$VERSION';\n");
    $fh->read_text("\n");
    $fh->read_text("my \$rc = Language::INTERCAL::Rcfile->new();\n");
    $fh->read_text("if (defined &Getopt::Long::Configure) {\n");
    $fh->read_text("    Getopt::Long::Configure qw(no_ignore_case auto_abbrev permute bundling pass_through);\n");
    $fh->read_text("} else {\n");
    $fh->read_text("    \$Getopt::Long::ignorecase = 0;\n");
    $fh->read_text("    \$Getopt::Long::autoabbrev = 1;\n");
    $fh->read_text("    \$Getopt::Long::order = \$Getopt::Long::PERMUTE;\n");
    $fh->read_text("    \$Getopt::Long::bundling = 1;\n");
    $fh->read_text("}\n");
    $fh->read_text("my \$wimp = 0;\n");
    $fh->read_text("my \$trace = 0;\n");
    $fh->read_text("my \$stdtrace = undef;\n");
    $fh->read_text("GetOptions(\n");
    $fh->read_text("    'wimp!'      => \\\$wimp,\n");
    $fh->read_text("    'trace!'     => \\\$trace,\n");
    $fh->read_text("    'stdtrace=s' => \\\$stdtrace,\n");
    $fh->read_text("    'nouserrc'   => sub { \$rc->setoption('nouserrc', 1) },\n");
    $fh->read_text("    'rcfile=s'   => sub { \$rc->setoption(\@_) },\n");
    $fh->read_text(");\n");
    $fh->read_text("\$rc->load();\n");
    $fh->read_text("my \$fh = Language::INTERCAL::GenericIO->new('FILE', 'w', \\*DATA);\n");
    $fh->read_text("my \$int = Language::INTERCAL::Interpreter->write(\$rc, \$fh, 1);\n");
    $fh->read_text("if (defined \$stdtrace) {\n");
    $fh->read_text("    \$trace = 1;\n");
    $fh->read_text("    my \$mode = \$stdtrace =~ s/^([ra]),//i ? lc(\$1) : 'r';\n");
    $fh->read_text("    my \$th = Language::INTERCAL::GenericIO->new('FILE', \$mode, \$stdtrace);\n");
    $fh->read_text("    \$int->setreg('\@TRFH', \$th);\n");
    $fh->read_text("}\n");
    $fh->read_text("\$int->setreg('\%WT', \$wimp);\n");
    $fh->read_text("\$int->setreg('\%TM', \$trace);\n");
    $fh->read_text("\$int->setreg('^AV', \\\@ARGV);\n");
    $fh->read_text("\$int->setreg('^EV', [map { \"\$_=\$ENV{\$_}\" } keys \%ENV]);\n");
    $fh->read_text("\$int->start()->run()->stop();\n");
    $fh->read_text("\n");
    $fh->read_text("__DATA__\n");
    $fh->read_text("CLC-INTERCAL $VERSION Object File\n");
    $fh->read_binary(pack('vCCCCC', @{$obj->{timestamp}}));
    $obj->{flags}{__object_format} = 1;
    my @flags = keys %{$obj->{flags}};
    $fh->read_binary(pack('v', scalar @flags));
    for my $fname (@flags) {
	my $fvalue = $obj->{flags}{$fname};
	my $flag = "$fname=$fvalue";
	$fh->read_binary(pack('v/a*', $flag));
    }
    my ($cs, $cp) = @{$obj->{code}};
    my @cp = keys %$cp;
    $fh->read_binary(pack('v/a* v', $cs, scalar @cp));
    for my $s (@cp) {
	my $p = $cp->{$s};
	$fh->read_binary(pack('vv', $s, scalar @$p));
	for my $q (@$p) {
	    my ($ju, $sl, $ls, $ll, $ds, $dl, $ge, $ab, $qu, $xs, $xl, @ru) =
		@$q;
	    my $ru = '';
	    vec($ru, $_, 1) = 1 for @ru;
	    $fh->read_binary(pack('vvvvvvvCCvv v/a*', $ju, $sl, $ls, $ll,
						      $ds, $dl, $ge, $ab,
						      $qu, $xs, $xl, $ru));
	}
    }
    my $source = defined $obj->{source} ? $obj->{source} : '';
    $fh->read_binary(pack('v/a*', $source));
    $obj->{symbols}->read($fh);
    $fh->read_binary(pack('v', scalar @{$obj->{parsers}}));
    for my $p (@{$obj->{parsers}}) {
	$p->read($fh);
    }
    $obj->{optimiser}->read($fh);
    $obj;
}

sub make_code {
    @_ == 2 or croak "Usage: OBJECT->make_code(NEWCODE)";
    my ($obj, $newcode) = @_;
    my %obj = (bug => [0, 0]);
    _setcode($obj, \%obj, $newcode);
    wantarray ? @{$obj{code}} : $obj{code}[0];
}

sub setcode {
    @_ == 3 or croak "Usage: OBJECT->set_code(CODE, CPTR)";
    my ($obj, $code, $cptr) = @_;
    $obj->{code} = [$code, $cptr];
    $obj;
}

sub code {
    @_ == 1 || @_ == 2 or croak "Usage: OBJECT->code [(NEWCODE)]";
    my $obj = shift;
    my @oldcode = @{$obj->{code}};
    if (@_) {
	my $newcode = shift;
	_setcode($obj, $obj, $newcode);
    }
    wantarray ? @oldcode : $oldcode[0];
}

sub source {
    @_ == 1 || @_ == 2 or croak "Usage: OBJECT->source [(NEWSOURCE)]";
    my $obj = shift;
    if (@_) {
	my $oldsource = $obj->{source};
	$obj->{source} = shift;
	length $obj->{source} > 0xffff
	    and faint(SP_INDIGESTION);
	return $oldsource;
    }
    $obj->{source};
}

sub forall_code {
    @_ == 3 or croak "Usage: forall_code(CPTR, RULES, CODE)";
    my ($cptr, $rules, $co) = @_;
    for my $sptr (sort { $a <=> $b } keys %$cptr) {
	for my $p (@{$cptr->{$sptr}}) {
	    my ($ju, $sl, $ls, $ll, $ds, $dl, $ge,
		$ab, $qu, $xs, $xl, @ru) = @$p;
	    $co->($xs, $xl, $sptr, $sl, $ab,
		  $ls, $ll, $ds, $dl, $ge, $qu);
	}
    }
}

sub find_code {
    @_ == 3 or croak "Usage: find_code(CPTR, SPTR, RULES)";
    my ($cptr, $sptr, $rules) = @_;
    # if possible, find a valid statement
    if (exists $cptr->{$sptr}) {
	TRY:
	for my $p (@{$cptr->{$sptr}}) {
	    my ($ju, $sl, $ls, $ll, $ds, $dl, $ge,
		$ab, $qu, $xs, $xl, @ru) = @$p;
	    if ($rules) {
		for my $rn (@ru) {
		    next TRY if ! $rules->[$rn];
		    next TRY if ! ${$rules->[$rn]};
		}
	    }
	    # the first one found is the best as we have already sorted the
	    # list in _setcode
	    return ($xs, $xl, $sl, $ab, $ls, $ll, $ds, $dl, $ge, $qu);
	}
    }
    # no valid statement; determine the length of the comment
    my @later = grep { $_ > $sptr } keys %$cptr;
    my $len = undef;
    if (@later) {
	my ($next) = sort { $a <=> $b } @later;
	$len = $next - $sptr;
    }
    return (undef, $sptr, $len, 0);
}

sub _addcode {
    my ($js, $cf) = @_;
    my $fp = index($$js, $cf);
    return $fp if $fp >= 0;
    $fp = length($$js);
    $$js .= $cf;
    return $fp;
}

sub _optimise {
    my ($obj, $code, $seen) = @_;
    return $code if ! exists $obj->{optimiser};
    return $seen->{$code} if exists $seen->{$code};
    $seen->{$code} = $obj->{optimiser}->optimise($code);
    return $seen->{$code};
}

sub _setcode {
    my ($pobj, $obj, $code) = @_;
    my %optimise = ();
    my %code = ();
    my $joincode = '';
    my $sts = pack('C', BC_STS);
    my @code = @{ref $code ? $code : [$code]};
    if (@code && $obj->{bug}[1] > rand(100)) {
	my $bpos = int(rand scalar @code);
	$code[$bpos] .= pack('C*', BC_BUG, BC($obj->{bug}[0] ? 1 : 0));
    }
    STATEMENT:
    for my $cv (@code) {
	next if $cv eq '';
	my $ep = length $cv;
	unless (substr($cv, 0, 1) eq $sts) {
	    my $bc = sprintf("%02X", ord(substr($cv, 0, 1)));
	    faint(SP_INVALID, $bc, "_setcode");
	}
	my $ncp = 1;
	my $start = BCget($cv, \$ncp, $ep);
	my $len = BCget($cv, \$ncp, $ep);
	my $junk = BCget($cv, \$ncp, $ep);
	my $count = BCget($cv, \$ncp, $ep);
	my @rules = ();
	while (@rules < $count) {
	    push @rules, BCget($cv, \$ncp, $ep);
	}
	@rules = sort { $a <=> $b } @rules;
	my $gerund = 0;
	my $abstain = 0;
	my $quantum = 0;
	my @label = (0, 0);
	my @dsx = (0, 0);
	while ($ncp < $ep) {
	    my $byte = ord(substr($cv, $ncp++, 1));
	    if ($byte == BC_NOT) {
		$abstain = 1;
		next;
	    }
	    if ($byte == BC_QUA) {
		$quantum = 1;
		next;
	    }
	    if ($byte == BC_LAB) {
		$ncp < $ep or faint(SP_INVALID, '(end of statement)', 'LAB');
		if (is_constant(ord(substr($cv, $ncp, 1)))) {
		    $label[0] = BCget($cv, \$ncp, $ep);
		    $label[1] = 0;
		} else {
		    my $diff = bc_skip($cv, $ncp, $ep);
		    $label[0] = _addcode(\$joincode, substr($cv, $ncp, $diff));
		    $label[1] = $diff;
		    $ncp += $diff;
		}
		next;
	    }
	    if ($byte == BC_DSX) {
		$ncp < $ep or faint(SP_INVALID, '(end of statement)', 'DSX');
		if (is_constant(ord(substr($cv, $ncp, 1)))) {
		    $dsx[0] = 1 + BCget($cv, \$ncp, $ep);
		    $dsx[1] = 0;
		} else {
		    my $diff = bc_skip($cv, $ncp, $ep);
		    $dsx[0] = _addcode(\$joincode, substr($cv, $ncp, $diff));
		    $dsx[1] = $diff;
		    $ncp += $diff;
		}
		next;
	    }
	    if ($byte == BC_USG) {
		my $vcp = $ncp;
		$gerund = BCget($cv, \$vcp, $ep);
		$ncp--;
		last;
	    }
	    $gerund = $byte;
	    $ncp--;
	    last;
	}
	my $addcode = substr($cv, $ncp, $ep - $ncp);
	if ($gerund == BC_FLA) {
	    # try executing this now...
	    my $fb = $ncp + 1;
	    my ($flag, $value);
	    if (substr($cv, $fb, 1) eq chr(BC_STR)) {
		$fb++;
		my $length = BCget($cv, \$fb, $ep);
		faint(SP_INVALID, 'flag name has wrong length', '_setcode')
		    if $length + $fb > $ep;
		$flag = substr($cv, $fb, $length);
		$fb += $length;
	    } else {
		my $length = BCget($cv, \$fb, $ep);
		$flag = '';
		while (length $flag < $length) {
		    $flag .= chr(BCget($cv, \$fb, $ep));
		}
	    }
	    if (substr($cv, $fb, 1) eq chr(BC_STR)) {
		$fb++;
		my $length = BCget($cv, \$fb, $ep);
		faint(SP_INVALID, 'flag name has wrong length', '_setcode')
		    if $length + $fb > $ep;
		$value = substr($cv, $fb, $length);
		$fb += $length;
	    } else {
		my $length = BCget($cv, \$fb, $ep);
		$value = '';
		while (length $value < $length) {
		    $value .= chr(BCget($cv, \$fb, $ep));
		}
	    }
	    faint(SP_INVALID, 'extra code after flag', '_setcode')
		if $fb != $ep;
	    $pobj->{flags}{$flag} = $value unless $abstain;
	    $addcode = chr(BC_FLA);
	    $abstain = 1;
	}
	my @objcode = (
	    _addcode(\$joincode, $addcode),
	    length($addcode),
	);
	# look for the very same thing...
	my @addit = (
	    $junk, $len,
	    $label[0], $label[1],
	    $dsx[0], $dsx[1],
	    $gerund, $abstain, $quantum,
	    $objcode[0], $objcode[1],
	    @rules,
	);
	if (exists $code{$start}{$junk}{$len}) {
	    TRY:
	    for my $p (@{$code{$start}{$junk}{$len}}) {
		next TRY if @addit != @$p;
		# the following works because @rules are sorted
		for (my $i = 0; $i < @addit; $i++) {
		    next TRY if $p->[$i] != $addit[$i];
		}
		# yup, it's the very same - no need to add it then
		next STATEMENT;
	    }
	}
	# we'll have to add this one
	push @{$code{$start}{$junk}{$len}}, \@addit;
    }
    length $joincode > 0xffff
	and faint(SP_INDIGESTION);
    # now go and transform each value of %code... note that we sort the
    # array so that noncomments are always before comments, and shorter
    # comments are preferred over longer; however within the same comment
    # length (or within the noncomment group) we prefer longer source
    # code; all else being equal, we prefer things which use more grammar
    # rules
    for my $sp (keys %code) {
	my @elems = ();
	for my $j (sort { $a <=> $b } keys %{$code{$sp}}) {
	    for my $l (sort { $b <=> $a } keys %{$code{$sp}{$j}}) {
		push @elems, sort {
		    scalar @$a <=> scalar @$b
		} @{$code{$sp}{$j}{$l}};
	    }
	}
	$code{$sp} = \@elems;
    }
    $obj->{code} = [$joincode, \%code];
}

1;