Author: bernhard
Date: Fri Oct 5 12:26:58 2007
New Revision: 21890
Modified:
trunk/languages/scheme/lib/Scheme.pm
trunk/languages/scheme/lib/Scheme/Builtins.pm
trunk/languages/scheme/lib/Scheme/Generator.pm
trunk/languages/scheme/t/logic/basic.t
Log:
[Scheme]
Start to adapt to the, not so new, calling conventions.
Modified: trunk/languages/scheme/lib/Scheme.pm
==============================================================================
--- trunk/languages/scheme/lib/Scheme.pm (original)
+++ trunk/languages/scheme/lib/Scheme.pm Fri Oct 5 12:26:58 2007
@@ -1,5 +1,5 @@
# $Id$
-# Copyright (C) 2001-2006, The Perl Foundation.
+# Copyright (C) 2001-2007, The Perl Foundation.
package Scheme;
@@ -10,9 +10,9 @@
use Data::Dumper;
-use Scheme::Tokenizer();
-use Scheme::Parser();
-use Scheme::Generator();
+use Scheme::Tokenizer ();
+use Scheme::Parser ();
+use Scheme::Generator ();
use Scheme::Builtins;
=head1 SUBROUTINES
@@ -26,12 +26,13 @@
sub new {
my ( $class, $file ) = @_;
- bless { file => $file }, $class;
+ return bless { file => $file }, $class;
}
=head2 link_functions
-Generate PASM.
+Generate PIR.
+Make sure that the used functions end up in the PIR.
=cut
@@ -43,18 +44,18 @@
my @provides = keys %{ $main->{scope} };
my $code = $main->{code};
- my $header = << 'END_HEADER';
-# Header information
- # new_pad 0
+ my $header = <<'END_HEADER';
+# PIR generated by Scheme.
+
+ # used builtins:
END_HEADER
while (@missing) {
my $miss = shift @missing;
my $link = Scheme::Builtins->generate($miss);
- $header .= << "END";
- newsub P16, .Sub, ${miss}_ENTRY
- store_lex 0, "$miss", P16
+ $header .= <<"END";
+ # $miss
END
push @function, $miss;
Modified: trunk/languages/scheme/lib/Scheme/Builtins.pm
==============================================================================
--- trunk/languages/scheme/lib/Scheme/Builtins.pm (original)
+++ trunk/languages/scheme/lib/Scheme/Builtins.pm Fri Oct 5 12:26:58 2007
@@ -14,38 +14,41 @@
my %built_ins = (
write => [
[ '# Write function', '' ],
- [ 'write_ENTRY', 'typeof', 'I0', 'P5' ],
- [ '', 'ne', 'I0', '.Undef', 'write_N_UNDEF' ],
+ [ '', '.sub', 'write' ],
+ [ '', '.param pmc', 'arg1' ],
+ [ '', 'ne', 'I0', '.Undef', 'write_N_LAMBDA' ],
[ '', 'print', '"()"' ],
- [ '', 'branch', 'write_RET' ],
- [ 'write_N_UNDEF', 'ne', 'I0', '.Scratchpad', 'write_N_LAMBDA' ],
- [ '', 'print', '"lambda"' ],
- [ '', 'branch', 'write_RET' ],
+ [ '#', 'branch', 'write_RET' ],
+ [ '#write_N_UNDEF', 'ne', 'I0', '.Scratchpad', 'write_N_LAMBDA' ],
+ [ '#', 'print', '"lambda"' ],
+ [ '#', 'branch', 'write_RET' ],
[ 'write_N_LAMBDA', 'eq', 'I0', '.Array', 'write_ARRAY' ],
- [ '', 'print', 'P5' ],
- [ '', 'branch', 'write_RET' ],
- [ 'write_ARRAY', 'print', '"("' ],
- [ 'write_NEXT', 'set', 'P6', 'P5' ],
- [ '', 'set', 'P5', 'P6[0]' ],
- [ '', 'save', 'P6' ],
- [ '', 'save', 'P1' ],
- [ '', '.include', '"interpinfo.pasm"' ],
- [ '', 'interpinfo', 'P0', '.INTERPINFO_CURRENT_SUB' ],
- [ '', 'invokecc' ],
- [ '', 'restore', 'P1' ],
- [ '', 'restore', 'P6' ],
- [ '', 'set', 'P5', 'P6[1]' ],
- [ '', 'typeof', 'I0', 'P5' ],
- [ '', 'eq', 'I0', '.Undef', 'write_KET' ],
- [ '', 'ne', 'I0', '.Array', 'write_DOT' ],
- [ '', 'print', '" "' ],
- [ '', 'branch', 'write_NEXT' ],
- [ 'write_DOT', 'print', '" . "' ],
- [ '', 'save', 'P1' ],
- [ '', 'invokecc' ],
- [ '', 'restore', 'P1' ],
- [ 'write_KET', 'print', '")"' ],
- [ 'write_RET', 'returncc' ],
+ [ '', 'print', 'arg1' ],
+ [ 'write_ARRAY', '', '' ],
+ [ '', '.end' ],
+ [ '#', 'branch', 'write_RET' ],
+ [ '#write_ARRAY', 'print', '"("' ],
+ [ '#write_NEXT', 'set', 'P6', 'arg1' ],
+ [ '#', 'set', 'arg1', 'P6[0]' ],
+ [ '#', 'save', 'P6' ],
+ [ '#', 'save', 'P1' ],
+ [ '#', '.include', '"interpinfo.pasm"' ],
+ [ '#', 'interpinfo', 'P0', '.INTERPINFO_CURRENT_SUB' ],
+ [ '#', 'invokecc', 'P0' ],
+ [ '#', 'restore', 'P1' ],
+ [ '#', 'restore', 'P6' ],
+ [ '#', 'set', 'arg1', 'P6[1]' ],
+ [ '#', 'typeof', 'I0', 'arg1' ],
+ [ '#', 'eq', 'I0', '.Undef', 'write_KET' ],
+ [ '#', 'ne', 'I0', '.Array', 'write_DOT' ],
+ [ '#', 'print', '" "' ],
+ [ '#', 'branch', 'write_NEXT' ],
+ [ '#write_DOT', 'print', '" . "' ],
+ [ '#', 'save', 'P1' ],
+ [ '#', 'invokecc' ],
+ [ '#', 'restore', 'P1' ],
+ [ '#write_KET', 'print', '")"' ],
+ [ '#', '.end' ],
],
apply => [
['# Apply function'],
@@ -133,7 +136,7 @@
my $self = Scheme::Builtins->new();
- for ( @{ $built_ins{$name} } ) {
+ foreach ( @{ $built_ins{$name} } ) {
my ( $label, $op, @args ) = @{$_};
$self->_add_inst( $label, $op, [EMAIL PROTECTED] );
}
Modified: trunk/languages/scheme/lib/Scheme/Generator.pm
==============================================================================
--- trunk/languages/scheme/lib/Scheme/Generator.pm (original)
+++ trunk/languages/scheme/lib/Scheme/Generator.pm Fri Oct 5 12:26:58 2007
@@ -65,7 +65,7 @@
my %regs = %{ $self->{regs} };
for my $type ( keys %regs ) {
for my $count ( 0 .. 31 ) {
- $self->_add_inst( '', 'save', ["$type$count"] )
+ $self->_add_inst( '#', 'save', ["$type$count"] )
if $regs{$type}->{$count};
}
}
@@ -107,7 +107,7 @@
for my $type ( reverse keys %regs ) {
for ( my $count = 31 ; $count >= 0 ; $count-- ) {
- $self->_add_inst( '', 'restore', ["$type$count"] )
+ $self->_add_inst( '#', 'restore', ["$type$count"] )
if $regs{$type}->{$count};
}
}
@@ -149,6 +149,15 @@
return $return;
}
+sub _find_name {
+ my ( $self, $symbol ) = @_;
+
+ my $return = $self->_save_1('P');
+ $self->_add_inst( '', 'find_name', [ $return, qq{"$symbol"} ] );
+
+ return $return;
+}
+
sub _store_lex {
my ( $self, $symbol, $value ) = @_;
@@ -2009,7 +2018,7 @@
my $self = shift;
my $symbol = shift;
- my $func_obj = $self->_find_lex($symbol);
+ my $func_obj = $self->_find_name($symbol);
my $scope = $self->{scope};
@@ -2037,6 +2046,7 @@
my $count = 5;
my $empty = $return;
+ my @args;
while ( my $arg = shift ) {
if ( $arg ne "P$count" ) {
if ( $arg =~ /^[INS]/ ) {
@@ -2054,18 +2064,17 @@
}
}
if ($moved) {
- $self->_add_inst( '', 'set', [ $empty, "P$count" ] );
+ push @args, $count;
$empty = $moved;
}
$self->_add_inst( '', 'set', [ "P$count", $arg ] );
+ push @args, $count;
}
$count++;
}
- $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_args', [ q{"} . join( q{,}, q{0} x
scalar(@args) ) . q{"}, join( q{,}, map { "P$_" } @args ) ] );
+ $self->_add_inst( '', 'invokecc', [ $func_obj ] );
$self->_add_inst( '', 'set', [ $return, 'P5' ] ) unless $return eq 'P5';
$self->_restore_set;
@@ -2184,6 +2193,7 @@
$self->_add_inst( '', '.end' );
+ # die Dumper( $self );
$self->_format_columns();
# not need any more
Modified: trunk/languages/scheme/t/logic/basic.t
==============================================================================
--- trunk/languages/scheme/t/logic/basic.t (original)
+++ trunk/languages/scheme/t/logic/basic.t Fri Oct 5 12:26:58 2007
@@ -8,23 +8,28 @@
use FindBin;
use lib "$FindBin::Bin/../../lib";
-#use Test::More tests => 7;
-use Test::More skip_all => 'Using obsolete calling conventions';
+use Test::More tests => 7;
+
use Parrot::Test;
###
### If
###
-output_is( <<'CODE', 1, 'basic if - Fail' );
+language_output_is( 'Scheme', <<'CODE', 1, 'basic if - Fail' );
(write (if (= 1 1) 1 0))
CODE
-output_is( <<'CODE', 1, 'basic if - Pass' );
+
+SKIP:
+{
+ skip( "adaption to calling converions is underway", 6 );
+
+language_output_is( 'Scheme', <<'CODE', 1, 'basic if - Pass' );
(write (if (= 0 1) 0 1))
CODE
-output_is( <<'CODE', 7, 'slightly more complex if' );
+language_output_is( 'Scheme', <<'CODE', 7, 'slightly more complex if' );
(write (if (= 9 9) 7 -23))
CODE
@@ -32,11 +37,11 @@
### And
###
-output_is( <<'CODE', 1, 'basic and - Pass' );
+language_output_is( 'Scheme', <<'CODE', 1, 'basic and - Pass' );
(write (and 1 1))
CODE
-output_is( <<'CODE', 0, 'basic and - Fail' );
+language_output_is( 'Scheme', <<'CODE', 0, 'basic and - Fail' );
(write (and 0 1))
CODE
@@ -44,14 +49,16 @@
### Or
###
-output_is( <<'CODE', 1, 'basic or - Pass' );
+language_output_is( 'Scheme', <<'CODE', 1, 'basic or - Pass' );
(write (or 1 1))
CODE
-output_is( <<'CODE', 0, 'basic or - Fail' );
+language_output_is( 'Scheme', <<'CODE', 0, 'basic or - Fail' );
(write (or 0 0))
CODE
+}
+
# Local Variables:
# mode: cperl
