Author: coke
Date: Sun Oct 9 10:19:39 2005
New Revision: 9420
Modified:
trunk/languages/BASIC/compiler/COMP_expressions.pm
trunk/languages/BASIC/compiler/COMP_parsefuncs.pm
trunk/languages/BASIC/compiler/RT_builtins.imc
trunk/languages/BASIC/compiler/RT_initialize.imc
trunk/languages/BASIC/compiler/RT_io.imc
trunk/languages/BASIC/compiler/RT_platform_win32.imc
trunk/languages/BASIC/compiler/compile.pl
Log:
BASIC: Fix enough to get eliza up and running again.
- more updates to current style
- more updates to use new calling conventions and MMD instead of old-style CC.
Modified: trunk/languages/BASIC/compiler/COMP_expressions.pm
==============================================================================
--- trunk/languages/BASIC/compiler/COMP_expressions.pm (original)
+++ trunk/languages/BASIC/compiler/COMP_expressions.pm Sun Oct 9 10:19:39 2005
@@ -397,7 +397,7 @@ sub fixup {
push(@expr, [ "STARTARG", "STARTARG" ] );
}
}
- return(@expr);
+ return (@expr);
}
sub get_expression {
my(%opts)[EMAIL PROTECTED];
@@ -476,7 +476,7 @@ sub pushargs {
my @args=();
while($$work[-1]->[0] ne "STARTARG") {
- my $item=pop @$work;
+ my $item= pop @$work;
my $a1=pushthing($code, $optype, @$item);
push @args, [ $a1, @$item ];
}
@@ -516,7 +516,7 @@ sub generate_code { # Will return a re
my($ac, @args, $extern, $pir_args);
if (isarray($sym) and $lhs) {
($ac,@args)=pushargs([EMAIL PROTECTED], \$optype,
[EMAIL PROTECTED]);
- $pir_args = join(",", map {$_->[0]} @args);
+ $pir_args = join(",", map {$_->[0]} (reverse @args));
$pir_args = ",$pir_args" if $pir_args;
$extern=$sym;
$optype=optype_of($extern);
@@ -525,10 +525,11 @@ sub generate_code { # Will return a re
return("~Array", "$optype", @code);
} elsif (hasargs($sym)) {
($ac,@args)=pushargs([EMAIL PROTECTED], \$optype,
[EMAIL PROTECTED]);
- $pir_args = join(",", map {$_->[0]} @args);
+ $pir_args = join(",", map {$_->[0]} (reverse @args));
$pir_args = ",$pir_args" if $pir_args;
$extern=$sym;
$optype=optype_of($extern);
+ my ($calling_code,@return_params);
if (isarray($sym)) {
NEST_ARRAY_ASSIGN:
if ($ac == 0) {
@@ -542,7 +543,8 @@ NEST_ARRAY_ASSIGN:
push @work, [ "result of $extern()", "RESULT",
"\$$optype$retcount"];
} else {
$extern=~s/\$/_string/g; $extern=~tr/a-z/A-Z/;
- push @code, qq{\$$optype$retcount =
_USERFUNC_${extern}_run($ac$pir_args)};
+
+ $calling_code = "(%s) =
_USERFUNC_${extern}_run($ac$pir_args)";
push @work, [ "result of $extern()", "RESULT",
"\$$optype$retcount"];
$retcount++;
# External functions return their arguments,
@@ -551,15 +553,20 @@ NEST_ARRAY_ASSIGN:
foreach my $arg (@args) {
next if $arg->[0] =~ /^\$P\d+$/;
if ($arg->[2] eq "BARE") {
- push @code, "\t.result
$arg->[0]";
+ push @return_params, $arg->[0]
} else {
- push @code, "\t.result \$"
- . optype_of($arg->[0], $arg)
- . "$retcount\t# Dummy, thrown
away";
- $retcount++;
+ push @return_params, "\$" .
+ optype_of($arg->[0], $arg) .
+ $retcount++;
}
}
+ if (@return_params) {
+ push @code, sprintf ($calling_code,
join(",",@return_params));
+ } else {
+ push @code, sprintf ($calling_code, '');
+ }
}
+
$retcount++;
} else {
my($op1,$op2)=(pop @work, pop @work);
Modified: trunk/languages/BASIC/compiler/COMP_parsefuncs.pm
==============================================================================
--- trunk/languages/BASIC/compiler/COMP_parsefuncs.pm (original)
+++ trunk/languages/BASIC/compiler/COMP_parsefuncs.pm Sun Oct 9 10:19:39 2005
@@ -100,35 +100,35 @@ sub parse_shared { # Keyword only
if ($user and ! $array ) {
print CODE<<SHARINGU;
# Sharing $stype (user) $var with main
- set P0, P10[0]
- set P1, P0["USER"]
- set P0, P1["$var"] # Pull the original
- set P2, P10[I25]
- set P3, P2["USER"]
- set P3["$var"], P0 # Hack in the alias
+ P0= P10[0]
+ P1= P0["USER"]
+ P0= P1["$var"] # Pull the original
+ P2= P10[I25]
+ P3= P2["USER"]
+ P3["$var"]= P0 # Hack in the alias
SHARINGU
} elsif ( $user and $array) {
# TODO TODO TODO TODO
print CODE<<SHARING;
# Sharing $stype $var with main (array=$array)
- set P0, P10[0]
- set P1, P0["$stype"]
- set P0, P1["$var"] # Pull the original
- set P2, P10[I25]
- set P3, P2["$stype"]
- set P3["$var"], P0 # Hack in the alias
+ P0= P10[0]
+ P1= P0["$stype"]
+ P0= P1["$var"] # Pull the original
+ P2= P10[I25]
+ P3= P2["$stype"]
+ P3["$var"]= P0 # Hack in the alias
SHARING
} else {
print CODE<<SHARING;
# Sharing $stype $var with main (array=$array)
- set P0, P10[0]
- set P1, P0["$stype"]
- set P0, P1["$var"] # Pull the original
- set P2, P10[I25]
- set P3, P2["$stype"]
- set P3["$var"], P0 # Hack in the alias
+ P0= P10[0]
+ P1= P0["$stype"]
+ P0= P1["$var"] # Pull the original
+ P2= P10[I25]
+ P3= P2["$stype"]
+ P3["$var"]= P0 # Hack in the alias
SHARING
}
@@ -147,7 +147,7 @@ sub input_read_assign {
push @{$code{$seg}->{code}},<<INP1;
\$S0 = _READLINE($filedesc)
\$P99 = _SPLITLINE(\$S0,$sf)
- set \$I0, \$P99
+ \$I0= \$P99
INP1
# Bug here...FIXME.. I'm using $vars before it's set.
@@ -163,7 +163,7 @@ INP1
while($type[CURR] !~ /COMP|COMM|STMT/) {
die if $loop++>20;
push @{$code{$seg}->{code}}, "\tpop \$S99, \$P99\n";
- push @{$code{$seg}->{code}}, "\tset \$N99, \$S99\n";
+ push @{$code{$seg}->{code}}, "\t\$N99= \$S99\n";
my($result, $type, @code)=EXPRESSION({ stuff => "\$X99", choose
=> 1 });
push @{$code{$seg}->{code}}, "@code";
@@ -234,7 +234,7 @@ sub parse_on {
push @{$code{$seg}->{code}},<<ON;
@code lt $result, 0.0, ONERR_${ons}
gt $result, 255.0, ONERR_${ons}
- branch ONOK_${ons}
+ goto ONOK_${ons}
ONERR_${ons}:
print "On...goto/gosub out of range at $sourceline\\n"
_platform_shutdown()
@@ -247,9 +247,9 @@ ON
if ($branch eq "gosub") {
push @{$code{$seg}->{code}}, qq{\tbsr
$labels{$jumps}\t# $branch $jumps\n};
push @{$code{$seg}->{code}}, qq{\t#RTJ ne S0, "",
RUNTIME_JUMP\n};
- push @{$code{$seg}->{code}}, qq{\tbranch ON_END_$ons\n};
+ push @{$code{$seg}->{code}}, qq{\tgoto ON_END_$ons\n};
} elsif ($branch eq "goto") {
- push @{$code{$seg}->{code}}, qq{\tbranch
$labels{$jumps}\t# $branch $jumps\n};
+ push @{$code{$seg}->{code}}, qq{\tgoto
$labels{$jumps}\t# $branch $jumps\n};
} else {
die "Illegal branch type, only GOSUB/GOTO allowed";
}
@@ -268,14 +268,14 @@ sub parse_randomize {
print "Random-number seed (-32768 to 32767)?"
bsr READLINE
bsr CHOMP
- set I12, S0
+ I12= S0
PROMPTRND
} else {
($result, $type, @code)=EXPRESSION();
push @{$code{$seg}->{code}},<<EOR;
@code find_global \$P0, "RANDSEED"
- set \$I0, $result
- set \$P0["value"], \$I0
+ \$I0= $result
+ \$P0["value"]= \$I0
store_global "RANDSEED", \$P0
EOR
feedme();
@@ -300,9 +300,9 @@ sub parse_locate { # locate x,y | loca
push @{$code{$seg}->{code}},<<XANDY;
@codey
- set \$N100, $resulty
+ \$N100= $resulty
@codex
- set \$N101, $resultx
+ \$N101= $resultx
_screen_locate(\$N101,\$N100)
XANDY
} elsif (@codey and not @codex) {
@@ -334,8 +334,8 @@ sub parse_color {
}
if (@codeb and @codef) { # F and B
push @{$code{$seg}->{code}},<<FANDB;
[EMAIL PROTECTED] set \$N100, $resultb
[EMAIL PROTECTED] set \$N101, $resultf
[EMAIL PROTECTED] \$N100= $resultb
[EMAIL PROTECTED] \$N101= $resultf
_screen_color(\$N101,\$N100)
FANDB
} elsif (@codeb and not @codef) {
@@ -489,7 +489,7 @@ sub parse_read {
while($type[CURR] !~ /COMP|COMM|STMT/) {
push @{$code{$seg}->{code}}, <<EOASS;
\$S99 = _READ()
- set \$N99, \$S99
+ \$N99= \$S99
EOASS
($result, $type, @code)=EXPRESSION({ stuff => '$X99', choose => 1 });
feedme();
@@ -584,20 +584,20 @@ sub parse_exit {
if ($syms[NEXT] eq "for") {
feedme();
$foo=$fors[$scopes]->[-1];
- push @{$code{$seg}->{code}}, "\tbranch
AFTER_NEXT_$foo->{num}\n";
+ push @{$code{$seg}->{code}}, "\tgoto AFTER_NEXT_$foo->{num}\n";
} elsif ($syms[NEXT] eq "function") {
- push @{$code{$seg}->{code}}, qq{\tbranch END_$seg\n};
+ push @{$code{$seg}->{code}}, qq{\tgoto END_$seg\n};
feedme();
#$_=english_func($funcname);
- #print CODE "\tbranch FUNC_EXIT_$_\n";
+ #print CODE "\tgoto FUNC_EXIT_$_\n";
} elsif ($syms[NEXT] eq "sub") {
- push @{$code{$seg}->{code}}, qq{\tbranch END_$seg\n};
+ push @{$code{$seg}->{code}}, qq{\tgoto END_$seg\n};
feedme();
- #print CODE "\tbranch SUB_EXIT_$subname\n";
+ #print CODE "\tgoto SUB_EXIT_$subname\n";
} elsif ($syms[NEXT] eq "do") {
feedme();
$foo=$dos[-1];
- push @{$code{$seg}->{code}}, "\tbranch AFTERDO_$foo->{jump}\n";
+ push @{$code{$seg}->{code}}, "\tgoto AFTERDO_$foo->{jump}\n";
} else {
die "Unknown EXIT type source line $sourceline";
}
@@ -614,10 +614,10 @@ sub parse_select {
print CODE<<SELECTSTART;
# Select case on
@a bsr DEREF # De-reference variables and whatnot.
- set P0, P10[I25]
- set P1, P0["SELECTS"]
- set P1["$selectcounter"], P6 # Store for later.
- branch CASE_${selectcounter}_0
+ P0= P10[I25]
+ P1= P0["SELECTS"]
+ P1["$selectcounter"]= P6 # Store for later.
+ goto CASE_${selectcounter}_0
SELECTSTART
# Honestly the next thing needs to be a case statement.
@@ -630,7 +630,7 @@ sub parse_case {
if ($syms[NEXT] eq "else") {
feedme();
- print CODE "\t branch CASE_${jump}_FIN\n";
+ print CODE "\t goto CASE_${jump}_FIN\n";
print CODE "CASE_${jump}_${incase}:\t# Default\n";
$selects[-1]->{incase}=$incase+1;
return;
@@ -638,12 +638,12 @@ sub parse_case {
my $lambda=<<GL;
- set P0, P10[I25]
- set P1, P0["SELECTS"]
- set P5, P1["$jump"] # Stored value.
+ P0= P10[I25]
+ P1= P0["SELECTS"]
+ P5= P1["$jump"] # Stored value.
GL
print CODE<<CASE_SETUP;
- branch CASE_${jump}_FIN
+ goto CASE_${jump}_FIN
CASE_${jump}_${incase}:
new P12, .PerlArray # OR
new P13, .PerlArray # TO
@@ -698,7 +698,7 @@ TO
print CODE $lambda;
if ($ors) {
print CODE <<ORS
- set I5, P12
+ I5= P12
CASE_${jump}_${incase}_STARTOR:
eq I5, 1, CASE_${jump}_${incase}_NO_OR
push P9, "or"
@@ -706,7 +706,7 @@ CASE_${jump}_${incase}_STARTOR:
CASE_${jump}_${incase}_NO_OR:
push P9, "="
push P9, "OP"
- set P0, P5 # The "constant"
+ P0= P5 # The "constant"
bsr RUNTIME_PUSH
pop P0, P12
bsr RUNTIME_PUSH
@@ -720,7 +720,7 @@ ORS
}
if ($tos) {
print CODE<<TOS;
- set I5, P13
+ I5= P13
div I5, I5, 2
CASE_${jump}_${incase}_STARTTO:
eq I5, 1, CASE_${jump}_${incase}_NO_TO
@@ -731,13 +731,13 @@ CASE_${jump}_${incase}_NO_TO:
push P9, "OP"
push P9, ">="
push P9, "OP"
- set P0, P5
+ P0= P5
bsr RUNTIME_PUSH
pop P0, P13
bsr RUNTIME_PUSH
push P9, "<="
push P9, "OP"
- set P0, P5
+ P0= P5
bsr RUNTIME_PUSH
pop P0, P13
bsr RUNTIME_PUSH
@@ -751,7 +751,7 @@ TOS
}
if ($ops) {
print CODE<<OPS;
- set I5, P14
+ I5= P14
div I5, I5, 2
CASE_${jump}_${incase}_STARTOPS:
eq I5, 1, CASE_${jump}_${incase}_NO_OP
@@ -762,9 +762,9 @@ CASE_${jump}_${incase}_NO_OP:
pop S0, P14
push P9, S0
push P9, "OP"
- set P0, P1
+ P0= P1
bsr RUNTIME_PUSH
- set P0, P5
+ P0= P5
bsr RUNTIME_PUSH
dec I5
gt I5, 0, CASE_${jump}_${incase}_STARTOPS
@@ -799,7 +799,7 @@ sub parse_wend {
$_=pop(@whiles);
$_=$_->{jump};
push @{$code{$seg}->{code}}, <<LOOPUP;
- branch WHILE_$_
+ goto WHILE_$_
AFTERWHILE_$_:
LOOPUP
}
@@ -828,7 +828,7 @@ sub parse_do {
sub parse_goto {
feedme;
create_label();
- push @{$code{$seg}->{code}}, "\tbranch $labels{$syms[CURR]}\t# Goto
$syms[CURR]\n";
+ push @{$code{$seg}->{code}}, "\tgoto $labels{$syms[CURR]}\t# Goto
$syms[CURR]\n";
}
sub parse_gosub {
feedme;
@@ -842,13 +842,13 @@ GOSUB
sub parse_return {
if ($type[NEXT] ne "BARE") {
push @{$code{$seg}->{code}}, <<RETURN1;
- set JUMPLABEL, ""
+ JUMPLABEL= ""
ret
RETURN1
} else {
feedme(); # Special "Return Label"
push @{$code{$seg}->{code}}, <<RETURN2;
- set JUMPLABEL, "$labels{$syms[CURR]}" # Return $syms[CURR]
+ JUMPLABEL= "$labels{$syms[CURR]}" # Return $syms[CURR]
ret
RETURN2
if (! $runtime_jump) {
@@ -860,7 +860,7 @@ RETURN2
sub parse_loop {
my $do=pop @dos;
if ($do->{needstmt} and not ( $syms[NEXT]=~/while|until/ ) ) {
- push @{$code{$seg}->{code}}, "\nbranch DO_$do->{jump}\t#
Unconditional\n";
+ push @{$code{$seg}->{code}}, "\ngoto DO_$do->{jump}\t#
Unconditional\n";
push @{$code{$seg}->{code}}, "AFTERDO_$do->{jump}:\n";
return;
}
@@ -877,7 +877,7 @@ sub parse_loop {
}
push @{$code{$seg}->{code}}, "\t$_\n";
} else {
- push @{$code{$seg}->{code}}, "\tbranch DO_$do->{jump}\n";
+ push @{$code{$seg}->{code}}, "\tgoto DO_$do->{jump}\n";
}
push @{$code{$seg}->{code}}, "AFTERDO_$do->{jump}:\n";
}
@@ -928,40 +928,40 @@ TYPE
foreach(@types) {
print CODE<<ADDT;
new P1, .PerlHash
- set P1["name"], '$_->[0]'
- set P1["type"], '$_->[1]'
+ P1["name"]= '$_->[0]'
+ P1["type"]= '$_->[1]'
push P0, P1
ADDT
}
print CODE<<TYPEE;
- set P1, P10[0]
- set P2, P1["types"]
- set P2["$typename"], P0
- branch OUTOF_$typename
+ P1= P10[0]
+ P2= P1["types"]
+ P2["$typename"]= P0
+ goto OUTOF_$typename
DIM_$typename:
#print "Dimensioning $typename\\n"
pushp
- new P2, .PerlHash
+ P2= .PerlHash
TYPEE
foreach(@types) {
my %val=( INT => 0, FLO => '0.0', STRING => '""' );
if ($_->[2] ne "USER") {
print CODE<<NOTUSER;
new P1, .PerlHash
- set P1["name"], '$_->[0]'
- set P1["type"], '$_->[2]'
- set P1["value"], $val{$_->[2]}
- set P2["$_->[0]"], P1
+ P1["name"]= '$_->[0]'
+ P1["type"]= '$_->[2]'
+ P1["value"]= $val{$_->[2]}
+ P2["$_->[0]"]= P1
NOTUSER
} else {
print CODE<<USERTYPE;
new P1, .PerlHash
- set P1["name"], '$_->[0]'
- set P1["type"], "USER"
+ P1["name"]= '$_->[0]'
+ P1["type"]= "USER"
bsr DIM_$_->[1]
- set P1["storage"], P0
- set P1["_type"], '$_->[1]'
- set P2["$_->[0]"], P1
+ P1["storage"]= P0
+ P1["_type"], '$_->[1]'
+ P2["$_->[0]"]= P1
USERTYPE
}
}
@@ -982,30 +982,30 @@ FINDIM
if ($_->[2] ne "USER") {
print CODE<<NOTUSER;
new P2, .PerlHash
- set P2["name"], '$_->[0]'
- set P2["type"], '$_->[2]'
- set P4, P6["storage"]
- set P5, P4["$_->[0]"]
- set $val{$_->[2]}, P5["value"]
- set P2["value"], $val{$_->[2]}
+ P2["name"]= '$_->[0]'
+ P2["type"]= '$_->[2]'
+ P4= P6["storage"]
+ P5= P4["$_->[0]"]
+ $val{$_->[2]}= P5["value"]
+ P2["value"]= $val{$_->[2]}
#print "-> Copied value for "
#print $val{$_->[2]}
#print "\\n"
- set P3["$_->[0]"], P2
+ P3["$_->[0]"]= P2
NOTUSER
} else {
print CODE<<USER;
new P2, .PerlHash
- set P2["name"], '$_->[0]'
- set P2["type"], "USER"
- set P5, P6 # Remember where we were...
- set P4, P6["storage"]
- set P6, P4["$_->[0]"]
+ P2["name"]= '$_->[0]'
+ P2["type"]= "USER"
+ P5= P6 # Remember where we were...
+ P4= P6["storage"]
+ P6= P4["$_->[0]"]
bsr COPY_$_->[1]
- set P2["storage"], P1
- set P6, P5 # Go back to where we were!
- set P2["_type"], '$_->[1]'
- set P3["$_->[0]"], P2
+ P2["storage"]= P1
+ P6= P5 # Go back to where we were!
+ P2["_type"]= '$_->[1]'
+ P3["$_->[0]"]= P2
#print "Finished substruct\\n"
USER
}
@@ -1034,14 +1034,14 @@ ANOTHERDIM:
my $type=$syms[CURR];
die "SIGIL not allowed here" unless ($var=~/\w$/);
print CODE<<DIMTYPE;
- set P1, P10[I25]
- set P2, P1["USER"]
+ P1= P10[I25]
+ P2= P1["USER"]
bsr DIM_$type
- new P1, .PerlHash
- set P1["_type"], '$type'
- set P1["type"], "USER"
- set P1["storage"], P0
- set P2["$var"], P1
+ P1 = new .PerlHash
+ P1["_type"]= '$type'
+ P1["type"]= "USER"
+ P1["storage"]= P0
+ P2["$var"]= P1
DIMTYPE
if ($syms[NEXT] eq ",") {
feedme();
@@ -1067,7 +1067,7 @@ DIMTYPE
$type=$th{$syms[CURR]};
} elsif (exists $usertypes{$syms[CURR]}) {
$type="USER";
- $ut=qq{\tset P2["usertype"],
"$syms[CURR]"\n};
+ $ut=qq{\tP2["usertype"]=
"$syms[CURR]"\n};
} else {
die "Unknown type $syms[CURR]";
}
@@ -1081,13 +1081,13 @@ DIMTYPE
#print STDERR "Marking ${var}${seg}\n";
push @{$code{$seg}->{code}}, <<DIMARR;
# Set aside storage for Array $var
- \$P0 = new PerlHash
- \$P2 = new PerlArray
- \$P3 = new PerlHash
+ \$P0 = new .PerlHash
+ \$P2 = new .PerlArray
+ \$P3 = new .PerlHash
\$P3["index"]=\$P2
\$P3["hash"]=\$P0
find_global \$P1, "BASICARR"
- set \$P1["$var$seg"], \$P3
+ \$P1["$var$seg"]= \$P3
store_global "BASICARR", \$P1
#
DIMARR
@@ -1128,13 +1128,13 @@ sub parse_for { # for var = start to f
$main::code{$main::seg}->{declarations}->{"FORLOOP_END_$forloop"}=1;
$main::code{$main::seg}->{declarations}->{"FORLOOP_STEP_$forloop"}=1;
push @{$code{$seg}->{code}}, <<COND;
[EMAIL PROTECTED] set FORLOOP_END_$forloop, $endexpr
[EMAIL PROTECTED] FORLOOP_END_$forloop= $endexpr
@stepcode
- set FORLOOP_STEP_$forloop, $stepexpr
+ FORLOOP_STEP_$forloop= $stepexpr
FOR_$forloop:
gt FORLOOP_STEP_$forloop, 0.0, FOR_GT_$forloop
lt $result, FORLOOP_END_$forloop, AFTER_NEXT_$forloop
- branch FOR_LOOP_BODY_$forloop
+ goto FOR_LOOP_BODY_$forloop
FOR_GT_$forloop:
gt $result, FORLOOP_END_$forloop, AFTER_NEXT_$forloop
FOR_LOOP_BODY_$forloop:
@@ -1152,14 +1152,14 @@ sub parse_next { # next [a[,b[,c]...]
if ($type[CURR] ne "BARE") { # next (no variable)
push @{$code{$seg}->{code}}, <<NEXT;
add $ps->{var}, $ps->{var}, FORLOOP_STEP_$ps->{num}
- branch FOR_$ps->{num}
+ goto FOR_$ps->{num}
AFTER_NEXT_$ps->{num}: noop
NEXT
} else { # next var
while (1) {
push @{$code{$seg}->{code}}, <<NEXT;
add $ps->{var}, $ps->{var}, FORLOOP_STEP_$ps->{num}
- branch FOR_$ps->{num}
+ goto FOR_$ps->{num}
AFTER_NEXT_$ps->{num}: noop
NEXT
if ($syms[NEXT] eq ",") {
@@ -1275,7 +1275,7 @@ EOH
push @{$code{$seg}->{code}},<<PUSHARR;
.param PerlHash array_$englishname
find_global \$P1, "BASICARR"
- set \$P1["${_}$seg"], array_$englishname
+ \$P1["${_}$seg"]= array_$englishname
store_global "BASICARR", \$P1
PUSHARR
# push @{$code{$seg}->{args}}, $_;
@@ -1313,7 +1313,7 @@ sub parse_function_dispatch {
# User function dispatch routine
#
UF_DISPATCH:
- set I1, -1
+ I1= -1
FUNCDISP
if (%functions) {
foreach(keys %functions) {
@@ -1321,7 +1321,7 @@ FUNCDISP
}
}
print FUNC<<FUNCEND;
- branch UF_DISPATCH_END
+ goto UF_DISPATCH_END
UF_DISPATCH_END:
#print "Ending user function, stack depth now "
#print I25
@@ -1330,13 +1330,13 @@ UF_DISPATCH_END:
FUNCEND
print FUNC<<SUBDISP;
SUB_DISPATCH:
- set I1, -1
+ I1= -1
SUBDISP
foreach (keys %subs) {
print FUNC qq{\teq S0, "$_", SUB_$_\n};
}
print FUNC<<SUBEND;
- branch SUB_DISPATCH_END
+ goto SUB_DISPATCH_END
SUB_DISPATCH_END:
ret
SUBEND
@@ -1414,7 +1414,7 @@ DATAPREP
foreach my $ld (@data) {
my $line=$ld->{line};
if (length $line) {
- push @{$code{_data}->{code}}, qq{\tset \$P1["$line"],
$counter\n};
+ push @{$code{_data}->{code}}, qq{\t\$P1["$line"]=
$counter\n};
}
foreach (@{$ld->{data}}) {
my($t,$v)=($_->{type}, $_->{value});
Modified: trunk/languages/BASIC/compiler/RT_builtins.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_builtins.imc (original)
+++ trunk/languages/BASIC/compiler/RT_builtins.imc Sun Oct 9 10:19:39 2005
@@ -179,6 +179,9 @@ ENDINT: .return(res)
.param int argc
.param string target
.param float start
+ .param float extent :optional
+ .param int has_extent :opt_flag
+
.local string res
.local string a
.local int strlen
@@ -188,7 +191,7 @@ ENDINT: .return(res)
set pos, start
dec pos
- eq argc, 3, MID3ARG
+ if has_extent goto MID3ARG
MIDLOOP:ge pos, strlen, MIDDONE
substr a, target, pos, 1
@@ -270,25 +273,34 @@ RND_BAIL:
time $N0
.return($N0)
.end
-.sub _BUILTIN_INSTR # float instr([float start,] string full, string
substr);
+
+# float instr(float start, string full, string substring);
+.sub _BUILTIN_INSTR @MULTI(int, float, string, string)
.param int argc
- .local int start
- set start, 1
- eq argc, 2, NOSTART
- .local float startf
- set start, startf
-NOSTART:
- dec start # BASIC starts at 1.
- .local string full
- .local string substr
- length $I0, substr
- eq $I0, 0, ENDINSTR
- index $I0, full, substr, start
- set $N0, $I0
-
-ENDINSTR:inc $N0
- .return($N0)
+ .param float start
+ .param string full
+ .param string substring
+
+ .local int start_i
+ start_i = start
+ dec start_i # BASIC starts at 1, parrot at 0.
+ $I0 = length substring
+ if $I0 == 0 goto ENDINSTR
+ $I0 = index full, substring, start_i
+ENDINSTR:
+ inc $I0
+ .return($I0)
+.end
+
+# float instr(string full, string substring);
+.sub _BUILTIN_INSTR @MULTI(int, string, string)
+ .param int argc
+ .param string full
+ .param string substring
+
+ .return _BUILTIN_INSTR(argc,1.0,full,substring)
.end
+
.sub _BUILTIN_UCASE_STRING # string ucase$(string targ)
.param int argc
.param string targ
Modified: trunk/languages/BASIC/compiler/RT_initialize.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_initialize.imc (original)
+++ trunk/languages/BASIC/compiler/RT_initialize.imc Sun Oct 9 10:19:39 2005
@@ -1,26 +1,26 @@
.const int TYPE = 0
.const int VALUE = 1
.sub _main @MAIN
- $P0 = new PerlHash
+ $P0 = new .PerlHash
store_global "BASICARR", $P0
- $P0 = new PerlArray
+ $P0 = new .PerlArray
store_global "READDATA", $P0
- $P0 = new PerlHash
+ $P0 = new .PerlHash
store_global "RESTOREINFO", $P0
- $P0=new PerlHash
+ $P0=new .PerlHash
$P0["value"]=0
store_global "READPOINTER", $P0
- $P0=new PerlHash
+ $P0=new .PerlHash
$P0["value"]=20021107
store_global "RANDSEED", $P0
- $P0=new PerlHash
+ $P0=new .PerlHash
$P0["value"]=0
store_global "PRINTCOL", $P0
- $P0=new PerlHash
+ $P0=new .PerlHash
store_global "DEBUGGER", $P0
- $P0=new PerlHash
+ $P0=new .PerlHash
store_global "COMMON", $P0
- $P0=new PerlArray
+ $P0=new .PerlArray
fdopen $P1, 0, "r" # STDIN and friends...
$P1 = getstdin
$P0[0]=$P1
@@ -32,7 +32,6 @@
$P0[2]=$P1
store_global "FDS", $P0
-
_data()
_platform_setup()
_basicmain()
Modified: trunk/languages/BASIC/compiler/RT_io.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_io.imc (original)
+++ trunk/languages/BASIC/compiler/RT_io.imc Sun Oct 9 10:19:39 2005
@@ -74,11 +74,11 @@ CLOSE_OK:
# # I0 Error?
.sub _READLINE # string readline(int fd)
.param int fd
- find_global $P0, "FDS"
- $P1=$P0[fd]
- set $S0, ""
- readline $S0, $P1
+ $P0 = find_global "FDS"
+ $P1 = $P0[fd]
+ $S0 = readline $P1
.return($S0)
+
.end
# # ###########################
# # SPLITLINE Splits a line into parts
Modified: trunk/languages/BASIC/compiler/RT_platform_win32.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_platform_win32.imc (original)
+++ trunk/languages/BASIC/compiler/RT_platform_win32.imc Sun Oct 9
10:19:39 2005
@@ -16,7 +16,7 @@ I can't test this on windows, and it's c
set I5, -10
invoke
store_global "Win32Inputhandle", P5
- $P0= new PerlHash
+ $P0= new .PerlHash
store_global "Win32console", $P0
_WIN32_CONSOLE_INFO()
.end
@@ -26,7 +26,7 @@ I can't test this on windows, and it's c
find_global P1, "kernel32"
dlfunc P0, P1, "GetConsoleScreenBufferInfo", "ipp"
find_global P5, "Win32handle"
- P6=new ManagedStruct
+ P6=new .ManagedStruct
set P6, SIZEOF_CONSOLE_SCREEN_BUFFER_INFO
set I0, 1
invoke
@@ -79,7 +79,7 @@ I can't test this on windows, and it's c
dlfunc P0, P2, "FillConsoleOutputCharacterA", "ipcilp"
set I0, 1
find_global P5, "Win32handle"
- P6=new ManagedStruct
+ P6=new .ManagedStruct
set P6, SIZEOF_DWORD
set I5, 32 # Char (space)
set I1, P1["xbuf"]
@@ -92,7 +92,7 @@ I can't test this on windows, and it's c
dlfunc P0, P2, "FillConsoleOutputAttribute", "ipiilp"
set I0, 1
find_global P5, "Win32handle"
- P6= new ManagedStruct
+ P6= new .ManagedStruct
set P6, SIZEOF_DWORD
set I5, P1["attr"] # Attrib
set I1, P1["xbuf"]
@@ -202,8 +202,8 @@ INKEY:
dlfunc P9, P1, "PeekConsoleInputA", "ippip"
dlfunc P10, P1, "ReadConsoleInputA", "ippip"
find_global P5, "Win32Inputhandle"
- P6=new ManagedStruct
- P7=new ManagedStruct
+ P6=new .ManagedStruct
+ P7=new .ManagedStruct
set P6, INPUT_BUFFER
set P7, SIZEOF_DWORD
Modified: trunk/languages/BASIC/compiler/compile.pl
==============================================================================
--- trunk/languages/BASIC/compiler/compile.pl (original)
+++ trunk/languages/BASIC/compiler/compile.pl Sun Oct 9 10:19:39 2005
@@ -52,18 +52,21 @@ foreach my $seg ("_main", "_basicmain",
print CODE ".sub $seg\n";
if (exists $code{$seg}->{declarations}) {
- print CODE "\t.local PerlHash _GLOBALS\n";
- print CODE "\t.local string JUMPLABEL\n";
- print CODE "\tset JUMPLABEL, \"\"\n";
+ print CODE <<'END_PIR';
+
+ .local pmc _GLOBALS
+ .local string JUMPLABEL
+ JUMPLABEL=''
+END_PIR
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";
+ push @init, qq{\t\t$var=""\n};
+ push @debdecl, "\t\t\$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";
+ push @init, qq{\t\t$var=0.0\n};
+ push @debdecl,
"\t\t\$S0=$var\n\t\t\$P1[\"$var\"]= \$S0\n";
}
}
@@ -155,16 +158,16 @@ foreach my $seg ("_main", "_basicmain",
saveall
.param int debline
find_global \$P0, "DEBUGGER"
- set \$I0, \$P0["step"]
+ \$I0= \$P0["step"]
ne \$I0, 0, DEBUGGER_STOP
- set \$P1, \$P0["break"]
- set \$I0, \$P1
+ \$P1= \$P0["break"]
+ \$I0= \$P1
eq \$I0, 0, DEBUGGER_DONE # No breakpoints
- set \$S0, debline
+ \$S0= debline
exists \$I0, \$P1[\$S0]
eq \$I0, 0, DEBUGGER_DONE # This breakpoint doesn't exist
DEBUGGER_STOP:
- \$P1=new PerlHash
+ \$P1=new .PerlHash
@debdecl .arg \$P1
.arg debline
_DEBUGGER_STOP_FOR_REAL()
@@ -177,21 +180,21 @@ if ($debug) {
print CODE<<FOO;
.sub _DEBUG_INIT
saveall
- \$P0=new PerlArray
+ \$P0=new .PerlArray
find_global \$P1, "DEBUGGER"
FOO
foreach([EMAIL PROTECTED]::basic-1) {
my $line=$main::basic[$_];
$line=~s/"/'/g;
- print CODE "\tset \$P0[",$_+1,"], \"$line\"\n";
+ print CODE "\t\$P0[",$_+1,"]= \"$line\"\n";
}
print CODE<<FOO;
- set \$P1["code"], \$P0
- set \$P1["step"], 1 # Turn on stepping mode
- \$P0=new PerlHash
- set \$P1["break"], \$P0 # Breakpoints
- \$P0=new PerlArray
- set \$P1["watch"], \$P0 # Watch
+ \$P1["code"]= \$P0
+ \$P1["step"]= 1 # Turn on stepping mode
+ \$P0=new .PerlHash
+ \$P1["break"]= \$P0 # Breakpoints
+ \$P0=new .PerlArray
+ \$P1["watch"]= \$P0 # Watch
store_global "DEBUGGER", \$P1
.end
FOO
