cvsuser 03/06/07 20:46:24
Modified: languages/BASIC/compiler COMP_expressions.pm
COMP_parsefuncs.pm COMP_parser.pm
RT_aggregates.pasm compile.pl testsuite.pl
Log:
Functions work, so does most kinds of arg passing. Still working on passing arrays
to functions
Revision Changes Path
1.8 +39 -21 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.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- COMP_expressions.pm 6 Jun 2003 21:25:56 -0000 1.7
+++ COMP_expressions.pm 8 Jun 2003 03:46:23 -0000 1.8
@@ -72,7 +72,13 @@
return 0;
}
sub isuserfunc {
- return 1 if (grep /^\Q$_[0]\E$/i, keys %functions );
+# print "Isuserfunc $_[0] and $funcname..";
+ return 0 if $funcname eq $_[0]; # We're processing this, don't count!
+ if (grep /^\Q$_[0]\E$/i, keys %functions ) {
+# print "Yes\n";
+ return 1;
+ }
+# print "No\n";
return 0
}
sub isarray {
@@ -366,11 +372,7 @@
}
if ($this->[1] eq "BARE") {
- my %lookup = ( '#' => "_hash",
- '!' => "",
- '&' => "_amp",
- '%' => "_percent");
- $this->[0]=~s/(%|!|\#|&)$/$lookup{$1}/e;
+ $this->[0]=changename($this->[0]);
}
push(@expr, $foo[$t]);
@@ -463,22 +465,16 @@
return unless @$work;
my @args=();
-# print "Work has ", scalar @$work, " things on it.\n";
while($$work[-1]->[0] ne "STARTARG") {
my $item=pop @$work;
- if ($item->[1] eq "RESULT") {
my $a1=pushthing($code, $optype, @$item);
- push @args, [ $a1, $item->[0] ];
- } else {
- my $a1=pushthing($code, $optype, @$item);
- push @args, [ $a1, $item->[0] ];
- }
+ push @args, [ $a1, @$item ];
}
foreach(@args) {
- push @$code, qq{\t.arg $_->[0]\t\t# $_->[1]};
+ push @$code, qq{\t.arg $_->[0]\t\t# $_->[0]};
}
pop @$work; # REmove startarg tag...
- return scalar @args;
+ return(scalar @args, @args);
}
sub optype_of {
my($func)[EMAIL PROTECTED];
@@ -507,21 +503,21 @@
next if ($sym eq ","); # Commas get ignored, args to stack
if (isarray($sym) and $lhs) {
- my $ac=pushargs([EMAIL PROTECTED], \$optype, [EMAIL
PROTECTED]);
+ my($ac,@args)=pushargs([EMAIL PROTECTED], \$optype, [EMAIL
PROTECTED]);
my $extern=$sym;
$optype=optype_of($extern);
push @code, qq{\t.arg $ac\t\t\t# argc};
push @code, qq{\tINSERT NEW VALUE HERE};
- push @code, qq{\t.arg "$extern"\t\t# array name};
+ push @code, qq{\t.arg "$extern$seg"\t\t# array name};
push @code, "\tcall _ARRAY_ASSIGN";
return("~Array", "$optype", @code);
} elsif (hasargs($sym)) {
- my $ac=pushargs([EMAIL PROTECTED], \$optype, [EMAIL
PROTECTED]);
+ my($ac,@args)=pushargs([EMAIL PROTECTED], \$optype, [EMAIL
PROTECTED]);
my $extern=$sym;
$optype=optype_of($extern);
if (isarray($sym)) {
push @code, qq{\t.arg $ac\t\t\t# argc};
- push @code, qq{\t.arg "$extern"\t\t# array name};
+ push @code, qq{\t.arg "$extern$seg"\t\t# array name};
push @code, "\tcall _ARRAY_LOOKUP_$optype";
push @code, "\t.result \$$optype$retcount";
push @work, [ "result of $extern()", "RESULT",
"\$$optype$retcount"];
@@ -535,8 +531,19 @@
$extern=~s/\$/_string/g; $extern=~tr/a-z/A-Z/;
push @code, qq{\t.arg $ac\t\t\t# argc};
push @code, qq{\tcall _USERFUNC_$extern};
- push @code, "\t.result $optype$retcount";
+ push @code, "\t.result \$$optype$retcount";
push @work, [ "result of $extern()", "RESULT",
"\$$optype$retcount"];
+ $retcount++;
+ foreach my $arg (@args) {
+ if ($arg->[2] eq "BARE") {
+ push @code, "\t.result $arg->[0]";
+ } else {
+ push @code, "\t.result \$"
+ . optype_of($arg->[0])
+ . "$retcount\t# Dummy, thrown away";
+ $retcount++;
+ }
+ }
}
$retcount++;
} else {
@@ -661,5 +668,16 @@
s/$/\n/ for @stream;
@stream=("\t#\n", "\t# Evaluating $whole\n", "\t# Result in $result of type
$type\n", @stream);
return($result, $type, @stream);
+}
+sub changename {
+ my($name)[EMAIL PROTECTED];
+ my %lookup = ( '#' => "_hash",
+ '!' => "",
+ '&' => "_amp",
+ '%' => "_percent",
+ );
+ $name=~s/(%|!|\#|&)$/$lookup{$1}/e;
+ $name=~tr/A-Z/a-z/;
+ return $name;
}
1;
1.11 +45 -53 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.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- COMP_parsefuncs.pm 6 Jun 2003 21:25:56 -0000 1.10
+++ COMP_parsefuncs.pm 8 Jun 2003 03:46:23 -0000 1.11
@@ -1064,7 +1064,7 @@
# Set aside storage for Array $var
\$P0 = new PerlHash
find_global \$P1, "BASICARR"
- set \$P1["$var"], \$P0
+ set \$P1["$var$seg"], \$P0
store_global "BASICARR", \$P1
#
DIMARR
@@ -1183,12 +1183,15 @@
sub parse_function {
feedme;
- open(CODESAVE, ">&CODE") || die "Cannot save CODE: $!";
- open(CODE, ">&FUNC") || die "Cannot connect CODE to FUNC: $!";
+ my $f;
$funcname=$syms[CURR];
- #print "Function $funcname $syms[CURR] CURR\n";
my $englishname=english_func($funcname);
$functions{$funcname}=$englishname;
+
+ $f="_USERFUNC_$funcname";
+ $f=changename($f);
+ $f=~s/\$/_string/g; $f=~tr/a-z/A-Z/;
+ $seg=$f;
CALL_BODY($englishname, "UF");
}
@@ -1210,60 +1213,53 @@
while($syms[CURR] ne ")") {
feedme();
}
- push(@params, "ARRAY", $a);
+ push(@params, $a);
} else {
- push(@params, typeof($syms[CURR]), $a);
+ push(@params, $a); # Always here?
}
}
}
my [EMAIL PROTECTED];
- print CODE <<FUNC_PREAMBLE;
- #
- # Function setup for $englishname( @params )
-${prefix}_$englishname:
- set S5, S0 # Remember the name of the function...
- bsr NEWFRAME
- restore I5 # Depth of arguments
- set I4, @{[ $argcnt/2 ]} # Expected depth <--- Compvar
- ne I5, I4, UF_ERRARGCNT
- new P5, .PerlArray
-FUNC_PREAMBLE
- @params=reverse @params;
- for($_=0; $_<=$#params; $_++) {
- print CODE qq{\tset P5[$_], "$params[$_]"\n};
- }
- for(0..((@params-1)/2)) {
- print CODE qq{\tbsr UF_ARGLOAD\n};
+ # The outer compiler will provide the framework for the
+ # function call. We just have to unwind its arguments.
+ $_=scalar @params;
+ push @{$code{$seg}->{code}}, <<EOH;
+ .param int argc
+ eq argc, $_, ${englishname}_ARGOK
+ print "Function $englishname received "
+ print argc
+ print " arguments expected $_\\n"
+ end
+${englishname}_ARGOK:
+EOH
+
+ foreach (@params) {
+ my $t=typeof($_);
+ $t="string" if $t eq "STRING";
+ $t="float" if $t eq "FLO";
+ $_=changename($_);
+ $_=~s/\$/_string/g;
+ push @{$code{$seg}->{code}}, qq{\t.param $t $_\n};
+ push @{$code{$seg}->{args}}, $_;
}
- print CODE <<F_PREAMBLE2;
- #destroy P5
- #
- # BEGIN $prefix code for $englishname
- #
-F_PREAMBLE2
+ return;
}
sub parse_endfunc {
feedme;
- print CODE<<POSTSCRIPT;
[EMAIL PROTECTED] english_func($funcname)]}:
- #
- # Teardown code for $funcname
- #
- #print "Exiting the user function $funcname\\n"
- set S0, "$funcname"
- bsr VARLOOKUP
- bsr VARSTUFF # Pack into P6
- set P6, P0 # Curly shuffle.
- bsr ENDFRAME
- set I1, 0 # Function found, exectued OK.
- branch UF_DISPATCH_END # Return to caller.
- #
- #
-POSTSCRIPT
-
- open(CODE, ">&CODESAVE") || die "Can't re-open code FH: $!";
+ my $t=$seg;
+ $seg=~s/^_//; # Remove the _
+ $seg=~tr/A-Z/a-z/; # lowercase
+ $seg=~s/userfunc_//;
+ if (exists $code{$t}->{args}) {
+ foreach(@{$code{$t}->{args}}) {
+ push @{$code{$t}->{code}}, "\t.return $_\t# Returning arg\n";
+ }
+ }
+ push @{$code{$t}->{code}}, "\t.return $seg\n";
+ $seg="_basicmain";
$funcname="";
+ return;
}
sub parse_endsub {
feedme;
@@ -1376,7 +1372,6 @@
sub parse_data_setup {
push @{$code{_data}->{code}},<<DATAPREP;
# Prepare the Read/Data stuff
- saveall
find_global \$P1, "RESTOREINFO"
find_global \$P2, "READDATA"
DATAPREP
@@ -1398,14 +1393,11 @@
push @{$code{_data}->{code}},<<DATADONE;
store_global "RESTOREINFO", \$P1
store_global "READDATA", \$P2
- restoreall
- ret
DATADONE
}
sub typeof {
my($var)[EMAIL PROTECTED];
- return "INT" if ($var=~/[%&]$/);
- return "FLO" if ($var=~/[!#]$/);
+ return "FLO" if ($var=~/[!#%&]$/);
return "STRING" if ($var=~/\$$/);
return "FLO"
}
1.9 +10 -9 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.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- COMP_parser.pm 6 Jun 2003 21:25:56 -0000 1.8
+++ COMP_parser.pm 8 Jun 2003 03:46:23 -0000 1.9
@@ -62,6 +62,7 @@
# ###################
# Program Termination
# ###################
+ restoreall
ret # back to _main
SHUTDOWN
@@ -279,15 +280,15 @@
# function assignment... WRONG-O!
# Don't go looking for lhs expression, please.
- if ($syms[NEXT] eq "=" and exists $functions{$syms[CURR]}) {
- # Assignment statement
- my $var=$syms[CURR];
- feedme; # Get the =
- #print "Going to expression with $syms[CURR]\n";
- print CODE EXPRESSION; # Evaluate the expression all queued
up.
- ASSIGNMENT_FUNC($var);
- goto PARSE_NOFEED;
- }
+ #if ($syms[NEXT] eq "=" and exists $functions{$syms[CURR]}) {
+ # # Assignment statement
+ # my $var=$syms[CURR];
+ # feedme; # Get the =
+ # #print "Going to expression with $syms[CURR]\n";
+ # print CODE EXPRESSION; # Evaluate the expression all queued
up.
+ # ASSIGNMENT_FUNC($var);
+ # goto PARSE_NOFEED;
+ #}
if ($syms[CURR] eq "_startasm") {
feedme;
1.4 +10 -0 parrot/languages/BASIC/compiler/RT_aggregates.pasm
Index: RT_aggregates.pasm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_aggregates.pasm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- RT_aggregates.pasm 6 Jun 2003 21:25:56 -0000 1.3
+++ RT_aggregates.pasm 8 Jun 2003 03:46:23 -0000 1.4
@@ -12,8 +12,13 @@
call _ARRAY_BUILDKEY
.result key
set $P0, BASICARR[array]
+ ne key, "", ARR_NORMAL
+ .return $P0 # Return the whole array.
+ branch ARR_END
+ARR_NORMAL:
set $N0, $P0[key]
.return $N0
+ARR_END:
restoreall
ret
.end
@@ -26,8 +31,13 @@
call _ARRAY_BUILDKEY
.result key
set $P0, BASICARR[array]
+ ne key, "", ARR_NORMAL
+ .return $P0
+ branch ARR_END
+ARR_NORMAL:
set $S0, $P0[key]
.return $S0
+ARR_END:
restoreall
ret
.end
1.5 +3 -3 parrot/languages/BASIC/compiler/compile.pl
Index: compile.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/compile.pl,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- compile.pl 6 Jun 2003 21:25:56 -0000 1.4
+++ compile.pl 8 Jun 2003 03:46:23 -0000 1.5
@@ -45,12 +45,12 @@
print CODE qq{.include "RT_initialize.pasm"\n};
my $debug=0;
-foreach my $seg ("_main", keys %code) {
+foreach my $seg ("_main", "_basicmain", keys %code) {
next unless exists $code{$seg};
my @debdecl=();
$debug=1 if (grep /debug/, @ARGV);
- print CODE ".sub $seg\n";
+ print CODE ".sub $seg\n\tsaveall\n";
if (exists $code{$seg}->{declarations}) {
foreach my $var (sort keys %{$code{$seg}->{declarations}}) {
if ($var=~/_string$/) {
@@ -91,7 +91,7 @@
ret
EOD
}
- print CODE ".end\n";
+ print CODE "\trestoreall\n\tret\n.end\n";
delete $code{$seg};
}
print CODE<<RUNTIMESHUTDOWN;
1.6 +48 -2 parrot/languages/BASIC/compiler/testsuite.pl
Index: testsuite.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/testsuite.pl,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- testsuite.pl 6 Jun 2003 21:25:56 -0000 1.5
+++ testsuite.pl 8 Jun 2003 03:46:23 -0000 1.6
@@ -9,7 +9,7 @@
local $/="";
$_=<DATA>;
}
- if (/function/ or /end sub/ or /type / or /select/) {
+ if (/end sub/ or /type / or /select/) { # /function/
print "Skipped\n";
next;
}
@@ -32,6 +32,41 @@
}
__DATA__
+' Function Array scopes, expect 4, 5.6
+function mine(a)
+ dim t(6)
+ t(3)=2
+ mine=a*2
+ print t(3)*2
+end function
+dim t(7)
+t(3)=5.6
+a=mine(5)
+print t(3)
+
+
+STOPPLEASE
+' Passing arrays (expect 12)
+function arrfunc(x())
+ print x(4)
+ arrfunc=55
+end function
+dim g(10)
+g(4)=12
+y=arrfunc(g())
+
+STOPPLEASE
+' Expect 234
+function inkey$(a, b)
+ a=3.14
+ inkey$="234"
+end function
+s$=inkey$(r, 45)
+print s$
+print r
+
+1740 print "Branched"
+ end
' Logical Operators
print " AND OR XOR EQV IMP a & ! b"
for i = 0 to 1
@@ -39,12 +74,23 @@
print i; j;
if i and j then a$="True " else a$="False "
if i or j then b$="True " else b$="False "
-if i xor j then c$="True " else c$="False "
if i eqv j then d$="True " else d$="False "
if i imp j then e$="True " else e$="False "
if i and not j then f$="True " else f$="False "
print a$;b$;c$;d$;e$;f$
next j,i
+
+' Function Array scopes, expect 4, 5.6
+function mine(a)
+ dim t(6)
+ t(3)=2
+ mine=a*2
+ print t(3)*2
+end function
+dim t(7)
+t(3)=5.6
+a=mine(5)
+print t(3)
' Unary minus goodness
Dim t7(1),w(10)
