|
996
|
1 # test bytecode interpreter - expressions
|
|
|
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::Interpreter '1.-94.-2';
|
|
|
11 use Language::INTERCAL::Rcfile '1.-94.-2';
|
|
|
12 use Language::INTERCAL::ByteCode '1.-94.-2', qw(:BC reg_code);
|
|
|
13 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
14
|
|
|
15 use vars qw(@all_tests);
|
|
|
16
|
|
|
17 require 't/expressions';
|
|
|
18
|
|
|
19 $| = 1;
|
|
|
20
|
|
|
21 my $randomness = 5;
|
|
|
22 @all_tests = map {
|
|
|
23 # repeat any tests involving randomness 5 times for better testing
|
|
|
24 defined $_->[5] ? () : ($_->[6] ? ($_) x $randomness : $_)
|
|
|
25 } @all_tests;
|
|
|
26 # add a couple of splat tests
|
|
|
27 push @all_tests,
|
|
|
28 ['SPL', BC_SPL, 2, [], ['.1' => SP_NODIM], SP_NODIM],
|
|
|
29 ['SPL', BC_SPL, 2, [], ['.1' => SP_NORESUME], SP_NORESUME];
|
|
|
30
|
|
|
31 my $maxtest = 2 * scalar @all_tests;
|
|
|
32 print "1..$maxtest\n";
|
|
|
33
|
|
|
34 my $testnum = 1;
|
|
|
35 my $rc = new Language::INTERCAL::Rcfile;
|
|
|
36 for my $tester (@all_tests) {
|
|
|
37 my ($name, $opcode, $base, $in, $out, $splat, $israndom) = @$tester;
|
|
|
38 my $obj = new Language::INTERCAL::Interpreter($rc);
|
|
|
39 $obj->object->setbug(0, 0);
|
|
|
40 my @x = (BC_STO, reg_code($out->[0]), ref $opcode ? @$opcode : $opcode);
|
|
|
41 my @y = (BC_STO, ref $opcode ? @$opcode : $opcode);
|
|
|
42 for my $r (@$in) {
|
|
|
43 if (ref $r) {
|
|
|
44 next if $r->[0] =~ /^%/;
|
|
|
45 push @x, reg_code($r->[0]);
|
|
|
46 push @y, reg_code($r->[0]);
|
|
|
47 } else {
|
|
|
48 push @x, BC($r);
|
|
|
49 push @y, BC($r);
|
|
|
50 }
|
|
|
51 }
|
|
|
52 push @y, reg_code($out->[0]);
|
|
|
53 my $cp = 0;
|
|
|
54 my @c = ();
|
|
|
55 push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), @x);
|
|
|
56 push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), @y);
|
|
|
57 push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), BC_GUP);
|
|
|
58 eval {
|
|
|
59 $obj->object->source('source');
|
|
|
60 $obj->object->code(\@c);
|
|
|
61 for my $r (@$in) {
|
|
|
62 if (ref $r && $r->[0] =~ /^%/) {
|
|
|
63 $obj->setreg($r->[0], $r->[1]);
|
|
|
64 }
|
|
|
65 }
|
|
|
66 $obj->setreg($out->[0], $out->[1]);
|
|
|
67 $obj->setreg('%BA', $base);
|
|
|
68 $obj->setreg('@OSFH', $devnull);
|
|
|
69 $obj->setreg('@TRFH', $devnull);
|
|
|
70 $obj->start()->run()->stop();
|
|
|
71 };
|
|
|
72 if ($@) {
|
|
|
73 print "not ok ", $testnum++, "\n";
|
|
|
74 print "not ok ", $testnum++, "\n";
|
|
|
75 print STDERR "Failed $name\n";
|
|
|
76 next;
|
|
|
77 }
|
|
|
78 my $os = $obj->splat;
|
|
|
79 if (defined $os) {
|
|
|
80 print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
|
|
|
81 print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
|
|
|
82 print STDERR "Failed $name (splat=$os)\n" unless defined $splat && $os == $splat;
|
|
|
83 next;
|
|
|
84 } else {
|
|
|
85 print defined $splat ? "not " : "", "ok ", $testnum++, "\n";
|
|
|
86 print STDERR "Failed $name\n" if defined $splat;
|
|
|
87 }
|
|
|
88 my $v = eval { $obj->getreg($out->[0])->number };
|
|
|
89 if ($@) {
|
|
|
90 print "not ok ", $testnum++, "\n";
|
|
|
91 print STDERR "Failed $name: $@";
|
|
|
92 next;
|
|
|
93 }
|
|
|
94 print STDERR "Failed $name ($v != $out->[1])\n" if $v != $out->[1];
|
|
|
95 print $v == $out->[1] ? '' : 'not ', "ok ", $testnum++, "\n";
|
|
|
96 }
|
|
|
97
|
