Changes from the last one:
* some tidying in the assembly
( now uses set I4, 4 instead of set_i_ic I4, 4 )
* moved lib/Test/Parrot.pm to Parrot/Test.pm
* now run with perl t/harness
Regards
Mattia
diff -r -b -u -2 -N parrot.cvs/Parrot/Test.pm parrot/Parrot/Test.pm
--- parrot.cvs/Parrot/Test.pm Thu Jan 1 01:00:00 1970
+++ parrot/Parrot/Test.pm Sun Sep 16 12:18:34 2001
@@ -0,0 +1,79 @@
+#
+
+package Parrot::Test;
+
+use strict;
+use vars qw(@EXPORT @ISA);
+
+require Exporter;
+require Test::More;
+
+@EXPORT = ( qw(output_is), @Test::More::EXPORT );
+@ISA = qw(Exporter Test::More);
+
+sub import {
+ my( $class, $plan, @args ) = @_;
+
+ Test::More->import( $plan, @args );
+
+ __PACKAGE__->_export_to_level( 2, __PACKAGE__ );
+}
+
+# this kludge is an hopefully portable way of having
+# redirections ( tested on Linux and Win2k )
+sub _run_command {
+ my( $command, %redir ) = @_;
+ my( $redir_string ) = '';
+
+ while( my @dup = each %redir ) {
+ my( $from, $to ) = @dup;
+ if( $to eq 'STDERR' ) { $to = "qq{>&STDERR}" }
+ elsif( $to eq 'STDOUT' ) { $to = "qq{>&STDOUT}" }
+ elsif( $to eq '/dev/null' ) { $to = ( $^O eq 'MSWin32' ) ?
+ 'qq{> NUL:}' : "qq{> $to}" }
+ else { $to = "qq{> $to}" }
+
+ $redir_string .= "open $from, $to;"
+ }
+
+ system "$^X -e \"$redir_string;system qq{$command};\"";
+}
+
+my $count;
+
+foreach my $i ( qw(is isnt like) ) {
+ no strict 'refs';
+
+ *{"Parrot::Test::output_$i"} = sub ($$;$) {
+ ++$count;
+ my( $assembly, $output, $desc ) = @_;
+ local( *ASSEMBLY, *OUTPUT );
+ my( $as_f, $by_f, $out_f ) = map {
+ my $t = $0; $t =~ s/\.t$/$count\.$_/; $t
+ } ( qw(pasm pbc out) );
+
+ open ASSEMBLY, "> $as_f" or die "Unable to open '$as_f'";
+ binmode ASSEMBLY;
+ print ASSEMBLY $assembly;
+ close ASSEMBLY;
+
+ _run_command( "perl assemble.pl $as_f --output $by_f" );
+ _run_command( "./test_prog $by_f", 'STDOUT' => $out_f );
+
+ my $prog_output;
+ open OUTPUT, "< $out_f";
+ {
+ local $/ = undef;
+ $prog_output = <OUTPUT>;
+ }
+ close OUTPUT;
+
+ @_ = ( $prog_output, $output, $desc );
+ #goto &{"Test::More::$i"};
+ my $ok = &{"Test::More::$i"}( @_ );
+ if( $ok ) { foreach my $i ( $as_f, $by_f, $out_f ) { unlink $i } }
+ }
+}
+
+1;
+
diff -r -b -u -2 -N parrot.cvs/t/harness parrot/t/harness
--- parrot.cvs/t/harness Thu Jan 1 01:00:00 1970
+++ parrot/t/harness Thu Sep 13 17:36:08 2001
@@ -0,0 +1,7 @@
+#! perl -w
+
+use strict;
+use Test::Harness qw(runtests);
+
+my @tests = map { glob( "t/$_/*.t" ) } ( qw(op misc) );
+runtests( @tests );
diff -r -b -u -2 -N parrot.cvs/t/op/basic.t parrot/t/op/basic.t
--- parrot.cvs/t/op/basic.t Thu Jan 1 01:00:00 1970
+++ parrot/t/op/basic.t Sun Sep 16 12:18:26 2001
@@ -0,0 +1,27 @@
+#! perl -w
+
+use Parrot::Test tests => 2;
+
+output_is( <<'CODE', '42', "branch_ic" );
+ set I4, 42
+ branch HERE
+ set I4, 1234
+HERE:
+ print I4
+ end
+CODE
+
+SKIP: {
+ skip( "label constants unimplemented in assembler", 1 );
+output_is( <<'CODE', <<OUTPUT, "jump" );
+ set I4, 42
+ set I5, HERE
+ jump I5
+ set I4, 1234
+HERE:
+ print I4
+ end
+CODE
+I reg 4 is 42
+OUTPUT
+}
diff -r -b -u -2 -N parrot.cvs/t/op/string.t parrot/t/op/string.t
--- parrot.cvs/t/op/string.t Thu Jan 1 01:00:00 1970
+++ parrot/t/op/string.t Sun Sep 16 11:33:06 2001
@@ -0,0 +1,48 @@
+#! perl -w
+
+use Parrot::Test tests => 4;
+
+output_is( <<'CODE', <<OUTPUT, "set_s_sc" );
+ set S4, "JAPH\n"
+ print S4
+ end
+CODE
+JAPH
+OUTPUT
+
+output_is( <<'CODE', '4', "length_i_s" );
+ set I4, 0
+ set S4, "JAPH"
+ length I4, S4
+ print I4
+ end
+CODE
+
+output_is( <<'CODE', <<OUTPUT, "chopn_s_ic" );
+ set S4, "JAPHxyzw"
+ set S5, "japhXYZW"
+ set S3, "\n"
+ chopn S4, 3
+ chopn S4, 1
+ chopn S5, 4
+ print S4
+ print S3
+ print S5
+ print S3
+ end
+CODE
+JAPH
+japh
+OUTPUT
+
+SKIP: {
+ skip "I'm unable to write it!", 1;
+output_is( <<'CODE', 'JAPH', "substr_s_s_i_i" );
+ set S4, "12345JAPH01"
+ set I4, 5
+ set I5, 4
+ substr S5, S4, I4, I5
+ print S5
+ end
+CODE
+}
