--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/t/03bytecode-expressions.t	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,81 @@
+# test bytecode interpreter - expressions
+
+# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
+
+# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
+# and distribute it is granted provided that the conditions set out in the
+# licence agreement are met. See files README and COPYING in the distribution.
+
+use Language::INTERCAL::GenericIO '1.-94.-2', qw($devnull);
+use Language::INTERCAL::Interpreter '1.-94.-2';
+use Language::INTERCAL::Rcfile '1.-94.-2';
+use Language::INTERCAL::ByteCode '1.-94.-2', qw(:BC reg_code);
+use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
+
+use vars qw(@all_tests);
+
+require 't/expressions';
+
+$| = 1;
+
+my $maxtest = 2 * scalar @all_tests;
+print "1..$maxtest\n";
+
+my $testnum = 1;
+my $rc = new Language::INTERCAL::Rcfile;
+for my $tester (@all_tests) {
+    my ($name, $opcode, $base, $in, $out, $splat, $israndom) = @$tester;
+    my $obj = new Language::INTERCAL::Interpreter($rc);
+    $obj->object->setbug(0, 0);
+    my @x = (BC_STO, ref $opcode ? @$opcode : $opcode);
+    for my $r (@$in) {
+	if (ref $r) {
+	    next if $r->[0] =~ /^%/;
+	    push @x, reg_code($r->[0]);
+	} else {
+	    push @x, BC($r);
+	}
+    }
+    push @x, reg_code($out->[0]);
+    my $cp = 0;
+    my @c = ();
+    push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), @x);
+    push @c, pack('C*', BC_STS, BC($cp++), BC(1), BC(0), BC(0), BC_GUP);
+    eval {
+	$obj->object->source('source');
+	$obj->object->code(\@c);
+	for my $r (@$in) {
+	    next unless ref $r;
+	    $obj->setreg($r->[0], $r->[1]);
+	}
+	$obj->setreg('%BA', $base);
+	$obj->setreg('@OSFH', $devnull);
+	$obj->setreg('@TRFH', $devnull);
+	$obj->start()->run()->stop();
+    };
+    if ($@) {
+	print STDERR "Failed $name\n";
+	print "not ok ", $testnum++, "\n";
+	print "not ok ", $testnum++, "\n";
+	next;
+    }
+    my $os = $obj->splat;
+    if (defined $os) {
+	print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
+	print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
+	print STDERR "Failed $name\n" unless defined $splat && $os == $splat;
+	next;
+    } else {
+	print defined $splat ? "not " : "", "ok ", $testnum++, "\n";
+	print STDERR "Failed $name\n" if defined $splat;
+    }
+    my $v = eval { $obj->getreg($out->[0])->number };
+    if ($@) {
+	print STDERR "Failed $name\n";
+	print "not ok ", $testnum++, "\n";
+	next;
+    }
+    print STDERR "Failed $name\n" if $v != $out->[1];
+    print $v == $out->[1] ? '' : 'not ', "ok ", $testnum++, "\n";
+}
+