Mercurial > repo

comparison interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/t/04bytecode-assignments.t @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
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