cvsuser 03/06/27 12:12:49
Modified: languages/BASIC/compiler COMP_expressions.pm
COMP_parsefuncs.pm COMP_parser.pm compile.pl
testsuite.pl
Log:
Almost got COMMON working right...
Revision Changes Path
1.15 +2 -2 parrot/languages/BASIC/compiler/COMP_expressions.pm
Index: COMP_expressions.pm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/COMP_expressions.pm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -w -r1.14 -r1.15
--- COMP_expressions.pm 26 Jun 2003 03:24:15 -0000 1.14
+++ COMP_expressions.pm 27 Jun 2003 19:12:49 -0000 1.15
@@ -455,8 +455,8 @@
} else {
$$optype="N";
}
- #print "Registering $sym\n";
- $main::code{$main::seg}->{declarations}->{$sym}=1;
+ $main::code{$main::seg}->{declarations}->{$sym}=1
+ unless
$main::code{$main::seg}->{declarations}->{$sym} or $main::common{$sym};
}
return $sym;
} elsif ($type eq "STARTARG") {
1.18 +24 -1 parrot/languages/BASIC/compiler/COMP_parsefuncs.pm
Index: COMP_parsefuncs.pm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/COMP_parsefuncs.pm,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -w -r1.17 -r1.18
--- COMP_parsefuncs.pm 26 Jun 2003 03:24:15 -0000 1.17
+++ COMP_parsefuncs.pm 27 Jun 2003 19:12:49 -0000 1.18
@@ -7,7 +7,7 @@
use vars qw( %arrays );
use vars qw( $funcname $subname );
use vars qw( %labels $branchseq @selects);
-use vars qw( @data $sourceline );
+use vars qw( @data $sourceline %common );
use vars qw( %code $debug $runtime_jump);
@@ -17,6 +17,29 @@
@selects=();
my $scopes=0;
my @data=();
+sub parse_common {
+ feedme();
+ while($type[CURR] !~ /COMP|COMM|STMT/) {
+ $var=$syms[CURR];
+ feedme();
+ next if $var eq ",";
+ my $array=0;
+ if ($syms[CURR] eq "(") {
+ $array=1;
+ while($syms[CURR] ne ")") {
+ feedme;
+ }
+ feedme;
+ }
+ $var=~s/\$$/_string/;
+ push @{$code{$seg}->{code}}, "\t# $var was declared COMMON\n";
+ if (! $array) {
+ $main::code{$main::seg}->{declarations}->{$var}="COMMON";
+ $common{$var}=1;
+ }
+
+ }
+}
sub parse_shared { # Keyword only
feedme();
1.13 +1 -1 parrot/languages/BASIC/compiler/COMP_parser.pm
Index: COMP_parser.pm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/COMP_parser.pm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -w -r1.12 -r1.13
--- COMP_parser.pm 24 Jun 2003 01:54:14 -0000 1.12
+++ COMP_parser.pm 27 Jun 2003 19:12:49 -0000 1.13
@@ -140,7 +140,7 @@
while | wend | dim | type | exit | function | for | next |
do | loop | goto | gosub | return | sub | call | select | case |
read | restore | input | open | close | on | randomize | stop | swap |
- shared | cls | locate | color
+ common | cls | locate | color
)$/x) {
no strict 'refs';
&{"parse_" . $1}();
1.11 +30 -2 parrot/languages/BASIC/compiler/compile.pl
Index: compile.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/compile.pl,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- compile.pl 17 Jun 2003 02:51:54 -0000 1.10
+++ compile.pl 27 Jun 2003 19:12:49 -0000 1.11
@@ -7,7 +7,7 @@
use strict;
use Getopt::Std;
use vars qw( @tokens @tokdsc);
-use vars qw(%code %options @basic);
+use vars qw(%code %options @basic %common);
use vars qw( @syms @type );
use vars qw( %labels $runtime_jump $debug $sourceline);
use COMP_toker;
@@ -46,18 +46,46 @@
open(CODE, ">TARG_test.imc") || die;
print CODE qq{.include "RT_initialize.pasm"\n};
+#
+# Take care of the COMMON declarations
+#
+if (keys %common) {
+ my %code_copy=%code;
+ print CODE "# Declarations of common variables\n";
+ foreach my $seg ("_main", "_basicmain", keys %code) {
+ next unless exists $code{$seg};
+ if (exists $code{$seg}->{declarations}) {
+ foreach my $var (sort keys %{$code{$seg}->{declarations}}) {
+ next unless $code{$seg}->{declarations}->{$var} eq
"COMMON";
+ if ($var=~/_string$/) {
+ print CODE ".local string $var\n";
+ } else {
+ print CODE ".local float $var\n";
+ }
+ delete $code{$seg}->{declarations}->{$var};
+ }
+ }
+ delete $code{$seg};
+ }
+ %code=%code_copy;
+}
+
+
foreach my $seg ("_main", "_basicmain", keys %code) {
next unless exists $code{$seg};
my @debdecl=();
+ my @init=();
print CODE ".sub $seg\n";
if (exists $code{$seg}->{declarations}) {
foreach my $var (sort keys %{$code{$seg}->{declarations}}) {
if ($var=~/_string$/) {
print CODE "\t.local string $var\n";
+ push @init, qq{\t\tset $var, ""\n};
push @debdecl, "\t\tset \$P1[\"$var\"], $var\n";
} else {
print CODE "\t.local float $var\n";
+ push @init, qq{\t\tset $var, 0.0\n};
push @debdecl, "\t\tset \$S0, $var\n\t\tset
\$P1[\"$var\"], \$S0\n";
}
@@ -65,7 +93,7 @@
}
print CODE<<INIT;
.sub ${seg}_run # Always jump here.
- call ${seg}_main
[EMAIL PROTECTED] call ${seg}_main
ret
.end
INIT
1.11 +16 -0 parrot/languages/BASIC/compiler/testsuite.pl
Index: testsuite.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/testsuite.pl,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- testsuite.pl 26 Jun 2003 03:24:15 -0000 1.10
+++ testsuite.pl 27 Jun 2003 19:12:49 -0000 1.11
@@ -32,6 +32,22 @@
}
__DATA__
+' Expect 5, 0, "Hello"
+common i, a$
+sub mysub
+ print "In the sub\n"
+ print i
+ print j
+ print a$
+ print c$
+end sub
+j=2
+i=5
+a$="Hello"
+c$="WRONG"
+call mysub()
+
+STOPPLEASE
' Passing string arrays, expect 99 and "Hello"
function foo(i, thing$())
print i
