|
996
|
1 # common code for all compiler tests - see t/*compiler-*.t
|
|
|
2
|
|
|
3 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
4
|
|
|
5 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
6 # and distribute it is granted provided that the conditions set out in the
|
|
|
7 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
8
|
|
|
9 use Language::INTERCAL::GenericIO '1.-94.-2', qw($devnull);
|
|
|
10 use Language::INTERCAL::Sick '1.-94.-2';
|
|
|
11 use Language::INTERCAL::Rcfile '1.-94.-2';
|
|
|
12 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
13
|
|
|
14 my $rc = new Language::INTERCAL::Rcfile;
|
|
|
15 my $cobj = new Language::INTERCAL::Sick($rc);
|
|
|
16
|
|
|
17 sub runtest {
|
|
|
18 my ($language, $give_up, $tests) = @_;
|
|
|
19 my $maxtest = 1 + 3 * @$tests;
|
|
|
20 print "1..$maxtest\n";
|
|
|
21 my $testnum = 1;
|
|
|
22 my $i_data = '';
|
|
|
23 my $i_fh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$i_data);
|
|
|
24 my $o_data = '';
|
|
|
25 my $o_fh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$o_data);
|
|
|
26 eval {
|
|
|
27 $cobj->reset();
|
|
|
28 $cobj->setoption('default_charset', 'ASCII');
|
|
|
29 $cobj->setoption('default_backend', 'Run');
|
|
|
30 $cobj->clearoption('preload');
|
|
|
31 if (ref $language) {
|
|
|
32 $cobj->setoption('preload', $_) for @$language;
|
|
|
33 } else {
|
|
|
34 $cobj->setoption('preload', $language);
|
|
|
35 }
|
|
|
36 $cobj->setoption('trace', 0);
|
|
|
37 $cobj->source('null.iacc');
|
|
|
38 $cobj->load_objects();
|
|
|
39 $obj = $cobj->get_object('null.iacc')
|
|
|
40 or die "Internal error: no compiler object\n";
|
|
|
41 $obj->object->setbug(0, 0);
|
|
|
42 #$obj->setreg('%TM', 1); 0 and
|
|
|
43 $obj->setreg('@TRFH', $devnull);
|
|
|
44 $obj->setreg('@OWFH', $i_fh);
|
|
|
45 $obj->setreg('@OSFH', $o_fh);
|
|
|
46 $obj->setreg('@ORFH', $o_fh);
|
|
|
47 };
|
|
|
48 if ($@) {
|
|
|
49 # if we can't even load the compiler...
|
|
|
50 print STDERR "FAILED $language: $@";
|
|
|
51 print "not ok ", $testnum++, "\n" while $testnum <= $maxtest;
|
|
|
52 return;
|
|
|
53 }
|
|
|
54 print "ok ", $testnum++, "\n";
|
|
|
55 for my $T (@$tests) {
|
|
|
56 my ($name, $in, $out, $splat, $source) = @$T;
|
|
|
57 $source .= "\n$give_up\n";
|
|
|
58 eval { $obj->compile($source) };
|
|
|
59 if ($@) {
|
|
|
60 print STDERR "Failed: compiling $name\n";
|
|
|
61 print "not ok ", $testnum++, "\n" for (1..3);
|
|
|
62 next;
|
|
|
63 }
|
|
|
64 print "ok ", $testnum++, "\n";
|
|
|
65 $i_data = $in;
|
|
|
66 $i_fh->reset;
|
|
|
67 $o_data = '';
|
|
|
68 $o_fh->reset;
|
|
|
69 eval { $obj->start()->run()->stop() };
|
|
|
70 if ($@) {
|
|
|
71 print STDERR "Failed: running $name\n";
|
|
|
72 print "not ok ", $testnum++, "\n" for (2..3);
|
|
|
73 next;
|
|
|
74 }
|
|
|
75 my $os = $obj->splat;
|
|
|
76 if (defined $os) {
|
|
|
77 print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
|
|
|
78 print STDERR "Failed $name (*$os)\n" unless defined $splat && $os == $splat;
|
|
|
79 } else {
|
|
|
80 print defined $splat ? "not " : "", "ok ", $testnum++, "\n";
|
|
|
81 print STDERR "Failed $name (no splat)\n" if defined $splat;
|
|
|
82 }
|
|
|
83 my $ok = ref $out ? (grep { $_ eq $o_data } @$out) : ($o_data eq $out);
|
|
|
84 if ($ok) {
|
|
|
85 print "ok ", $testnum++, "\n";
|
|
|
86 } else {
|
|
|
87 my $O = $o_data; $O =~ s/\n/\\n/g;
|
|
|
88 print STDERR "Failed $name (invalid output $O)\n";
|
|
|
89 print "not ok ", $testnum++, "\n";
|
|
|
90 }
|
|
|
91 }
|
|
|
92 }
|
|
|
93
|
|
|
94 1;
|
