The BASIC compiler is now upgraded to critical condition. I did some major surgery to use the updated calling conventions. (no more .arg; .result; nested .subs; saveall; restoreall; entrytype; etc.)
Could probably use a test suite; a generated make file/*.pl files.
There are few cases where the functions passed things on the stack and used "entrytype" to figure out how to deal with the args. I faked this by checking the total # of parameters passed, which doesn't help much for cases where both the first and second args can be either a string or a float. Fortunately, wumpus doesn't trip over my hack. It'd probably be a good idea to switch to PMC passing for these cases (look for S5/N5/I5 references).
Regards.
Will Coleda wrote:
> cvsuser 04/11/13 22:17:04
> Modified: languages LANGUAGES.STATUS
> languages/BASIC/compiler BASIC_README COMP_expressions.pm
> COMP_parsefuncs.pm COMP_parser.pm RT_aggregates.imc
> RT_builtins.imc RT_debugger.imc RT_initialize.imc
> RT_io.imc RT_platform.imc
> RT_platform_ANSIscreen.imc RT_platform_win32.imc
> RT_support.imc compile.pl testrun.pl
> Log:
> [perl #30084] - Basic compiler does not work...
> Wumpus is now working again. Updated to use the current calling conventions.
> There are still some dodgy bits.
> Revision Changes Path
> 1.21 +2 -1 parrot/languages/LANGUAGES.STATUS
> Index: LANGUAGES.STATUS
> ===================================================================
> RCS file: /cvs/public/parrot/languages/LANGUAGES.STATUS,v
> retrieving revision 1.20
> retrieving revision 1.21
> diff -u -r1.20 -r1.21
> --- LANGUAGES.STATUS 14 Nov 2004 06:09:17 -0000 1.20
> +++ LANGUAGES.STATUS 14 Nov 2004 06:17:02 -0000 1.21
> @@ -7,8 +7,9 @@
> N: BASIC/compiler
> A: Clint Pierce
> +A: Will Coleda (work with parrot 0.1.0+)
> D: BASIC Compiler
> -S: Broken [perl #30084]
> +S: Cautiously Optimistic - wumpus example seems to work again.
> M: Yes
> V: 0.0.11
> 1.3 +3 -3 parrot/languages/BASIC/compiler/BASIC_README
> Index: BASIC_README
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/BASIC_README,v
> retrieving revision 1.2
> retrieving revision 1.3
> diff -u -r1.2 -r1.3
> --- BASIC_README 16 May 2003 20:10:30 -0000 1.2
> +++ BASIC_README 14 Nov 2004 06:17:03 -0000 1.3
> @@ -70,9 +70,9 @@
> How do I get going? Quickstart?
> 1. Edit "testrun.pl" and change the pathname at the beginning of the
> script to wherever parrot is.
> - 2. Type "compile.pl wumpus2.bas"
> - This produces "TARG_test.pasm" and "TARG_localfuncs.pasm"
> - 3. Type "testrun.pl" and enjoy.
> + 2. Type "perl compile.pl samples/wumpus2.bas"
> + This produces "TARG_test.imc" and "TARG_localfuncs.imc"
> + 3. Type "perl testrun.pl" and enjoy.
> eliza2 and wumpus2 are simply ports from the Parrot BASIC 1.0 version. All
> that had to be done were to add DIM statements and a RANDOMIZE.
> 1.20 +14 -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.19
> retrieving revision 1.20
> diff -u -r1.19 -r1.20
> --- COMP_expressions.pm 27 Feb 2004 13:13:25 -0000 1.19
> +++ COMP_expressions.pm 14 Nov 2004 06:17:03 -0000 1.20
> @@ -480,9 +480,9 @@
> my $a1=pushthing($code, $optype, @$item);
> push @args, [ $a1, @$item ];
> }
> - foreach(@args) {
> - push @$code, qq{\t.arg $_->[0]\t\t# $_->[0]};
> - }
> + #foreach(@args) {
> + #push @$code, qq{\t.arg $_->[0]\t\t# $_->[0]};
> + #}
> pop @$work; # REmove startarg tag...
> return(scalar @args, @args);
> }
> @@ -513,43 +513,36 @@
> next;
> }
> next if ($sym eq ","); # Commas get ignored, args to stack
> - my($ac, @args, $extern);
> + my($ac, @args, $extern, $pir_args);
> if (isarray($sym) and $lhs) {
> ($ac,@args)=pushargs(\@code, \$optype, \@work);
> + $pir_args = join(",", map {$_->[0]} @args);
> + $pir_args = ",$pir_args" if $pir_args;
> $extern=$sym;
> $optype=optype_of($extern);
> goto NEST_ARRAY_ASSIGN if (@work); # Ugly, yeah sue me.
> - push @code, qq{\t.arg $ac\t\t\t# argc};
> - push @code, qq{\tINSERT NEW VALUE HERE};
> - push @code, qq{\t.arg "$extern$seg"\t\t# array name};
> - push @code, "\tcall _ARRAY_ASSIGN";
> + push @code, qq{\t_ARRAY_ASSIGN("$extern$seg",INSERT NEW VALUE HERE,$ac$pir_args)};
> return("~Array", "$optype", @code);
> } elsif (hasargs($sym)) {
> ($ac,@args)=pushargs(\@code, \$optype, \@work);
> + $pir_args = join(",", map {$_->[0]} @args);
> + $pir_args = ",$pir_args" if $pir_args;
> $extern=$sym;
> $optype=optype_of($extern);
> if (isarray($sym)) {
> -NEST_ARRAY_ASSIGN: push @code, qq{\t.arg $ac\t\t\t# argc};
> - push @code, qq{\t.arg "$extern$seg"\t\t# array name};
> - push @code, "\tcall _ARRAY_LOOKUP_$optype";
> +NEST_ARRAY_ASSIGN:
> if ($ac == 0) {
> $optype="P";
> }
> - push @code, "\t.result \$$optype$retcount";
> + push @code, qq{\t\$$optype$retcount = _ARRAY_LOOKUP_$optype("$extern$seg",$ac$pir_args)};
> push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount"];
> } elsif (isbuiltin($sym)) {
> $extern=~s/\$/_string/g; $extern=~tr/a-z/A-Z/;
> - push @code, qq{\t.arg $ac\t\t\t# argc};
> - push @code, qq{\tcall _BUILTIN_$extern};
> - push @code, "\t.result \$$optype$retcount";
> + push @code, qq{\$$optype$retcount = _BUILTIN_$extern($ac$pir_args)};
> 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 @code, qq{\$$optype$retcount = _USERFUNC_${extern}_run($ac$pir_args)};
> push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount"];
> $retcount++;
> # External functions return their arguments,
> @@ -621,7 +614,7 @@
> );
> }
> } else {
> - s/INSERT NEW VALUE HERE/.arg $right\t\t\t# Value to receive/g for @$leftexpr;
> + s/INSERT NEW VALUE HERE/$right/g for @$leftexpr;
> s/--TYPE--/$righttype/g for @$leftexpr;
> @ass=(
> 1.23 +34 -56 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.22
> retrieving revision 1.23
> diff -u -r1.22 -r1.23
> --- COMP_parsefuncs.pm 30 Jun 2003 01:21:08 -0000 1.22
> +++ COMP_parsefuncs.pm 14 Nov 2004 06:17:03 -0000 1.23
> @@ -28,9 +28,7 @@
> $targ.=$seg;
> $source.=$seg;
> push @{$code{$seg}->{code}}, <<KEYS;
> - .arg "$targ"
> - .arg "$source"
> - call _ARRAY_KEYS
> + _ARRAY_KEYS("$source","$targ")
> KEYS
> }
> sub parse_common {
> @@ -147,13 +145,8 @@
> $sf=0 if ($filedesc);
> push @{$code{$seg}->{code}},<<INP1;
> - .arg $filedesc
> - call _READLINE
> - .result \$S0
> - .arg $sf
> - .arg \$S0
> - call _SPLITLINE
> - .result \$P99
> + \$S0 = _READLINE($filedesc)
> + \$P99 = _SPLITLINE(\$S0,$sf)
> set \$I0, \$P99
> INP1
> @@ -244,7 +237,7 @@
> branch ONOK_${ons}
> ONERR_${ons}:
> print "On...goto/gosub out of range at $sourceline\\n"
> - call _platform_shutdown
> + _platform_shutdown()
> end
> ONOK_${ons}:
> ON
> @@ -310,19 +303,17 @@
> set \$N100, $resulty
> @codex
> set \$N101, $resultx
> - .arg \$N100
> - .arg \$N101
> - call _screen_locate
> + _screen_locate(\$N101,\$N100)
> XANDY
> } elsif (@codey and not @codex) {
> push @{$code{$seg}->{code}},<<YNOTX;
> -@codey .arg $resulty # Broke!
> - call _screen_locate
> +@codey noop # Broke!
> + _screen_locate($resulty)
> YNOTX
> } elsif (@codex and not @codey) {
> push @{$code{$seg}->{code}},<<XNOTY;
> -@codex .arg $resultx # Broke!
> - call _screen_locate
> +@codex noop # Broke!
> + _screen_locate($resultx)
> XNOTY
> }
> }
> @@ -345,19 +336,17 @@
> push @{$code{$seg}->{code}},<<FANDB;
> @codeb set \$N100, $resultb
> @codef set \$N101, $resultf
> - .arg \$N100
> - .arg \$N101
> - call _screen_color
> + _screen_color(\$N101,\$N100)
> FANDB
> } elsif (@codeb and not @codef) {
> push @{$code{$seg}->{code}},<<BNOTF;
> -@codeb .arg $resultb
> - call _screen_color # Broke!
> +@codeb noop
> + _screen_color($resultb) # Broke!
> BNOTF
> } elsif (@codef and not @codeb) {
> push @{$code{$seg}->{code}},<<FNOTB;
> -@codef .arg $resultf
> - call _screen_color # Broke!
> +@codef noop
> + _screen_color($resultf) # Broke!
> FNOTB
> }
> }
> @@ -366,7 +355,7 @@
> @e=EXPRESSION();
> }
> push @{$code{$seg}->{code}},<<CLS;
> - call _screen_clear
> + _screen_clear()
> CLS
> feedme();
> }
> @@ -392,10 +381,8 @@
> feedme();
> $fd=$syms[CURR];
> push @{$code{$seg}->{code}},<<OPEN;
> -@code .arg $fd
> - .arg "$mode"
> - .arg $result
> - call _OPEN
> +@code noop
> + _OPEN($result,"$mode",$fd)
> OPEN
> }
> sub parse_close {
> @@ -404,25 +391,19 @@
> feedme();
> $fd=$syms[CURR];
> push @{$code{$seg}->{code}},<<CLOSE;
> - .arg $fd
> - call _CLOSE
> + _CLOSE($fd)
> CLOSE
> }
> sub fdprint {
> my($fd, $string)=@_;
> if ($fd) {
> push @{$code{$seg}->{code}}, <<PRINT;
> - .arg "$string"
> - .arg 1
> - .arg $fd
> - call _WRITE
> + _WRITE($fd,1,"$string")
> PRINT
> } else {
> if ($string ne "\\n") {
> push @{$code{$seg}->{code}}, <<PRINT;
> - .arg "$string"
> - .arg 1
> - call _BUILTIN_DISPLAY
> + _BUILTIN_DISPLAY(1,"$string")
> PRINT
> } else {
> push @{$code{$seg}->{code}}, <<PRINT;
> @@ -485,16 +466,13 @@
> feedme();
> if ($fd) {
> push @{$code{$seg}->{code}}, <<PRINT;
> -@code .arg $result
> - .arg 1
> - .arg $fd
> - call _WRITE
> +@code noop
> + _WRITE($fd,1,$result)
> PRINT
> } else {
> push @{$code{$seg}->{code}}, <<PRINT;
> -@code .arg $result
> - .arg 1
> - call _BUILTIN_DISPLAY
> +@code noop
> + _BUILTIN_DISPLAY(1,$result)
> PRINT
> }
> #print "After Expression have $type[CURR] $syms[CURR]\n";
> @@ -510,8 +488,7 @@
> sub parse_read {
> while($type[CURR] !~ /COMP|COMM|STMT/) {
> push @{$code{$seg}->{code}}, <<EOASS;
> - call _READ
> - .result \$S99
> + \$S99 = _READ()
> set \$N99, \$S99
> EOASS
> ($result, $type, @code)=EXPRESSION({ stuff => '$X99', choose => 1 });
> @@ -546,7 +523,7 @@
> print "Stopped at source line "
> print I11
> print "\\n"
> - call _platform_shutdown
> + _platform_shutdown()
> end
> STOP
> }
> @@ -590,15 +567,16 @@
> push(@data, { line => $currline, data => \@ld });
> }
> sub parse_restore {
> + my @args;
> if ($type[NEXT] eq "BARE" or $type[NEXT] eq "INT") {
> feedme();
> create_label();
> - push @{$code{$seg}->{code}}, qq{\t.arg "$labels{$syms[CURR]}"\n};
> + push @args, qq{"$labels{$syms[CURR]}"};
> } else {
> - push @{$code{$seg}->{code}}, qq{\t.arg ""\n};
> + push @args, qq{""};
> }
> feedme();
> - push @{$code{$seg}->{code}}, "\tcall _RESTORE\n";
> + push @{$code{$seg}->{code}}, "\t_RESTORE(" . join(",",@args) . ")\n";
> }
> @@ -1274,7 +1252,7 @@
> print "Function $englishname received "
> print argc
> print " arguments expected $_\\n"
> - call _platform_shutdown
> + _platform_shutdown()
> end
> ${englishname}_ARGOK:
> EOH
> @@ -1383,7 +1361,7 @@
> print "Structure type of "
> print S0
> print " not found\\n"
> - call _platform_shutdown
> + _platform_shutdown()
> end
> DISP2
> @@ -1403,7 +1381,7 @@
> print "Structure type of "
> print S0
> print " not found\\n"
> - call _platform_shutdown
> + _platform_shutdown()
> end
> DISP2
> RTJUMP:
> @@ -1422,7 +1400,7 @@
> print "Runtime branch of "
> print JUMPLABEL
> print " not found\\n"
> - call _platform_shutdown
> + _platform_shutdown()
> end
> RTBE
> }
> 1.19 +3 -6 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.18
> retrieving revision 1.19
> diff -u -r1.18 -r1.19
> --- COMP_parser.pm 27 Feb 2004 13:13:25 -0000 1.18
> +++ COMP_parser.pm 14 Nov 2004 06:17:03 -0000 1.19
> @@ -62,8 +62,6 @@
> # ###################
> # Program Termination
> # ###################
> - restoreall
> - ret # back to _main
> SHUTDOWN
> }
> @@ -90,7 +88,7 @@
> my($result, $type, @code);
> if ($debug) {
> - push @{$code{$seg}->{code}},"\tcall _DEBUG_INIT\n";
> + push @{$code{$seg}->{code}},"\t_DEBUG_INIT()\n";
> debug();
> }
> @@ -250,7 +248,7 @@
> print CODE "CASE_$s->{jump}_FIN:\n";
> goto PARSE;
> }
> - push @{$code{$seg}->{code}}, "\tcall _platform_shutdown\n\tend\n";
> + push @{$code{$seg}->{code}}, "\t_platform_shutdown()\n\tend\n";
> goto PARSE;
> }
> die "Unkown keyword $syms[CURR]/$type[CURR] source line $sourceline";
> @@ -368,8 +366,7 @@
> }
> sub debug {
> push @{$code{$seg}->{code}}, <<DEBUG;
> - .arg $sourceline
> - call ${seg}_debug
> + ${seg}_debug($sourceline)
> DEBUG
> }
> 1.2 +39 -64 parrot/languages/BASIC/compiler/RT_aggregates.imc
> Index: RT_aggregates.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_aggregates.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_aggregates.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_aggregates.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -4,111 +4,97 @@
> .const int STRING = 3
> .const int PMC = 4
> .sub _ARRAY_LOOKUP_N # float ARRAY_LOOKUP_N(string array, int keycount[, string|float])
> - saveall
> .param string array
> .local string key
> - .local PerlHash BASICARR
> + .local pmc BASICARR
> find_global BASICARR, "BASICARR"
> - call _ARRAY_BUILDKEY
> - .result key
> + key = _ARRAY_BUILDKEY()
> set $P0, BASICARR[array]
> ne key, "", ARR_NORMAL
> - .return $P0 # Return the whole array.
> - branch ARR_END
> + .return($P0) # Return the whole array.
> ARR_NORMAL:
> $P1=$P0["hash"] # forked arrays, awaiting keys()
> set $N0, $P1[key]
> - .return $N0
> -ARR_END:
> - restoreall
> - ret
> + .return($N0)
> .end
> .sub _ARRAY_LOOKUP_S # string ARRAY_LOOKUP_S(string array, int keycount[, string|float])
> - saveall
> .param string array
> .local string key
> - .local PerlHash BASICARR
> + .local pmc BASICARR
> find_global BASICARR, "BASICARR"
> - call _ARRAY_BUILDKEY
> - .result key
> + key = _ARRAY_BUILDKEY()
> set $P0, BASICARR[array]
> ne key, "", ARR_NORMAL
> - .return $P0
> - branch ARR_END
> + .return($P0)
> ARR_NORMAL:
> $P1=$P0["hash"] # forked arrays, awaiting keys()
> set $S0, $P1[key]
> - .return $S0
> + .return($S0)
> ARR_END:
> - restoreall
> - ret
> + noop
> .end
> # void ARRAY_ASSIGN_N(string array, PerlArray rhs, int keycount[, string|float keys])
> # void ARRAY_ASSIGN_N(string array, string rhs, int keycount[, string|float keys])
> .sub _ARRAY_ASSIGN # void ARRAY_ASSIGN_N(string array, float rhs, int keycount[, string|float keys])
> - saveall
> .param string array
> - entrytype $I0, 0
> +
> + # XXX used to use entrytype. now using calling conventions.
> + # problem in that the last arg to this function seems to also
> + # have variable types, so our check is currently a little naive.
> # Assign a number
> - ne $I0, FLOAT, ASSIGN_STRING
> - .param float rhs
> + ne I4, 1, ASSIGN_STRING
> .local string key
> - .local PerlHash BASICARR
> + .local pmc BASICARR
> find_global BASICARR, "BASICARR"
> - call _ARRAY_BUILDKEY # Will absorb rest of arguments.
> - .result key
> + key = _ARRAY_BUILDKEY() # Will absorb rest of arguments.
> set $P1, BASICARR[array]
> set $P0, $P1["hash"]
> - set $P0[key], rhs
> + set $P0[key], N5
> store_global "BASICARR", BASICARR
> branch END_ASSIGN
> # Assign a string
> ASSIGN_STRING:
> - ne $I0, STRING, ASSIGN_UNK
> + ne I2, 1, ASSIGN_UNK
> - .param string rhs
> .local string key
> - .local PerlHash BASICARR
> + .local pmc BASICARR
> find_global BASICARR, "BASICARR"
> - call _ARRAY_BUILDKEY # Will absorb rest of arguments.
> - .result key
> + key = _ARRAY_BUILDKEY() # Will absorb rest of arguments.
> set $P1, BASICARR[array]
> set $P0, $P1["hash"]
> - set $P0[key], rhs
> + set $P0[key], S5
> store_global "BASICARR", BASICARR
> branch END_ASSIGN
> # Assign a... well, we dunno WTF this is.
> ASSIGN_UNK:
> - ne $I0, PMC, ASSIGN_ERR
> - .param PerlArray blob
> + ne I3, 1, ASSIGN_ERR
> .local string key
> - .local PerlHash BASICARR
> + .local pmc BASICARR
> find_global BASICARR, "BASICARR"
> - call _ARRAY_BUILDKEY
> + key = _ARRAY_BUILDKEY()
> set $P1, BASICARR[array]
> set $P0, $P1["hash"]
> - .result key
> - set $S0, blob[TYPE]
> + set $S0, P5[TYPE]
> ne $S0, "STRING", NOTSTRING
> - set $S1, blob[VALUE]
> + set $S1, P5[VALUE]
> set $P0[key], $S1
> branch END_UNK
> NOTSTRING:
> ne $S0, "INT", NOTINT
> - set $I0, blob[VALUE]
> + set $I0, P5[VALUE]
> set $N0, $I0
> set $P0[key], $N0
> branch END_UNK
> NOTINT: ne $S0, "FLOAT", ASSIGN_ERR
> - set $N0, blob[VALUE]
> + set $N0, P5[VALUE]
> set $P0[key], $N0
> branch END_UNK
> @@ -137,19 +123,17 @@
> $P1["index"]=$P0
> BASICARR[array]=$P1
> store_global "BASICARR", BASICARR
> -REALEND:restoreall
> - ret
> +REALEND:noop
> .end
> # This gets a *lot* easier when PerlHash->keys() gets implemented
> .sub _ARRAY_KEYS # void ARRAY_KEYS(string source, string target)
> - saveall
> .param string source
> .param string target
> - .local PerlHash BASICARR
> + .local pmc BASICARR
> - .local PerlArray SRCINDEX
> - .local PerlHash TARGARR
> - .local PerlArray TARGINDEX
> + .local pmc SRCINDEX
> + .local pmc TARGARR
> + .local pmc TARGINDEX
> .local int i
> find_global BASICARR, "BASICARR"
> $P0=BASICARR[source]
> @@ -172,39 +156,32 @@
> inc i
> branch KEYLOOP
> -ENDLOOP:restoreall
> - ret
> +ENDLOOP:noop
> .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
> +# .local pmc BASICARR
> # find_global BASICARR, "BASICARR"
> -# call _ARRAY_BUILDKEY # Will absorb rest of arguments.
> -# .result key
> +# key = _ARRAY_BUILDKEY() # Will absorb rest of arguments.
> # 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
> .sub _ARRAY_BUILDKEY # string ARRAY_BUILDKEY(int keycount[, string|float...])
> - saveall
> .param int keycount
> .local string key
> set key, ""
> KEYLOOP:le keycount, 0, KEYDONE
> - entrytype $I0, 0
> concat key, "|"
> - eq $I0, FLOAT, ADDFLOAT
> - eq $I0, STRING, ADDSTRING
> + eq I4, 1, ADDFLOAT
> + eq I2, 1, ADDSTRING
> print "Wrong type on stack, key creation\n"
> end
> ADDFLOAT:
> @@ -220,7 +197,5 @@
> dec keycount
> branch KEYLOOP
> -KEYDONE:.return key
> - restoreall
> - ret
> +KEYDONE:.return(key)
> .end
> 1.2 +102 -206 parrot/languages/BASIC/compiler/RT_builtins.imc
> Index: RT_builtins.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_builtins.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_builtins.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_builtins.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -2,45 +2,45 @@
> #
> .const int FLOAT = 2
> .const int STRING = 3
> -.sub _BUILTIN_DISPLAY # void display(....)
> - saveall
> - .local string buf
> - call _BUILTIN_DISPLAY_WORK
> - .result buf
> - print buf
> - restoreall
> - ret
> -.end
> +#.sub _BUILTIN_DISPLAY # void display(....)
> + #.param int argc
> + #.param string display
> + #.local string buf
> +
> + # XXX pass along whatever arguments were given.
> +
> + #buf = _BUILTIN_DISPLAY_WORK(showme)
> + #print buf
> +#.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
> +.sub _BUILTIN_DISPLAY #_WORK # string display_work(string|float thingy[, string|float thingy2])
> .param int argc
> +
> .local string buf
> .local int intver
> .local string s
> .local int PRINTCOL
> + # XXX Used to use entrytype. our naive fix here will eventually
> + # fail, because of the two variable type arguments.
> +
> find_global $P0, "PRINTCOL"
> set PRINTCOL, $P0["value"]
> set buf, ""
> NEXT: eq argc, 0, END_DISPLAY
> dec argc
> - entrytype $I0, 0
> - eq $I0, STRING, DISPSTRING
> - ne $I0, FLOAT, DISPERR
> + eq I2, 1, DISPSTRING
> + ne I4, 1, DISPERR
> # Now, do floats
> - .param float number
> - set intver, number
> + set intver, N5
> set $N0, intver
> - eq $N0, number, DISPINT # Nope, it's an integer.
> - .arg number
> - call _NORMALIZE_FLOAT
> - .result s
> - lt number, 0.0, NEGFLO
> + eq $N0, N5, DISPINT # Nope, it's an integer.
> + s = _NORMALIZE_FLOAT(N5)
> + lt N5, 0.0, NEGFLO
> concat buf, " "
> NEGFLO: concat buf, s
> concat buf, " "
> @@ -56,11 +56,10 @@
> branch NEXT
> DISPSTRING:
> - .param string str
> - length $I0, str
> - eq str, "\t", DISPTAB
> - concat buf, str
> - eq str, "\n", DISPNL
> + length $I0, S5
> + eq S5, "\t", DISPTAB
> + concat buf, S5
> + eq S5, "\n", DISPNL
> add PRINTCOL, PRINTCOL, $I0
> branch NEXT
> DISPTAB:
> @@ -76,17 +75,15 @@
> DISPNL: set PRINTCOL, 0
> branch NEXT
> END_DISPLAY:
> - .return buf
> set $P0["value"], PRINTCOL
> store_global "PRINTCOL", $P0
> - restoreall
> - ret
> + print buf
> + .return(buf)
> DISPERR:print "Unknown type on stack to print\n"
> end
> .end
> .sub _NORMALIZE_FLOAT # string normalize_flo(float number)
> - saveall
> .param float number # INTERNAL, no argc!
> set $S0, number
> FLO_NORM:
> @@ -102,27 +99,21 @@
> substr $S0, $S0, 0, $I0
> branch FLO_NORM
> FLO_END:
> - .return $S0
> - restoreall
> - ret
> + .return($S1)
> .end
> # Builtin functions for BASIC
> #
> .sub _BUILTIN_ABS # float abs(float arg)
> - saveall
> .param int argc
> .param float arg
> .local float res
> abs res, arg
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> # INT - a math function that returns the largest integer less than
> # or equal to a numeric-expression
> .sub _BUILTIN_INT # float int(float arg)
> - saveall
> .param int argc
> .param float arg
> .local float res
> @@ -131,68 +122,50 @@
> set res, truncate
> ge arg, 0.0, ENDINT
> dec res
> -ENDINT: .return res
> - restoreall
> - ret
> +ENDINT: .return(res)
> .end
> .sub _BUILTIN_CHR_STRING # string chr(float arg)
> - saveall
> .param int argc
> .param float arg
> .local string res
> .local int truncate
> set truncate, arg
> chr res, truncate
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> .sub _BUILTIN_ASC # float asc(string arg)
> - saveall
> .param int argc
> .param string arg
> .local int conv
> .local float res
> ord conv, arg
> set res, conv
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> .sub _BUILTIN_STR_STRING # string str(float arg)
> - saveall
> .param int argc
> .param float arg
> .local string res
> set res, arg
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> .sub _BUILTIN_VAL # float val(string arg)
> - saveall
> .param int argc
> .param string arg
> .local float res
> set res, arg
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> .sub _BUILTIN_LEN # float len(string arg)
> - saveall
> .param int argc
> .param string arg
> .local float res
> .local int conv
> length conv, arg
> set res, conv
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> .sub _BUILTIN_MID_STRING # string mid(string targ, float start [, float extent])
> - saveall
> .param int argc
> .param string target
> .param float start
> @@ -215,7 +188,7 @@
> MID3ARG:
> .local float count
> - .param float extent
> + .local float extent
> set count, 0.0
> MID3L:
> ge pos, strlen, MIDDONE
> @@ -227,27 +200,18 @@
> branch MID3L
> MIDDONE:
> - .return res
> - restoreall
> - ret
> + .return(res)
> .end
> .sub _BUILTIN_LEFT_STRING # string left(string targ, float extent)
> - saveall
> .param int argc
> .param string targ
> .param float extent
> .local string res
> - .arg extent
> - .arg 1.0
> - .arg targ
> - .arg 3
> - call _BUILTIN_MID_STRING
> - restoreall
> - ret
> + res = _BUILTIN_MID_STRING(3, targ, 1.0, extent)
> + .return(res)
> .end
> .sub _BUILTIN_RIGHT_STRING # string right(string targ, float extent)
> - saveall
> .param int argc
> .param string targ
> .param float extent
> @@ -260,24 +224,18 @@
> inc $I0
> set $N0, $I0
> - .arg extent
> - .arg $N0
> - .arg targ
> - .arg 3
> - call _BUILTIN_MID_STRING
> - restoreall
> - ret
> + res = _BUILTIN_MID_STRING(3,targ,$N0,extent)
> + .return(res)
> .end
> # Modifies the system-wide RANDSEED
> # Produces 16-bit pseudo-random numbers.
> .sub _BUILTIN_RND # float rnd([float seed])
> - saveall
> - .local int RANDSEED
> .param int argc
> + .local int RANDSEED
> find_global $P0, "RANDSEED"
> set RANDSEED, $P0["value"]
> eq argc, 0, RND_GEN
> - .param float repeat
> + .local float repeat
> eq repeat, 0.0, RND_REPEAT
> RND_GEN:
> @@ -291,67 +249,52 @@
> set $N0, RANDSEED
> div $N0, $N0, 65536.0
> RND_BAIL:
> - .return $N0
> set $P0["value"], RANDSEED
> store_global "RANDSEED", $P0
> - restoreall
> - ret
> + .return($N0)
> .end
> .sub _BUILTIN_TIMER # float timer()
> - saveall
> .param int argc
> time $N0
> - .return $N0
> - restoreall
> - ret
> + .return($N0)
> .end
> .sub _BUILTIN_INSTR # float instr([float start,] string full, string substr);
> - saveall
> .param int argc
> .local int start
> set start, 1
> eq argc, 2, NOSTART
> - .param float startf
> + .local float startf
> set start, startf
> NOSTART:
> dec start # BASIC starts at 1.
> - .param string full
> - .param string substr
> + .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
> - restoreall
> - ret
> + .return($N0)
> .end
> .sub _BUILTIN_UCASE_STRING # string ucase$(string targ)
> - saveall
> .param int argc
> - .arg 122
> - .arg 97
> - .arg 32
> - call _XCASE
> - restoreall
> - ret
> + .param string targ
> + .local string res
> + res = _XCASE(32,97,122,targ)
> + .return(res)
> .end
> .sub _BUILTIN_LCASE_STRING # string lcase$(string targ)
> - saveall
> .param int argc
> - .arg 90
> - .arg 65
> - .arg -32
> - call _XCASE
> - restoreall
> - ret
> + .param string targ
> + .local string res
> + res = _XCASE(-32,65,90,targ)
> + .return(res)
> .end
> # For internal use only. No ARGC!
> .sub _XCASE # string xcase(string targ, int offset, int lower, int upper
> - saveall
> .param int offset
> .param int lower
> .param int upper
> @@ -377,12 +320,9 @@
> inc $I0
> branch XCASE_LOOP
> XCASE_DONE:
> - .return $S3
> - restoreall
> - ret
> + .return($S3)
> .end
> .sub _BUILTIN_SGN # float sgn(float number)
> - saveall
> .param int argc
> .param float number
> set $N0, 0.0
> @@ -391,14 +331,12 @@
> lt number, 0.0, FINISHED
> set $N0, 1.0
> FINISHED:
> - .return $N0
> - restoreall
> - ret
> + .return($N0)
> .end
> .sub _BUILTIN_STRING_STRING # string string(float repeat, float ascii)
> - saveall # string string(float repeat, string string)
> .param int argc
> .param float repeatf
> +
> .local int repeat
> set repeat, repeatf
> .local string repeater
> @@ -407,97 +345,66 @@
> set target, ""
> entrytype $I0, 0
> eq $I0, FLOAT, FLOATB
> - .param string thing
> + .local string thing
> set repeater, thing
> branch REP
> -FLOATB: .param float ascii
> +FLOATB: .local float ascii
> set $I0, ascii
> chr repeater, $I0
> REP: ge $I1, repeat, BAIL
> concat target, repeater
> inc $I1
> branch REP
> -BAIL: .return target
> - restoreall
> - ret
> +BAIL: .return(target)
> .end
> -.sub _TRIG_IN
> - saveall
> +.sub _BUILTIN_LOG # float log(float op)
> .param int argc
> .param float op
> - set $N0, op
> - ret
> -.end
> -.sub _TRIG_OUT
> - .return $N0
> - restoreall
> - ret
> -.end
> -.sub _BUILTIN_LOG # float log(float op)
> - call _TRIG_IN
> - ln $N0, $N0
> - call _TRIG_OUT
> - ret
> + ln op, op
> + .return(op)
> .end
> .sub _BUILTIN_EXP # float exp(float op)
> - call _TRIG_IN
> - exp $N0, $N0
> - call _TRIG_OUT
> - ret
> + .param int argc
> + .param float op
> + exp op, op
> + .return(op)
> .end
> .sub _BUILTIN_SIN # float sin(float op)
> - call _TRIG_IN
> - sin $N0, $N0
> - call _TRIG_OUT
> - ret
> + .param int argc
> + .param float op
> + sin op, op
> + .return(op)
> .end
> .sub _BUILTIN_COS # float cos(float op)
> - call _TRIG_IN
> - cos $N0, $N0
> - call _TRIG_OUT
> - ret
> + .param int argc
> + .param float op
> + cos op, op
> + .return(op)
> .end
> .sub _BUILTIN_TAN # float tan(float op)
> - call _TRIG_IN
> - tan $N0, $N0
> - call _TRIG_OUT
> - ret
> + .param int argc
> + .param float op
> + tan op, op
> + .return(op)
> .end
> .sub _BUILTIN_ATN # float atn(float op)
> - call _TRIG_IN
> - atan $N0, $N0
> - call _TRIG_OUT
> - ret
> + .param int argc
> + .param float op
> + atan op, op
> + .return(op)
> .end
> .const float EPSILON = 0.000001
> .sub _BUILTIN_SQR # float sqr(float operand)
> - saveall
> .param int argc
> - .param float operand
> - lt operand, 0.0, ERR_RANGE
> - eq operand, 0.0, END
> - div $N1, operand, 3.0 # First guess
> -AGAIN: div $N2, operand, $N1 # Newton's method
> - add $N2, $N2, $N1
> - mul $N2, $N2, 0.5
> - sub $N3, $N2, $N1
> - gt $N3, 0.0, INV
> - mul $N3, $N3, -1.0
> -INV: set $N1, $N2
> - gt $N3, EPSILON, AGAIN
> - set operand, $N1
> -END: .return operand
> - restoreall
> - ret
> -
> + .param float op
> + if op < 0 goto ERR_RANGE
> + sqrt op, op
> + .return(op)
> ERR_RANGE:
> print "Number out of range\n"
> - .return -1.0
> - restoreall
> - ret
> + .return(-1.0)
> .end
> .sub _BUILTIN_TAB_STRING # string tab(float cols)
> - saveall
> .param int argc
> .param float cols
> .local int PRINTCOL
> @@ -519,12 +426,9 @@
> concat $S0, " "
> inc $I1
> branch TAB_SP
> -TAB_RET:.return $S0
> - restoreall
> - ret
> +TAB_RET:.return($S0)
> .end
> .sub _BUILTIN_LTRIM_STRING # string ltrim(string oldstring)
> - saveall
> .param int argc
> .param string oldstring
> set $S0, oldstring
> @@ -537,12 +441,9 @@
> substr $S0, $S0, 1, $I0
> branch BI_LTRIM
> LTRIM_END:
> - .return $S0
> - restoreall
> - ret
> + .return($S0)
> .end
> .sub _BUILTIN_RTRIM_STRING # string rtrim(string oldstring)
> - saveall
> .param int argc
> .param string oldstring
> set $S0, oldstring
> @@ -555,34 +456,29 @@
> substr $S0, $S0, 0, $I0
> branch BI_RTRIM
> RTRIM_END:
> - .return $S0
> - restoreall
> - ret
> + .return($S0)
> .end
> .sub _BUILTIN_INPUT_STRING # string input$(float numchars[, string fdinfo])
> - saveall
> .param int argc
> .param float numcharsf
> .local int numchars
> + .local string res
> set numchars, numcharsf
> .local int fd
> set fd, 0 # Stdin
> eq argc, 1, DOREAD
> - .param string fdinfo
> + .local string fdinfo
> length $I0, fdinfo
> dec $I0
> substr fdinfo, fdinfo, 1, $I0
> set fd, fdinfo
> -DOREAD: .arg fd
> - .arg numchars
> - call _READCHARS
> - restoreall
> - ret
> +DOREAD: res = _READCHARS(numchars,fd)
> + .return(res)
> .end
> .sub _BUILTIN_INKEY_STRING # string inkey$(void)
> .param int argc
> - call _scan_read # Put terminal in char-at-a-time mode
> - call _inkey_string
> - ret
> + .local string res
> + _scan_read() # Put terminal in char-at-a-time mode
> + res = _inkey_string()
> + .return(res)
> .end
> -
> 1.2 +4 -11 parrot/languages/BASIC/compiler/RT_debugger.imc
> Index: RT_debugger.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_debugger.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_debugger.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_debugger.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -1,7 +1,6 @@
> .sub _DEBUGGER_STOP_FOR_REAL # void Debugger_stop(int line, PerlHash local_values)
> - saveall
> .param int line
> - .param PerlHash locals
> + .param pmc locals
> find_global $P25, "DEBUGGER"
> set $P0, $P25["code"]
> @@ -27,20 +26,15 @@
> print line
> print "->"
> - .arg 0
> - call _READLINE
> - call _CHOMP
> - .result $S0
> + $S0 = _READLINE(0)
> + $S0 = _CHOMP($S0)
> length $I0, $S0
> set $I1, $P25["step"]
> add $I0, $I0, $I1
> eq $I0, 0, DEBUGGER_COMMAND # If no step mode, and no input, re-prompt
> - .arg 1
> - .arg $S0
> - call _SPLITLINE # P1 will have array of values
> - .result $P1
> + $P1 = _SPLITLINE($S0,1) # P1 will have array of values
> set $I0, $P1
> add $I0, $I0, $I1
> @@ -206,6 +200,5 @@
> DEBUGGER_DONE:
> store_global "DEBUGGER", $P25
> - restoreall
> ret
> .end
> 1.2 +10 -10 parrot/languages/BASIC/compiler/RT_initialize.imc
> Index: RT_initialize.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_initialize.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_initialize.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_initialize.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -1,7 +1,6 @@
> .const int TYPE = 0
> .const int VALUE = 1
> -.local string JUMPLABEL
> -.sub _main
> +.sub _main @MAIN
> $P0 = new PerlHash
> store_global "BASICARR", $P0
> $P0 = new PerlArray
> @@ -23,19 +22,20 @@
> store_global "COMMON", $P0
> $P0=new PerlArray
> fdopen $P1, 0, "r" # STDIN and friends...
> + $P1 = getstdin
> $P0[0]=$P1
> - fdopen $P1, 1, "w"
> + $P1 = getstdout
> + #Don't buffer stdout...
> + $I0 = pioctl $P1, 3, 0
> $P0[1]=$P1
> - fdopen $P1, 2, "w"
> + $P1 = getstderr
> $P0[2]=$P1
> store_global "FDS", $P0
> - JUMPLABEL = ""
> - call _data_run
> - call _platform_setup
> - call _basicmain_run
> - call _platform_shutdown
> + _data()
> + _platform_setup()
> + _basicmain()
> + _platform_shutdown()
> end
> -
> .end
> 1.3 +8 -39 parrot/languages/BASIC/compiler/RT_io.imc
> Index: RT_io.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_io.imc,v
> retrieving revision 1.2
> retrieving revision 1.3
> diff -u -r1.2 -r1.3
> --- RT_io.imc 8 Jul 2003 13:57:30 -0000 1.2
> +++ RT_io.imc 14 Nov 2004 06:17:03 -0000 1.3
> @@ -4,7 +4,6 @@
> #
> # Not a lot of error handling here yet
> .sub _READCHARS # string readchars(int numchar, int fd)
> - saveall
> .param int numchar
> .param int fd
> ne fd, 0, NORESET
> @@ -13,12 +12,9 @@
> $P1=$P0[fd]
> set $S0, ""
> read $S0, $P1, numchar
> - .return $S0
> - restoreall
> - ret
> + .return($S0)
> .end
> .sub _OPEN # void open(string filename, string mode, int fd)
> - saveall
> .param string filename
> .param string mode
> .param int fd
> @@ -34,11 +30,8 @@
> 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"
> @@ -52,19 +45,15 @@
> 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
> + buffer = _BUILTIN_DISPLAY(fd, buffer) #_WORK()
> find_global $P1, "PRINTCOL"
> $P1["value"]=oldprintcol
> store_global "PRINTCOL", $P1
> @@ -72,8 +61,6 @@
> find_global $P0, "FDS"
> set $P1, $P0[fd]
> print $P1, buffer
> - restoreall
> - ret
> .end
> #
> @@ -86,28 +73,22 @@
> # # Returns:
> # # I0 Error?
> .sub _READLINE # string readline(int fd)
> - saveall
> .param int fd
> find_global $P0, "FDS"
> $P1=$P0[fd]
> set $S0, ""
> readline $S0, $P1
> - .return $S0
> - restoreall
> - ret
> + .return($S0)
> .end
> # # ###########################
> # # SPLITLINE Splits a line into parts
> # # Outputs:
> # # P1 Array of strings
> .sub _SPLITLINE # PerlArray splitline (string line, int splitflag)
> - saveall
> .param string line
> .param int splitflag
> .local string token
> - .arg line
> - call _CHOMP
> - .result line
> + line = _CHOMP(line)
> $P1=new PerlArray
> eq splitflag, 0, SPLITSINGLE
> @@ -115,10 +96,7 @@
> SPLITAGAIN:
> length $I0, line
> eq $I0, 0, SPLITEND
> - .arg line
> - call _REMOVETOK
> - .result line
> - .result token
> + (line,token) = _REMOVETOK(line)
> push $P1, token
> branch SPLITAGAIN
> @@ -132,10 +110,7 @@
> push $P1, line
> SPLITGONE:
> - .return $P1
> - restoreall
> -
> - ret
> + .return($P1)
> .end
> #
> # # ############################
> @@ -145,7 +120,6 @@
> # # Leading/trailing spaces ignored and removed.
> # # Quotes can surround part of a token w/commas and spaces
> .sub _REMOVETOK # (string token, string neworiginal) removetok(string original)
> - saveall
> .param string original
> set $I1, 0 # Inquote
> set $S1, "" # Base string
> @@ -172,15 +146,12 @@
> branch TOKLOOP
> STARTQ: set $I1, 1
> branch TOKLOOP
> -EOTOK: .return $S1 # The token
> - .return original# The original, w/o the token
> - restoreall
> +EOTOK: .return(original,$S1)
> .end
> # # ###########################
> # # CHOMP Remove trailing \r\n thingies from S0
> .sub _CHOMP # string chomp(string line)
> - saveall
> .param string line
> length $I0, line
> dec $I0
> @@ -195,9 +166,7 @@
> dec $I0
> le $I0, 0, CHOMPOK
> branch CHOMPLOOK
> -CHOMPOK:.return line
> - restoreall
> - ret
> +CHOMPOK:.return(line)
> .end
> #
> 1.2 +22 -42 parrot/languages/BASIC/compiler/RT_platform.imc
> Index: RT_platform.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_platform.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_platform.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_platform.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -1,37 +1,31 @@
> .include "RT_platform_win32.imc"
> .include "RT_platform_ANSIscreen.imc"
> .sub _platform_setup # void platform_setup(void)
> - saveall
> sysinfo S0, 4
> ne S0, "MSWin32", NOTWIN
> - call _win32_setup
> + _win32_setup()
> branch END
> -NOTWIN: call _ansi_setup
> -END: restoreall
> - ret
> +NOTWIN: _ansi_setup()
> +END: noop
> .end
> .sub _platform_shutdown
> - saveall
> sysinfo S0, 4
> ne S0, "MSWin32", NOTWIN
> - call _win32_shutdown
> + _win32_shutdown()
> branch END
> -NOTWIN: call _ansi_shutdown
> -END: restoreall
> - ret
> +NOTWIN: _ansi_shutdown()
> +END: noop
> .end
> .sub _screen_clear
> - saveall
> find_global $P0, "PRINTCOL"
> set $P0["value"], 0
> store_global "PRINTCOL", $P0
> sysinfo S0, 4
> ne S0, "MSWin32", NOTWIN
> - call _win32_screen_clear
> + _win32_screen_clear()
> branch END
> -NOTWIN: call _ansi_screen_clear
> -END: restoreall
> - ret
> +NOTWIN: _ansi_screen_clear()
> +END: noop
> .end
> #SCREEN_SETXCUR:
> @@ -48,7 +42,6 @@
> #
> # # X in P7, Y in P6
> .sub _screen_locate # void screen_locate(float x, float y)
> - saveall
> .param float xf
> .param float yf
> .local int x
> @@ -58,17 +51,13 @@
> set y, yf
> sysinfo sys, 4
> - .arg y
> - .arg x
> ne sys, "MSWin32", NOTWIN
> - call _WIN32_SCREEN_LOCATE
> + _WIN32_SCREEN_LOCATE(x,y)
> branch END
> -NOTWIN: call _ANSI_SCREEN_LOCATE
> -END: restoreall
> - ret
> +NOTWIN: _ANSI_SCREEN_LOCATE(x,y)
> +END: noop
> .end
> .sub _screen_color # void screen_color(float fore, float back)
> - saveall
> .param float foref
> .param float backf
> .local int fore
> @@ -76,44 +65,35 @@
> .local string sys
> set back, backf
> set fore, foref
> - .arg back
> - .arg fore
> sysinfo sys, 4
> ne sys, "MSWin32", NOTWIN
> - call _WIN32_SCREEN_COLOR
> + _WIN32_SCREEN_COLOR(fore,back)
> branch END
> -NOTWIN: call _ANSI_SCREEN_COLOR
> -END: restoreall
> - ret
> +NOTWIN: _ANSI_SCREEN_COLOR(fore,back)
> +END: noop
> .end
> .sub _line_read
> - saveall
> .local string sys
> sysinfo sys, 4
> eq sys, "MSWin32", END
> - call _TERMIO_normal
> -END: restoreall
> - ret
> + _TERMIO_normal()
> +END: noop
> .end
> .sub _scan_read
> - saveall
> .local string sys
> sysinfo sys, 4
> eq sys, "MSWin32", END
> - call _TERMIO_scankey
> -END: restoreall
> - ret
> + _TERMIO_scankey()
> +END: noop
> .end
> .sub _inkey_string # string inkey$(void)
> - saveall
> .local string sys
> sysinfo sys, 4
> ne sys, "MSWin32", NOTWIN
> - call _WIN32_INKEY
> + _WIN32_INKEY()
> branch END
> -NOTWIN: call _TERMIO_INKEY
> -END: restoreall
> - ret
> +NOTWIN: _TERMIO_INKEY()
> +END: noop
> .end
> 1.2 +4 -47 parrot/languages/BASIC/compiler/RT_platform_ANSIscreen.imc
> Index: RT_platform_ANSIscreen.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_platform_ANSIscreen.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_platform_ANSIscreen.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_platform_ANSIscreen.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -7,7 +7,6 @@
> .const int CYAN = 6
> .const int WHITE = 7
> .sub _ansi_setup
> - saveall
> $P0=new PerlArray
> set $P0[0], BLACK
> set $P0[1], BLUE
> @@ -41,21 +40,15 @@
> $P0=new PerlHash
> $P0["value"]=0
> store_global "scankey", $P0
> -
> - restoreall
> - ret
> .end
> .sub _ansi_screen_clear
> print "\e[2J"
> print "\e[H"
> - ret
> .end
> .sub _ansi_shutdown
> - call _TERMIO_normal
> - ret
> + _TERMIO_normal()
> .end
> .sub _ANSI_SCREEN_LOCATE # void ansi_screen_locate (int x, int y)
> - saveall
> .param int x
> .param int y
> print "\e["
> @@ -63,8 +56,6 @@
> print ";"
> print y
> print "H"
> - restoreall
> - ret
> .end
> ## These don't work exactly right. ANSI would require that I send
> ## \e[6n and read the input stream for a \e[row;colR reply from the
> @@ -93,7 +84,6 @@
> ## 3 = cyan 7 = white 11 = light cyan 15 = bright white
> #
> .sub _ANSI_SCREEN_COLOR # void ansi_screen_color(int fg, int bg)
> - saveall
> .param int fore
> .param int back
> print "\e"
> @@ -115,11 +105,8 @@
> print "4"
> print $I3
> print "m"
> - restoreall
> - ret
> .end
> .sub _set_noecho_cbreak
> - saveall
> loadlib P1, ""
> dlfunc P0, P1, "ioctl", "iiip"
> set I0, 1
> @@ -135,32 +122,21 @@
> set I6, 0x5405
> set P5, P10
> invoke # ioctl(0, TCGETA, &settty);
> - .arg 2
> - .arg 6
> - .arg P10
> - call _get_little_endian
> - .result I0
> + I0 = _get_little_endian(P10,6,2)
> set I1, 2 # ICANON
> bnot I1, I1 # ~ICANON
> band I0, I0, I1 # settty.c_lflag &= ~ICANON;
> set I1, 8 # IECHO
> bnot I1, I1 # ~ICANON
> band I0, I0, I1 # settty.c_lflag &= ~ECHO;
> - .arg I0
> - .arg 2
> - .arg 6
> - .arg P10
> - call _set_little_endian
> + _set_little_endian(P10,6,2,I10)
> set I5, 0
> set I6, 0x5408
> set P5, P10
> invoke # ioctl(0, TCSETAF, &settty);
> store_global "ioctl_mode", P9
> - restoreall
> - ret
> .end
> .sub _set_echo_nocbreak
> - saveall
> loadlib P1, ""
> dlfunc P0, P1, "ioctl", "iiip"
> find_global P9, "ioctl_mode"
> @@ -168,12 +144,9 @@
> set I6, 0x5408
> set P5, P9
> invoke # ioctl(0, TCSETAF, &savetty)
> - restoreall
> - ret
> .end
> .sub _set_nonblock # void _set_nonblock
> - saveall
> set I11, 0
> loadlib P1, ""
> dlfunc P0, P1, "fcntl", "iiii"
> @@ -192,11 +165,8 @@
> $P0=new PerlHash
> set $P0["value"], I11
> store_global "fcntl_mode", $P0
> - restoreall
> - ret
> .end
> .sub _unset_nonblock # void _unset_nonblock
> - saveall
> find_global P0, "fcntl_mode"
> set I11, P0["value"]
> loadlib P1, ""
> @@ -205,11 +175,8 @@
> set I5, 0
> set I6, 4
> invoke # nmode=fcntl(0, F_SETFL, mode)
> - restoreall
> - ret
> .end
> .sub _TERMIO_scankey
> - saveall
> find_global $P0, "scankey"
> set I0, $P0["value"]
> eq I0, 1, END
> @@ -217,11 +184,8 @@
> call _set_noecho_cbreak
> END: set $P0["value"], 1
> store_global "scankey", $P0
> - restoreall
> - ret
> .end
> .sub _TERMIO_normal
> - saveall
> find_global $P0, "scankey"
> set I0, $P0["value"]
> eq I0, 0, END
> @@ -229,19 +193,12 @@
> call _set_echo_nocbreak
> END: set $P0["value"], 0
> store_global "scankey", $P0
> - restoreall
> - ret
> .end
> # For now, uses TERMIO calls directly and assumes you're on a
> # LITTLE ENDIAN machine.
> .sub _TERMIO_INKEY
> - saveall
> -
> read $S0, 1
> -
> - .return $S0
> - restoreall
> - ret
> + .return($S0)
> .end
> 1.2 +19 -76 parrot/languages/BASIC/compiler/RT_platform_win32.imc
> Index: RT_platform_win32.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_platform_win32.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_platform_win32.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_platform_win32.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -1,7 +1,6 @@
> .const int SIZEOF_CONSOLE_SCREEN_BUFFER_INFO = 22
> .const int SIZEOF_DWORD = 4
> .sub _win32_setup # void win32_setup(void)
> - saveall
> loadlib P1, "kernel32.dll"
> dlfunc P0, P1, "GetStdHandle", "pi"
> set I0, 1
> @@ -15,15 +14,11 @@
> store_global "Win32Inputhandle", P5
> $P0= new PerlHash
> store_global "Win32console", $P0
> - call _WIN32_CONSOLE_INFO
> - restoreall
> - ret
> + _WIN32_CONSOLE_INFO()
> .end
> .sub _win32_shutdown # void win32_shutdown(void)
> - ret
> .end
> .sub _WIN32_CONSOLE_INFO # void WIN32_CONSOLE_INFO(void)
> - saveall
> find_global P1, "kernel32"
> dlfunc P0, P1, "GetConsoleScreenBufferInfo", "ipp"
> find_global P5, "Win32handle"
> @@ -34,39 +29,24 @@
> set P5, P6
> find_global P0, "Win32console"
> - .arg P5
> - .arg 0 # dwSize.X
> - call _UMS_GET_SHORT
> - .result $I1
> + $I1 = _UMS_GET_SHORT(0,P5) # 0==dwSize.X
> set P0["xbuf"], $I1
> - .arg P5
> - .arg 2 # dwSize.Y
> - call _UMS_GET_SHORT
> - .result $I1
> + $I1 = _UMS_GET_SHORT(2,P5) # 0==dwSize.X
> set P0["ybuf"], $I1
> - .arg P5
> - .arg 4
> - call _UMS_GET_SHORT
> - .result $I1
> + $I1 = _UMS_GET_SHORT(4,P5)
> inc $I1
> set P0["curx"], $I1
> - .arg P5
> - .arg 4
> - call _UMS_GET_SHORT
> - .result $I1
> + $I1 = _UMS_GET_SHORT(4,P5)
> inc $I1
> set P0["cury"], $I1
> set $I1, P5[8]
> set P0["attr"], $I1 # wAttributes
> - restoreall
> - ret
> .end
> .sub _UMS_GET_SHORT # int value ums_get_short(int offset, ManagedStruct buf)
> - saveall
> .param int offset
> .param ManagedStruct buf
> set $I2, buf[offset]
> @@ -74,29 +54,22 @@
> set $I3, buf[offset]
> shl $I3, $I3, 8
> add $I3, $I3, $I2
> - .return $I3
> - restoreall
> - ret
> + .return($I3)
> .end
> .sub _win32_screen_clear # void _WIN32_SCREEN_CLEAR(void)
> - call _WIN32_CONSOLE_CLEAR
> - call _WIN32_CONSOLE_HOME
> - ret
> + _WIN32_CONSOLE_CLEAR()
> + _WIN32_CONSOLE_HOME()
> .end
> .sub _WIN32_CONSOLE_HOME # void Win32_console_home(void)
> - saveall
> find_global P2, "kernel32"
> dlfunc P0, P2, "SetConsoleCursorPosition", "ipi"
> set I0, 1
> find_global P5, "Win32handle"
> set I5, 0
> invoke
> - restoreall
> - ret
> .end
> .sub _WIN32_CONSOLE_CLEAR # void Win32_console_clear(void)
> - saveall
> find_global P1, "Win32console"
> find_global P2, "kernel32"
> dlfunc P0, P2, "FillConsoleOutputCharacterA", "ipcilp"
> @@ -123,57 +96,35 @@
> mul I6, I1, I2 # Length
> set I7, 0 # Coords
> invoke
> - restoreall
> - ret
> .end
> .sub _WIN32_SCREEN_FINDPOS # void Win32_screen_findpos(void)
> - call _WIN32_CONSOLE_INFO
> - ret
> + _WIN32_CONSOLE_INFO()
> .end
> .sub _WIN32_SCREEN_GETXCUR # int win32_screen_getxcur(void)
> - saveall
> find_global P1, "Win32console"
> set $I0, P1["curx"]
> - .return $I0
> - restoreall
> - ret
> + .return($I0)
> .end
> .sub _WIN32_SCREEN_GETYCUR # int win32_screen_getycur(void)
> - saveall
> find_global P1, "Win32console"
> set $I0, P1["cury"]
> - .return $I0
> - restoreall
> - ret
> + .return($I0)
> .end
> .sub _WIN32_SCREEN_SETXCUR # void win32_screen_setxcur(int x)
> - saveall
> .param int x
> .local int y
> - call _WIN32_SCREEN_FINDPOS
> - call _WIN32_SCREEN_GETYCUR
> - .result y
> - .arg y
> - .arg x
> - call _WIN32_SCREEN_LOCATE
> - restoreall
> - ret
> + _WIN32_SCREEN_FINDPOS()
> + y = _WIN32_SCREEN_GETYCUR()
> + _WIN32_SCREEN_LOCATE(x,y)
> .end
> .sub _WIN32_SCREEN_SETYCUR # void win32_screen_setycur(int y)
> - saveall
> .param int y
> .local int x
> - call _WIN32_SCREEN_FINDPOS
> - call _WIN32_SCREEN_GETXCUR
> - .result x
> - .arg y
> - .arg x
> - call _WIN32_SCREEN_LOCATE
> - restoreall
> - ret
> + _WIN32_SCREEN_FINDPOS()
> + x = _WIN32_SCREEN_GETXCUR()
> + _WIN32_SCREEN_LOCATE(x,y)
> .end
> .sub _WIN32_SCREEN_LOCATE # void win32_screen_locate(int x, int y)
> - saveall
> .param int x
> .param int y
> dec x
> @@ -187,8 +138,6 @@
> set I0, 1
> find_global P5, "Win32handle"
> invoke
> - restoreall
> - ret
> .end
> #SCREEN Mode 0 Syntax: COLOR [foreground][,[background][,border]]
> @@ -221,7 +170,6 @@
> # # background in I1
> # # "border" is not obeyed here.
> .sub _WIN32_SCREEN_COLOR # void Win32_screen_color(int fore, int back)
> - saveall
> .param int fore
> .param int back
> shl I5, back, 4
> @@ -231,16 +179,13 @@
> find_global P5, "Win32handle"
> set I0, 1
> invoke
> - call _WIN32_CONSOLE_INFO # refresh this.
> - restoreall
> - ret
> + _WIN32_CONSOLE_INFO() # refresh this.
> .end
> .const int SIZEOF_INPUT_RECORD = 20
> .const int NUMBER_OF_EVENTS = 128
> # buffer is INPUT_RECORD * EVENTS
> .const int INPUT_BUFFER = 2560
> .sub _WIN32_INKEY # string Win32_inkey(void)
> - saveall
> set S0, ""
> set I9, 0
> find_global P1, "kernel32"
> @@ -302,7 +247,5 @@
> NO_EVENTS:
> END_EVENTS:
> -END: .return S0
> - restoreall
> - ret
> +END: .return(S0)
> .end
> 1.2 +7 -19 parrot/languages/BASIC/compiler/RT_support.imc
> Index: RT_support.imc
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/RT_support.imc,v
> retrieving revision 1.1
> retrieving revision 1.2
> diff -u -r1.1 -r1.2
> --- RT_support.imc 4 Jul 2003 02:13:41 -0000 1.1
> +++ RT_support.imc 14 Nov 2004 06:17:03 -0000 1.2
> @@ -25,8 +25,7 @@
> # branch GEN_ERROR
> .sub _READ # PerlArray READ(void)
> - saveall
> - .local PerlArray READDATA
> + .local pmc READDATA
> .local int READPOINTER
> find_global READDATA, "READDATA"
> find_global $P0, "READPOINTER"
> @@ -38,22 +37,19 @@
> set $S1, READDATA[READPOINTER]
> inc READPOINTER
> - .return $S1
> set $P0["value"], READPOINTER
> store_global "READPOINTER", $P0
> - restoreall
> - ret
> + .return($S1)
> ERR_READ:
> print "Out of data"
> end
> .end
> .sub _RESTORE # void RESTORE(string where)
> - saveall
> .param string where
> .local int READPOINTER
> - .local PerlHash RESTOREINFO
> + .local pmc RESTOREINFO
> find_global RESTOREINFO, "RESTOREINFO"
> find_global $P0, "READPOINTER"
> set READPOINTER, $P0["value"]
> @@ -62,13 +58,10 @@
> set $P0["value"], READPOINTER
> store_global "READPOINTER", $P0
> - restoreall
> - ret
> .end
> .sub _get_little_endian # int get_little_endian(struct, offset, bytes)
> - saveall
> - .param ManagedStruct struct
> + .param pmc struct
> .param int offset
> .param int bytes
> .local int target
> @@ -81,13 +74,10 @@
> add target, target, $I3
> dec $I6
> branch LOOP
> -END: .return target
> - restoreall
> - ret
> +END: .return(target)
> .end
> .sub _set_little_endian # void set_little_endian(struct, offset, bytes, value)
> - saveall
> - .param ManagedStruct struct
> + .param pmc struct
> .param int offset
> .param int bytes
> .param int value
> @@ -99,7 +89,5 @@
> set struct[offset], $I1
> inc offset
> branch LOOP2
> -END2: restoreall
> - ret
> -
> +END2: noop
> .end
> 1.16 +13 -18 parrot/languages/BASIC/compiler/compile.pl
> Index: compile.pl
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/compile.pl,v
> retrieving revision 1.15
> retrieving revision 1.16
> diff -u -r1.15 -r1.16
> --- compile.pl 27 Feb 2004 13:13:25 -0000 1.15
> +++ compile.pl 14 Nov 2004 06:17:03 -0000 1.16
> @@ -9,7 +9,7 @@
> use vars qw( @tokens @tokdsc);
> use vars qw(%code %options @basic %common);
> use vars qw( @syms @type );
> -use vars qw( %labels $runtime_jump $debug $sourceline);
> +use vars qw( %labels $runtime_jump $debug $sourceline);
> use COMP_toker;
> use COMP_parser;
> use COMP_assignments;
> @@ -45,7 +45,6 @@
> open(CODE, ">TARG_test.imc") || die;
> -print CODE qq{.include "RT_initialize.imc"\n};
> foreach my $seg ("_main", "_basicmain", keys %code) {
> next unless exists $code{$seg};
> my @debdecl=();
> @@ -54,6 +53,8 @@
> 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";
> foreach my $var (sort keys %{$code{$seg}->{declarations}}) {
> if ($var=~/_string$/) {
> print CODE "\t.local string $var\n";
> @@ -67,14 +68,14 @@
> }
> }
> - print CODE<<INIT;
> - .sub ${seg}_run # Always jump here.
> - call ${seg}_main
> - ret
> - .end
> -INIT
> + #print CODE<<INIT;
> + #.sub ${seg}_run # Always jump here.
> + #${seg}_main()
> + #ret
> + #.end
> +#INIT
> my($edit,@saves);
> - print CODE "\t.sub ${seg}_main\n\t\tsaveall\n";
> + #print CODE "\t.sub ${seg}_main\n\t\tsaveall\n";
> # If any "common" declared variables are in scope, set them up.
> @saves=();
> @@ -144,8 +145,6 @@
> }
> 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";
> delete $code{$seg};
> if (! $debug) {
> print CODE ".end\t# outer segment\n";
> @@ -168,11 +167,8 @@
> \$P1=new PerlHash
> @debdecl .arg \$P1
> .arg debline
> - call _DEBUGGER_STOP_FOR_REAL
> - DEBUGGER_DONE:
> - restoreall
> - ret
> -
> + _DEBUGGER_STOP_FOR_REAL()
> + DEBUGGER_DONE: noop
> .end # End debug segment
> .end # End outer segment
> EOD
> @@ -197,8 +193,6 @@
> \$P0=new PerlArray
> set \$P1["watch"], \$P0 # Watch
> store_global "DEBUGGER", \$P1
> - restoreall
> - ret
> .end
> FOO
> }
> @@ -206,6 +200,7 @@
> #
> # Pull in the runtime libraries
> #
> +.include "RT_initialize.imc"
> .include "RT_aggregates.imc"
> .include "RT_builtins.imc"
> .include "RT_debugger.imc"
> 1.7 +4 -5 parrot/languages/BASIC/compiler/testrun.pl
> Index: testrun.pl
> ===================================================================
> RCS file: /cvs/public/parrot/languages/BASIC/compiler/testrun.pl,v
> retrieving revision 1.6
> retrieving revision 1.7
> diff -u -r1.6 -r1.7
> --- testrun.pl 27 Feb 2004 13:13:25 -0000 1.6
> +++ testrun.pl 14 Nov 2004 06:17:03 -0000 1.7
> @@ -1,11 +1,10 @@
> #! perl -w
> no warnings 'once';
> -$parpath='../../../languages/imcc/';
> -if (! -d $parpath) {
> - $parpath='../../..';
> -}
> +$parpath='../../../';
> unlink "_test.pbc";
> -$a=system("$parpath/imcc.exe TARG_test.imc");
> +# XXX - This file should be generated at config time, so as to get
> +# the appropriate path and executable name.
> +$a=system("$parpath/parrot TARG_test.imc");
|
