← Back to branch summary

~ubuntu-branches/ubuntu/trusty/clc-intercal/trusty-proposed

« back to all changes in this revision

Viewing changes to t/03bytecode-expressions.t

  • Committer: Bazaar Package Importer
  • Author(s): Mark Brown
  • Date: 2006-10-08 13:30:54 UTC
  • mfrom: (1.1.1 upstream) (3.1.1 dapper)
  • Revision ID: james.westby@ubuntu.com-20061008133054-fto70u71yoyltr3m
Tags: 1:1.0~2pre1.-94.-4.1-1
* New upstream release.
* Change to dh_installman.

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/03bytecode-expressions.t
 
1
# test bytecode interpreter - expressions
 
2
 
 
3
# Copyright (c) 2006 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.-4', qw($devnull);
 
10
use Language::INTERCAL::Interpreter '1.-94.-4';
 
11
use Language::INTERCAL::ByteCode '1.-94.-4', qw(:BC reg_code);
 
12
use Language::INTERCAL::Splats '1.-94.-4', qw(:SP);
 
13
 
 
14
use vars qw(@all_tests);
 
15
 
 
16
require 't/expressions';
 
17
 
 
18
$| = 1;
 
19
 
 
20
my $maxtest = 2 * scalar @all_tests;
 
21
print "1..$maxtest\n";
 
22
 
 
23
my $testnum = 1;
 
24
for my $tester (@all_tests) {
 
25
    my ($name, $opcode, $base, $in, $out, $splat) = @$tester;
 
26
    my $obj = new Language::INTERCAL::Interpreter;
 
27
    $obj->object->setbug(0, 0);
 
28
    my @x = (BC_STO, ref $opcode ? @$opcode : $opcode);
 
29
    for my $r (@$in) {
 
30
        if (ref $r) {
 
31
            next if $r->[0] =~ /^%/;
 
32
            push @x, reg_code($r->[0]);
 
33
        } else {
 
34
            push @x, BC($r);
 
35
        }
 
36
    }
 
37
    push @x, reg_code($out->[0]);
 
38
    my $cp = 0;
 
39
    my @c = ();
 
40
    push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), @x);
 
41
    push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), BC_GUP);
 
42
    eval {
 
43
        $obj->object->source('source');
 
44
        $obj->object->code(\@c);
 
45
        for my $r (@$in) {
 
46
            next unless ref $r;
 
47
            $obj->setreg($r->[0], $r->[1]);
 
48
        }
 
49
        $obj->setreg('%BA', $base);
 
50
        $obj->setreg('@OSFH', $devnull);
 
51
        $obj->setreg('@TRFH', $devnull);
 
52
        $obj->start()->run()->stop();
 
53
    };
 
54
    if ($@) {
 
55
        print STDERR "Failed $name\n";
 
56
        print "not ok ", $testnum++, "\n";
 
57
        print "not ok ", $testnum++, "\n";
 
58
        next;
 
59
    }
 
60
    my $os = $obj->splat;
 
61
    if (defined $os) {
 
62
        print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
 
63
        print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
 
64
        print STDERR "Failed $name\n" unless defined $splat && $os == $splat;
 
65
        next;
 
66
    } else {
 
67
        print defined $splat ? "not " : "", "ok ", $testnum++, "\n";
 
68
        print STDERR "Failed $name\n" if defined $splat;
 
69
    }
 
70
    my $v = eval { $obj->getreg($out->[0])->number };
 
71
    if ($@) {
 
72
        print STDERR "Failed $name\n";
 
73
        print "not ok ", $testnum++, "\n";
 
74
        next;
 
75
    }
 
76
    print STDERR "Failed $name\n" if $v != $out->[1];
 
77
    print $v == $out->[1] ? '' : 'not ', "ok ", $testnum++, "\n";
 
78
}
 
79