cvsuser 03/07/03 19:13:41
Modified: languages/BASIC/compiler compile.pl testsuite.pl
Added: languages/BASIC/compiler 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
Removed: languages/BASIC/compiler RT_aggregates.pasm RT_builtins.pasm
RT_debugger.pasm RT_initialize.pasm RT_io.pasm
RT_platform.pasm RT_platform_ANSIscreen.pasm
RT_platform_win32.pasm RT_support.pasm
Log:
IMCC now doesn't allow .const in .pasm files. Renamed all of the .pasm files
to .imc (they're PIR anyway).
Revision Changes Path
1.13 +7 -7 parrot/languages/BASIC/compiler/compile.pl
Index: compile.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/compile.pl,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -w -r1.12 -r1.13
--- compile.pl 29 Jun 2003 01:23:26 -0000 1.12
+++ compile.pl 4 Jul 2003 02:13:41 -0000 1.13
@@ -45,7 +45,7 @@
open(CODE, ">TARG_test.imc") || die;
-print CODE qq{.include "RT_initialize.pasm"\n};
+print CODE qq{.include "RT_initialize.imc"\n};
foreach my $seg ("_main", "_basicmain", keys %code) {
next unless exists $code{$seg};
my @debdecl=();
@@ -206,12 +206,12 @@
#
# Pull in the runtime libraries
#
-.include "RT_aggregates.pasm"
-.include "RT_builtins.pasm"
-.include "RT_debugger.pasm"
-.include "RT_io.pasm"
-.include "RT_platform.pasm"
-.include "RT_support.pasm"
+.include "RT_aggregates.imc"
+.include "RT_builtins.imc"
+.include "RT_debugger.imc"
+.include "RT_io.imc"
+.include "RT_platform.imc"
+.include "RT_support.imc"
RUNTIMESHUTDOWN
close(CODE);
1.16 +4 -0 parrot/languages/BASIC/compiler/testsuite.pl
Index: testsuite.pl
===================================================================
RCS file: /cvs/public/parrot/languages/BASIC/compiler/testsuite.pl,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -w -r1.15 -r1.16
--- testsuite.pl 30 Jun 2003 01:21:08 -0000 1.15
+++ testsuite.pl 4 Jul 2003 02:13:41 -0000 1.16
@@ -32,6 +32,10 @@
}
__DATA__
+input a$,
+print a$
+
+STOPPLEASE
' Expect 10
sub second(b() )
b(5)=10
1.1 parrot/languages/BASIC/compiler/RT_aggregates.imc
Index: RT_aggregates.imc
===================================================================
# Array things.
# Yes, the _N and _S are cheesy hacks.
.const int FLOAT = 2
.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
find_global BASICARR, "BASICARR"
call _ARRAY_BUILDKEY
.result key
set $P0, BASICARR[array]
ne key, "", ARR_NORMAL
.return $P0 # Return the whole array.
branch ARR_END
ARR_NORMAL:
$P1=$P0["hash"] # forked arrays, awaiting keys()
set $N0, $P1[key]
.return $N0
ARR_END:
restoreall
ret
.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
find_global BASICARR, "BASICARR"
call _ARRAY_BUILDKEY
.result key
set $P0, BASICARR[array]
ne key, "", ARR_NORMAL
.return $P0
branch ARR_END
ARR_NORMAL:
$P1=$P0["hash"] # forked arrays, awaiting keys()
set $S0, $P1[key]
.return $S0
ARR_END:
restoreall
ret
.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
# Assign a number
ne $I0, FLOAT, ASSIGN_STRING
.param float rhs
.local string key
.local PerlHash BASICARR
find_global BASICARR, "BASICARR"
call _ARRAY_BUILDKEY # Will absorb rest of arguments.
.result key
set $P1, BASICARR[array]
set $P0, $P1["hash"]
set $P0[key], rhs
store_global "BASICARR", BASICARR
branch END_ASSIGN
# Assign a string
ASSIGN_STRING:
ne $I0, STRING, ASSIGN_UNK
.param string rhs
.local string key
.local PerlHash BASICARR
find_global BASICARR, "BASICARR"
call _ARRAY_BUILDKEY # Will absorb rest of arguments.
.result key
set $P1, BASICARR[array]
set $P0, $P1["hash"]
set $P0[key], rhs
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
.local string key
.local PerlHash BASICARR
find_global BASICARR, "BASICARR"
call _ARRAY_BUILDKEY
set $P1, BASICARR[array]
set $P0, $P1["hash"]
.result key
set $S0, blob[TYPE]
ne $S0, "STRING", NOTSTRING
set $S1, blob[VALUE]
set $P0[key], $S1
branch END_UNK
NOTSTRING:
ne $S0, "INT", NOTINT
set $I0, blob[VALUE]
set $N0, $I0
set $P0[key], $N0
branch END_UNK
NOTINT: ne $S0, "FLOAT", ASSIGN_ERR
set $N0, blob[VALUE]
set $P0[key], $N0
branch END_UNK
END_UNK:
store_global "BASICARR", BASICARR
branch END_ASSIGN
ASSIGN_ERR:
print "Assignment error"
print $I0
end
END_ASSIGN:
# Temporary, needed only until PerlHash->keys() gets implemented
find_global BASICARR, "BASICARR"
set $P1, BASICARR[array]
set $P0, $P1["index"]
.local int i
set i, 0
E_A: set $S0, $P0[i]
eq $S0, "", E_A2
eq $S0, key, E_A2
inc i
branch E_A
E_A2: $P0[i]=key
$P1["index"]=$P0
BASICARR[array]=$P1
store_global "BASICARR", BASICARR
REALEND:restoreall
ret
.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 PerlArray SRCINDEX
.local PerlHash TARGARR
.local PerlArray TARGINDEX
.local int i
find_global BASICARR, "BASICARR"
$P0=BASICARR[source]
SRCINDEX=$P0["index"]
$P0=BASICARR[target]
TARGARR=$P0["hash"]
TARGINDEX=$P0["index"]
set i, 0
KEYLOOP:set $S0, SRCINDEX[i]
eq $S0, "", ENDLOOP
set $S1, i
set $S2, "|"
concat $S2, $S2, $S1
length $I1, $S0
dec $I1
substr $S3, $S0, 1, $I1
TARGARR[$S2]=$S3
TARGINDEX[i]=$S2
inc i
branch KEYLOOP
ENDLOOP:restoreall
ret
.end
#.sub _ARRAY_ASSIGN_S # void ARRAY_ASSIGN_N(string array, string rhs, int keycount[,
string|float keys])
# saveall
# .param string array
# .param string rhs
# .local string key
# .local PerlHash BASICARR
# find_global BASICARR, "BASICARR"
# call _ARRAY_BUILDKEY # Will absorb rest of arguments.
# .result key
# set $P0, BASICARR[array]
# set $P0[key], rhs
#
# store_global "BASICARR", BASICARR
# restoreall
# ret
#.end
# These are probably defined somewhere, I can't find them.
.const int FLOAT = 2
.const int STRING = 3
.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
print "Wrong type on stack, key creation\n"
end
ADDFLOAT:
restore $N0
set $I1, $N0
set $S0, $I1
concat key, $S0
dec keycount
branch KEYLOOP
ADDSTRING:
restore $S0
concat key, $S0
dec keycount
branch KEYLOOP
KEYDONE:.return key
restoreall
ret
.end
1.1 parrot/languages/BASIC/compiler/RT_builtins.imc
Index: RT_builtins.imc
===================================================================
# Display stuff on stack.
#
.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
# Prepares stuff for printing. Side effect: edits the global PRINTCOL
# for the current column.
#
.sub _BUILTIN_DISPLAY_WORK # string display_work(string|float thingy[,
string|float thingy2])
saveall
.param int argc
.local string buf
.local int intver
.local string s
.local int PRINTCOL
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
# Now, do floats
.param float number
set intver, number
set $N0, intver
eq $N0, number, DISPINT # Nope, it's an integer.
.arg number
call _NORMALIZE_FLOAT
.result s
lt number, 0.0, NEGFLO
concat buf, " "
NEGFLO: concat buf, s
concat buf, " "
branch NEXT
# Integers display -1234_
# or _1234
DISPINT:set $S0, intver
lt intver, 0, NEGINT
concat buf, " "
NEGINT: concat buf, $S0
concat buf, " "
branch NEXT
DISPSTRING:
.param string str
length $I0, str
eq str, "\t", DISPTAB
concat buf, str
eq str, "\n", DISPNL
add PRINTCOL, PRINTCOL, $I0
branch NEXT
DISPTAB:
set $I0, PRINTCOL
mod $I0, $I0, 8
sub $I0, 7, $I0
set $I1, 0
eq $I1, $I0, NEXT
concat buf, " "
inc PRINTCOL
inc I1
branch DISPTAB
DISPNL: set PRINTCOL, 0
branch NEXT
END_DISPLAY:
.return buf
set $P0["value"], PRINTCOL
store_global "PRINTCOL", $P0
restoreall
ret
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:
length $I0, $S0
substr $S1, $S0, $I0, 1
eq $S1, ".", FLO_CHOP_DEC
eq $S1, "0", FLO_CHOP
branch FLO_END
FLO_CHOP_DEC:
substr $S0, $S0, 0, $I0
branch FLO_END
FLO_CHOP:
substr $S0, $S0, 0, $I0
branch FLO_NORM
FLO_END:
.return $S0
restoreall
ret
.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
.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
.local int truncate
set truncate, arg
set res, truncate
ge arg, 0.0, ENDINT
dec res
ENDINT: .return res
restoreall
ret
.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
.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
.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
.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
.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
.end
.sub _BUILTIN_MID_STRING # string mid(string targ, float start [, float extent])
saveall
.param int argc
.param string target
.param float start
.local string res
.local string a
.local int strlen
.local int pos
length strlen, target
set res, ""
set pos, start
dec pos
eq argc, 3, MID3ARG
MIDLOOP:ge pos, strlen, MIDDONE
substr a, target, pos, 1
concat res, a
inc pos
branch MIDLOOP
MID3ARG:
.local float count
.param float extent
set count, 0.0
MID3L:
ge pos, strlen, MIDDONE
substr a, target, pos, 1
concat res, a
inc pos
inc count
ge count, extent, MIDDONE
branch MID3L
MIDDONE:
.return res
restoreall
ret
.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
.end
.sub _BUILTIN_RIGHT_STRING # string right(string targ, float extent)
saveall
.param int argc
.param string targ
.param float extent
.local string res
.local int conv
length $I0, targ
set conv, extent
sub $I0, $I0, conv
inc $I0
set $N0, $I0
.arg extent
.arg $N0
.arg targ
.arg 3
call _BUILTIN_MID_STRING
restoreall
ret
.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
find_global $P0, "RANDSEED"
set RANDSEED, $P0["value"]
eq argc, 0, RND_GEN
.param float repeat
eq repeat, 0.0, RND_REPEAT
RND_GEN:
mul RANDSEED, RANDSEED, 5
add RANDSEED, RANDSEED, 1
mod RANDSEED, RANDSEED, 65536
set $N0, RANDSEED
div $N0, $N0, 65536.0
branch RND_BAIL
RND_REPEAT:
set $N0, RANDSEED
div $N0, $N0, 65536.0
RND_BAIL:
.return $N0
set $P0["value"], RANDSEED
store_global "RANDSEED", $P0
restoreall
ret
.end
.sub _BUILTIN_TIMER # float timer()
saveall
.param int argc
time $N0
.return $N0
restoreall
ret
.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
set start, startf
NOSTART:
dec start # BASIC starts at 1.
.param string full
.param string substr
length $I0, substr
eq $I0, 0, ENDINSTR
index $I0, full, substr, start
set $N0, $I0
ENDINSTR:inc $N0
.return $N0
restoreall
ret
.end
.sub _BUILTIN_UCASE_STRING # string ucase$(string targ)
saveall
.param int argc
.arg 122
.arg 97
.arg 32
call _XCASE
restoreall
ret
.end
.sub _BUILTIN_LCASE_STRING # string lcase$(string targ)
saveall
.param int argc
.arg 90
.arg 65
.arg -32
call _XCASE
restoreall
ret
.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
.param string targ
length $I5, targ
set $S3, ""
set $I0, 0
XCASE_LOOP:
ge $I0, $I5, XCASE_DONE
substr $S1, targ, $I0, 1
ord $I2, $S1
ge $I2, lower, XCASE_OK1
branch XCASE_INSERT
XCASE_OK1:
le $I2, upper, XCASE_SHIFT
branch XCASE_INSERT
XCASE_SHIFT:
sub $I2, $I2, offset
XCASE_INSERT:
chr $S1, $I2
concat $S3, $S1
inc $I0
branch XCASE_LOOP
XCASE_DONE:
.return $S3
restoreall
ret
.end
.sub _BUILTIN_SGN # float sgn(float number)
saveall
.param int argc
.param float number
set $N0, 0.0
eq number, 0.0, FINISHED
set $N0, -1.0
lt number, 0.0, FINISHED
set $N0, 1.0
FINISHED:
.return $N0
restoreall
ret
.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
.local string target
set $I1, 0
set target, ""
entrytype $I0, 0
eq $I0, FLOAT, FLOATB
.param string thing
set repeater, thing
branch REP
FLOATB: .param 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
.end
.sub _TRIG_IN
saveall
.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
.end
.sub _BUILTIN_EXP # float exp(float op)
call _TRIG_IN
exp $N0, $N0
call _TRIG_OUT
ret
.end
.sub _BUILTIN_SIN # float sin(float op)
call _TRIG_IN
sin $N0, $N0
call _TRIG_OUT
ret
.end
.sub _BUILTIN_COS # float cos(float op)
call _TRIG_IN
cos $N0, $N0
call _TRIG_OUT
ret
.end
.sub _BUILTIN_TAN # float tan(float op)
call _TRIG_IN
tan $N0, $N0
call _TRIG_OUT
ret
.end
.sub _BUILTIN_ATN # float atn(float op)
call _TRIG_IN
atan $N0, $N0
call _TRIG_OUT
ret
.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
ERR_RANGE:
print "Number out of range\n"
.return -1.0
restoreall
ret
.end
.sub _BUILTIN_TAB_STRING # string tab(float cols)
saveall
.param int argc
.param float cols
.local int PRINTCOL
find_global $P0, "PRINTCOL"
set PRINTCOL, $P0["value"]
set $I0, cols
dec $I0
set $S0, ""
eq $I0, PRINTCOL, TAB_RET
lt $I0, PRINTCOL, TAB_NL
set $I1, PRINTCOL
branch TAB_SP
TAB_NL: concat $S0, "\n"
set $I0, 0
set $I1, 0
TAB_SP: eq $I1, $I0, TAB_RET
concat $S0, " "
inc $I1
branch TAB_SP
TAB_RET:.return $S0
restoreall
ret
.end
.sub _BUILTIN_LTRIM_STRING # string ltrim(string oldstring)
saveall
.param int argc
.param string oldstring
set $S0, oldstring
BI_LTRIM:
length $I0, $S0
eq $I0, 0, LTRIM_END
substr $S1, $S0, 0, 1
ne $S1, " ", LTRIM_END
dec $I0
substr $S0, $S0, 1, $I0
branch BI_LTRIM
LTRIM_END:
.return $S0
restoreall
ret
.end
.sub _BUILTIN_RTRIM_STRING # string rtrim(string oldstring)
saveall
.param int argc
.param string oldstring
set $S0, oldstring
BI_RTRIM:
length $I0, $S0
eq $I0, 0, RTRIM_END
dec $I0
substr $S1, $S0, $I0, 1
ne $S1, " ", RTRIM_END
substr $S0, $S0, 0, $I0
branch BI_RTRIM
RTRIM_END:
.return $S0
restoreall
ret
.end
.sub _BUILTIN_INPUT_STRING # string input$(float numchars[, string fdinfo])
saveall
.param int argc
.param float numcharsf
.local int numchars
set numchars, numcharsf
.local int fd
set fd, 0 # Stdin
eq argc, 1, DOREAD
.param string fdinfo
length $I0, fdinfo
dec $I0
substr fdinfo, fdinfo, 1, $I0
set fd, fdinfo
DOREAD: .arg fd
.arg numchars
call _READCHARS
restoreall
ret
.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
.end
1.1 parrot/languages/BASIC/compiler/RT_debugger.imc
Index: RT_debugger.imc
===================================================================
.sub _DEBUGGER_STOP_FOR_REAL # void Debugger_stop(int line, PerlHash local_values)
saveall
.param int line
.param PerlHash locals
find_global $P25, "DEBUGGER"
set $P0, $P25["code"]
set $S0, $P0[line]
print "\n"
print $S0
print "\n"
bsr DEBUGGER_PRINTWATCH
branch DEBUGGER_COMMAND
# Commands are:
# \n -- Step once, or no-op if not stepping
# c -- Continue (clears step mode)
# s -- Step (sets step mode)
# b,xxx -- set breakpoint at x
# d,xxx -- delete breakpoint at x
# p,var -- display var's value (no arrays yet)
# aw,var -- add var to watchlist
# dw,var -- delete var from watchlist
# pw -- print watches
# daw -- delete all watches
DEBUGGER_COMMAND:
print line
print "->"
.arg 0
call _READLINE
call _CHOMP
.result $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
set $I0, $P1
add $I0, $I0, $I1
eq $I0, 0, DEBUGGER_COMMAND # If no values, re-prompt
shift $S0, $P1
eq $S0, "c", DEBUGGER_CONT
eq $S0, "s", DEBUGGER_STEPON
eq $S0, "b", DEBUGGER_ARG
eq $S0, "d", DEBUGGER_ARG
eq $S0, "p", DEBUGGER_PRINT
eq $S0, "q", DEBUGGER_QUIT
eq $S0, "aw", DEBUGGER_ADDWATCH
eq $S0, "dw", DEBUGGER_DELWATCH
eq $S0, "daw", DEBUGGER_DELALLWATCH
eq $S0, "pw", DEBUGGER_PRINTWATCH1
set $I1, $P25["step"]
eq $I1, 0, DEBUGGER_UNK
ret
DEBUGGER_PRINT:
set $I0, $P1
eq $I0, 0, DEBUGGER_PARG
shift $S0, $P1
set $S1, locals[$S0]
print $S1
print "\n"
branch DEBUGGER_COMMAND
DEBUGGER_PRINTWATCH1:
bsr DEBUGGER_PRINTWATCH
branch DEBUGGER_COMMAND
DEBUGGER_PARG:
print "Expected variable name argument"
branch DEBUGGER_COMMAND
DEBUGGER_UNK:
print "Unknown command\n"
branch DEBUGGER_COMMAND
DEBUGGER_QUIT:
print "Debugger exiting\n"
end
DEBUGGER_ADDWATCH:
set $I0, $P1
eq $I0, 0, DEBUGGER_PARG
shift $S0, $P1
bsr DEBUG_ADD
print "Watch for "
print $S0
print " added\n"
branch DEBUGGER_COMMAND
DEBUGGER_DELWATCH:
set $I0, $P1
eq $I0, 0, DEBUGGER_PARG
shift $S0, $P1
bsr DEBUG_CLEAR
print "Watch for "
print $S0
print " cleared\n"
branch DEBUGGER_COMMAND
DEBUGGER_DELALLWATCH:
$P0=new PerlArray
set $P25["watch"], $P0
print "All watches cleared.\n"
branch DEBUGGER_COMMAND
DEBUGGER_ARG:
set $I0, $P1
eq $I0, 0, DEBUGGER_ERR
shift $I0, $P1
set $S1, $I0
set $P0, $P25["break"]
eq $S0, "b", DEBUGGER_SET
branch DEBUGGER_DEL
DEBUGGER_SET:
set $P0[$S1], 1
print "Breakpoint set at line "
print $S1
print "\n"
branch DEBUGGER_COMMAND
DEBUGGER_DEL:
delete $P0[$S1]
print "Breakpoint cleared from line "
print $S1
print "\n"
branch DEBUGGER_COMMAND
DEBUGGER_CONT:
set $P25["step"], 0
branch DEBUGGER_DONE
DEBUGGER_STEPON:
set $P25["step"], 1
branch DEBUGGER_DONE
DEBUGGER_ERR:
print "Numeric argument expected\n"
branch DEBUGGER_COMMAND
DEBUG_CLEAR:
set P0, P25["watch"]
set I0, P0
eq I0, 0, DEBUG_CLEAREND
set I1, 0
DEBUG_CLEARLOOP:
eq I1, I0, DEBUG_CLEAREND
set S1, P0[I1]
eq S1, S0, DEBUG_CLEARBLANK
inc I1
branch DEBUG_CLEARLOOP
DEBUG_CLEARBLANK:
set P0[I1], ""
branch DEBUG_CLEAREND
DEBUG_CLEAREND:
ret
DEBUG_ADD:
set $P0, $P25["watch"]
set $I0, $P0
eq $I0, 0, DEBUG_ADDNEW
set $I1, 0
DEBUG_ADDLOOP:eq $I1, $I0, DEBUG_ADDNEW
set $S1, $P0[$I1]
eq $S1, "", DEBUG_ADDSLOT
eq $S1, $S0, DEBUG_ADDEND
inc $I1
branch DEBUG_ADDLOOP
DEBUG_ADDSLOT:set $P0[$I1], $S0
branch DEBUG_ADDEND
DEBUG_ADDNEW: push $P0, $S0
DEBUG_ADDEND: ret
DEBUGGER_PRINTWATCH:
set $P0, $P25["watch"]
set $I0, $P0
eq $I0, 0, DEBUG_PRINTEND
print "Watches: "
set $I1, 0
DEBUG_PRINTLOOP:
eq $I1, $I0, DEBUG_PRINTEND
set $S0, $P0[$I1]
inc $I1
eq $S0, "", DEBUG_PRINTLOOP
print $S0
print "="
set $S1, locals[$S0]
print $S1
print "\t"
branch DEBUG_PRINTLOOP
DEBUG_PRINTEND:
print "\n"
ret
DEBUGGER_DONE:
store_global "DEBUGGER", $P25
restoreall
ret
.end
1.1 parrot/languages/BASIC/compiler/RT_initialize.imc
Index: RT_initialize.imc
===================================================================
.const int TYPE = 0
.const int VALUE = 1
.local string JUMPLABEL
.sub _main
$P0 = new PerlHash
store_global "BASICARR", $P0
$P0 = new PerlArray
store_global "READDATA", $P0
$P0 = new PerlHash
store_global "RESTOREINFO", $P0
$P0=new PerlHash
$P0["value"]=0
store_global "READPOINTER", $P0
$P0=new PerlHash
$P0["value"]=20021107
store_global "RANDSEED", $P0
$P0=new PerlHash
$P0["value"]=0
store_global "PRINTCOL", $P0
$P0=new PerlHash
store_global "DEBUGGER", $P0
$P0=new PerlHash
store_global "COMMON", $P0
$P0=new PerlArray
fdopen $P1, 0, "r" # STDIN and friends...
$P0[0]=$P1
fdopen $P1, 1, "w"
$P0[1]=$P1
fdopen $P1, 2, "w"
$P0[2]=$P1
store_global "FDS", $P0
JUMPLABEL = ""
call _data_run
call _platform_setup
call _basicmain_run
call _platform_shutdown
end
.end
1.1 parrot/languages/BASIC/compiler/RT_io.imc
Index: RT_io.imc
===================================================================
# I/O *core* functions
# All of this is likely to change once Parrot gets
# the I/O sorted out.
#
# 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
call _line_read
NORESET:find_global $P0, "FDS"
$P1=$P0[fd]
set $S0, ""
read $S0, $P1, numchar
.return $S0
restoreall
ret
.end
.sub _OPEN # void open(string filename, string mode, int fd)
saveall
.param string filename
.param string mode
.param int fd
.local int error
open $P1, filename, mode
err error
eq error, 0, OPEN_OK
print "Error "
print error
print " in open\n"
end
OPEN_OK:
find_global $P0, "FDS"
$P0[fd]=$P1
store_global "FDS", $P0
restoreall
ret
.end
.sub _CLOSE # void close(int fd)
saveall
.param int fd
.local int error
find_global $P0, "FDS"
set $P1, $P0[fd]
close $P1
err error
eq error, 0, CLOSE_OK
print "Error "
print error
print " in close\n"
end
CLOSE_OK:
store_global "FDS", $P0
restoreall
ret
.end
.sub _WRITE # void writestring(int fd, 1, string stuff)
saveall
.param int fd
.local string buffer
.local int oldprintcol
find_global $P1, "PRINTCOL"
oldprintcol=$P1["value"]
call _BUILTIN_DISPLAY_WORK
.result buffer
find_global $P1, "PRINTCOL"
$P1["value"]=oldprintcol
store_global "PRINTCOL", $P1
find_global $P0, "FDS"
set $P1, $P0[fd]
print $P1, buffer
restoreall
ret
.end
#
# # ###########################
# # READLINE Read FD until EOL
# # Takes:
# # I1 FD to read
# # S0 String read (EOL included!)
# #
# # Returns:
# # I0 Error?
.sub _READLINE # string readline(int fd)
saveall
.param int fd
ne 0, fd, NOTSTDIN
call _line_read
readline $S0, fd
branch ENDREAD
NOTSTDIN:
find_global $P0, "FDS"
$P1=$P0[fd]
set $S0, ""
read $S0, $P1, 255
ENDREAD:
.return $S0
restoreall
ret
.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
$P1=new PerlArray
eq splitflag, 0, SPLITSINGLE
SPLITAGAIN:
length $I0, line
eq $I0, 0, SPLITEND
.arg line
call _REMOVETOK
.result line
.result token
push $P1, token
branch SPLITAGAIN
SPLITEND:
set $I1, $P1
ne $I1, 0, SPLITGONE
push $P1, ""
branch SPLITGONE
SPLITSINGLE:
push $P1, line
SPLITGONE:
.return $P1
restoreall
ret
.end
#
# # ############################
# # Remove a token from the front of S0
# # BASIC's Rules:
# # COMMAS separate tokens
# # 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
TOKLOOP:
length $I0, original
eq $I0, 0, EOTOK
substr $S2, original, 0, 1
dec $I0
substr original, original, 1, $I0
eq $S2, '"', QUOTE
eq $I1, 1, QUOTED
eq $S2, " ", WHITESP
eq $S2, "\r", WHITESP
eq $S2, "\n", WHITESP
eq $S2, ",", EOTOK
concat $S1, $S1, $S2
branch TOKLOOP
WHITESP:length $I0, $S1
eq $I0, 0, TOKLOOP # Leading spaces
QUOTED: concat $S1, $S1, $S2
branch TOKLOOP
QUOTE: eq $I1, 0, STARTQ
set $I1, 0
branch TOKLOOP
STARTQ: set $I1, 1
branch TOKLOOP
EOTOK: .return $S1 # The token
.return original# The original, w/o the token
restoreall
.end
# # ###########################
# # CHOMP Remove trailing \r\n thingies from S0
.sub _CHOMP # string chomp(string line)
saveall
.param string line
length $I0, line
dec $I0
le $I0, 0, CHOMPOK
CHOMPLOOK:
substr $S1, line, $I0, 1
eq $S1, "\n", CHOMPIT
eq $S1, "\r", CHOMPIT
eq $S1, "", CHOMPIT
branch CHOMPOK
CHOMPIT:substr line, line, 0, $I0
dec $I0
le $I0, 0, CHOMPOK
branch CHOMPLOOK
CHOMPOK:.return line
restoreall
ret
.end
#
#ERR_INPFIELDS:
# print "Input field count wrong"
# branch GEN_ERROR
#ERR_BADF:
# print "File descriptor is incorrect"
# branch GEN_ERROR
1.1 parrot/languages/BASIC/compiler/RT_platform.imc
Index: RT_platform.imc
===================================================================
.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
branch END
NOTWIN: call _ansi_setup
END: restoreall
ret
.end
.sub _platform_shutdown
saveall
sysinfo S0, 4
ne S0, "MSWin32", NOTWIN
call _win32_shutdown
branch END
NOTWIN: call _ansi_shutdown
END: restoreall
ret
.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
branch END
NOTWIN: call _ansi_screen_clear
END: restoreall
ret
.end
#SCREEN_SETXCUR:
# set I1, P6[.VALUE]
# sysinfo S0, 4
# eq S0, "MSWin32", WIN32_SCREEN_SETXCUR
# branch ANSI_SCREEN_SETXCUR
#
#SCREEN_SETYCUR:
# set I1, P6[.VALUE]
# sysinfo S0, 4
# eq S0, "MSWin32", WIN32_SCREEN_SETYCUR
# branch ANSI_SCREEN_SETYCUR
#
# # 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
.local int y
.local string sys
set x, xf
set y, yf
sysinfo sys, 4
.arg y
.arg x
ne sys, "MSWin32", NOTWIN
call _WIN32_SCREEN_LOCATE
branch END
NOTWIN: call _ANSI_SCREEN_LOCATE
END: restoreall
ret
.end
.sub _screen_color # void screen_color(float fore, float back)
saveall
.param float foref
.param float backf
.local int fore
.local int back
.local string sys
set back, backf
set fore, foref
.arg back
.arg fore
sysinfo sys, 4
ne sys, "MSWin32", NOTWIN
call _WIN32_SCREEN_COLOR
branch END
NOTWIN: call _ANSI_SCREEN_COLOR
END: restoreall
ret
.end
.sub _line_read
saveall
.local string sys
sysinfo sys, 4
eq sys, "MSWin32", END
call _TERMIO_normal
END: restoreall
ret
.end
.sub _scan_read
saveall
.local string sys
sysinfo sys, 4
eq sys, "MSWin32", END
call _TERMIO_scankey
END: restoreall
ret
.end
.sub _inkey_string # string inkey$(void)
saveall
.local string sys
sysinfo sys, 4
ne sys, "MSWin32", NOTWIN
call _WIN32_INKEY
branch END
NOTWIN: call _TERMIO_INKEY
END: restoreall
ret
.end
1.1 parrot/languages/BASIC/compiler/RT_platform_ANSIscreen.imc
Index: RT_platform_ANSIscreen.imc
===================================================================
.const int BLACK = 0
.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
.sub _ansi_setup
saveall
$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
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
store_global "ANSI_bgcolors", $P0
$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
.end
.sub _ANSI_SCREEN_LOCATE # void ansi_screen_locate (int x, int y)
saveall
.param int x
.param int y
print "\e["
print x
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
## terminal. I *really* can't do that until IO is fixed, because STDIN
## is line-buffered and asking the user to press return after each cursor
## positioning is lame.
#ANSI_SCREEN_SETXCUR:
# print "\e[;"
# print I1
# print "H"
# ret
#
#ANSI_SCREEN_SETYCUR:
# print "\e["
# print I1
# print ";H"
# ret
#
# # I0,I1
# # QB origin is 1,1
## QB.exe
## 0 = black 4 = red 8 = grey 12 = light red
## 1 = blue 5 = magenta 9 = light blue 13 = light magenta
## 2 = green 6 = brown 10 = light green 14 = yellow
## 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"
# # foreground in I0
# # background in I1
print "[0;"
find_global $P0, "ANSI_fgcolors"
lt fore, 8, ANSI_FG
sub fore, fore, 8
print "1;" # Turn on high intensity
ANSI_FG: set $I3, $P0[fore]
print "3"
print $I3
print ";"
# Background
ANSI_BG:find_global $P0, "ANSI_bgcolors"
set $I3, $P0[back]
print "4"
print $I3
print "m"
restoreall
ret
.end
.sub _set_noecho_cbreak
saveall
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);
.arg 2
.arg 6
.arg P10
call _get_little_endian
.result I0
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 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"
set I5, 0
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"
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)
$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, ""
dlfunc P0, P1, "fcntl", "iiil"
set I7, I11
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
#call _set_nonblock
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
#call _unset_nonblock
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
.end
1.1 parrot/languages/BASIC/compiler/RT_platform_win32.imc
Index: RT_platform_win32.imc
===================================================================
.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
set I5, -11
invoke
store_global "kernel32", P1
store_global "Win32handle", P5
set I0, 1
set I5, -10
invoke
store_global "Win32Inputhandle", P5
$P0= new PerlHash
store_global "Win32console", $P0
call _WIN32_CONSOLE_INFO
restoreall
ret
.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"
P6=new ManagedStruct
set P6, SIZEOF_CONSOLE_SCREEN_BUFFER_INFO
set I0, 1
invoke
set P5, P6
find_global P0, "Win32console"
.arg P5
.arg 0 # dwSize.X
call _UMS_GET_SHORT
.result $I1
set P0["xbuf"], $I1
.arg P5
.arg 2 # dwSize.Y
call _UMS_GET_SHORT
.result $I1
set P0["ybuf"], $I1
.arg P5
.arg 4
call _UMS_GET_SHORT
.result $I1
inc $I1
set P0["curx"], $I1
.arg P5
.arg 4
call _UMS_GET_SHORT
.result $I1
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]
inc offset
set $I3, buf[offset]
shl $I3, $I3, 8
add $I3, $I3, $I2
.return $I3
restoreall
ret
.end
.sub _win32_screen_clear # void _WIN32_SCREEN_CLEAR(void)
call _WIN32_CONSOLE_CLEAR
call _WIN32_CONSOLE_HOME
ret
.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"
set I0, 1
find_global P5, "Win32handle"
P6=new ManagedStruct
set P6, SIZEOF_DWORD
set I5, 32 # Char (space)
set I1, P1["xbuf"]
set I2, P1["ybuf"]
mul I6, I1, I2 # Length
set I7, 0 # Coords
invoke
# Now, re-fill screen with whatever attribute is currently
# in effect.
dlfunc P0, P2, "FillConsoleOutputAttribute", "ipiilp"
set I0, 1
find_global P5, "Win32handle"
P6= new ManagedStruct
set P6, SIZEOF_DWORD
set I5, P1["attr"] # Attrib
set I1, P1["xbuf"]
set I2, P1["ybuf"]
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
.end
.sub _WIN32_SCREEN_GETXCUR # int win32_screen_getxcur(void)
saveall
find_global P1, "Win32console"
set $I0, P1["curx"]
.return $I0
restoreall
ret
.end
.sub _WIN32_SCREEN_GETYCUR # int win32_screen_getycur(void)
saveall
find_global P1, "Win32console"
set $I0, P1["cury"]
.return $I0
restoreall
ret
.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
.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
.end
.sub _WIN32_SCREEN_LOCATE # void win32_screen_locate(int x, int y)
saveall
.param int x
.param int y
dec x
dec y
set I5, x
shl I5, I5, 16
add I5, I5, y
find_global P1, "Win32console"
find_global P2, "kernel32"
dlfunc P0, P2, "SetConsoleCursorPosition", "ipi"
set I0, 1
find_global P5, "Win32handle"
invoke
restoreall
ret
.end
#SCREEN Mode 0 Syntax: COLOR [foreground][,[background][,border]]
# � foreground is the text color (range = 0-31, with 16-31 blinking)
# � background is the screen color (range = 0-7)
# � border is the color surrounding the screen (range = 0-15)
# 0 = black 4 = red 8 = grey 12 = light red
# 1 = blue 5 = magenta 9 = light blue 13 = light magenta
# 2 = green 6 = brown 10 = light green 14 = yellow
# 3 = cyan 7 = white 11 = light cyan 15 = bright white
.const int FOREGROUND_BLUE = 1
.const int FOREGROUND_GREEN = 2
.const int FOREGROUND_RED = 4
.const int FOREGROUND_INTENSITY = 8
.const int BACKGROUND_BLUE = 16
.const int BACKGROUND_GREEN = 32
.const int BACKGROUND_RED = 64
.const int BACKGROUND_INTENSITY = 128
#WIN32_SCREEN_GETFORE:
# set P1, P24["console"]
# set I0, P1["attr"]
# band I0, I0, 15
# ret
#WIN32_SCREEN_GETBACK:
# set P1, P24["console"]
# set I0, P1["attr"]
# shr I0, I0, 4
# ret
# # Call with the foreground in I0
# # 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
add I5, I5, fore
find_global P2, "kernel32"
dlfunc P0, P2, "SetConsoleTextAttribute", "ipi"
find_global P5, "Win32handle"
set I0, 1
invoke
call _WIN32_CONSOLE_INFO # refresh this.
restoreall
ret
.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"
dlfunc P0, P1, "SetConsoleMode", "ipi"
set I0, 1
find_global P5, "Win32Inputhandle"
set I5, 0
invoke
INKEY:
dlfunc P9, P1, "PeekConsoleInputA", "ippip"
dlfunc P10, P1, "ReadConsoleInputA", "ippip"
find_global P5, "Win32Inputhandle"
P6=new ManagedStruct
P7=new ManagedStruct
set P6, INPUT_BUFFER
set P7, SIZEOF_DWORD
# Are there any events?
set P0, P9 # Peek
set I0, 1
set I5, NUMBER_OF_EVENTS # sizeof read buffer
invoke
# Peek down the event queue to see if there's a key event
set I0, P7[0] # Number of events.
eq I0, 0, NO_EVENTS
set I5, -1
NEXT_EVENT:
inc I5
eq I5, I0, END_EVENTS
mul I7, I5, SIZEOF_INPUT_RECORD
set I1, P6[I7]
ne I1, 1, NEXT_EVENT
# Got a key event, was it a key down?
add I8, I7, SIZEOF_DWORD
set I1, P6[I8]
ne I1, 1, NEXT_EVENT # Nope, a key up
# Is it a special-key thingy? (shift, alt...)
add I8, I7, 14
set I1, P6[I8]
eq I1, 0, NEXT_EVENT
# Cool. Grab the key.
set I9, I1
chr S0, I9
# I6 is the event we're interested in!
#
# There *was* a key event. Pull everything up to that event
#
inc I5
set P0, P10 # ReadConsoleInput
set I0, 1
find_global P5, "Win32Inputhandle"
invoke
branch END
NO_EVENTS:
END_EVENTS:
END: .return S0
restoreall
ret
.end
1.1 parrot/languages/BASIC/compiler/RT_support.imc
Index: RT_support.imc
===================================================================
# # ##########################
# # Do next read for READ/DATA
# # P15 has the data itself
# # P16 has the index (for restore)
# # I15 is the current pointer
# # Trashes I0
# # Returns:
# # P0 value read.
#READ: set I0, P15
# dec I0
# lt I0, I15, ERR_READ
# set P0, P15[I15]
# inc I15
# ret
#
# # ####################################
# # Index you want to restore into in S0
# # An invalid "restore X" statement generates
# # no error! It simply does a "restore"
#RESTORE:set I15, P16[S0]
# ret
#
#ERR_READ:
# print "Out of data"
# branch GEN_ERROR
.sub _READ # PerlArray READ(void)
saveall
.local PerlArray READDATA
.local int READPOINTER
find_global READDATA, "READDATA"
find_global $P0, "READPOINTER"
set READPOINTER, $P0["value"]
set $I0, READDATA
dec $I0
lt $I0, READPOINTER, ERR_READ
set $S1, READDATA[READPOINTER]
inc READPOINTER
.return $S1
set $P0["value"], READPOINTER
store_global "READPOINTER", $P0
restoreall
ret
ERR_READ:
print "Out of data"
end
.end
.sub _RESTORE # void RESTORE(string where)
saveall
.param string where
.local int READPOINTER
.local PerlHash RESTOREINFO
find_global RESTOREINFO, "RESTOREINFO"
find_global $P0, "READPOINTER"
set READPOINTER, $P0["value"]
set READPOINTER, RESTOREINFO[where]
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 int offset
.param int bytes
.local int target
set target, 0
eq bytes, 0, END
add $I6, offset, bytes
LOOP: lt $I6, offset, END
shl target, target, 8
set $I3, struct[$I6]
add target, target, $I3
dec $I6
branch LOOP
END: .return target
restoreall
ret
.end
.sub _set_little_endian # void set_little_endian(struct, offset, bytes, value)
saveall
.param ManagedStruct struct
.param int offset
.param int bytes
.param int value
add $I6, offset, bytes
eq bytes, 0, END2
LOOP2: eq offset, $I6, END2
band $I1, value, 255
shr value, value, 8
set struct[offset], $I1
inc offset
branch LOOP2
END2: restoreall
ret
.end
