Mercurial > repo
view interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/Object.pm @ 9070:77f510ad2f14
<evilipse> ` chmod 777 / -R
author | HackBot |
---|---|
date | Sun, 25 Sep 2016 20:07:36 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;