cvsuser 03/06/29 15:43:49
Modified: languages/BASIC/compiler COMP_expressions.pm
COMP_parsefuncs.pm COMP_parser.pm COMP_toker.pm
RT_aggregates.pasm RT_builtins.pasm
RT_initialize.pasm RT_io.pasm testsuite.pl
Log:
Many small bugs fixed, preparing for hash madness
Revision Changes Path
1.17 +5 -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.16
retrieving revision 1.17
diff -u -w -r1.16 -r1.17
--- COMP_expressions.pm 29 Jun 2003 01:23:26 -0000 1.16
+++ COMP_expressions.pm 29 Jun 2003 22:43:48 -0000 1.17
@@ -486,7 +486,10 @@
return(scalar @args, @args);
}
sub optype_of {
- my($func)[EMAIL PROTECTED];
+ my($func, $extra)[EMAIL PROTECTED];
+ if ($extra and $extra->[2] eq "STRING") {
+ return "S";
+ }
if ($func=~/\$$/) {
return "S";
} else {
@@ -557,7 +560,7 @@
push @code, "\t.result $arg->[0]";
} else {
push @code, "\t.result \$"
- . optype_of($arg->[0])
+ . optype_of($arg->[0], $arg)
. "$retcount\t# Dummy, thrown away";
$retcount++;
}
1.21 +31 -29 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.20
retrieving revision 1.21
diff -u -w -r1.20 -r1.21
--- COMP_parsefuncs.pm 29 Jun 2003 01:23:26 -0000 1.20
+++ COMP_parsefuncs.pm 29 Jun 2003 22:43:48 -0000 1.21
@@ -128,16 +128,10 @@
push @{$code{$seg}->{code}}, $prompt;
my $sf=1;
- if ($filedesc) {
- # FIXME, P17 is still global
- push @{$code{$seg}->{code}}, qq{\tset I1, P17["$filedesc"]\n};
- push @{$code{$seg}->{code}}, qq{\teq I1, 0, ERR_BADF\n};
- $sf=0;
- } else {
- push @{$code{$seg}->{code}}, "\t.arg $filedesc # STDIN\n";
- }
+ $sf=0 if ($filedesc);
push @{$code{$seg}->{code}},<<INP1;
+ .arg $filedesc
call _READLINE
.result \$S0
.arg $sf
@@ -150,7 +144,7 @@
# Bug here...FIXME.. I'm using $vars before it's set.
$vars=1;
if ($noreloop) {
- push @{$code{$seg}->{code}}, "\tne \$I0, $vars, ERR_INPFIELDS\n";
+ push @{$code{$seg}->{code}}, "\t#ne \$I0, $vars, ERR_INPFIELDS\n";
} else {
push @{$code{$seg}->{code}}, "\tne \$I0, $vars, INPUT_$inputcounts #
Re-prompt\n";
}
@@ -233,7 +227,7 @@
gt $result, 255.0, ONERR_${ons}
branch ONOK_${ons}
ONERR_${ons}:
- call _ERR_ON_RANGE
+ print "On...goto/gosub out of range at $sourceline\\n"
call _platform_shutdown
end
ONOK_${ons}:
@@ -361,15 +355,15 @@
feedme();
}
sub parse_open {
- my(@filename)=EXPRESSION;
+ ($result, $type, @code)=EXPRESSION();
feedme();
die "Expecting FOR at $sourceline" unless $syms[CURR] eq "for";
feedme();
my $mode="";
if ($syms[CURR] eq "input") {
- $mode="r";
+ $mode="<";
} elsif ($syms[CURR] eq "output") {
- $mode="w";
+ $mode=">";
} elsif ($syms[CURR] eq "random") {
die "random file i/o not implemented yet at $sourceline"
} else {
@@ -381,14 +375,11 @@
die "Expecting #" unless $syms[CURR] eq "#";
feedme();
$fd=$syms[CURR];
- print CODE <<OPEN;
[EMAIL PROTECTED]
- bsr DEREF
- bsr UNSTUFF
- ne S2, "STRING", ERR_FN
- set S1, "$mode"
- bsr OPEN
- set P17["$fd"], I0
+ push @{$code{$seg}->{code}},<<OPEN;
[EMAIL PROTECTED] .arg $fd
+ .arg "$mode"
+ .arg $result
+ call _OPEN
OPEN
}
sub parse_close {
@@ -396,18 +387,20 @@
die "Expecting # at $sourceline" unless $syms[CURR] eq "#";
feedme();
$fd=$syms[CURR];
- print CODE<<CLOSE;
- set I0, P17["$fd"]
- bsr CLOSE
- set P17["$fd"], 0
+ push @{$code{$seg}->{code}},<<CLOSE;
+ .arg $fd
+ call _CLOSE
CLOSE
}
sub fdprint {
my($fd, $string)[EMAIL PROTECTED];
if ($fd) {
- print CODE qq{\tset S0, "$string"\n};
- print CODE qq{\tset I1, P17["$fd"]\n};
- print CODE qq{\tbsr PRINTLINE\n};
+ push @{$code{$seg}->{code}}, <<PRINT;
+ .arg "$string"
+ .arg 1
+ .arg $fd
+ call _WRITE
+PRINT
} else {
if ($string ne "\\n") {
push @{$code{$seg}->{code}}, <<PRINT;
@@ -474,11 +467,20 @@
last if $expr;
($result, $type, @code)=EXPRESSION({nofeed => 1});
feedme();
+ if ($fd) {
+ push @{$code{$seg}->{code}}, <<PRINT;
[EMAIL PROTECTED] .arg $result
+ .arg 1
+ .arg $fd
+ call _WRITE
+PRINT
+ } else {
push @{$code{$seg}->{code}}, <<PRINT;
@code .arg $result
.arg 1
call _BUILTIN_DISPLAY
PRINT
+ }
#print "After Expression have $type[CURR] $syms[CURR]\n";
$eol=0;
$expr=1;
1.14 +3 -3 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.13
retrieving revision 1.14
diff -u -w -r1.13 -r1.14
--- COMP_parser.pm 27 Jun 2003 19:12:49 -0000 1.13
+++ COMP_parser.pm 29 Jun 2003 22:43:48 -0000 1.14
@@ -120,15 +120,15 @@
defint | const | declare | lprint | static # Maybe
these...
)$/x) {
print "WARNING: $syms[CURR] is unimplemented, skipping.\n";
- print CODE "\t# Unimplemented '$syms[CURR] ";
+ push @{$code{$seg}->{code}}, "\t# Unimplemented '$syms[CURR] ";
while(1) {
feedme();
$_=$type[CURR];
last unless $_;
last if $_ =~ /STMT|COMM|COMP/;
- print CODE "$syms[CURR] ";
+ push @{$code{$seg}->{code}}, "$syms[CURR] ";
}
- print CODE "'\n";
+ push @{$code{$seg}->{code}}, "'\n";
goto PARSE;
}
if ($syms[CURR] eq "redim") {
1.2 +2 -1 parrot/languages/BASIC/compiler/COMP_toker.pm
Index: COMP_toker.pm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/COMP_toker.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- COMP_toker.pm 9 Mar 2003 23:08:47 -0000 1.1
+++ COMP_toker.pm 29 Jun 2003 22:43:48 -0000 1.2
@@ -208,7 +208,8 @@
die "unknown: $cur at source line $stmts";
goto MAIN;
-END: return;
+END: emit("STMT");
+ return;
}
1.5 +16 -16 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.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- RT_aggregates.pasm 8 Jun 2003 03:46:23 -0000 1.4
+++ RT_aggregates.pasm 29 Jun 2003 22:43:48 -0000 1.5
@@ -120,23 +120,23 @@
restoreall
ret
.end
-.sub _ARRAY_ASSIGN_S # void ARRAY_ASSIGN_N(string array, string rhs, int keycount[,
string|float keys])
- saveall
- .param string array
- .param string rhs
- .local string key
- .local PerlHash BASICARR
- find_global BASICARR, "BASICARR"
+#.sub _ARRAY_ASSIGN_S # void ARRAY_ASSIGN_N(string array, string rhs, int
keycount[, string|float keys])
+# saveall
+# .param string array
+# .param string rhs
+# .local string key
+# .local PerlHash BASICARR
+# find_global BASICARR, "BASICARR"
- call _ARRAY_BUILDKEY # Will absorb rest of arguments.
- .result key
- set $P0, BASICARR[array]
- set $P0[key], rhs
-
- store_global "BASICARR", BASICARR
- restoreall
- ret
-.end
+# call _ARRAY_BUILDKEY # Will absorb rest of arguments.
+# .result key
+# set $P0, BASICARR[array]
+# set $P0[key], rhs
+#
+# store_global "BASICARR", BASICARR
+# restoreall
+# ret
+#.end
# These are probably defined somewhere, I can't find them.
.const int FLOAT = 2
.const int STRING = 3
1.9 +14 -2 parrot/languages/BASIC/compiler/RT_builtins.pasm
Index: RT_builtins.pasm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_builtins.pasm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- RT_builtins.pasm 24 Jun 2003 13:22:31 -0000 1.8
+++ RT_builtins.pasm 29 Jun 2003 22:43:48 -0000 1.9
@@ -2,7 +2,19 @@
#
.const int FLOAT = 2
.const int STRING = 3
-.sub _BUILTIN_DISPLAY # void display(string|float thingy[,
string|float thingy2])
+.sub _BUILTIN_DISPLAY # void display(....)
+ saveall
+ .local string buf
+ call _BUILTIN_DISPLAY_WORK
+ .result buf
+ print buf
+ restoreall
+ ret
+.end
+# Prepares stuff for printing. Side effect: edits the global PRINTCOL
+# for the current column.
+#
+.sub _BUILTIN_DISPLAY_WORK # string display_work(string|float thingy[,
string|float thingy2])
saveall
.param int argc
.local string buf
@@ -64,7 +76,7 @@
DISPNL: set PRINTCOL, 0
branch NEXT
END_DISPLAY:
- print buf
+ .return buf
set $P0["value"], PRINTCOL
store_global "PRINTCOL", $P0
restoreall
1.9 +8 -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.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- RT_initialize.pasm 29 Jun 2003 01:23:26 -0000 1.8
+++ RT_initialize.pasm 29 Jun 2003 22:43:48 -0000 1.9
@@ -21,6 +21,14 @@
store_global "DEBUGGER", $P0
$P0=new PerlHash
store_global "COMMON", $P0
+ $P0=new PerlArray
+ fdopen $P1, 0, "r" # STDIN and friends...
+ $P0[0]=$P1
+ fdopen $P1, 1, "w"
+ $P0[1]=$P1
+ fdopen $P1, 2, "w"
+ $P0[2]=$P1
+ store_global "FDS", $P0
JUMPLABEL = ""
1.4 +70 -43 parrot/languages/BASIC/compiler/RT_io.pasm
Index: RT_io.pasm
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_io.pasm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- RT_io.pasm 24 Jun 2003 01:54:14 -0000 1.3
+++ RT_io.pasm 29 Jun 2003 22:43:48 -0000 1.4
@@ -4,58 +4,78 @@
#
# Not a lot of error handling here yet
.sub _READCHARS # string readchars(int numchar, int fd)
- call _line_read
-
saveall
.param int numchar
.param int fd
+ ne fd, 0, NORESET
+ call _line_read
+NORESET:find_global $P0, "FDS"
+ $P1=$P0[fd]
set $S0, ""
- read $S0, fd, numchar
+ read $S0, $P1, numchar
.return $S0
restoreall
ret
.end
+.sub _OPEN # void open(string filename, string mode, int fd)
+ saveall
+ .param string filename
+ .param string mode
+ .param int fd
+ .local int error
+ open $P1, filename, mode
+ err error
+ eq error, 0, OPEN_OK
+ print "Error "
+ print error
+ print " in open\n"
+ end
+OPEN_OK:
+ find_global $P0, "FDS"
+ $P0[fd]=$P1
+ store_global "FDS", $P0
+ restoreall
+ ret
+.end
+.sub _CLOSE # void close(int fd)
+ saveall
+ .param int fd
+ .local int error
+ find_global $P0, "FDS"
+ set $P1, $P0[fd]
+ close $P1
+ err error
+ eq error, 0, CLOSE_OK
+ print "Error "
+ print error
+ print " in close\n"
+ end
+CLOSE_OK:
+ store_global "FDS", $P0
+ restoreall
+ ret
+.end
+.sub _WRITE # void writestring(int fd, 1, string stuff)
+ saveall
+ .param int fd
+ .local string buffer
+ .local int oldprintcol
+ find_global $P1, "PRINTCOL"
+ oldprintcol=$P1["value"]
+ call _BUILTIN_DISPLAY_WORK
+ .result buffer
+ find_global $P1, "PRINTCOL"
+ $P1["value"]=oldprintcol
+ store_global "PRINTCOL", $P1
+ find_global $P0, "FDS"
+ set $P1, $P0[fd]
+ print $P1, buffer
+ restoreall
+ ret
+.end
-# # ###########################
-# # OPEN
-# # Takes:
-# # S0 Filename
-# # S1 Mode (r, w, a)
-# # Returns:
-# # I0 File Descriptor
-# # I1 0
-#OPEN: open I0, S0, S1
-# err I1
-# ne I1, 0, ERR_OPEN
-# ret
-#
-#ERR_FN:
-# print "Expecting string as filename"
-# branch GEN_ERROR
-#
-#ERR_OPEN:
-# print "Unable to open "
-# print S0
-# branch IO_ERR
-#
-#CLOSE: eq I0, 0, ERR_BADF
-# close I0
-# err I1
-# ne I1, 0, ERR_CLOSE
-# ret
-#
-#ERR_CLOSE:
-# print "Unable to close "
-# print I0
-# branch IO_ERR
-#
-#IO_ERR: err S1
-# print ": "
-# print S1
-# branch GEN_ERROR
-#
#
# # ###########################
# # READLINE Read FD until EOL
@@ -66,11 +86,18 @@
# # Returns:
# # I0 Error?
.sub _READLINE # string readline(int fd)
- call _line_read
saveall
.param int fd
- set $S0, ""
+ ne 0, fd, NOTSTDIN
+ call _line_read
readline $S0, fd
+ branch ENDREAD
+NOTSTDIN:
+ find_global $P0, "FDS"
+ $P1=$P0[fd]
+ set $S0, ""
+ read $S0, $P1, 255
+ENDREAD:
.return $S0
restoreall
ret
1.14 +22 -2 parrot/languages/BASIC/compiler/testsuite.pl
Index: testsuite.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/testsuite.pl,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -w -r1.13 -r1.14
--- testsuite.pl 29 Jun 2003 01:23:26 -0000 1.13
+++ testsuite.pl 29 Jun 2003 22:43:48 -0000 1.14
@@ -32,6 +32,28 @@
}
__DATA__
+' 5 and PI
+dim a$(), m()
+a$(1)="5"
+print a$(1)
+m(99)=3.14
+print m(99)
+
+' basic I/O 1..5
+open "_testfile" for output as #3
+for i=1 to 5
+ print #3, i
+next i
+close #3
+open "_testfile" for input as #5
+for i = 1 to 5
+ input #5,a$
+ print a$,
+next i
+close #5
+print
+
+
' Expect 5, 0, "Hello"
common i, a$
sub mysub
@@ -48,7 +70,6 @@
call mysub()
-STOPPLEASE
' Expect 10
sub second(b() )
b(5)=10
@@ -69,7 +90,6 @@
end if
-STOPPLEASE
' Passing string arrays, expect 99 and "Hello"
function foo(i, thing$())
