cvsuser 03/06/28 18:23:26
Modified: languages/BASIC/compiler COMP_expressions.pm
COMP_parsefuncs.pm RT_initialize.pasm compile.pl
testsuite.pl
Log:
Got COMMON working all right. The asteroids demo is almost ready. Trying it
on an ANSI-graphics system to see how it works.
Revision Changes Path
1.16 +3 -1 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.15
retrieving revision 1.16
diff -u -w -r1.15 -r1.16
--- COMP_expressions.pm 27 Jun 2003 19:12:49 -0000 1.15
+++ COMP_expressions.pm 29 Jun 2003 01:23:26 -0000 1.16
@@ -456,7 +456,7 @@
$$optype="N";
}
$main::code{$main::seg}->{declarations}->{$sym}=1
- unless
$main::code{$main::seg}->{declarations}->{$sym} or $main::common{$sym};
+ unless
$main::code{$main::seg}->{declarations}->{$sym};
}
return $sym;
} elsif ($type eq "STARTARG") {
@@ -541,8 +541,10 @@
push @work, [ "result of $extern()", "RESULT",
"\$$optype$retcount"];
} else {
$extern=~s/\$/_string/g; $extern=~tr/a-z/A-Z/;
+ push @code, qq{#SAVECOMMON};
push @code, qq{\t.arg $ac\t\t\t# argc};
push @code, qq{\tcall _USERFUNC_${extern}_run};
+ push @code, qq{#RESTORECOMMON};
push @code, "\t.result \$$optype$retcount";
push @work, [ "result of $extern()", "RESULT",
"\$$optype$retcount"];
$retcount++;
1.20 +1 -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.19
retrieving revision 1.20
diff -u -w -r1.19 -r1.20
--- COMP_parsefuncs.pm 27 Jun 2003 19:27:40 -0000 1.19
+++ COMP_parsefuncs.pm 29 Jun 2003 01:23:26 -0000 1.20
@@ -433,7 +433,7 @@
my $fd="";
my ($result, $type, @CODE);
feedme();
- if ($syms[CURR] eq "#") {
+ if ($syms[CURR] eq "#" and $type[CURR] eq "PUN") {
feedme();
$fd=$syms[CURR];
feedme();
1.8 +2 -0 parrot/languages/BASIC/compiler/RT_initialize.pasm
Index: RT_initialize.pasm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_initialize.pasm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- RT_initialize.pasm 24 Jun 2003 01:54:14 -0000 1.7
+++ RT_initialize.pasm 29 Jun 2003 01:23:26 -0000 1.8
@@ -19,6 +19,8 @@
store_global "PRINTCOL", $P0
$P0=new PerlHash
store_global "DEBUGGER", $P0
+ $P0=new PerlHash
+ store_global "COMMON", $P0
JUMPLABEL = ""
1.12 +67 -26 parrot/languages/BASIC/compiler/compile.pl
Index: compile.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/compile.pl,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- compile.pl 27 Jun 2003 19:12:49 -0000 1.11
+++ compile.pl 29 Jun 2003 01:23:26 -0000 1.12
@@ -46,31 +46,6 @@
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=();
@@ -78,6 +53,7 @@
print CODE ".sub $seg\n";
if (exists $code{$seg}->{declarations}) {
+ print CODE "\t.local PerlHash _GLOBALS\n";
foreach my $var (sort keys %{$code{$seg}->{declarations}}) {
if ($var=~/_string$/) {
print CODE "\t.local string $var\n";
@@ -93,15 +69,80 @@
}
print CODE<<INIT;
.sub ${seg}_run # Always jump here.
[EMAIL PROTECTED] call ${seg}_main
+ call ${seg}_main
ret
.end
INIT
+ my($edit,@saves);
print CODE "\t.sub ${seg}_main\n\t\tsaveall\n";
+
+ # If any "common" declared variables are in scope, set them up.
+ @saves=();
+ foreach my $var (keys %{$code{$seg}->{declarations}}) {
+ if (exists $main::common{$var}) {
+ push(@saves, $var);
+ }
+ }
+ if (@saves) {
+ print CODE qq{\t\t# Grab "COMMON" variables from global stash\n};
+ print CODE qq{\t\tfind_global _GLOBALS, "COMMON"\n};
+ foreach(@saves) {
+ print CODE qq{\t\t$_=_GLOBALS["$_"]\n};
+ }
+ }
+
+ # Emit the code for the segment
foreach(@{$code{$seg}->{code}}) {
s/#RTJ// if $runtime_jump;
+ if (/#SAVECOMMON/) {
+ @saves=();
+ $edit="";
+ foreach my $var (keys %{$code{$seg}->{declarations}}) {
+ if (exists $main::common{$var}) {
+ push(@saves, $var);
+ }
+ }
+ if (@saves) {
+ $edit.=qq{\tfind_global _GLOBALS, "COMMON"\n};
+ foreach(@saves) {
+ $edit.=qq{\t_GLOBALS["$_"]=$_\n};
+ }
+ $edit.=qq{\tstore_global "COMMON", _GLOBALS\n};
+ }
+ s/#SAVECOMMON/$edit/;
+ }
+ if (/#RESTORECOMMON/) {
+ @saves=();
+ $edit="";
+ foreach my $var (keys %{$code{$seg}->{declarations}}) {
+ if (exists $main::common{$var}) {
+ push(@saves, $var);
+ }
+ }
+ if (@saves) {
+ $edit.=qq{\tfind_global _GLOBALS, "COMMON"\n};
+ foreach(@saves) {
+ $edit.=qq{\t$_=_GLOBALS["$_"]\n};
+ }
+ }
+ s/#RESTORECOMMON/$edit/;
+ }
s/^/\t/gm;
print CODE;
+ }
+ # Put back all of the globals we've used in this sub
+ @saves=();
+ foreach my $var (keys %{$code{$seg}->{declarations}}) {
+ if (exists $main::common{$var}) {
+ push(@saves, $var);
+ }
+ }
+ if (@saves) {
+ print CODE qq{\t\tfind_global _GLOBALS, "COMMON"\n};
+ foreach(@saves) {
+ print CODE qq{\t_GLOBALS["$_"]=$_\n};
+ }
+ print CODE qq{\t\tstore_global "COMMON", _GLOBALS\n\t};
}
print CODE "\t\trestoreall\n\t\tret\n";
print CODE "\t.end\t# main segment\n";
1.13 +24 -0 parrot/languages/BASIC/compiler/testsuite.pl
Index: testsuite.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/testsuite.pl,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -w -r1.12 -r1.13
--- testsuite.pl 27 Jun 2003 19:27:40 -0000 1.12
+++ testsuite.pl 29 Jun 2003 01:23:26 -0000 1.13
@@ -47,6 +47,30 @@
c$="WRONG"
call mysub()
+
+STOPPLEASE
+' Expect 10
+sub second(b() )
+ b(5)=10
+end sub
+sub first(a() )
+ call second(a())
+end sub
+dim t(),f()
+call first(t())
+print t(5)
+
+
+' Expect OK
+y=59.7363
+x=19.506
+if ( y > 0 ) and (x > 0) then
+ print "OK"
+end if
+
+
+STOPPLEASE
+
' Passing string arrays, expect 99 and "Hello"
function foo(i, thing$())
print i
