Author: bernhard
Date: Tue May 3 14:14:35 2005
New Revision: 7964
Modified:
trunk/config/gen/makefiles.pl
trunk/config/gen/makefiles/m4.in
trunk/languages/m4/t/basic/002_hello.t
trunk/languages/m4/t/harness
trunk/languages/scheme/Scheme/Test.pm
trunk/lib/Parrot/Test.pm
trunk/lib/Parrot/Test/m4.pm
Log:
When GNU m4 is available run the m4 test suite twice:
with GNU m4 and with Parrot m4. Concatenating their outputs
was a bad idea.
Add Parrot::Test::m4::output_isnt and Parrot::Test::m4::output_like.
Fiddle with Parrot::Test
Modified: trunk/config/gen/makefiles.pl
==============================================================================
--- trunk/config/gen/makefiles.pl (original)
+++ trunk/config/gen/makefiles.pl Tue May 3 14:14:35 2005
@@ -18,9 +18,9 @@
use vars qw($description @args);
use Parrot::Configure::Step ':gen';
-$description="Generating build files...";
+$description = "Generating build files...";
[EMAIL PROTECTED]();
[EMAIL PROTECTED] = ();
sub runstep {
makefiles();
@@ -29,7 +29,7 @@
}
sub cflags {
- genfile('config/gen/makefiles/CFLAGS.in', 'CFLAGS',
+ genfile('config/gen/makefiles/CFLAGS.in' => 'CFLAGS',
commentType => '#');
open(CFLAGS, ">> CFLAGS") or die "open >> CFLAGS: $!";
@@ -48,46 +48,70 @@
}
sub makefiles {
- genfile('config/gen/makefiles/root.in', 'Makefile',
- commentType => '#', replace_slashes => 1, conditioned_lines => 1);
- genfile('config/gen/makefiles/pge.in', 'compilers/pge/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/languages.in', 'languages/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/jako.in', 'languages/jako/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/miniperl.in', 'languages/miniperl/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/scheme.in', 'languages/scheme/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/m4.in', 'languages/m4/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/perl6.in', 'languages/perl6/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/bf.in', 'languages/bf/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/befunge.in', 'languages/befunge/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/cola.in', 'languages/cola/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/ook.in', 'languages/ook/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/lisp.in', 'languages/lisp/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/urm.in', 'languages/urm/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/tcl.in', 'languages/tcl/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/tcl_examples.in',
'languages/tcl/examples/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/dynclasses.in', 'dynclasses/Makefile',
- commentType => '#', replace_slashes => 1, conditioned_lines => 1);
- genfile('config/gen/makefiles/dynclasses_pl.in', 'dynclasses/build.pl',
- commentType => '#', replace_slashes => 0, conditioned_lines => 1);
- genfile('config/gen/makefiles/dynoplibs.in', 'dynoplibs/Makefile',
- commentType => '#', replace_slashes => 1);
- genfile('config/gen/makefiles/parrot_compiler.in',
'languages/parrot_compiler/Makefile',
- commentType => '#', replace_slashes => 1);
+ genfile('config/gen/makefiles/root.in' => 'Makefile',
+ commentType => '#',
+ replace_slashes => 1,
+ conditioned_lines => 1);
+ genfile('config/gen/makefiles/pge.in' => 'compilers/pge/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/languages.in' => 'languages/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/jako.in' => 'languages/jako/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/miniperl.in' => 'languages/miniperl/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/scheme.in' => 'languages/scheme/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/m4.in' => 'languages/m4/Makefile',
+ commentType => '#',
+ replace_slashes => 1,
+ conditioned_lines => 1);
+ genfile('config/gen/makefiles/perl6.in' => 'languages/perl6/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/bf.in' => 'languages/bf/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/befunge.in' => 'languages/befunge/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/cola.in' => 'languages/cola/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/ook.in' => 'languages/ook/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/lisp.in' => 'languages/lisp/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/urm.in' => 'languages/urm/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/tcl.in' => 'languages/tcl/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/tcl_examples.in' =>
'languages/tcl/examples/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/dynclasses.in' => 'dynclasses/Makefile',
+ commentType => '#',
+ replace_slashes => 1,
+ conditioned_lines => 1);
+ genfile('config/gen/makefiles/dynclasses_pl.in' => 'dynclasses/build.pl',
+ commentType => '#',
+ replace_slashes => 0,
+ conditioned_lines => 1);
+ genfile('config/gen/makefiles/dynoplibs.in' => 'dynoplibs/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
+ genfile('config/gen/makefiles/parrot_compiler.in' =>
'languages/parrot_compiler/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
if ( Configure::Data->get('has_perldoc') ) {
# set up docs/Makefile, partly based on the .ops in the root dir
Modified: trunk/config/gen/makefiles/m4.in
==============================================================================
--- trunk/config/gen/makefiles/m4.in (original)
+++ trunk/config/gen/makefiles/m4.in Tue May 3 14:14:35 2005
@@ -20,6 +20,8 @@
# some constants
M4_EVAL_COMPILER_SO = ../../runtime/parrot/dynext/m4_eval_compiler.so
+#CONDITIONED_LINE(has_gnu_m4):USE_GNU_M4 = -use-gnu-m4
+#INVERSE_CONDITIONED_LINE(has_gnu_bc):USE_GNU_M4 =
# the default target
all: build
@@ -44,7 +46,7 @@
@echo ""
test: build
- cd .. && $(PERL) -I../lib m4/t/harness
+ cd .. && $(PERL) -I../lib m4/t/harness $(USE_GNU_M4)
build: runtime $(M4_EVAL_COMPILER_SO) m4.pbc
Modified: trunk/languages/m4/t/basic/002_hello.t
==============================================================================
--- trunk/languages/m4/t/basic/002_hello.t (original)
+++ trunk/languages/m4/t/basic/002_hello.t Tue May 3 14:14:35 2005
@@ -2,9 +2,9 @@
use strict;
-use Parrot::Test tests => 1;
+use Parrot::Test tests => 3;
-language_output_is( 'm4', <<'CODE', <<'OUT', 'hello' );
+language_output_is( 'm4', <<'CODE', <<'OUT', 'hello language_output_is' );
Hello World!
This m4 input contains no macro calls.
This m4 input contains three empty lines.
@@ -25,3 +25,14 @@
The last line is empty.
OUT
+
+language_output_like( 'm4', <<'CODE', '/ello/', 'hello language_output_like' );
+Hello World!
+CODE
+
+
+language_output_isnt( 'm4', <<'CODE', <<'OUT', 'hello language_output_isnt' );
+Hello World!
+CODE
+Hallo Welt!
+OUT
Modified: trunk/languages/m4/t/harness
==============================================================================
--- trunk/languages/m4/t/harness (original)
+++ trunk/languages/m4/t/harness Tue May 3 14:14:35 2005
@@ -31,6 +31,7 @@
use lib '..';
use Cwd();
+use Data::Dumper;
use File::Spec;
use Test::Harness();
@@ -44,6 +45,9 @@
print "\n" if scalar(@files);
} else {
my @files;
+ # TODO: use Getopt::Long or such
+ my $use_gnu_m4 = ( grep { m/^-use-gnu-m4$/ } @ARGV ) ? 1 : 0;
+ @ARGV = grep { ! m/^-use-gnu-m4$/ } @ARGV;
if ( scalar(@ARGV) ) {
# Someone specified tests for me to run.
@files = grep { -f $_ } @ARGV
@@ -56,7 +60,16 @@
@files = glob( File::Spec->catfile( 't', '*', '*.t' ) );
}
}
- Test::Harness::runtests( @files ) if scalar( @files );
+
+ # Always test Parrot m4
+ {
+ $ENV{PARROT_M4_TEST_PROG} = '';
+ Test::Harness::runtests( @files ) if scalar( @files );
+ }
+ if ( $use_gnu_m4 ) {
+ $ENV{PARROT_M4_TEST_PROG} = 'm4';
+ Test::Harness::runtests( @files ) if scalar( @files );
+ }
}
=head1 HISTORY
Modified: trunk/languages/scheme/Scheme/Test.pm
==============================================================================
--- trunk/languages/scheme/Scheme/Test.pm (original)
+++ trunk/languages/scheme/Scheme/Test.pm Tue May 3 14:14:35 2005
@@ -5,6 +5,7 @@
use strict;
use vars qw(@EXPORT @ISA);
use lib '../lib';
+
use Parrot::Config;
require Exporter;
@@ -23,15 +24,15 @@
my $count;
-foreach my $i ( qw(is isnt like) ) {
+foreach my $meth ( qw(is isnt like) ) {
no strict 'refs';
- *{"Scheme::Test::output_$i"} = sub ($$;$) {
+ *{"Scheme::Test::output_$meth"} = sub ($$;$) {
my( $assembly, $output, $desc ) = @_;
++$count;
my( $scheme_f, $as_f, $by_f, $out_f ) = map { # JMG
- my $t = $0; $t =~ s/\.t$/$count\.$_/; $t
+ my $t = $0; $t =~ s/\.t$/_$count\.$_/; $t
} ( qw(scheme pasm pbc out) ); # JMG
# STDERR is written into same output file
@@ -53,9 +54,9 @@
my $prog_output = Parrot::Test::slurp_file( "$out_f" );
@_ = ( $prog_output, $output, $desc );
- #goto &{"Test::More::$i"};
- my $ok = &{"Test::More::$i"}( @_ );
- # if( $ok ) { foreach my $i ( $scheme_f, $as_f, $by_f, $out_f ) {
unlink $i } } # JMG
+ #goto &{"Test::More::$meth"};
+ my $ok = &{"Test::More::$meth"}( @_ );
+ # if( $ok ) { foreach my $meth ( $scheme_f, $as_f, $by_f, $out_f ) {
unlink $meth } } # JMG
}
}
Modified: trunk/lib/Parrot/Test.pm
==============================================================================
--- trunk/lib/Parrot/Test.pm (original)
+++ trunk/lib/Parrot/Test.pm Tue May 3 14:14:35 2005
@@ -33,32 +33,17 @@
=over 4
-=item C<output_is($code, $expected, $description)>
+=item C<pasm_output_is($code, $expected, $description)> or C<output_is($code,
$expected, $description)>
Runs the Parrot Assembler code and passes the test if a string comparison
of the output with the expected result it true.
-=item C<pasm_output_is($code, $expected, $description)>
-
-Runs the Parrot Assembler code and passes the test if a string comparison
-of the output with the expected result it true.
-
-=item C<output_like($code, $expected, $description)>
-
-Runs the Parrot Assembler code and passes the test if
-the output matches the expected result.
-
-=item C<pasm_output_like($code, $expected, $description)>
+=item C<pasm_output_like($code, $expected, $description)> or
C<output_like($code, $expected, $description)>
Runs the Parrot Assembler code and passes the test if
the output matches the expected result.
-=item C<output_isnt($code, $unexpected, $description)>
-
-Runs the Parrot Assembler code and passes the test
-if a string comparison of the output with the unexpected result is false.
-
-=item C<pasm_output_isnt($code, $unexpected, $description)>
+=item C<pasm_output_isnt($code, $unexpected, $description)> or
C<output_isnt($code, $unexpected, $description)>
Runs the Parrot Assembler code and passes the test
if a string comparison of the output with the unexpected result is false.
@@ -66,7 +51,7 @@
=item C<pir_output_is($code, $expected, $description)>
Runs the PIR code and passes the test if a string comparison of output
-with the expected result it true.
+with the expected result is true.
=item C<pir_output_like($code, $expected, $description)>
@@ -81,7 +66,7 @@
=item C<pbc_output_is($code, $expected, $description)>
Runs the Parrot Bytecode and passes the test if a string comparison of output
-with the expected result it true.
+with the expected result is true.
=item C<pbc_output_like($code, $expected, $description)>
@@ -96,14 +81,17 @@
=item C<pir_2_pasm_is($code, $expected, $description)>
Compile the Parrot Intermediate Representation and generate Parrot Assembler
Code.
+Pass if the generated PASM is $expected.
=item C<pir_2_pasm_like($code, $expected, $description)>
Compile the Parrot Intermediate Representation and generate Parrot Assembler
Code.
+Pass if the generated PASM matches $expected.
=item C<pir_2_pasm_isnt($code, $unexpected, $description)>
Compile the Parrot Intermediate Representation and generate Parrot Assembler
Code.
+Pass unless the generated PASM is $expected.
=item C<c_output_is($code, $expected, $description)>
@@ -140,6 +128,9 @@
# equivalent to "cd some_dir && make test"
run_command("make test", CD => "some_dir");
+=item C<slurp_file($file_name)>
+
+Read the whole file $file_name and return the content as a string.
=back
@@ -149,6 +140,7 @@
use strict;
use vars qw(@EXPORT @ISA);
+
use Parrot::Config;
use File::Spec;
use Data::Dumper;
@@ -160,21 +152,21 @@
@EXPORT = qw( output_is output_like output_isnt
- pbc_output_is pbc_output_like pbc_output_isnt
pasm_output_is pasm_output_like pasm_output_isnt
pir_output_is pir_output_like pir_output_isnt
pir_2_pasm_is pir_2_pasm_like pir_2_pasm_isnt
+ pbc_output_is pbc_output_like pbc_output_isnt
c_output_is c_output_like c_output_isnt
- language_output_is
+ language_output_is language_output_like language_output_isnt
skip
+ slurp_file
run_command
);
@ISA = qw(Exporter);
# tell parrot it's being tested. this disables searching of installed
libraries
# (see Parrot_get_runtime_prefix in src/library.c).
-$ENV{PARROT_TEST} = 1
- unless defined($ENV{PARROT_TEST});
+$ENV{PARROT_TEST} = 1 unless defined($ENV{PARROT_TEST});
my $builder = Test::Builder->new();
@@ -261,9 +253,11 @@
binmode(CODE);
print CODE $code;
close( CODE );
+
+ return;
}
-# Why can't we inherit from Test::More ?
+# We can inherit from Test::More, so we do it.
*skip = \&Test::More::skip;
# What about File::Slurp?
@@ -279,7 +273,7 @@
return $file;
}
-sub generate_functions {
+sub _generate_functions {
my ($package, $code_generator) = @_;
my $path_to_parrot = $INC{"Parrot/Config.pm"};
@@ -419,16 +413,18 @@
}
}
- my %languages_test_map = (
- language_output_is => 'is_eq',
+ my %language_test_map = (
+ language_output_is => 'output_is',
+ language_output_like => 'output_like',
+ language_output_isnt => 'output_isnt',
);
- foreach my $func ( keys %languages_test_map ) {
+ foreach my $func ( keys %language_test_map ) {
no strict 'refs';
- my $delegate_func = $func;
- $delegate_func =~ s/^language_//;
*{$package.'::'.$func} = sub ($$$;$) {
+ # TODO: $language should be the name of the test Module
+ # that would open the door for Scheme::Test
my $language = $_[0];
$language = ucfirst($language) unless ( $language eq 'm4' );
@@ -445,16 +441,18 @@
$obj->{builder} = $builder;
$obj->{relpath} = $path_to_parrot;
$obj->{parrot} = $parrot;
- $obj->$delegate_func(@_[1..$#_]);
+ my $meth = $language_test_map{$func};
+ $obj->$meth(@_[1..$#_]);
# restore prior level, just in case.
$builder->level($level);
}
}
- my %c_test_map = ( c_output_is => 'is_eq',
- c_output_isnt => 'isnt_eq',
- c_output_like => 'like'
+ my %c_test_map = (
+ c_output_is => 'is_eq',
+ c_output_isnt => 'isnt_eq',
+ c_output_like => 'like'
);
foreach my $func ( keys %c_test_map ) {
@@ -553,7 +551,12 @@
}
}
-Parrot::Test::generate_functions(__PACKAGE__, \&generate_code );
+Parrot::Test::_generate_functions(__PACKAGE__, \&generate_code );
+
+=head1 TODO
+
+C<generate_code> should be renamed and be published to everybody who needs
+to generate files.
=head1 SEE ALSO
Modified: trunk/lib/Parrot/Test/m4.pm
==============================================================================
--- trunk/lib/Parrot/Test/m4.pm (original)
+++ trunk/lib/Parrot/Test/m4.pm Tue May 3 14:14:35 2005
@@ -1,12 +1,13 @@
# $Id$
-use strict;
-
package Parrot::Test::m4;
-require Parrot::Test;
+use strict;
+
+use Data::Dumper;
use File::Basename;
+require Parrot::Test;
=head1 NAME
@@ -28,59 +29,59 @@
return bless {};
}
-
-=head2 output_is
-
-This gets called when language_output_is() is called in a test file.
-
-=cut
-
-sub output_is {
- my $self = shift;
- my ( $code, $output, $desc ) = @_;
+my %language_test_map = (
+ output_is => 'is_eq',
+ output_like => 'like',
+ output_isnt => 'isnt_eq'
+ );
+
+foreach my $func ( keys %language_test_map ) {
+ no strict 'refs';
+
+ *{"Parrot::Test::m4::$func"} = sub ($$;$) {
+ my $self = shift;
+ my ( $code, $output, $desc ) = @_;
- my $count = $self->{builder}->current_test + 1;
+ my $count = $self->{builder}->current_test + 1;
- # flatten filenames (don't use directories)
- my $lang_f = Parrot::Test::per_test( '.m4', $count );
- my $parrot_m4_out_f = Parrot::Test::per_test( '.parrot_out', $count );
- my $gnu_m4_out_f = Parrot::Test::per_test( '.gnu_out', $count );
-
- my $test_prog_args = $ENV{TEST_PROG_ARGS} || '';
- my $parrot_m4 = "$self->{parrot} languages/m4/m4.pbc
${test_prog_args} languages/${lang_f}";
- my $gnu_m4 = "m4 ${test_prog_args} languages/${lang_f}";
-
- # This does nor create byte code, but m4 code
- my $parrotdir = dirname( $self->{parrot} );
- Parrot::Test::generate_code( $code, $parrotdir, $count, $lang_f );
-
- # STDERR is written into same output file
- my $parrot_exit_code = Parrot::Test::run_command(
- $parrot_m4,
- CD => $self->{relpath},
- STDOUT => $parrot_m4_out_f, STDERR => $parrot_m4_out_f
- );
- my $gnu_exit_code = Parrot::Test::run_command(
- $gnu_m4,
- CD => $self->{relpath},
- STDOUT => $gnu_m4_out_f, STDERR => $gnu_m4_out_f
- );
+ # flatten filenames (don't use directories)
+ my $lang_f = Parrot::Test::per_test( '.m4', $count );
+ my $m4_out_f = Parrot::Test::per_test( $ENV{PARROT_M4_TEST_PROG}
? '.gnu_out' : '.parrot_out', $count );
+ my $test_prog_args = $ENV{TEST_PROG_ARGS} || '';
+ my $test_prog = $ENV{PARROT_M4_TEST_PROG} ||
+ "$self->{parrot} languages/m4/m4.pbc";
+ $test_prog .= " ${test_prog_args} languages/${lang_f}";
+ # die Dumper( $test_prog, \%ENV );
+
+ # This does nor create byte code, but m4 code
+ my $parrotdir = dirname( $self->{parrot} );
+ Parrot::Test::generate_code( $code, $parrotdir, $count, $lang_f );
+
+ # STDERR is written into same output file
+ my $exit_code = Parrot::Test::run_command(
+ $test_prog,
+ CD => $self->{relpath},
+ STDOUT => $m4_out_f, STDERR => $m4_out_f
+ );
- my $pass = $self->{builder}->is_eq(
Parrot::Test::slurp_file($parrot_m4_out_f) .
Parrot::Test::slurp_file($gnu_m4_out_f),
- $output . $output,
- $desc );
- unless ( $pass )
- {
- my $diag = '';
- $diag .= "'$parrot_m4' failed with exit code $parrot_exit_code." if
$parrot_exit_code;
- $diag .= "'$gnu_m4' failed with exit code $gnu_exit_code.";
- $self->{builder}->diag( $diag ) if $diag;
- }
+ my $builder_func = $language_test_map{$func};
+ # That's the reason for: no strict 'refs';
+ my $pass = $self->{builder}->$builder_func(
+ Parrot::Test::slurp_file($m4_out_f),
+ $output,
+ $desc
+ );
+ unless ( $pass ) {
+ my $diag = '';
+ $diag .= "'$test_prog' failed with exit code $exit_code." if
$exit_code;
+ $self->{builder}->diag( $diag ) if $diag;
+ }
- # The generated files are left in the t/* directories.
- # Let 'make clean' and '.cvsignore' take care of them.
+ # The generated files are left in the t/* directories.
+ # Let 'make clean' and '.cvsignore' take care of them.
- return $pass;
+ return $pass;
+ }
}
1;
