Author: bernhard Date: Sun May 1 07:20:38 2005 New Revision: 7951 Modified: trunk/languages/scheme/Scheme.pm trunk/languages/scheme/Scheme/Builtins.pm trunk/languages/scheme/Scheme/Generator.pm trunk/languages/scheme/Scheme/Test.pm trunk/languages/scheme/schemec trunk/languages/scheme/t/harness trunk/languages/scheme/t/logic/defines.t Log: When trying scheme I got a bunch of test failures, most notable from calling invoke on PMCNULL. I tried to fix this by switching to using 'returncc' and 'interpinfo'. However tests 9 and 10 of t/logic/defines.t are still failing.
Modified: trunk/languages/scheme/Scheme.pm ============================================================================== --- trunk/languages/scheme/Scheme.pm (original) +++ trunk/languages/scheme/Scheme.pm Sun May 1 07:20:38 2005 @@ -1,29 +1,49 @@ +# $Id$ + package Scheme; use strict; use Data::Dumper; -use Scheme::Tokenizer qw(tokenize); -use Scheme::Parser qw(parse); -use Scheme::Generator qw(generate); +use Scheme::Tokenizer(); +use Scheme::Parser(); +use Scheme::Generator(); use Scheme::Builtins; +=head1 SUBROUTINES + +=head2 new + +A constructor + +=cut + sub new { - my ($class,$file) = @_; + my ($class, $file) = @_; + bless { file => $file },$class; } + +=head2 link_functions + +Generate PASM. + +=cut + sub link_functions { - my $main = shift; + my ( $main ) = @_; my @function = ( $main ); my @missing = @{$main->{functions}}; my @provides = keys %{$main->{scope}}; my $code = $main->{code}; - - my $header = "# Header information\n new_pad 0\n"; + my $header = << 'END_HEADER'; +# Header information + new_pad 0 +END_HEADER while (@missing) { my $miss = shift @missing; @@ -45,16 +65,24 @@ $code .= $link->{code}; } - $header . $code; + return $header . $code; } + +=head2 compile + +This is called in schemec. + +=cut + sub compile { my $self = shift; - $self->{tokens} = tokenize($self->{file}); - $self->{tree} = parse($self->{tokens}); - $self->{code} = link_functions(generate($self->{tree})); - print $self->{code}; + $self->{tokens} = Scheme::Tokenizer::tokenize($self->{file}); + $self->{tree} = Scheme::Parser::parse($self->{tokens}); + $self->{code} = link_functions(Scheme::Generator::generate($self->{tree})); + + return $self->{code}; } 1; Modified: trunk/languages/scheme/Scheme/Builtins.pm ============================================================================== --- trunk/languages/scheme/Scheme/Builtins.pm (original) +++ trunk/languages/scheme/Scheme/Builtins.pm Sun May 1 07:20:38 2005 @@ -24,6 +24,8 @@ ['', 'set', 'P5', 'P6[0]'], ['', 'save', 'P6'], ['', 'save', 'P1'], + ['', '.include', '"interpinfo.pasm"'], + ['', 'interpinfo', 'P0', '.INTERPINFO_CURRENT_SUB'], ['', 'invokecc'], ['', 'restore', 'P1'], ['', 'restore', 'P6'], @@ -38,7 +40,7 @@ ['', 'invokecc'], ['', 'restore', 'P1'], ['write_KET', 'print', '")"'], - ['write_RET', 'invoke', 'P1'], + ['write_RET', 'returncc'], ], apply => [['# Apply function'], Modified: trunk/languages/scheme/Scheme/Generator.pm ============================================================================== --- trunk/languages/scheme/Scheme/Generator.pm (original) +++ trunk/languages/scheme/Scheme/Generator.pm Sun May 1 07:20:38 2005 @@ -1,3 +1,5 @@ +# $Id$ + package Scheme::Generator; use strict; @@ -23,6 +25,7 @@ #------------------------------------ sub _new_regs { + return { I => { map { $_ => 0 } (0..31) }, N => { map { $_ => 0 } (0..31) }, @@ -32,9 +35,10 @@ }; sub _save { - my $self = shift; + my $self = shift; my $count = shift; my $type = shift || 'I'; + die "No registers to save" unless $count and $count>0; die "Illegal register type" @@ -382,7 +386,7 @@ $self->_add_inst('', 'set', ['P5', $temp]); $self->_add_inst('', 'pop_pad'); - $self->_add_inst('', 'invoke P1'); + $self->_add_inst('', 'returncc'); $self->_add_inst("DONE_$label"); $self->{regs} = pop @{$self->{frames}}; @@ -1931,7 +1935,7 @@ my $func_obj = shift; my $return = $self->_save_1 ('P'); - $self->_restore ($return); # dont need to save this + $self->_restore($return); # dont need to save this $self->_save_set; my $count = 5; @@ -1960,9 +1964,11 @@ $count++; } - $self->_add_inst ('', 'set', ['P0', $func_obj]) unless $func_obj eq 'P0'; - $self->_add_inst ('', 'invokecc'); - $self->_add_inst ('', 'set', [$return,'P5']) unless $return eq 'P5'; + $self->_add_inst('', 'set', ['P0', $func_obj]) unless $func_obj eq 'P0'; + $self->_add_inst('', 'set', ['I0', 0]); # Pass all args in Px registers + $self->_add_inst('', 'set', ['I3', $count-5]); # Tell about number of registers + $self->_add_inst('', 'invokecc'); + $self->_add_inst('', 'set', [$return,'P5']) unless $return eq 'P5'; $self->_restore_set; $return =~ /(\w)(\d+)/; @@ -2021,6 +2027,7 @@ sub _generate { my ($self,$node) = @_; + my $return; if (exists $node->{children}) { @@ -2048,11 +2055,13 @@ $return = $self->_constant($node->{value}); } } + return $return; } sub generate { my $tree = shift; + my $self = Scheme::Generator->new({}); my $temp; Modified: trunk/languages/scheme/Scheme/Test.pm ============================================================================== --- trunk/languages/scheme/Scheme/Test.pm (original) +++ trunk/languages/scheme/Scheme/Test.pm Sun May 1 07:20:38 2005 @@ -74,7 +74,7 @@ @_ = ( $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 + # if( $ok ) { foreach my $i ( $scheme_f, $as_f, $by_f, $out_f ) { unlink $i } } # JMG } } Modified: trunk/languages/scheme/schemec ============================================================================== --- trunk/languages/scheme/schemec (original) +++ trunk/languages/scheme/schemec Sun May 1 07:20:38 2005 @@ -1,4 +1,5 @@ #! perl -w +# $Id$ use strict; use lib '.'; @@ -12,6 +13,6 @@ } defined $ARGV[0] or Usage(); -$ARGV[0]=~/\.scheme$|\.scm$/i or Usage(); +$ARGV[0] =~ m/\.scheme$|\.scm$/i or Usage(); -Scheme->new($ARGV[0])->compile(); +print Scheme->new($ARGV[0])->compile(); Modified: trunk/languages/scheme/t/harness ============================================================================== --- trunk/languages/scheme/t/harness (original) +++ trunk/languages/scheme/t/harness Sun May 1 07:20:38 2005 @@ -1,8 +1,43 @@ #! perl -w +=head1 NAME + +scheme/t/harness - a harness for scheme + +=head1 DESCRIPTION + +If I'm called with a single +argument of "-files", I just return a list of files to process. +This list is one per line, and is relative to the languages dir. + +If I'm called with no args, I run the complete suite. + +Otherwise I run the tests that were passed on the command line. + +=cut + use strict; -use Test::Harness qw(runtests); use lib '../..'; [EMAIL PROTECTED] = map { glob( "t/$_/*.t" ) } qw(io arith logic) unless @ARGV; -runtests( @ARGV ); +use File::Spec; +use Test::Harness qw(runtests); + +my $language = "scheme"; + +my @files = map { glob( File::Spec->catfile( 't', $_, '*.t' ) ) } qw(io arith logic); +if ( grep { /^-files$/ } @ARGV ) { + # I must be running out of languages/ + my $dir = File::Spec->catfile( $language, "t" ); + print join("\n", @files); + print "\n" if @files; + exit; +} elsif (@ARGV) { + # Someone specified tests for me to run. + @files = grep {-f $_} @ARGV +} else { + # I must be running out of languages/$language +} + + +exit unless scalar( @files ); +runtests(@files); Modified: trunk/languages/scheme/t/logic/defines.t ============================================================================== --- trunk/languages/scheme/t/logic/defines.t (original) +++ trunk/languages/scheme/t/logic/defines.t Sun May 1 07:20:38 2005 @@ -29,9 +29,9 @@ (write a) CODE -output_is (<<'CODE', '(2 1)', 'define function'); +output_is (<<'CODE', '(18 17)', 'define function'); (define (f a b) (list b a)) -(write (f 1 2)) +(write (f 17 18)) CODE output_is (<<'CODE', '3', 'define via lambda');
