Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/t/compiler-test @ 10372:f04f06041b47
<oerjan> ` echo hum>test; echo erm>test2
author | HackBot |
---|---|
date | Tue, 07 Mar 2017 23:22:53 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
# common code for all compiler tests - see t/*compiler-*.t # 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 Language::INTERCAL::GenericIO '1.-94.-2', qw($devnull); use Language::INTERCAL::Sick '1.-94.-2'; use Language::INTERCAL::Rcfile '1.-94.-2'; use Language::INTERCAL::Splats '1.-94.-2', qw(:SP); my $rc = new Language::INTERCAL::Rcfile; my $cobj = new Language::INTERCAL::Sick($rc); sub runtest { my ($language, $give_up, $tests) = @_; my $maxtest = 1 + 3 * @$tests; print "1..$maxtest\n"; my $testnum = 1; my $i_data = ''; my $i_fh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$i_data); my $o_data = ''; my $o_fh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$o_data); eval { $cobj->reset(); $cobj->setoption('default_charset', 'ASCII'); $cobj->setoption('default_backend', 'Run'); $cobj->clearoption('preload'); if (ref $language) { $cobj->setoption('preload', $_) for @$language; } else { $cobj->setoption('preload', $language); } $cobj->setoption('trace', 0); $cobj->source('null.iacc'); $cobj->load_objects(); $obj = $cobj->get_object('null.iacc') or die "Internal error: no compiler object\n"; $obj->object->setbug(0, 0); #$obj->setreg('%TM', 1); 0 and $obj->setreg('@TRFH', $devnull); $obj->setreg('@OWFH', $i_fh); $obj->setreg('@OSFH', $o_fh); $obj->setreg('@ORFH', $o_fh); }; if ($@) { # if we can't even load the compiler... print STDERR "FAILED $language: $@"; print "not ok ", $testnum++, "\n" while $testnum <= $maxtest; return; } print "ok ", $testnum++, "\n"; for my $T (@$tests) { my ($name, $in, $out, $splat, $source) = @$T; $source .= "\n$give_up\n"; eval { $obj->compile($source) }; if ($@) { print STDERR "Failed: compiling $name\n"; print "not ok ", $testnum++, "\n" for (1..3); next; } print "ok ", $testnum++, "\n"; $i_data = $in; $i_fh->reset; $o_data = ''; $o_fh->reset; eval { $obj->start()->run()->stop() }; if ($@) { print STDERR "Failed: running $name\n"; print "not ok ", $testnum++, "\n" for (2..3); next; } my $os = $obj->splat; if (defined $os) { print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n"; print STDERR "Failed $name (*$os)\n" unless defined $splat && $os == $splat; } else { print defined $splat ? "not " : "", "ok ", $testnum++, "\n"; print STDERR "Failed $name (no splat)\n" if defined $splat; } my $ok = ref $out ? (grep { $_ eq $o_data } @$out) : ($o_data eq $out); if ($ok) { print "ok ", $testnum++, "\n"; } else { my $O = $o_data; $O =~ s/\n/\\n/g; print STDERR "Failed $name (invalid output $O)\n"; print "not ok ", $testnum++, "\n"; } } } 1;