Author: coke
Date: Fri Oct 7 13:22:03 2005
New Revision: 9398
Modified:
trunk/languages/BASIC/compiler/COMP_parser.pm
trunk/languages/BASIC/compiler/RT_aggregates.imc
trunk/languages/BASIC/compiler/RT_builtins.imc
trunk/languages/BASIC/compiler/RT_platform_ANSIscreen.imc
trunk/languages/BASIC/compiler/RT_platform_win32.imc
trunk/languages/LANGUAGES.STATUS
Log:
BASIC: Update the ANSI version of the code to use the new calling conventions.
Several of the samples work again.
Windows platform was just commented out due to lack of test platform.
Modified: trunk/languages/BASIC/compiler/COMP_parser.pm
==============================================================================
--- trunk/languages/BASIC/compiler/COMP_parser.pm (original)
+++ trunk/languages/BASIC/compiler/COMP_parser.pm Fri Oct 7 13:22:03 2005
@@ -1,7 +1,7 @@
#! perl -w
use strict;
-use constant VERSION => 2.2;
+use constant VERSION => 2.3;
use constant PREV => 2;
use constant CURR => 1;
Modified: trunk/languages/BASIC/compiler/RT_aggregates.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_aggregates.imc (original)
+++ trunk/languages/BASIC/compiler/RT_aggregates.imc Fri Oct 7 13:22:03 2005
@@ -5,102 +5,112 @@
.const int PMC = 4
.sub _ARRAY_LOOKUP_N # float ARRAY_LOOKUP_N(string array, int keycount[,
string|float])
.param string array
+ .param int keycount
+ .param pmc things :slurpy
+
.local string key
.local pmc BASICARR
find_global BASICARR, "BASICARR"
- key = _ARRAY_BUILDKEY()
- set $P0, BASICARR[array]
- ne key, "", ARR_NORMAL
+ key = _ARRAY_BUILDKEY(keycount,things)
+ $P0 = BASICARR[array]
+ if key != "" goto ARR_NORMAL
.return($P0) # Return the whole array.
ARR_NORMAL:
- $P1=$P0["hash"] # forked arrays, awaiting keys()
- set $N0, $P1[key]
+ $P1 = $P0["hash"] # forked arrays, awaiting keys()
+ $N0 = $P1[key]
.return($N0)
.end
+
.sub _ARRAY_LOOKUP_S # string ARRAY_LOOKUP_S(string array, int keycount[,
string|float])
.param string array
+ .param int keycount
+ .param pmc things :slurpy
+
.local string key
.local pmc BASICARR
find_global BASICARR, "BASICARR"
- key = _ARRAY_BUILDKEY()
- set $P0, BASICARR[array]
- ne key, "", ARR_NORMAL
+ key = _ARRAY_BUILDKEY(keycount, things)
+ $P0 = BASICARR[array]
+ if key != "" goto ARR_NORMAL
.return($P0)
ARR_NORMAL:
- $P1=$P0["hash"] # forked arrays, awaiting keys()
- set $S0, $P1[key]
+ $P1 = $P0["hash"] # forked arrays, awaiting keys()
+ $S0 = $P1[key]
.return($S0)
ARR_END:
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])
.param string array
-
- # 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.
+ .param pmc rhs
+ .param int keycount
+ .param pmc things :slurpy
# Assign a number
- ne I4, 1, ASSIGN_STRING
+ .local int rhs_type
+ rhs_type = typeof rhs
+ if rhs_type == .String goto ASSIGN_STRING
.local string key
.local pmc BASICARR
- find_global BASICARR, "BASICARR"
+ BASICARR = find_global "BASICARR"
- key = _ARRAY_BUILDKEY() # Will absorb rest of arguments.
- set $P1, BASICARR[array]
- set $P0, $P1["hash"]
- set $P0[key], N5
+ key = _ARRAY_BUILDKEY(keycount,things)
+ $P1 = BASICARR[array]
+ $P0 = $P1["hash"]
+ $P0[key] = rhs
store_global "BASICARR", BASICARR
- branch END_ASSIGN
+ goto END_ASSIGN
# Assign a string
ASSIGN_STRING:
- ne I2, 1, ASSIGN_UNK
+ if rhs_type != .String goto ASSIGN_UNK
.local string key
.local pmc BASICARR
find_global BASICARR, "BASICARR"
- key = _ARRAY_BUILDKEY() # Will absorb rest of arguments.
- set $P1, BASICARR[array]
- set $P0, $P1["hash"]
- set $P0[key], S5
+ key = _ARRAY_BUILDKEY(keycount, things)
+ $P1 = BASICARR[array]
+ $P0 = $P1["hash"]
+ $P0[key] = rhs
store_global "BASICARR", BASICARR
- branch END_ASSIGN
+ goto END_ASSIGN
# Assign a... well, we dunno WTF this is.
ASSIGN_UNK:
- ne I3, 1, ASSIGN_ERR
+ #ne I3, 1, ASSIGN_ERR (handled by calling conventions now)
.local string key
.local pmc BASICARR
find_global BASICARR, "BASICARR"
- key = _ARRAY_BUILDKEY()
- set $P1, BASICARR[array]
- set $P0, $P1["hash"]
+ key = _ARRAY_BUILDKEY(keycount,things)
+ $P1 = BASICARR[array]
+ $P0 = $P1["hash"]
+ $S0 = rhs[TYPE]
- set $S0, P5[TYPE]
- ne $S0, "STRING", NOTSTRING
- set $S1, P5[VALUE]
- set $P0[key], $S1
- branch END_UNK
+ if $S0 != "STRING" goto NOTSTRING
+ $S1 = rhs[VALUE]
+ $P0[key]= $S1
+ goto END_UNK
NOTSTRING:
- ne $S0, "INT", NOTINT
- set $I0, P5[VALUE]
- set $N0, $I0
- set $P0[key], $N0
- branch END_UNK
-
-NOTINT: ne $S0, "FLOAT", ASSIGN_ERR
- set $N0, P5[VALUE]
- set $P0[key], $N0
- branch END_UNK
+ if $S0 != "INT" goto NOTINT
+ $I0 = rhs[VALUE]
+ $N0 = $I0
+ $P0[key] = $N0
+ goto END_UNK
+
+NOTINT:
+ if $S0 != "FLOAT" goto ASSIGN_ERR
+ $N0 = rhs[VALUE]
+ $P0[key] = $N0
+ #goto END_UNK
END_UNK:
store_global "BASICARR", BASICARR
- branch END_ASSIGN
+ goto END_ASSIGN
ASSIGN_ERR:
print "Assignment error"
@@ -110,20 +120,23 @@ ASSIGN_ERR:
END_ASSIGN:
# Temporary, needed only until PerlHash->keys() gets implemented
find_global BASICARR, "BASICARR"
- set $P1, BASICARR[array]
- set $P0, $P1["index"]
+ $P1 = BASICARR[array]
+ $P0 = $P1["index"]
.local int i
- set i, 0
-E_A: set $S0, $P0[i]
- eq $S0, "", E_A2
- eq $S0, key, E_A2
+ i = 0
+E_A:
+ $S0 = $P0[i]
+ if $S0=="" goto E_A2
+ if $S0==key goto E_A2
inc i
- branch E_A
-E_A2: $P0[i]=key
+ goto E_A
+E_A2:
+ $P0[i]=key
$P1["index"]=$P0
BASICARR[array]=$P1
store_global "BASICARR", BASICARR
-REALEND:noop
+REALEND:
+ noop
.end
# This gets a *lot* easier when PerlHash->keys() gets implemented
.sub _ARRAY_KEYS # void ARRAY_KEYS(string source, string target)
@@ -172,30 +185,41 @@ ENDLOOP:noop
# store_global "BASICARR", BASICARR
#.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...])
.param int keycount
+ .param pmc things
+
.local string key
- set key, ""
-KEYLOOP:le keycount, 0, KEYDONE
- concat key, "|"
- eq I4, 1, ADDFLOAT
- eq I2, 1, ADDSTRING
+ key = ""
+
+ .local pmc thing
+ .local int key_type
+KEYLOOP:
+ if keycount ==0 goto KEYDONE
+ thing = shift things
+ key_type = typeof thing
+
+ key .= "|"
+ if key_type == .Float goto ADDFLOAT
+ if key_type == .String goto ADDSTRING
+
print "Wrong type on stack, key creation\n"
end
ADDFLOAT:
- restore $N0
- set $I1, $N0
- set $S0, $I1
- concat key, $S0
+ $I1 = thing
+ $S0 = $I1
+ key .= $S0
dec keycount
- branch KEYLOOP
+ goto KEYLOOP
ADDSTRING:
- restore $S0
- concat key, $S0
+ $S0 = thing
+ key .= $S0
dec keycount
- branch KEYLOOP
-
-KEYDONE:.return(key)
+ goto KEYLOOP
+KEYDONE:
+ .return(key)
.end
Modified: trunk/languages/BASIC/compiler/RT_builtins.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_builtins.imc (original)
+++ trunk/languages/BASIC/compiler/RT_builtins.imc Fri Oct 7 13:22:03 2005
@@ -17,6 +17,7 @@
#
.sub _BUILTIN_DISPLAY #_WORK # string display_work(string|float
thingy[, string|float thingy2])
.param int argc
+ .param pmc printme
.local string buf
.local int intver
@@ -26,60 +27,69 @@
# 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"]
+ $P0 = find_global "PRINTCOL"
+ PRINTCOL = $P0["value"]
- set buf, ""
-NEXT: eq argc, 0, END_DISPLAY
+ buf = ""
+NEXT:
+ if argc==0 goto END_DISPLAY
dec argc
- eq I2, 1, DISPSTRING
- ne I4, 1, DISPERR
+ $I0 = typeof printme
+ if $I0 == .String goto DISPSTRING
+ if $I0 != .Float goto DISPERR
# Now, do floats
- set intver, N5
- set $N0, intver
- 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, " "
- branch NEXT
+ intver = printme
+ $N0 = intver
+ $N1 = printme
+ if $N0 == $N1 goto DISPINT # Nope, it's an integer.
+ s = _NORMALIZE_FLOAT(printme)
+ if printme < 0 goto NEGFLO
+ buf .= " "
+NEGFLO:
+ buf .= s
+ buf .= " "
+ goto NEXT
# Integers display -1234_
# or _1234
-DISPINT:set $S0, intver
- lt intver, 0, NEGINT
- concat buf, " "
-NEGINT: concat buf, $S0
- concat buf, " "
- branch NEXT
+DISPINT:
+ $S0 = intver
+ if intver <0 goto NEGINT
+ buf .= " "
+NEGINT:
+ buf .= $S0
+ buf .= " "
+ goto NEXT
DISPSTRING:
- length $I0, S5
- eq S5, "\t", DISPTAB
- concat buf, S5
- eq S5, "\n", DISPNL
- add PRINTCOL, PRINTCOL, $I0
- branch NEXT
+ s = printme
+ $I0 = length s
+ if s == "\t" goto DISPTAB
+ buf .= s
+ if s == "\n" goto DISPNL
+ PRINTCOL += $I0
+ goto NEXT
DISPTAB:
- set $I0, PRINTCOL
- mod $I0, $I0, 8
- sub $I0, 7, $I0
- set $I1, 0
- eq $I1, $I0, NEXT
- concat buf, " "
+ $I0 = PRINTCOL
+ $I0 %= 8
+ $I0 = 7 - $I0
+ $I1 = 0
+ if $I1 == $I0 goto NEXT
+ buf .= " "
inc PRINTCOL
- inc I1
- branch DISPTAB
-DISPNL: set PRINTCOL, 0
- branch NEXT
+ inc $I1
+ goto DISPTAB
+DISPNL:
+ PRINTCOL = 0
+ goto NEXT
END_DISPLAY:
- set $P0["value"], PRINTCOL
+ $P0["value"] = PRINTCOL
store_global "PRINTCOL", $P0
print buf
.return(buf)
-DISPERR:print "Unknown type on stack to print\n"
+DISPERR:
+ print "Unknown type on stack to print\n"
end
.end
Modified: trunk/languages/BASIC/compiler/RT_platform_ANSIscreen.imc
==============================================================================
--- trunk/languages/BASIC/compiler/RT_platform_ANSIscreen.imc (original)
+++ trunk/languages/BASIC/compiler/RT_platform_ANSIscreen.imc Fri Oct 7
13:22:03 2005
@@ -1,53 +1,68 @@
.const int BLACK = 0
-.const int RED = 1
+.const int RED = 1
.const int GREEN = 2
.const int YELLOW = 3
.const int BLUE = 4
.const int MAGENTA= 5
.const int CYAN = 6
.const int WHITE = 7
+
+.const int TCGETA = 0x5405
+.const int TCSETAF = 0x5408
+
+.const int ICANON = 2
+.const int IECHO = 8
+
+.const int F_GETFL = 3
+.const int F_SETFL = 4
+
+.const int STDIN = 0
+
.sub _ansi_setup
- $P0=new PerlArray
- set $P0[0], BLACK
- set $P0[1], BLUE
- set $P0[2], GREEN
- set $P0[3], CYAN
- set $P0[4], RED
- set $P0[5], MAGENTA
- set $P0[6], YELLOW
- set $P0[7], WHITE
+ $P0=new .PerlArray
+ $P0[0]= BLACK
+ $P0[1]= BLUE
+ $P0[2]= GREEN
+ $P0[3]= CYAN
+ $P0[4]= RED
+ $P0[5]= MAGENTA
+ $P0[6]= YELLOW
+ $P0[7]= WHITE
store_global "ANSI_fgcolors", $P0
- $P0=new PerlArray
- set $P0[0], BLACK
- set $P0[1], BLUE
- set $P0[2], GREEN
- set $P0[3], CYAN
- set $P0[4], RED
- set $P0[5], MAGENTA
- set $P0[6], YELLOW
- set $P0[7], WHITE
- set $P0[8], BLACK
- set $P0[9], BLUE
- set $P0[10], GREEN
- set $P0[11], CYAN
- set $P0[12], RED
- set $P0[13], MAGENTA
- set $P0[14], YELLOW
- set $P0[15], 8
+ $P0=new .PerlArray
+ $P0[0]= BLACK
+ $P0[1]= BLUE
+ $P0[2]= GREEN
+ $P0[3]= CYAN
+ $P0[4]= RED
+ $P0[5]= MAGENTA
+ $P0[6]= YELLOW
+ $P0[7]= WHITE
+ $P0[8]= BLACK
+ $P0[9]= BLUE
+ $P0[10]= GREEN
+ $P0[11]= CYAN
+ $P0[12]= RED
+ $P0[13]= MAGENTA
+ $P0[14]= YELLOW
+ $P0[15]= 8
store_global "ANSI_bgcolors", $P0
- $P0=new PerlHash
+ $P0=new .PerlHash
$P0["value"]=0
store_global "scankey", $P0
.end
+
.sub _ansi_screen_clear
print "\e[2J"
print "\e[H"
.end
+
.sub _ansi_shutdown
_TERMIO_normal()
.end
+
.sub _ANSI_SCREEN_LOCATE # void ansi_screen_locate (int x, int y)
.param int x
.param int y
@@ -57,6 +72,7 @@
print y
print "H"
.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
## terminal. I *really* can't do that until IO is fixed, because STDIN
@@ -94,102 +110,110 @@
lt fore, 8, ANSI_FG
sub fore, fore, 8
print "1;" # Turn on high intensity
-ANSI_FG: set $I3, $P0[fore]
+ANSI_FG:
+ $I3 = $P0[fore]
print "3"
print $I3
print ";"
# Background
-ANSI_BG:find_global $P0, "ANSI_bgcolors"
- set $I3, $P0[back]
+ANSI_BG:
+ $P0 = find_global "ANSI_bgcolors"
+ $I3 = $P0[back]
print "4"
print $I3
print "m"
.end
+
.sub _set_noecho_cbreak
- loadlib P1, ""
- dlfunc P0, P1, "ioctl", "iiip"
- set I0, 1
- P9 = new ManagedStruct # Saved
- P10 = new ManagedStruct # New
- set P9, 20 # sizeof termio 4/byte aligned
- set P10, 20
- set I5, 0
- set I6, 0x5405 # TCGETA
- set P5, P9
- invoke # ioctl(0, TCGETA, &savetty);
- set I5, 0
- set I6, 0x5405
- set P5, P10
- invoke # ioctl(0, TCGETA, &settty);
- 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;
- _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
+
+ $P1 = loadlib ""
+ .local pmc ioctl
+ ioctl = dlfunc $P1, "ioctl", "iiip"
+
+ $P9 = new .ManagedStruct # Saved
+ $P9 = 20
+
+ $P10 = new .ManagedStruct # New
+ $P10 = 20
+
+ ioctl(0, TCGETA, $P9)
+
+ ioctl(0, TCGETA, $P10)
+
+ $I0 = _get_little_endian($P10,6,2)
+
+ $I1 = ICANON
+ $I1 = bnot $I1
+ $I0 = band $I0, $I1 # settty.c_lflag &= ~ICANON;
+
+ $I1 = IECHO
+ $I1 = bnot $I1
+ $I0 = band $I0, $I1 # settty.c_lflag &= ~ECHO;
+
+ _set_little_endian($P10,6,2,$I0)
+
+ ioctl(0, TCSETAF, $P10)
+
+ store_global "ioctl_mode", $P9
.end
+
.sub _set_echo_nocbreak
- loadlib P1, ""
- dlfunc P0, P1, "ioctl", "iiip"
- find_global P9, "ioctl_mode"
- set I5, 0
- set I6, 0x5408
- set P5, P9
- invoke # ioctl(0, TCSETAF, &savetty)
+ $P1 = loadlib ""
+ .local pmc ioctl
+ ioctl = dlfunc $P1, "ioctl", "iiip"
+ $P9 = find_global "ioctl_mode"
+
+ ioctl(0, TCSETAF, $P9)
.end
.sub _set_nonblock # void _set_nonblock
- set I11, 0
- loadlib P1, ""
- dlfunc P0, P1, "fcntl", "iiii"
- set I0, 1
- set I5, 0 # Stdin
- set I6, 3 # F_GETFL
- invoke # mode=fcntl(0, F_GETFL, unused)
-
- set I11, I5 # Old values
- dlfunc P0, P1, "fcntl", "iiil"
- bor I7, I5, 2048 # O_NONBLOCK 04000
- set I5, 0 # Stdin
- set I6, 4 # F_SETFL
- invoke # nmode=fcntl(0, F_SETFL, mode | O_NONBLOCK)
+ I11= 0
+ $P1 = loadlib ""
+ .local pmc fcntl
+ fcntl = dlfunc $P1, "fcntl", "iiii"
+
+ .local int old_value
+ old_value = fcntl(STDIN, F_GETFL)
+
+ fcntl = dlfunc $P1, "fcntl", "iiil"
+
+ $I7 = bor I5, 2048 # O_NONBLOCK 04000
+ #invoke # nmode=fcntl(0, F_SETFL, mode | O_NONBLOCK)
+ fcntl(STDIN, F_SETFL, $I7)
- $P0=new PerlHash
- set $P0["value"], I11
+ $P0=new .PerlHash
+ $P0["value"]= old_value
store_global "fcntl_mode", $P0
.end
+
.sub _unset_nonblock # void _unset_nonblock
- find_global P0, "fcntl_mode"
- set I11, P0["value"]
- loadlib P1, ""
- dlfunc P0, P1, "fcntl", "iiil"
- set I7, I11
- set I5, 0
- set I6, 4
- invoke # nmode=fcntl(0, F_SETFL, mode)
+ $P0 = find_global "fcntl_mode"
+ $I11= $P0["value"]
+ $P1 = loadlib ""
+ .local pmc fcntl
+ fcntl = dlfunc $P1, "fcntl", "iiil"
+
+ fcntl(0, F_SETFL, $I11)
.end
+
.sub _TERMIO_scankey
find_global $P0, "scankey"
- set I0, $P0["value"]
+ I0= $P0["value"]
eq I0, 1, END
_set_noecho_cbreak()
-END: set $P0["value"], 1
+END:
+ $P0["value"]= 1
store_global "scankey", $P0
.end
+
.sub _TERMIO_normal
find_global $P0, "scankey"
- set I0, $P0["value"]
+ I0= $P0["value"]
eq I0, 0, END
_set_echo_nocbreak()
-END: set $P0["value"], 0
+END:
+ $P0["value"]= 0
store_global "scankey", $P0
.end
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 Fri Oct 7
13:22:03 2005
@@ -1,3 +1,7 @@
+=for fixing
+
+I can't test this on windows, and it's currently broken. Please fix it.
+
.const int SIZEOF_CONSOLE_SCREEN_BUFFER_INFO = 22
.const int SIZEOF_DWORD = 4
.sub _win32_setup # void win32_setup(void)
@@ -249,3 +253,5 @@ NO_EVENTS:
END_EVENTS:
END: .return(S0)
.end
+
+=cut
Modified: trunk/languages/LANGUAGES.STATUS
==============================================================================
--- trunk/languages/LANGUAGES.STATUS (original)
+++ trunk/languages/LANGUAGES.STATUS Fri Oct 7 13:22:03 2005
@@ -18,19 +18,17 @@ W: http://xamber.org/
N: BASIC/compiler
A: Clint Pierce
-A: Will Coleda (work with parrot 0.1.0+)
+A: Will Coleda (work with parrot 0.3.0+)
D: BASIC Compiler
-S: Broken. Using PIR, but deprecated "invoke" and manually managing
-S: old-sylte calling conventions: needs to be updated to work with new
-S: calling conventions
+S: some of the samples work again.
M: Yes
-V: N/A
+V: 0.3.0
N: BASIC/interpreter
A: Clint Pierce
D: BASIC Interpreter written in pure Parrot
S: Broken - probably due to changes in PIR syntax.
-M: Yes
+M: No?
V: 0.0.11
N: bc
