Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/t/04bytecode-assignments.t @ 12508:335a2a849232 draft default tip
<wib_jonas> `` f=/hackenv/bin/dateu; >$f echo $\'#!/bin/bash\\nset -e\\nif (( 1 < $# )); then echo "dateu error: too many command-line arguments. Usage: dateu datetimestring"; exit 2; fi\\nexec date -u ${1:+-d "$1"} "+%Y-%m-%d %H:%M:%S.%3N %z %Z %B %-e %A %G-W%V-%u"\'; chmod a+x "$f"
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Wed, 03 Jul 2024 18:15:24 +0100 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
# 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 $randomness = 5; @all_tests = map { # repeat any tests involving randomness 5 times for better testing defined $_->[5] ? () : ($_->[6] ? ($_) x $randomness : $_) } @all_tests; # add a couple of splat tests push @all_tests, ['SPL', BC_SPL, 2, [], ['.1' => SP_NODIM], SP_NODIM], ['SPL', BC_SPL, 2, [], ['.1' => SP_NORESUME], SP_NORESUME]; 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, reg_code($out->[0]), ref $opcode ? @$opcode : $opcode); my @y = (BC_STO, ref $opcode ? @$opcode : $opcode); for my $r (@$in) { if (ref $r) { next if $r->[0] =~ /^%/; push @x, reg_code($r->[0]); push @y, reg_code($r->[0]); } else { push @x, BC($r); push @y, BC($r); } } push @y, 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), @y); 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) { if (ref $r && $r->[0] =~ /^%/) { $obj->setreg($r->[0], $r->[1]); } } $obj->setreg($out->[0], $out->[1]); $obj->setreg('%BA', $base); $obj->setreg('@OSFH', $devnull); $obj->setreg('@TRFH', $devnull); $obj->start()->run()->stop(); }; if ($@) { print "not ok ", $testnum++, "\n"; print "not ok ", $testnum++, "\n"; print STDERR "Failed $name\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 (splat=$os)\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 "not ok ", $testnum++, "\n"; print STDERR "Failed $name: $@"; next; } print STDERR "Failed $name ($v != $out->[1])\n" if $v != $out->[1]; print $v == $out->[1] ? '' : 'not ', "ok ", $testnum++, "\n"; }