' QBASIC/QB64 subset interpreter by Ed Davis.
' ------------------------------------------------------------------------------------------
'------------------------------------------------------------------------
' 03 Jul 2021 todo
' [x] store/retrieve variables like eval-ed4
' [x] const id[$] = number|string {, const id[$] = number|string}
' [ ] consolidate loop handling data structures
' [x] arrays
' [x] parse
' [x] allocate 1 dimensional
' [x] allocate 2 dimensional
' [x] assign (idstmt, stridstmt)
' [x] reference (strfactor, primary)
' [ ] Subs
' [ ] Functions
' [ ] Shared variables
' getvarindex& (getstrindex$), used in:
' forstmt: to reference the "i" variable
' inputstmt: to reference the "input" variable: input "", numeric_store(i)
' swapstmt: reference: swap(numeric_store(i1), numeric_store(i2))
' assignment: numeric_store(i) = value
' primary: primary# = numeric_store(i)
'idstmt (stridstmt) - only called by assignment
'------------------------------------------------------------------------
' Currently supports:
'
' Double and string variables only. No dim for these.
' One or two dimensional arrays.
' All standard operators, with hopefully the correct precedence.
'
' String operators:
' +
' =, <>, <, >, <=, >=
'
'
' Numeric binary operators
' ^,
' *, /
' \
' mod,
' +, -,
' shl,<<, shr,>>
' =, <>, <, >, <=, >=,
' and,
' or,
' xor,
' eqv,
' imp,
'
' Numeric unary operators
' not, -, +
'
' Commands supported:
'
' bye, quit - exits the interpreter
' clear - clears variables
' dump - shows info about arrays
' edit - edits the current or default program
' files - shows a list of files
' help - simple help screen
' list - lists current program
' list vars - iists variables
' load, old - loads a program into the interpreter
' new - discards the current program
' reload - reloads the current program from disk
' run - runs the current program
' save - saves the current program
' ston - turns stepping on
' stoff - turns stepping off
' tron - turns tracing on
' troff - turns tracing off
'
' Statements:
'
' Iteration:
' do [while|until]
' stmts
' loop
'
' or
'
' do
' stmts
' loop [while|until]
'
' exit do
'
' while stmts wend - exit while
'
' for index = n to expr [step n]
' next
'
' exit for
'
' Control transfer:
' gosub, return
' goto - buggy if you jump outside of loops or multiline if
'
' Selection:
' singleline or multiline if
' if elseif else end if
'
' const - declare numeric or string constants
'
' dim - declares double or string arrays
'
' end, stop, system - exits program to interpreter
'
' Other commands:
'
' chdir circle cls color draw environ input line locate mid$ paint
' palette play preset print, ? pset randomize rem screen shell
' sleep sound swap view width window
'
' QB64 commands:
'
' _delay _display _freeimage _fullscreen _limit _printstring
' _screenmove _title
'
' Numeric functions:
'
' abs acos acosh acot acoth acsc acsch asc asec asech asin asinh
' atanh atn, atan cdbl cint clng cos cosh cot coth csc csch csng
' csrlin cvd cvi exp false frac fix instr int len ln log log10 peek
' point pos rnd screen sec sech sgn sin sinh sqr, sqrt tan tanh
' timer true ubound val
'
' QB64 Numeric functions:
'
' _atan2 _ceil _d2g _d2r _fontwidth _fontheight _g2d _g2r _height
' _instrrev _keydown _keyhit _mousebutton _mouseinput _mousex
' _mousey _newimage _pi _r2d _r2g _rgb _rgba _rgba32 _rgb32 _round
' _width
'
' String Functions:
'
' chr$ command$ date$ environ$ hex$ inkey$ lcase$ left$" lpad$
' ltrim$ mid$ mki$ oct$ replace$ right$ rpad$ rtrim$ space$ str$
' string$ time$ trim$ ucase$
'
' QB64 string functions:
'
' _clipboard$ _cwd$ _os$ _startdir$ _title$ _trim$
'
' No other numeric data types besides double. Only suffix accepted is $ for strings.
' Only up to two dimensional arrays
' No subs or functions.
' No dim.
' Lots of other stuff missing.
'------------------------------------------------------------------------------------------
const true
= -1, false
= 0 const e
= 2.71828182845905 const halfpi
= 1.5707963267949 const pi
= 3.14159265358979 const tyunknown
=0, tyident
=1, tystrident
=2, tynum
=3, tystring
=4 const left_side
= 0, right_side
= 1
' do/while/for/if tracking
' for arrays: make sure the user specified index is between lo_bnd..hi_bnd inclusive
' then, computed index = v.index + user_index - v.lo_bnd
index
as long ' index into string table; numeric table; or string/numeric array table lo_bnd2
as long ' only if 2 dimensional hi_bnd2
as long ' only if 2 dimensional a_len
as long ' non-zero if array a_width
as long ' used in computing index when 2 dimensional
' variable names
' string and numeric values
' string and numeric arrays
' used by expression parser
const right_assoc
= 0, left_assoc
= 1, unaryminus_prec
= 13, unaryplus_prec
= 13, unarynot_prec
= 6
'for performance timing
'dim shared scantime as double
'dim shared starttime as double
'dim shared nsyms as long
const ct_unknown
=0, ct_alpha
=1, ct_digit
=2, ct_period
=3, ct_punc1
=4 const ct_dquote
=5, ct_squote
=6, ct_amp
=7, ct_lt
=8, ct_gt
=9
'---------------------------------------------------------------------------------------------------
' Listed here since I can not remember them:
' % = integer (16 bit)
' & = long (32 bit)
' ! = single (default)
' # = double
' $ = string
'---------------------------------------------------------------------------------------------------
' Maybe add:
' min(x, x1, x2...), max(...), ave(...), sum(...)
'#define floor(x) ((x*2.0-0.5)shr 1)
'#define ceil(x) (-((-x*2.0-0.5)shr 1))
'---------------------------------------------------------------------------------------------------
tracing = false
stepping = false
str_st_ndx = 0
num_st_ndx = 0
'------------------------------------------------------------------------
' main loop
'------------------------------------------------------------------------
quit = false
'starttime = timer
if cmd$
<> "" then quit
= true
pgm(0) = "run " + cmd$
' show timings
'dim total_time as double
'total_time = timer - starttime
'print "Total time: "; total_time; " Scan time: "; scantime; " Parse time: "; total_time - scantime; " Symbols: "; nsyms
'sleep
at_line$
= "":
if curline
> 0 then at_line$
= "(" + str$(curline
) + ")"
rest_of_line$
= sym
+ " " + the_ch
+ " " + mid$(thelin
, textp
)
print "name", "index", "lo", "hi", "len" for i
= 1 to var_names_max
print var_names
(i
).vname
, var_names
(i
).index
, var_names
(i
).lo_bnd
, var_names
(i
).hi_bnd
, var_names
(i
).a_len
'------------------------------------------------------------------------
' command processor
'------------------------------------------------------------------------
'print "docmd"
errors = false
restart_loop:
stackp = 0 ' these were -1 ??? @review
loopp = 0 ' these were -1 ??? @review
while_sp = 0
do_sp = 0
if_sp = 0
loop_top:
call initgetsym
(curline
+ 1, 1)
case "troff":
call getsym: tracing
= false
case "tron":
call getsym: tracing
= true
case "stoff":
call getsym: stepping
= false
case "ston":
call getsym: stepping
= true
' need to account for:
' - assignment
' let ...
' [str]ident = expression
' [str]ident(expression [, expression]) = expression
' - labels
' ident:
' - non-assignment, including labels
'
print "Unknown command: "; sym: errors
= true
print at_line$;
"Stmt expected, found:"; rest_of_line$: errors
= true
print at_line$;
"Stmt expected, found:"; rest_of_line$: errors
= true
print at_line$;
"Extra stmts:"; rest_of_line$: errors
= true
print "symtype:"; symtype;
" sym:"; sym;
" ch:"; the_ch
'------------------------------------------------------------------------
' variable storage/retrieval
'------------------------------------------------------------------------
' find position of vname in var_names
for i
= 1 to var_names_max
if var_names
(i
).vname
= vname
then find_vname& = i
find_vname& = 0
' helper function for 2d arrays
ar_scale = i - (lo - 1)
' get the index of "a" in either string_arr_store or numeric_arr_store
' pointing to: a(expr [, expr])
i = find_vname&(ident)
expect("(")
index = numeric_expr#
expect(",")
index2 = numeric_expr#
expect(")")
if var_names
(i
).a_len
= 0 then print at_line$;
"'"; ident;
"' is not declared as an array": errors
= true:
exit function
' verfiy that the index is within range
if index
< var_names
(i
).lo_bnd
or index
> var_names
(i
).hi_bnd
then print at_line$;
"Index is out of range:"; index;
"("; var_names
(i
).lo_bnd;
","; var_names
(i
).hi_bnd;
")": errors
= true:
exit function if index2
< var_names
(i
).lo_bnd2
or index2
> var_names
(i
).hi_bnd2
then
' compute the actual index
lo = var_names(i).lo_bnd
lo2 = var_names(i).lo_bnd2
x = var_names(i).index + (var_names(i).a_width * (ar_scale(index2, lo2) - 1) + ar_scale(index, lo)) - 1
x = var_names(i).index + ar_scale(index, lo) - 1
'x = var_names(i).index + index - (var_names(i).lo_bnd - 1) - 1
'print "index: "; x
get_array_index& = x
' primary: if var does not exist, create it. Return the var store index
' sym is the numeric variable name
ident = sym: ident_type = symtype
if ident_type
= tystrident
then print at_line$;
"type mismatch": errors
= true
print at_line$;
"not a variable": errors
= true
' see if variable exists
i = find_vname&(ident)
getvarindex& = var_names(i).index
if side
= left_side
and var_names
(i
).is_const
then print at_line$;
"Cannot update const variable: "; ident: errors
= true
'if side = right_side then print at_line$; "Reference to unassigned variable: "; ident: errors = true
' create a new variable
num_store_max = num_store_max + 1
var_names_max = var_names_max + 1
var_names(var_names_max).vname = ident
var_names(var_names_max).symtype = ident_type
var_names(var_names_max).index = num_store_max
numeric_store(num_store_max) = 0 ' default value
getvarindex& = num_store_max
ident = sym: ident_type = symtype
print at_line$;
"type mismatch": errors
= true
print at_line$;
"not a variable": errors
= true
' see if variable exists
i = find_vname&(ident)
getstrindex& = var_names(i).index
if side
= left_side
and var_names
(i
).is_const
then print at_line$;
"Cannot update const variable: "; ident: errors
= true
'if side = right_side then print at_line$; "Reference to unassigned variable: "; ident: errors = true
' create a new variable
str_store_max = str_store_max + 1
var_names_max = var_names_max + 1
var_names(var_names_max).vname = ident
var_names(var_names_max).symtype = ident_type
var_names(var_names_max).index = str_store_max
string_store(str_store_max) = "" ' default value
getstrindex& = str_store_max
' a(expr)
' when called, sym pointing at the ident
ident = sym: ident_type = symtype
x = get_array_index&(ident)
n = numeric_arr_store(x)
get_numeric_array_value# = n
' a(expr)
' when called, sym pointing at the ident
ident = sym: ident_type = symtype
x = get_array_index&(ident)
s = string_arr_store(x)
get_string_array_value$ = s
vname = sym
'print "stridstmt"
i = getstrindex&(left_side)
expect("=")
string_store(i) = strexpression$
vname = sym
i = getvarindex&(left_side)
expect("=")
numeric_store(i) = numeric_expr#
' ident = expression
print at_line$;
"Expecting assignment stmt, found: "; sym: errors
= true
' ident(expression [, expression]) = expression
ident = sym: ident_type = symtype
x = get_array_index&(ident)
expect("=")
if ident_type
= tystrident
then s = strexpression$
'assign string
string_arr_store(x) = s
n = numeric_expr#
'assign number
numeric_arr_store(x) = n
'------------------------------------------------------------------------
' statement parsing
'------------------------------------------------------------------------
print "bye or quit -- exit" print "help -- show this screen" print "clear -- clear variables" print "edit -- edit current program" print "list -- show source" print "list vars -- show variables" print "load -- load program from disk" print "new -- clear program in memory" print "reload -- reload program from disk" print "run -- run program in memory" print "save -- save program to disk" print "cls -- clear screen" print "tron -- tracing on" print "troff -- tracing off" print "ston -- stepping on" print "stoff -- stepping off"
if symtype
= tystring
or symtype
= tystrident
then filespec = strexpression$
filespec = sym ' gettoeol destroys sym
filespec = filespec + gettoeol$
if instr(filespec
, ".") = 0 then filespec
= filespec
+ ".bas" getfn$ = filespec
for i
= 1 to str_store_max
string_store(i) = ""
for i
= 1 to num_store_max
numeric_store(i) = 0
clearvars
for i
= 1 to var_names_max
var_names(i).vname = ""
var_names(i).index = 0
str_store_max = 0: num_store_max = 0: var_names_max = 0
initvars
clearprog
if fn = "" then curr_filename
= getfn$
("Program file") else curr_filename
= fn
n = 0
'if pgm(0) <> "" then
n = the_num + 1
n = n + 1
pgm(n) = pgm(0)
'end if
curline = 0
if editor
= "" then editor
= "notepad.exe" if curr_filename
= "" then curr_filename
= "default.bas" shell editor
+ " " + curr_filename
call loadprog
(curr_filename
)
filespec = getfn$("Save as")
print at_line$;
"*** error: you don't have permission to write to that file."
for i
= 1 to var_names_max
if var_names
(i
).a_len
> 0 then print "Array:"; var_names
(i
).vname
, " index: "; var_names
(i
).index;
print string_store
(var_names
(i
).index
);
" size: "; var_names
(i
).a_len;
print " type: "; var_names
(i
).symtype
print "String:"; var_names
(i
).vname
, " index: "; var_names
(i
).index;
print string_store
(var_names
(i
).index
);
print " type: "; var_names
(i
).symtype
print "Number:"; var_names
(i
).vname
, " index: "; var_names
(i
).index;
print numeric_store
(var_names
(i
).index
);
print " type: "; var_names
(i
).symtype
' CIRCLE [STEP] (x!,y!),radius![,[color%] [,[start!] [,[end!] [,aspect!]]]]
expect("(")
x = numeric_expr#
expect(",")
y = numeric_expr#
expect(")")
expect(",")
radius = numeric_expr#
'[,[color%] [,[start!] [,[end!] [,aspect!]]]]
elipse = numeric_expr#
circle (x
, y
), radius
, , , , elipse
arcend = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, , , arcend
, elipse
circle (x
, y
), radius
, , , arcend
arcbeg = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, , arcbeg
, , elipse
arcend = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, , arcbeg
, arcend
, elipse
circle (x
, y
), radius
, , arcbeg
, arcend
' [,[start!] [,[end!] [,aspect!]]]]
clr = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, clr
, , , elipse
arcend = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, clr
, , arcend
, elipse
circle (x
, y
), radius
, clr
, , arcend
arcbeg = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, clr
, arcbeg
, , elipse
arcend = numeric_expr#
elipse = numeric_expr#
circle (x
, y
), radius
, clr
, arcbeg
, arcend
, elipse
circle (x
, y
), radius
, clr
, arcbeg
, arcend
circle (x
, y
), radius
, clr
, arcbeg
' color [fore] [,back]
back = numeric_expr#
fore = numeric_expr#
back = numeric_expr#
lo = numeric_expr#
hi = numeric_expr#
hi = lo
lo = 0
' dim ident(numeric expression [to numeric expression]) {, ident(numeric expression [to numeric expression])}
ident = sym
ident_type = symtype
if symtype
<> tyident
and symtype
<> tystrident
then print at_line$;
" Expecting an identifier, but found: "; sym: errors
= true:
exit sub call getsym
' skip array name
expect("(")
call get_array_bounds
(lo
, hi
) lo2 = 0: hi2 = 0: multi = false
if accept&
(",") then call get_array_bounds
(lo2
, hi2
): multi
= true
expect(")")
' see if it already exists
i = find_vname&(ident)
' add it
a_len = hi - lo + 1
a_width = a_len
a_len = a_len * (hi2 - lo2 + 1)
var_names_max = var_names_max + 1
var_names(var_names_max).vname = ident
var_names(var_names_max).symtype = ident_type
var_names(var_names_max).lo_bnd = lo
var_names(var_names_max).hi_bnd = hi
var_names(var_names_max).lo_bnd2 = lo2
var_names(var_names_max).hi_bnd2 = hi2
var_names(var_names_max).multi = multi
var_names(var_names_max).a_len = a_len
var_names(var_names_max).a_width = a_width
if ident_type
= tystrident
then index = str_arr_stor_max + 1
str_arr_stor_max = str_arr_stor_max + a_len
index = num_arr_stor_max + 1
num_arr_stor_max = num_arr_stor_max + a_len
var_names(var_names_max).index = index
' const id[$] = number|string {, const id[$] = number|string}
i = find_vname&(sym)
var_names(var_names_max).is_const = true
s = strexpression$
' need to account for loop [until|while expr] and next [i]
if while_sp
<= 0 then errors
= true:
print at_line$;
"'exit while' without while": errors
= true:
exit sub while_sp = while_sp - 1
call find_matching_pair
("while", "wend") if do_sp
<= 0 then errors
= true:
print at_line$;
"'exit do' without do": errors
= true:
exit sub do_sp = do_sp - 1
call find_matching_pair
("do", "loop") call getsym
' skip until\while ' somehow skip over the until\while expression
if loopp
<= 0 then errors
= true:
print at_line$;
"'exit for' without do": errors
= true:
exit sub loopp = loopp - 1
call find_matching_pair
("for", "next") print at_line$;
"'exit without do/for/while": errors
= true:
exit sub
if endif_count
> 0 and if_sp
> 0 then if_sp
= if_sp
- endif_count
if loop_count
> 0 and do_sp
> 0 then do_sp
= do_sp
- loop_count
if next_count
> 0 and loopp
> 0 then loopp
= loopp
- next_count
if wend_count
> 0 and while_sp
> 0 then while_sp
= while_sp
- wend_count
' for xvar = -1.5 to 1.5 step .01
xvar = getvarindex&(left_side) ' get position of "i"
print at_line$;
"for index variable already in use": errors
= true
expect("=")
numeric_store(xvar) = numeric_expr#
loopp = loopp + 1
loopvars(loopp) = xvar
looplines(loopp) = curline
expect("to")
loopmax(loopp) = numeric_expr#
if accept&
("step") then loopstep
(loopp
) = numeric_expr#
else loopstep
(loopp
) = 1 loopoff(loopp) = textp
' finds target, using current sym
get_target = numeric_expr#
lbl = sym
get_target& = i
print at_line$;
"Target of goto not found:"; sym: errors
= true
get_target& = 0
target = get_target&
validlinenum(target)
stackp = stackp + 1
if stackp
> stacksize
then print at_line$;
"out of stack space": errors
= true
gosubstack(stackp) = curline
' 26 May 2021 was just textp
gosuboffstack(stackp) = textp - 1
'print "textp:"; textp; "=>"; pgm$(curline)
'if sym = ":" then gosuboffstack(stackp) = textp
call initgetsym
(target
, 1)
target = get_target&
gotoline(target)
' single line if: if expr then if expr then if expr then s else s else s else s
level = 0
begin:
level = level + 1
cond = numeric_expr#
b = accept&("then")
'*** multiline if processing ***
if sym
= "" then 'multiline if print at_line$;
"can't mix multi and single line 'if'": errors
= true
'*** singleline if processing ***
call find_matching_sline_if
' if else found, pick up there, otherwise skip rest of stmt
if symtype
= tynum
then gotoline
(int(the_num
))
if_sp = if_sp + 1
if_stack(if_sp) = curline
'print at_line$; "if after inc: if_sp: "; if_sp, pgm(curline)
rem let docmd process these commands
'need to find the next corresponding 'elseif' or 'else' or 'endif'
restart:
' on the "if" or "elseif" line, so skip it
s = find_matching_else$ 'either elseif, else or endif
'print at_line$; "found: "; sym
'print sym; ": "; mid$(thelin, textp)
call getsym
'skip "elseif" cond = numeric_expr#
b = accept&("then")
'print at_line$; "elseif evaluated to: "; cond
call getsym
' skip the else, so docmd goes to next line
' called from docmd()
'scan until matching endif
' but first, allow more "elseif"'s
s = find_matching_else$
' allow an "else"
s = find_matching_else$
' finally, need an "endif"
' pop the if stack
if_sp = if_sp - 1
call getsym
' skip "endif" ' done
' called from docmd()
'print at_line$; "else begin: if_sp: "; if_sp, pgm(curline)
'part of a single-line if?
call initgetsym
(curline
, 1) 'if not "else", then single-line if
' looks like multiline if - but have we seen the start of it?
'scan until matching endif
if find_matching_else$
<> "endif" then print at_line$;
"else without endif": errors
= true:
exit sub
call getsym
'skip the "endif" 'pop the if stack
if_sp = if_sp - 1
'print at_line$; "else end: if_sp: "; if_sp, pgm(curline)
' called from docmd()
if_sp = if_sp - 1
'print at_line$; "endif: if_sp: "; if_sp, pgm(curline)
call getsym
'skip "endif"
' input [;] ["prompt" ;|,] variablelist
expect(",")
' input [;] ["prompt" ;|,] variablelist
inputsetup
ident = sym: ident_type = symtype
if ident_type
= tystrident
then
i = find_vname&(ident)
if ident_type
<> var_names
(i
).symtype
then print at_line$;
"Type mismatch: "; ident_type;
" vs. table: "; var_names
(i
).symtype: errors
= true:
exit sub if var_names
(i
).a_len
> 0 then ' array x = get_array_index&(ident)
if ident_type
= tystrident
then 'assign string
string_arr_store(x) = st
'assign number
numeric_arr_store(x) = n
if ident_type
= tystrident
then i = getstrindex&(left_side)
string_store(i) = st
i = getvarindex&(left_side)
numeric_store(i) = n
' line input [;] ["prompt";] variable$
inputsetup
ident = sym: ident_type = symtype
if ident_type
<> tystrident
then print at_line$;
"String variable expected": errors
= true:
exit sub
i = find_vname&(ident)
if ident_type
<> var_names
(i
).symtype
then print at_line$;
"Type mismatch: "; ident_type;
" vs. table: "; var_names
(i
).symtype: errors
= true:
exit sub if var_names
(i
).a_len
> 0 then ' array x = get_array_index&(ident)
'assign string
string_arr_store(x) = st
i = getstrindex&(left_side)
string_store(i) = st
' line [[step](x1!,y1!)]-[step](x2!,y2!) [,[color%] [,[b | bf] [,style%]]]
' ??? step is not currently supported
step1 = false: step2 = false
if accept&
("step") then step1
= true
expect("(")
x1 = numeric_expr#
expect(",")
y1 = numeric_expr#
expect(")")
expect("-")
if accept&
("step") then step2
= true
expect("(")
x2 = numeric_expr#
expect(",")
y2 = numeric_expr#
expect(")")
' so far we have: line(x, y)-(x2, y2)
'[,[color%] [,[b | bf] [,style%]]]
' only acceptable value is a ","
'1) ,c
'2) ,c,b
'3) ,c,b,s
'4) ,c,,s
'5) ,,b
'6) ,,b,s
'7) ,,,s
'must have s (7)
line (x1
, y1
)-(x2
, y2
), , , numeric_expr#
'must have b
if rect_type
<> "B" and rect_type
<> "BF" then print at_line$;
"line ... - expecting 'B' or 'BF', found: "; rect_type: errors
= true:
exit sub 'must have s (6)
line (x1
, y1
)-(x2
, y2
), , B
, numeric_expr#
line (x1
, y1
)-(x2
, y2
), , BF
, numeric_expr#
'(5)
line (x1
, y1
)-(x2
, y2
), , B
line (x1
, y1
)-(x2
, y2
), , BF
'must have c
clr = numeric_expr#
'must have s (4)
line (x1
, y1
)-(x2
, y2
), clr
, , numeric_expr#
'must have b
if rect_type
<> "B" and rect_type
<> "BF" then print at_line$;
"line ... - expecting 'B' or 'BF', found: "; rect_type: errors
= true:
exit sub 'must have s (3)
line (x1
, y1
)-(x2
, y2
), clr
, B
, numeric_expr#
line (x1
, y1
)-(x2
, y2
), clr
, BF
, numeric_expr#
'(2)
line (x1
, y1
)-(x2
, y2
), clr
, B
line (x1
, y1
)-(x2
, y2
), clr
, BF
'(1)
line (x1
, y1
)-(x2
, y2
), clr
col = numeric_expr#
row = numeric_expr#
col = numeric_expr#
' mid$(s, i, n)
expect("(")
xvar = getstrindex&(left_side)
expect(",")
start = numeric_expr#
if accept&
(",") then length
= numeric_expr#
else nolength
= -1 expect(")")
expect("=")
mid$(string_store
(xvar
), start
) = strexpression$
mid$(string_store
(xvar
), start
, length
) = strexpression$
' increment the current "i"
numeric_store(loopvars(loopp)) = numeric_store(loopvars(loopp)) + loopstep(loopp)
if tracing
then print "["; curline;
"] ";
"next: "; numeric_store
(loopvars
(loopp
))
' see if "for" should continue
cont = false
if numeric_store
(loopvars
(loopp
)) >= loopmax
(loopp
) then cont = true
if numeric_store
(loopvars
(loopp
)) <= loopmax
(loopp
) then cont = true
call initgetsym
(looplines
(loopp
), loopoff
(loopp
)) loopp = loopp - 1
' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
expect("(")
x = numeric_expr#
expect(",")
y = numeric_expr#
expect(")")
paint (x
, y
), , numeric_expr#
f = numeric_expr#
paint (x
, y
), f
, numeric_expr#
' palette [attribute%,color&]
a = numeric_expr#
expect(",")
c = numeric_expr#
printed = false
printed = true
val_type = any_expr&(0)
' preset (column, row)
' preset [step] (x!,y!) [,color%]
expect("(")
x = numeric_expr#
expect(",")
y = numeric_expr#
expect(")")
' pset (column, row)
' pset [step] (x!,y!) [,color%]
' PSET [STEP] (x!,y!) [,color%]
expect("(")
x = numeric_expr#
expect(",")
y = numeric_expr#
expect(")")
clr = numeric_expr#
lin = gosubstack(stackp)
offs = gosuboffstack(stackp)
if tracing
then print "returning to: "; lin;
": "; offs
'print "["; curline; "] "; "returning to: "; lin; ": "; offs; " while_sp: "; while_sp
stackp = stackp - 1
if offs
<= 1 then print at_line$;
"returnstmt - offs <= 1": errors
= true
call initgetsym
(lin
, offs
)
' SCREEN mode% [,[colorswitch%] [,[activepage%] [,visualpage%]]]
' shell [string]
s = ""
s = s + the_ch
'print "shell: "; s
' sleep [seconds]
' swap v1, v2
sym1 = sym
symtype1 = symtype
i1 = getvarindex&(left_side)
i1 = getstrindex&(left_side)
expect(",")
sym2 = sym
symtype2 = symtype
i2 = getvarindex&(left_side)
i2 = getstrindex&(left_side)
print at_line$; sym1;
" and "; sym2;
" are not the same data type": errors
= true
swap numeric_store
(i1
), numeric_store
(i2
) swap string_store
(i1
), string_store
(i2
)
' VIEW [[SCREEN] (x1!,y1!)-(x2!,y2!) [,[color%] [,border%]]]
expect("(")
x1 = numeric_expr#
expect(",")
y1 = numeric_expr#
expect(")")
expect("-")
expect("(")
x2 = numeric_expr#
expect(",")
y2 = numeric_expr#
expect(")")
border = numeric_expr#
view (x1
, y1
)-(x2
, y2
), , border
clr = numeric_expr#
border = numeric_expr#
view (x1
, y1
)-(x2
, y2
), clr
, border
view (x1
, y1
)-(x2
, y2
), clr
while_sp = while_sp + 1
while_line(while_sp) = curline
while_off(while_sp) = textp
if len(sym
) > 0 then while_off
(while_sp
) = textp
- len(sym
) - 1 'print "["; curline; "] "; "*while:sym:";sym; " textp:";textp; " =>";mid$(pgm(curline), textp); " while_sp: "; while_sp
while_sp = while_sp - 1
'print "["; curline; "] "; "*wend bool_expr is 0!"; " while_sp: "; while_sp
call find_matching_pair
("while", "wend")
if while_sp
<= 0 then errors
= true:
print at_line$;
"wend without while": errors
= true:
exit sub call initgetsym
(while_line
(while_sp
), while_off
(while_sp
)) whilestmt(false)
' do [(while|until) expr][:]
do_sp = do_sp + 1
do_loop(do_sp).lline = curline
do_loop(do_sp).loff = textp
if len(sym
) > 0 then do_loop
(do_sp
).loff
= textp
- len(sym
) - 1 'print "*do:"; "sym:"; sym; " textp:";textp; "=>";mid$(pgm(curline), textp - len(sym))
do_sp = do_sp - 1
call find_matching_pair
("do", "loop") do_sp = do_sp - 1
call find_matching_pair
("do", "loop")
' loop [(while|until) expr]
if do_sp
<= 0 then errors
= true:
print at_line$;
"loop without do": errors
= true:
exit sub
do_sp = do_sp - 1
do_sp = do_sp - 1
call initgetsym
(do_loop
(do_sp
).lline
, do_loop
(do_sp
).loff
) 'print "loop line:"; curline; "off:"; do_loop(do_sp).loff; "==>"; pgm(curline)
dostmt(false)
' width , height
' width width
' width width, height
w = numeric_expr#
' window [ [ screen] (x1!, y1!) - (x2!, y2!)]
expect("(")
x1 = numeric_expr#
expect(",")
y1 = numeric_expr#
expect(")")
expect("-")
expect("(")
x2 = numeric_expr#
expect(",")
y2 = numeric_expr#
expect(")")
'------------------------------------------------------------------------
' Various helper routines
'------------------------------------------------------------------------
if sym
= "do" or sym
= "while" or sym
= "for" then
level = 1
more = true
have_sym = false
endif_count = 0: wend_count = 0: next_count = 0: loop_count = 0
have_sym = false
'print at_line$; "matching, level"; level; "sym=>"; sym
'if isalpha&(mid$(sym, 1, 1)) then print "fm: level: sym: "; level; ": '"; sym; "' "; mid$(thelin, textp, 40)
case s1: level
= level
+ 1 case s2: level
= level
- 1
case "if" ' need to only do "if" case if multiline if call getsym
' skip the "then" ' if nothing past "then", it is a multiline if
if sym
= "" then endif_count
= endif_count
- 1 case "endif": endif_count
= endif_count
+ 1 case "while": wend_count
= wend_count
- 1 case "wend": wend_count
= wend_count
+ 1 case "for": next_count
= next_count
- 1 case "next": next_count
= next_count
+ 1 loop_count = loop_count - 1
loop_count = loop_count + 1
call initgetsym
(curline
+ 1, 1) print at_line$;
"Cannot find matching: "; s2: errors
= true
have_sym = true
' find matching elseif/else/endif
find_matching_else$ = ""
level = 0
call initgetsym
(curline
+ 1, 1) 'print "find_matching_else: "; curline; " sym: "; sym; " level: "; level; "textp: "; textp; " line:"; thelin
if curline
>= pgmsize
then print "searching for endif, found eof": errors
= true:
exit do level = level + 1
find_matching_else
= sym:
exit do level = level - 1
sub find_matching_sline_if
level = 1
'print "find_matching_sline_if level: "; level; " sym: "; sym
level = level + 1
level = level - 1
is_multi_line_if& = false
' is it single or multi line "if" - ignore single line if's
' multi line "if"
is_multi_line_if& = true
accept& = false
if not accept&
(s
) then print at_line$;
"expecting "; s;
" but found "; sym: errors
= true
is_stmt_end&
= sym
= "" or sym
= ":"
print at_line$;
"line number out of range:"; the_num: errors
= true
'print "storeline"
storeline& = false
validlinenum
(int(the_num
)) pgm
(the_num
) = mid$(pgm
(0), textp
, len(pgm
(0)) - textp
+ 1) storeline& = true
pgm(i) = ""
validlinenum(target)
call initgetsym
(target
, 1)
'------------------------------------------------------------------------
'------[QB64 specific functions]-----------------------------------------
'------------------------------------------------------------------------
' _atan2(y, x)
expect("(")
y = numeric_expr#
expect(",")
x = numeric_expr#
expect(")")
s = ""
if symtype
= tystring
or symtype
= tystrident
then s
= strexpression$
' freeimage [image]&
' ([start], haystack, needle)
expect("(")
i = 0
if symtype
= tynum
or symtype
= tyident
then i = numeric_expr#
expect(",")
haystack = strexpression$
expect(",")
needle = strexpression$
expect(")")
instrrevfun&
= _instrrev(i
, haystack
, needle
)
' _newimage(width&, height&[, {0|1|2|7|8|9|10|11|12|13|256|32}])
expect("(")
w = numeric_expr#
expect(",")
h = numeric_expr#
mode = numeric_expr#
expect(")")
'colorIndex~& = _RGB(red&, green&, blue&[, imageHandle&])
expect("(")
r = numeric_expr#
expect(",")
g = numeric_expr#
expect(",")
b = numeric_expr#
h = numeric_expr#
rgbfun
= _rgb(r
, g
, b
, h
) expect(")")
'color32value~& = _RGB32(red&, green&, blue&, alpha&)
'color32value~& = _RGB32(red&, green&, blue&)
'color32value~& = _RGB32(intensity&, alpha&)
'color32value~& = _RGB32(intensity&)
expect("(")
r = numeric_expr#
expect(",")
g = numeric_expr#
expect(",")
b = numeric_expr#
expect(",")
a = numeric_expr#
expect(")")
'_RGBA(red&, green&, blue&, alpha&[, imageHandle&])
expect("(")
r = numeric_expr#
expect(",")
g = numeric_expr#
expect(",")
b = numeric_expr#
expect(",")
a = numeric_expr#
h = numeric_expr#
rgbafun
= _rgba(r
, g
, b
, a
, h
) rgbafun
= _rgba(r
, g
, b
, a
)
expect(")")
'color32value~& = _RGBA32(red&, green&, blue&, alpha&)
expect("(")
r = numeric_expr#
expect(",")
g = numeric_expr#
expect(",")
b = numeric_expr#
expect(",")
a = numeric_expr#
expect(")")
'_PRINTSTRING(column, row), textExpression$[, imageHandle&]
expect("(")
c = numeric_expr#
expect(",")
r = numeric_expr#
expect(")")
expect(",")
ex = strexpression$
' _SCREENMOVE {column&, row&|_MIDDLE}
'print "screenmovestmt:"; sym
call getsym
'and skip over _middle c = numeric_expr#
expect(",")
r = numeric_expr#
' sound frequence, duration
f = numeric_expr#
expect(",")
d = numeric_expr#
'------------------------------------------------------------------------
' various functions called from primary
'------------------------------------------------------------------------
sinh = (e ^ z - e ^ (-z)) / 2
tanh = (e ^ (2 * z) - 1) / (e ^ (2 * z) + 1)
acoth
= .5 * (log(1 + 1 / z
) - log(1 - 1 / z
))
acsch
= log(sqr(1 + z
^ (-2)) + z
^ (-1))
asech
= log(sqr(z
^ (-1) - 1) * sqr(z
^ (-1) + 1) + z
^ (-1))
asin2 = -halfpi
asin2 = halfpi
asin2
= atn(i
/ sqr(1 - i
* i
))
asinh
= log(z
+ sqr(1 + z
^ 2))
atanh
= .5 * (log(1 + z
) - log(1 - z
))
cosh = (e ^ z + e ^ (-z)) / 2
shlf# = x
if n
>= 0 then shlf#
= x
* (2 ^ n
)
shrf# = x
if n
>= 0 then shrf#
= x \
(2 ^ n
)
' ([start,] haystack, needle)
expect("(")
i = 1
if symtype
= tynum
or symtype
= tyident
then i = numeric_expr#
expect(",")
haystack = strexpression$
expect(",")
needle = strexpression$
expect(")")
instrfun&
= instr(i
, haystack
, needle
)
' mid$(s$, start [, end])
expect("(")
i = strexpression$
expect(",")
x = numeric_expr#
y = numeric_expr#
expect(")")
' lpad$(s$, padded_len [, pad_string$])
expect("(")
s = strexpression$
expect(",")
padded_len = numeric_expr#
pad_string = " "
pad_string = strexpression$
expect(")")
lpadfun$ = s
lpadfun$
= mid$(s
, 1, padded_len
)
' result = peek(string)
case "for index" : peekfun#
= loopp
case "do index" : peekfun#
= do_sp
case "while index" : peekfun#
= while_sp
case "if index" : peekfun#
= if_sp
case "gosub index" : peekfun#
= stackp
case "numeric var total" : peekfun#
= num_store_max
case "string var total" : peekfun#
= str_store_max
case "variables total" : peekfun#
= var_names_max
'result = Point( coord_x, coord_y [,buffer] )
'result = Point( function_index )
expect("(")
x = numeric_expr#
pointfun#
= point(x
, numeric_expr#
) expect(")")
expect("(")
posfun#
= pos(numeric_expr#
) expect(")")
' rpad$(s$, padded_len [, pad_string$])
expect("(")
s = strexpression$
expect(",")
padded_len = numeric_expr#
pad_string = " "
pad_string = strexpression$
expect(")")
rpadfun$ = s
rpadfun$
= mid$(s
, 1, padded_len
)
' replace$(haystack$, needle$ [, newst$])
expect("(")
haystack = strexpression$
expect(",")
needle = strexpression$
newst = ""
newst = strexpression$
expect(")")
start = 1
p
= instr(start
, haystack
, needle
) haystack
= mid$(haystack
, 1, p
- 1) + newst
+ mid$(haystack
, p
+ len(needle
)) start
= p
+ len(newst
) + 1
replacefun$ = haystack
' ubound(array-name)
expect("(")
i = find_vname(sym)
print at_line$;
"ubound: not an array: "; sym: errors
= true
uboundfun& = var_names(i).hi_bnd
expect(")")
' screen(row, col)
expect("(")
row = numeric_expr#
expect(",")
col = numeric_expr#
expect(")")
'------------------------------------------------------------------------
' expression parser
'------------------------------------------------------------------------
case "^": binary_prec&
= 14 case "*", "/": binary_prec&
= 12 case "\" : binary_prec&
= 11 case "mod": binary_prec&
= 10 case "+", "-": binary_prec&
= 9 case ">>", "<<", "shl", "shr": binary_prec&
= 8 case "=", "<>", "<", ">", "<=", ">=": binary_prec&
= 7 case "and": binary_prec&
= 5 case "or": binary_prec&
= 4 case "xor": binary_prec&
= 3 case "eqv": binary_prec&
= 2 case "imp": binary_prec&
= 1
case "chr$":
call getsym: expect
("("): strfactor$
= chr$(numeric_expr#
): expect
(")") case "environ$":
call getsym: expect
("("): strfactor$
= environ$(strexpression$
): expect
(")") case "hex$":
call getsym: expect
("("): strfactor$
= hex$(numeric_expr#
): expect
(")") case "lcase$":
call getsym: expect
("("): strfactor$
= lcase$(strexpression$
): expect
(")") expect("(")
s = strexpression$
expect(",")
x = numeric_expr#
expect(")")
case "lpad$":
call getsym: strfactor$
= lpadfun$
case "ltrim$":
call getsym: expect
("("): strfactor$
= ltrim$(strexpression$
): expect
(")") case "mid$":
call getsym: strfactor$
= midfun$
case "mki$":
call getsym: expect
("("): strfactor$
= mki$(numeric_expr#
): expect
(")") case "oct$":
call getsym: expect
("("): strfactor$
= oct$(numeric_expr#
): expect
(")") case "replace$":
call getsym: strfactor$
= replacefun$
expect("(")
s = strexpression$
expect(",")
x = numeric_expr#
expect(")")
case "rpad$":
call getsym: strfactor$
= rpadfun$
case "rtrim$":
call getsym: expect
("("): strfactor$
= rtrim$(strexpression$
): expect
(")") expect("(")
strfactor$
= space$(numeric_expr#
) expect(")")
case "str$":
call getsym: expect
("("): strfactor$
= str$(numeric_expr#
): expect
(")") call getsym
' string$(n [, strexpr]) expect("(")
x = numeric_expr#
expect(",")
if symtype
= tystring
or symtype
= tystrident
then strfactor$
= string$(x
, strexpression$
) strfactor$
= string$(x
, numeric_expr#
) expect(")")
case "ucase$":
call getsym: expect
("("): strfactor$
= ucase$(strexpression$
): expect
(")")
strfactor$
= mid$(sym
, 2, len(sym
) - 1) strfactor$ = get_string_array_value$
strfactor$ = string_store(getstrindex&(right_side))
print at_line$;
"In strfactor, expecting an operand, found: "; sym;
" symtype is: "; symtype: errors
= true
case "-":
call getsym: primary#
= -numeric_expr2#
(unaryminus_prec
) case "+":
call getsym: primary#
= numeric_expr2#
(unaryplus_prec
) case "not":
call getsym: primary#
= not numeric_expr2#
(unarynot_prec
) case "abs":
call getsym: expect
("("): primary#
= abs(numeric_expr#
): expect
(")") case "acos":
call getsym: expect
("("): primary#
= halfpi
- asin2
(numeric_expr#
): expect
(")") case "acosh":
call getsym: expect
("("): primary#
= acosh
(numeric_expr#
): expect
(")") case "acot":
call getsym: expect
("("): primary#
= halfpi
- atn(numeric_expr#
): expect
(")") case "acoth":
call getsym: expect
("("): primary#
= acoth
(numeric_expr#
): expect
(")") case "acsc":
call getsym: expect
("("): primary#
= asin2
(1 / numeric_expr#
): expect
(")") case "acsch":
call getsym: expect
("("): primary#
= acsch
(numeric_expr#
): expect
(")") case "asc":
call getsym: expect
("("): primary#
= asc(strexpression$
): expect
(")") case "asec":
call getsym: expect
("("): primary#
= halfpi
- asin2
(1 / numeric_expr#
): expect
(")") case "asech":
call getsym: expect
("("): primary#
= asech
(numeric_expr#
): expect
(")") case "asin":
call getsym: expect
("("): primary#
= asin2
(numeric_expr#
): expect
(")") case "asinh":
call getsym: expect
("("): primary#
= asinh
(numeric_expr#
): expect
(")") case "atanh":
call getsym: expect
("("): primary#
= atanh
(numeric_expr#
): expect
(")") case "atn", "atan":
call getsym: expect
("("): primary#
= atn(numeric_expr#
): expect
(")") case "cdbl":
call getsym: expect
("("): primary#
= cdbl(numeric_expr#
): expect
(")") case "cint":
call getsym: expect
("("): primary#
= cint(numeric_expr#
): expect
(")") case "clng":
call getsym: expect
("("):primary#
= clng(numeric_expr#
): expect
(")") case "cos":
call getsym: expect
("("): primary#
= cos(numeric_expr#
): expect
(")") case "cosh":
call getsym: expect
("("): primary#
= cosh
(numeric_expr#
): expect
(")") case "cot":
call getsym: expect
("("): primary#
= 1 / tan(numeric_expr#
): expect
(")") case "coth":
call getsym: expect
("("): primary#
= 1 / tanh
(numeric_expr#
): expect
(")") case "csc":
call getsym: expect
("("): primary#
= 1 / sin(numeric_expr#
): expect
(")") case "csch":
call getsym: expect
("("): primary#
= 1 / sinh
(numeric_expr#
): expect
(")") case "csng":
call getsym: expect
("("): primary#
= csng(numeric_expr#
): expect
(")") case "cvd":
call getsym: expect
("("): primary#
= cvd(strexpression$
): expect
(")") case "cvi":
call getsym: expect
("("): primary#
= cvi(strexpression$
): expect
(")") case "exp":
call getsym: expect
("("): primary#
= exp(numeric_expr#
): expect
(")") case "false":
call getsym: primary#
= false
case "frac":
call getsym: expect
("("): primary#
= frac#
(numeric_expr#
): expect
(")") case "fix":
call getsym: expect
("("): primary#
= fix(numeric_expr#
): expect
(")") case "instr":
call getsym: primary#
= instrfun&
case "int":
call getsym: expect
("("): primary#
= int(numeric_expr#
): expect
(")") case "len":
call getsym: expect
("("): primary#
= len(strexpression$
): expect
(")") case "ln":
call getsym: expect
("("): primary#
= log(numeric_expr#
): expect
(")") expect("(")
primary#
= i
/ log(numeric_expr#
) primary# = i
expect(")")
case "log10":
call getsym: expect
("("): primary#
= log(numeric_expr#
) / log(10): expect
(")") case "peek":
call getsym: expect
("("): primary#
= peekfun#
(strexpression$
): expect
(")") case "point":
call getsym: primary#
= pointfun#
case "pos":
call getsym: primary#
= posfun#
primary#
= rnd(numeric_expr#
) expect(")")
case "screen":
call getsym: primary#
= screenfun&
case "sec":
call getsym: expect
("("): primary#
= 1 / cos(numeric_expr#
): expect
(")") case "sech":
call getsym: expect
("("): primary#
= 1 / cosh
(numeric_expr#
): expect
(")") case "sgn":
call getsym: expect
("("): primary#
= sgn(numeric_expr#
): expect
(")") case "sin":
call getsym: expect
("("): primary#
= sin(numeric_expr#
): expect
(")") case "sinh":
call getsym: expect
("("): primary#
= sinh
(numeric_expr#
): expect
(")") case "sqr", "sqrt":
call getsym: expect
("("): primary#
= sqr(numeric_expr#
): expect
(")") case "tan":
call getsym: expect
("("): primary#
= tan(numeric_expr#
): expect
(")") case "tanh":
call getsym: expect
("("): primary#
= tanh
(numeric_expr#
): expect
(")") case "true":
call getsym: primary#
= true
case "ubound":
call getsym: primary#
= uboundfun
case "val":
call getsym: expect
("("): primary#
= val(strexpression$
): expect
(")")
case "_atan2":
call getsym: primary#
= atan2fun#
case "_ceil":
call getsym: expect
("("): primary#
= _ceil(numeric_expr#
): expect
(")") case "_d2g":
call getsym: expect
("("): primary#
= _d2g(numeric_expr#
): expect
(")") case "_d2r":
call getsym: expect
("("): primary#
= _d2r(numeric_expr#
): expect
(")") case "_g2d":
call getsym: expect
("("): primary#
= _g2d(numeric_expr#
): expect
(")") case "_g2r":
call getsym: expect
("("): primary#
= _g2r(numeric_expr#
): expect
(")") case "_instrrev":
call getsym: primary#
= instrrevfun&
case "_keydown":
call getsym: expect
("("): primary#
= _keydown(numeric_expr#
): expect
(")") case "_newimage":
call getsym: primary#
= newimagefun&
case "_r2d":
call getsym: expect
("("): primary#
= _r2d(numeric_expr#
): expect
(")") case "_r2g":
call getsym: expect
("("): primary#
= _r2g(numeric_expr#
): expect
(")") case "_rgb":
call getsym: primary#
= rgbfun
case "_rgba":
call getsym: primary#
= rgbafun
case "_rgba32":
call getsym: primary#
= rgba32fun
case "_rgb32":
call getsym: primary#
= rgb32fun
case "_round":
call getsym: expect
("("): primary#
= _round(numeric_expr#
): expect
(")")
print "Unknown function: "; sym: errors
= true:
call getsym
primary# = the_num
primary# = get_numeric_array_value#
primary# = numeric_store(getvarindex&(right_side))
print at_line$;
"In primary, expecting an operand, found: "; sym;
" symtype is: "; symtype: errors
= true
s = strfactor$
s = s + strfactor$
strexpression$ = s
'-------------------------------------------------------------------------------------------------
str_st_ndx = str_st_ndx + 1
str_stack(str_st_ndx) = s
num_st_ndx = num_st_ndx + 1
num_stack(num_st_ndx) = n
pop_str = str_stack(str_st_ndx)
str_st_ndx = str_st_ndx - 1
pop_num = num_stack(num_st_ndx)
num_st_ndx = num_st_ndx - 1
s2 = pop_str$
s = pop_str$
print at_line$;
"In expr, expecting a string operator, found: "; op;
" symtype is: "; symtype: errors
= true
push_num(n)
evalstrexpr& = tynum
n2 = pop_num#
n = pop_num#
case "shl","<<": n
= shlf#
(n
, n2
) case "shr",">>": n
= shrf#
(n
, n2
) print at_line$;
"In expr, expecting a numeric operator, found: "; op;
" symtype is: "; symtype: errors
= true
push_num(n)
evalnumericexpr& = tynum
' return the type of expression, either string or numeric; result is on the stack
' we need to decide which primary to call - numeric or string
' leading parens don't tell us which primary, so just do recursive call
left_type = any_expr&(0)
expect(")")
push_str(strexpression$)
left_type = tystring
push_num(primary#)
left_type = tynum
print at_line$;
"In expr, unexpected end-of-line found: "; pgm
(curline
): errors
= true
print at_line$;
"In expr, expecting an expr, found: "; sym;
" symtype is: "; symtype;
" - near column: "; textp
errors = true
do ' while binary operator and precedence(sym) >= p
prec = binary_prec&(sym)
op = sym
' all operators are left associative in qbasic
prec = prec + 1
right_type = any_expr&(prec)
if left_type
= tystring
and right_type
= tystring
then left_type = evalstrexpr&(op)
left_type = evalnumericexpr&(op)
print at_line$;
"type missmatch in expr - left_type:"; left_type;
" right_type:"; right_type: errors
= true
any_expr& = left_type
numeric_expr2# = pop_num#
print at_line$;
"numeric expression expected": errors
= true
' process and return a numeric expression
numeric_expr# = numeric_expr2#(0)
bool_expr& = (numeric_expr# <> 0)
'------------------------------------------------------------------------
' scanner
'------------------------------------------------------------------------
ctype_arr(i) = ct_unknown
' alpha
ctype_arr(i) = ct_alpha
ctype_arr(i) = ct_alpha
ctype_arr
(asc("_")) = ct_alpha
' num
ctype_arr(i) = ct_digit
ctype_arr
(asc(".")) = ct_period
ctype_arr
(asc(",")) = ct_punc1
ctype_arr
(asc(";")) = ct_punc1
ctype_arr
(asc("=")) = ct_punc1
ctype_arr
(asc("+")) = ct_punc1
ctype_arr
(asc("-")) = ct_punc1
ctype_arr
(asc("*")) = ct_punc1
ctype_arr
(asc("/")) = ct_punc1
ctype_arr
(asc("\")) = ct_punc1
ctype_arr
(asc("^")) = ct_punc1
ctype_arr
(asc("(")) = ct_punc1
ctype_arr
(asc(")")) = ct_punc1
ctype_arr
(asc("?")) = ct_punc1
ctype_arr
(asc(":")) = ct_punc1
ctype_arr
(asc("<")) = ct_lt
ctype_arr
(asc(">")) = ct_gt
ctype_arr
(asc("&")) = ct_amp
ctype_arr
(asc(chr$(34))) = ct_dquote
ctype_arr
(asc(chr$(39))) = ct_squote
' other code relies on textp always being incremented; so do it even on EOL
the_ch = ""
the_ch
= mid$(thelin
, textp
, 1) textp = textp + 1
'print "getch: textp: "; textp; " the_ch: "; the_ch; " thelin: "; thelin
sym = ""
getch
symtype = tyident
case "%", "&", "!", "#": sym
= sym
+ the_ch: getch
' just ignore case "$": symtype
= tystrident: sym
= sym
+ the_ch: getch
' string ' see if we have "end if", if so, convert to "endif"
sym = "endif"
getch ' skip " "
getch ' skip "i"
getch ' skip "f"
sym = ""
sym = sym + the_ch
getch
sym = sym + the_ch
getch
sym = sym + the_ch
getch
sym = sym + "e"
getch
if the_ch
= "+" or the_ch
= "-" then sym
= sym
+ the_ch: getch
sym = sym + the_ch
getch
symtype = tynum
' on entry pointing to 'h'
sym = "&h"
getch ' skip the 'h'
sym = sym + the_ch
getch
symtype = tynum
getch
print at_line$;
"string not terminated": errors
= true
sym = sym + the_ch
getch
getch
symtype = tystring
the_ch = ""
sym = ""
symtype = tyunknown
s = ""
s = s + the_ch
getch
gettoeol$ = s
' symtype: unknown, tystring, tynum, tyident, tystrident
' sym: the symbol just read, above, and punctuation
'print "in getsym"
'dim ttt as double
'ttt = timer
'nsyms = nsyms + 1
sym = ""
symtype = tyunknown
' skip white space
sym = the_ch
case ct_punc1: getch
'punctuation case ct_alpha: readident
'identifier case ct_digit
, ct_period: readnumber
'number case ct_dquote: readstr
'double quote case ct_squote: skiptoeol
'comment getch
if instr("=><", the_ch
) > 0 then sym
= sym
+ the_ch: getch
'<=, <> << getch
if the_ch
= "=" or the_ch
= ">" then sym
= sym
+ the_ch: getch
' >=, >> getch
readhex
print at_line$;
"getsym: '& found, expecting 'h' but found:"; the_ch: errors
= true
print at_line$;
"getsym: unexpected character read:"; the_ch: errors
= true
getch
'scantime = scantime + (timer - ttt)
'print "initgetsym"
curline = n
textp = col
thelin = pgm(curline)
the_ch = " "