Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Sick.pm @ 3553:a2c0fbb7c2b1
<Roujo> revert
author | HackBot |
---|---|
date | Thu, 29 Aug 2013 20:30:48 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Sick; # Compiler/user interface/whatnot for CLC-INTERCAL # 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/Sick.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use File::Basename; use File::Spec::Functions; use Language::INTERCAL::Exporter '1.-94.-2'; use Language::INTERCAL::Charset '1.-94.-2', qw(charset_name toascii charset); use Language::INTERCAL::GenericIO '1.-94.-2'; use Language::INTERCAL::Backend '1.-94.-2', qw(backend generate_code); use Language::INTERCAL::Interpreter '1.-94.-2'; sub new { @_ == 2 or croak "Usage: new Language::INTERCAL::Sick(RC)"; my ($class, $rc) = @_; bless { object_option => { backend => '', bug => 1, charset => '', name => '%o', optimise => 0, output => '%p.%s', preload => [], suffix => '', trace => undef, trace_fh => undef, ubug => 0.01, verbose => 0, }, shared_option => { default_backend => 'Object', default_charset => [], default_extra => [], default_suffix => [], preload_callback => undef, }, sources => [], filepath => {}, shared_filepath => {}, int_cache => {}, loaded => 0, rc => $rc, theft_server => 0, server => 0, }, $class; } sub reset { @_ == 1 or croak "Usage: SICK->reset"; my ($sick) = @_; $sick->{loaded} = 0; $sick->{sources} = []; $sick; } my %checkoption = ( backend => \&_load_backend, bug => \&_check_bug, charset => \&_load_charset, default_backend => \&_load_backend, default_charset => \&_load_charset, default_extra => \&_check_extra, default_suffix => \&_check_suffix, optimise => \&_check_bool, preload => \&_check_object, preload_callback => \&_check_callback, trace => \&_check_bool, trace_fh => \&_check_filehandle, ubug => \&_check_bug, verbose => \&_check_filehandle, ); my %object_type = ( IACC => 'COMPILER', COMPILER => 'COMPILER', ASSEMBLER => 'COMPILER', RUNCOMPILER => 'COMPILER', BASE => 'ONEONLY', POSTPRE => 'ONEONLY', EXTENSION => 'REPEAT', OPTION => 'REPEAT', OPTIMISER => 'REPEAT', ); sub option { @_ == 2 or @_ == 3 or croak "Usage: SICK->option(NAME [, VALUE])"; @_ == 2 ? shift->getoption(@_) : shift->setoption(@_); } sub getoption { @_ == 2 or croak "Usage: SICK->getoption(NAME)"; my ($sick, $name) = @_; my $value = exists $sick->{object_option}{$name} ? $sick->{object_option}{$name} : exists $sick->{shared_option}{$name} ? $sick->{shared_option}{$name} : die "Unknown option $name\n"; return $value unless ref $value; return $value if UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO'); return @$value if 'ARRAY' eq ref $value; return map { ($_ => [@{$value->{$_}}]) } keys %$value if 'HASH' eq ref $value; return (); # should never get here } sub setoption { @_ == 3 or croak "Usage: SICK->setoption(NAME, VALUE)"; my ($sick, $name, $value) = @_; my $hash = exists $sick->{object_option}{$name} ? $sick->{object_option} : exists $sick->{shared_option}{$name} ? $sick->{shared_option} : die "Unknown option $name\n"; if (exists $checkoption{$name}) { $value = $checkoption{$name}->($name, $sick, $value); } if (! ref $hash->{$name}) { $hash->{$name} = $value; } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) { $hash->{$name} = $value; } elsif ('ARRAY' eq ref $hash->{$name}) { push @{$hash->{$name}}, $value; } elsif ('HASH' eq ref $hash->{$name}) { my ($key, $as, @add) = @$value; if (exists $hash->{$name}{$key}) { $hash->{$name}{$key}[0] = $as; } else { $hash->{$name}{$key} = [$as]; } push @{$hash->{$name}{$key}}, @add; } else { # not supposed to get here die "Cannot set option $name\n"; } $sick; } sub clearoption { @_ == 2 or croak "Usage: SICK->clearoption(NAME)"; my ($sick, $name) = @_; my $hash = exists $sick->{object_option}{$name} ? $sick->{object_option} : exists $sick->{shared_option}{$name} ? $sick->{shared_option} : die "Unknown option $name\n"; if (ref $hash->{$name}) { if (UNIVERSAL::isa($hash->{$name}, 'Language::INTERCAL::GenericIO')) { $hash->{$name} = 0; } elsif ('ARRAY' eq ref $hash->{$name}) { $hash->{$name} = []; } elsif ('HASH' eq ref $hash->{$name}) { $hash->{$name} = {}; } else { die "Cannot clear option $name\n"; } } else { die "Cannot clear option $name\n"; } $sick; } sub alloptions { @_ == 1 or @_ == 2 or croak "Usage: SICK->alloptions [(shared)]"; my ($sick, $shared) = @_; my %vals = (); my @hash = (); push @hash, 'object_option' if ! defined $shared || ! $shared; push @hash, 'shared_option' if ! defined $shared || ! $shared; for my $hash (@hash) { while (my ($name, $value) = each %{$sick->{$hash}}) { if (! ref $value) { # nothing, but we don't want to be caught in next cases } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) { # nothing, but we don't want to be caught in next cases } elsif ('ARRAY' eq ref $value) { # a shallow copy will do -- we know values are strings $value = [ @$value ]; } elsif ('HASH' eq ref $value) { # two level deep copy: the values are arrays of strings my %v = (); while (my ($key, $val) = each %$value) { $v{$key} = [ @$val ]; } $value = \%v; } elsif (ref $value) { # WTF? $value = undef; } $vals{$name} = $value; } } %vals; } sub source { @_ == 2 or croak "Usage: SICK->source(FILENAME)"; my ($sick, $file) = @_; $file = _check_file($sick, $file); push @{$sick->{sources}}, { 'source' => $file, 'option' => { $sick->alloptions(0) }, # don't copy shared options 'filepath' => $sick->{filepath}, }; $sick->{loaded} = 0; $sick; } sub load_objects { @_ == 1 or croak "Usage: SICK->load_objects()"; my ($sick) = @_; return $sick if $sick->{loaded}; for (my $i = 0; $i < @{$sick->{sources}}; $i++) { my $object = $sick->{sources}[$i]; next if exists $object->{object}; my $o = $object->{option}; my ($obj, $fn, $base, $is_src) = _load_source($sick, $object, $o); $object->{is_src} = $is_src; $object->{base} = $base; $object->{object} = $obj; $object->{filename} = $fn; } $sick->{loaded} = 1; $sick; } sub save_objects { @_ == 2 or croak "Usage: SICK->save_objects(AND_KEEP?)"; my ($sick, $keep) = @_; $sick->load_objects(); for my $object (@{$sick->{sources}}) { my $o = $object->{option}; my $backend = $o->{backend}; next unless $object->{is_src} || $backend ne 'Object'; my $out = $o->{output}; next if $out eq ''; $backend = $sick->{shared_option}{default_backend} if $backend eq ''; my $v = $o->{verbose} ? sub { my ($name) = @_; $o->{verbose}->read_text($name eq '' ? 'Running...' : "Saving $name... "); } : ''; my $orig = $object->{source}; $orig =~ s/\.[^.]*$//; my %op = ( verbose => $v, ); generate_code($object->{object}, $backend, $o->{name}, $object->{base}, $out, $orig, \%op); $o->{verbose}->read_text("OK\n") if $o->{verbose}; undef $object unless $keep; } $sick; } sub theft_server { @_ == 2 or croak "Usage: SICK->theft_server(SERVER)"; my ($sick, $server) = @_; $sick->{theft_server} = $server; $sick; } sub server { @_ == 2 or croak "Usage: SICK->server(SERVER)"; my ($sick, $server) = @_; $sick->{server} = $server; $sick; } sub get_object { @_ == 2 or croak "Usage: SICK->get_object(NAME)"; my ($sick, $name) = @_; for my $o (@{$sick->{sources}}) { next if $o->{source} ne $name; return $o->{object}; } undef; } sub all_objects { @_ == 2 || @_ == 3 or croak "Usage: SICK->all_objects(CALLBACK [, JUST_FLAGS])"; my ($sick, $callback, $just_flags) = @_; for my $search (@{$sick->{rc}->getoption('include')}) { opendir(SEARCH, $search) or next; while (defined (my $ent = readdir SEARCH)) { $ent =~ /^(.*)\.io$/ or next; my $name = $1; my $file = catfile($search, $ent); -f $file or next; eval { my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $file); my $ob = Language::INTERCAL::Object->write($fh, $just_flags); my $type = undef; $ob->has_flag('TYPE') and $type = $ob->flag_value('TYPE'); $callback->($name, $file, $type, $ob); }; } closedir SEARCH; } $sick; } # private methods follow sub _check_bool { my ($name, $sick, $value) = @_; return $value if $value =~ /^\d+$/; return 1 if $value =~ /^t(?:rue)?$/i; return 1 if $value =~ /^y(?:es)?$/i; return 0 if $value =~ /^f(?:alse)?$/i; return 0 if $value =~ /^n(?:o)?$/i; die "Invalid value for $name\: '$value'\n"; } sub _check_filehandle { my ($name, $sick, $value) = @_; return $value if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO'); return undef if $value =~ /^\d+$/ && $value == 0; return undef if $value =~ /^n(?:one)?$/i; die "Invalid filehandle value '$value'\n"; } sub _check_path { my ($name, $sick, $value) = @_; return $value if -d $value; die "Invalid path '$value'\n"; } sub _check_bug { my ($name, $sick, $value) = @_; $value =~ /^(?:\d+(?:\.\d*)?|\.\d+)$/ or die "Value '$value' is not a positive number\n"; $value <= 100 or die "Value '$value' is too large for a probability\n"; $value; } sub _check_extra { my ($name, $sick, $value) = @_; ref $value && ref $value eq 'ARRAY' or die "Invalid value for $name (must be a array ref)\n"; @$value == 3 or die "Invalid value for $name (requires three elements)\n"; my ($extra, $preload, $as) = @$value; ref $preload && ref $preload eq 'ARRAY' or die "Invalid value for $name (preloads must be array ref)\n"; [$extra, $preload, $as]; } sub _check_suffix { my ($name, $sick, $value) = @_; ref $value && ref $value eq 'ARRAY' or die "Invalid value for $name (must be a array ref)\n"; @$value == 3 or die "Invalid value for $name (requires three elements)\n"; my ($suffix, $as, $map) = @$value; ref $map && ref $map eq 'HASH' or die "Invalid value for $name (third element must be hash ref)\n"; exists $map->{''} && ref $map->{''} && ref $map->{''} eq 'ARRAY' or die "Invalid value for $name (preloads must be array ref)\n"; # suffix map have alternatives expressed as something like # ./2:3:4:5:6:7/i => .2i .3i ... .7i # ./l:n:g:t://i => .li .ni .gi .ti .lni .nli ... # note that we have no nesting of alternatives; use different rules my @resplit = (); my $regex = ''; while ($suffix =~ s#^(.*?)/##) { $regex .= quotemeta($1); $suffix =~ s#^(.*?)/## or die "Invalid value for $name\: unclosed / in suffix\n"; my @extra = split(/:/, $1); for my $extra (@extra) { exists $map->{$extra} or next; ref $map->{$extra} && ref $map->{$extra} eq 'ARRAY' or die "Invalid value for $name " . "(preloads for $extra must be array ref)\n"; } my $extra = join('|', map { quotemeta } @extra); my $star = $suffix =~ s#^:## ? '*' : ''; $regex .= '((?:' . $extra . ')' . $star . ')'; push @resplit, qr/^($extra)/; } $regex .= quotemeta($suffix) . '$'; $regex = qr/$regex/i; return [$regex, $as, \@resplit, $map]; } sub _find_file { my ($sick, $value, $ftype, $cache, $path) = @_; return $cache->{$value} if exists $cache->{$value}; # try opening file from current directory if (-f $value) { $cache->{$value} = $value; return $value; } if (! file_name_is_absolute($value)) { my ($file, $dir) = fileparse($value); $path = $sick->{rc}->getoption('include') if ! defined $path; for my $search (@$path) { my $n = catfile($search, $dir, $file); $n = canonpath($n); if (-f $n) { $cache->{$value} = $n; return $n; } } } die "Cannot find $ftype \"$value\"\n"; } sub _check_file { my ($sick, $value) = @_; _find_file($sick, $value, 'file', $sick->{filecache}, $sick->{rc}->getoption('include')); $value; } sub _find_object { my ($sick, $value, $cache, $path) = @_; if ($value !~ /\.ior?$/) { # try adding suffix first my $v = eval { _find_file($sick, $value . '.io', 'object', $cache, $path); }; unless ($@) { return $v . 'r' if -f $v . 'r'; return $v; } } _find_file($sick, $value, 'object', $cache, $path); } sub _check_object { my ($name, $sick, $value) = @_; # _find_object($sick, $value, # $sick->{filecache}, # $sick->{rc}->getoption('include')); $value; } sub _check_callback { my ($name, $sick, $value) = @_; ! $value and return $value; # unset callback ref $value && UNIVERSAL::isa($value, 'CODE') and return [$value]; ref $value && UNIVERSAL::isa($value, 'ARRAY') or die "Invalid callback, must be a CODE or ARRAY reference\n"; ref $value->[0] && UNIVERSAL::isa($value->[0], 'CODE') or die "Invalid callback, first element must be a CODE reference\n"; $value; } sub _open_file { my ($sick, $source, $cache, $path) = @_; my $fn = _find_file($sick, $source, 'file', $cache, $path); my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn); ($fn, $fh); } sub _load_backend { my ($name, $sick, $value) = @_; defined backend($value) or die "Invalid backend: $value"; $value; } sub _load_charset { my ($name, $sick, $value) = @_; defined charset_name($value) or die "Invalid charset: $value\n"; $value; } sub _load_source { my ($sick, $source, $o) = @_; my ($fn, $fh) = _open_file($sick, $source->{source}, $source->{filepath}, $sick->{rc}->getoption('include')); $o->{verbose}->read_text("$fn... ") if $o->{verbose}; my $base = $fn; my $suffix = ''; if ($o->{suffix}) { $suffix = $o->{suffix}; $suffix = '.' . $suffix if $suffix !~ /^\./; $base =~ s/(\.[^.]*)$//; # remove and ignore suffix } elsif ($base =~ s/(\.[^.]*)$//) { $suffix = lc($1); } # first see if it is a real object (you never know) my $int = eval { Language::INTERCAL::Interpreter->write($sick->{rc}, $fh); }; if (defined $int && ref $int) { $o->{verbose}->read_text("[COMPILER OBJECT]\n") if $o->{verbose}; $int->server($sick->{server}); $int->theft_server($sick->{theft_server}); $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh}; $int->setreg('TM', $o->{trace}) if defined $o->{trace}; return ($int, $fn, $base, 0); } # failed for whatever reason, we'll try loading as a source $fh->reset(); my @preload = @{$o->{preload}}; @preload = _guess_preloads($sick, $suffix, $o) unless @preload; # try to find a compiler my @options = (); my @compiler = (); my %preloaded = (); for my $p (@preload, 'postpre') { next if $p eq ''; _preload($sick, $p, $source->{filepath}, $o, \%preloaded, \@options, \@compiler); } exists $preloaded{COMPILER} or die "Invalid preload list: no compiler\n"; # load the compiler and run it if required if ($compiler[1]) { # compiler saved using RunObject $int = $compiler[0]; } else { # compiler saved using Object - create a new interpreter and run the # compiler in it $int = Language::INTERCAL::Interpreter->new($sick->{rc}); unshift @options, $compiler[0]; } $int->server($sick->{server}); $int->theft_server($sick->{theft_server}); $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh}; $int->setreg('TM', $o->{trace}) if defined $o->{trace}; my $obj = $int->object; if ($o->{bug} > 0) { $obj->setbug(0, $o->{bug}); } else { $obj->setbug(1, $o->{ubug}); } # execute all the options for my $p (@options) { $int->start(1)->run($p)->stop(); } # do we need to guess character set? my $chr = $o->{charset}; if ($chr eq '') { $chr = _guess_charset($sick, $source->{source}, $fh); } $fh->write_charset($chr); $fh->reset(); # now read file my $line = 1; my $col = 1; my $scount = 0; my $text = $fh->write_text(''); $o->{verbose}->read_text("\n source: " . length($text) . " bytes") if $o->{verbose}; $obj->source($text); $int->verbose_compile($o->{verbose}); $int->compile($text); $o->{verbose}->read_text(" [object: " . _int_size($obj) . " bytes]") if $o->{verbose}; $o->{verbose}->read_text("\n") if $o->{verbose}; return ($int, $fn, $base, 1); } sub _preload { my ($sick, $file, $cache, $o, $preloaded, $options, $compiler) = @_; my $fn = _find_object($sick, $file, $cache, $sick->{rc}->getoption('include')); $o->{verbose}->read_text("\n [$file: $fn") if $o->{verbose}; my ($ci, $size); if (exists $sick->{int_cache}{$fn}) { ($ci, $size) = @{$sick->{int_cache}{$fn}}; if ($o->{verbose} && ! $size) { $sick->{int_cache}{$fn}[1] = $size = _int_size($ci); } } else { my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn); $ci = Language::INTERCAL::Interpreter->write($sick->{rc}, $fh); $size = $o->{verbose} ? _int_size($ci) : 0; $sick->{int_cache}{$fn} = [$ci, $size]; } $ci->object->has_flag('TYPE') or die "Invalid object - did not provide a type\n"; my $ct = $ci->object->flag_value('TYPE'); exists $object_type{$ct} or die "Invalid object type: $ct\n"; my $ot = $object_type{$ct}; if ($ot eq 'COMPILER') { exists $preloaded->{$ct} and die "Invalid preloads list - compiler " . "$preloaded->{$ot} already loaded\n"; $preloaded->{$ot} = $file; $compiler->[0] = $ci; $compiler->[1] = $ct eq 'RUNCOMPILER'; } elsif ($ot eq 'ONEONLY') { exists $preloaded->{$ct} and die "Invalid preloads list - \L$ct\E " . "$preloaded->{$ct} already loaded\n"; $preloaded->{$ct} = $file; push @$options, $ci; } elsif ($ot eq 'REPEAT') { push @$options, $ci; } else { die "Internal error, unmapped type $ot\n"; } # if they want to do additional checks, let them if ($sick->{shared_option}{preload_callback}) { my ($code, @args) = @{$sick->{shared_option}{preload_callback}}; $code->($sick, $file, $fn, $ct, @args); } $o->{verbose}->read_text(": type \L$ct\E: $size bytes]") if $o->{verbose}; } sub _guess_extra { my ($sick, $extra) = @_; for my $xd (@{$sick->{shared_option}{default_extra}}) { my ($x, $preload, $as) = @$xd; next if $x ne $extra; return ($preload, $as); } (); } sub _guess_preloads { my ($sick, $suffix, $o) = @_; # must guess preloads from suffix for my $sd (@{$sick->{shared_option}{default_suffix}}) { my ($regex, $as, $resplit, $map) = @$sd; next unless ref $resplit; my @extra = $suffix =~ $regex; next unless @extra; if (@$resplit) { my @e = (); for my $r (@$resplit) { my $e = shift @extra; next unless defined $e; while ($e =~ s/$r//) { push @e, $1; } die "Internal error in _guess_preloads\n" if $e ne ''; } @extra = @e; } else { @extra = (); } my @preloads = (); my %preloads = (); for my $p (@{$map->{''}}) { my $q = $p; if ($q =~ s/^\?//) { next unless $o->{optimise}; } push @preloads, $q; $preloads{$q} = 1; } my @as = ( $as ); my %as = ( $as => 1 ); for my $extra (@extra) { my ($_p, $a); if (exists $map->{$extra}) { ($_p, $a) = @{$map->{$extra}}; } else { ($_p, $a) = _guess_extra($sick, $extra); die "Inconsistent sickrc: $extra?\n" unless defined $_p; } for my $p (@$_p) { my $q = $p; if ($q =~ s/^\?//) { next unless $o->{optimise}; } next if exists $preloads{$q}; push @preloads, $q; $preloads{$q} = 1; } next if $a eq '' || exists $as{$a}; push @as, $a; $as{$a} = 1; } $o->{verbose}->read_text(" [" . join(' + ', @as) . "]") if $o->{verbose}; return @preloads; } die "Cannot guess file type\n"; } sub _guess_charset { my ($sick, $source, $fh) = @_; my %counts = (); for my $name (@{$sick->{shared_option}{default_charset}}) { eval { my $cnv = toascii($name); my $count = 0; while ((my $line = $fh->write_binary(4096)) ne '') { my $cl = &$cnv($line); $count++ while $line =~ /DO|PLEASE/ig; } $counts{$name} = $count; }; $fh->reset(); } my @counts = sort {$counts{$b} <=> $counts{$a}} grep {$counts{$_}} keys %counts; if (@counts == 0 && $fh->write_binary(1) eq '') { $fh->reset(); @counts = qw(ASCII); $counts{ASCII} = 1; } if (! @counts || $counts{$counts[0]} < 1) { my $cr = $sick->{object_option}{verbose} ? "\n" : ""; die "${cr}File \"$source\": cannot guess character set\n"; } $counts[0]; } sub _int_size { my ($int) = @_; my $size = 0; my $fh = new Language::INTERCAL::GenericIO 'COUNT', 'r', \$size; $int->read($fh); $size; } 1