|
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 $maxtest = 2 * scalar @all_tests;
|
|
|
22 print "1..$maxtest\n";
|
|
|
23
|
|
|
24 my $testnum = 1;
|
|
|
25 my $rc = new Language::INTERCAL::Rcfile;
|
|
|
26 for my $tester (@all_tests) {
|
|
|
27 my ($name, $opcode, $base, $in, $out, $splat, $israndom) = @$tester;
|
|
|
28 my $obj = new Language::INTERCAL::Interpreter($rc);
|
|
|
29 $obj->object->setbug(0, 0);
|
|
|
30 my @x = (BC_STO, ref $opcode ? @$opcode : $opcode);
|
|
|
31 for my $r (@$in) {
|
|
|
32 if (ref $r) {
|
|
|
33 next if $r->[0] =~ /^%/;
|
|
|
34 push @x, reg_code($r->[0]);
|
|
|
35 } else {
|
|
|
36 push @x, BC($r);
|
|
|
37 }
|
|
|
38 }
|
|
|
39 push @x, reg_code($out->[0]);
|
|
|
40 my $cp = 0;
|
|
|
41 my @c = ();
|
|
|
42 push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), @x);
|
|
|
43 push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), BC_GUP);
|
|
|
44 eval {
|
|
|
45 $obj->object->source('source');
|
|
|
46 $obj->object->code(\@c);
|
|
|
47 for my $r (@$in) {
|
|
|
48 next unless ref $r;
|
|
|
49 $obj->setreg($r->[0], $r->[1]);
|
|
|
50 }
|
|
|
51 $obj->setreg('%BA', $base);
|
|
|
52 $obj->setreg('@OSFH', $devnull);
|
|
|
53 $obj->setreg('@TRFH', $devnull);
|
|
|
54 $obj->start()->run()->stop();
|
|
|
55 };
|
|
|
56 if ($@) {
|
|
|
57 print STDERR "Failed $name\n";
|
|
|
58 print "not ok ", $testnum++, "\n";
|
|
|
59 print "not ok ", $testnum++, "\n";
|
|
|
60 next;
|
|
|
61 }
|
|
|
62 my $os = $obj->splat;
|
|
|
63 if (defined $os) {
|
|
|
64 print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
|
|
|
65 print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
|
|
|
66 print STDERR "Failed $name\n" unless defined $splat && $os == $splat;
|
|
|
67 next;
|
|
|
68 } else {
|
|
|
69 print defined $splat ? "not " : "", "ok ", $testnum++, "\n";
|
|
|
70 print STDERR "Failed $name\n" if defined $splat;
|
|
|
71 }
|
|
|
72 my $v = eval { $obj->getreg($out->[0])->number };
|
|
|
73 if ($@) {
|
|
|
74 print STDERR "Failed $name\n";
|
|
|
75 print "not ok ", $testnum++, "\n";
|
|
|
76 next;
|
|
|
77 }
|
|
|
78 print STDERR "Failed $name\n" if $v != $out->[1];
|
|
|
79 print $v == $out->[1] ? '' : 'not ', "ok ", $testnum++, "\n";
|
|
|
80 }
|
|
|
81
|
