Author Topic: QBASIC/QB64 subset interpreter  (Read 5629 times)

0 Members and 1 Guest are viewing this topic.

Offline Ed Davis

  • Newbie
  • Posts: 40
    • View Profile
QBASIC/QB64 subset interpreter
« on: July 03, 2021, 03:03:26 pm »
QBASIC/QB64 subset interpreter by Ed Davis.
----------------------------------------------------------------------------------
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 one or two dimensional arrays
No subs or functions.
No dim.
Lots of other stuff missing.

You can run a single line of code at the ">" prompt:

>n=1:lim=25:while n<=lim:k=3:p=1:n=n+2:while k*k<=n and p:p=(n\k)*k<>n:k=k+2:wend:while p:print n; " is prime":exit while:wend:wend

You'll get:

  3 is prime
  5 is prime
  7 is prime
  11 is prime
  13 is prime
  17 is prime
  19 is prime
  23 is prime

Or you can just use it as a fancy calculator:

>3 + 4/(2*3*4) - 4/(4*5*6) + 4/(6*7*8) - 4/(8*9*10) + 4/(10*11*12) - 4/(12*13*14)
3.1408

To run an example:

Start the interpreter

You'll get a prompt.  type:  run filename
For example:

>run matrix.bas

Or:

>load matrix.bas
>run

To edit a program, type "edit".  If no program is loaded, it will edit "default.bas".
It uses notepad.exe by default, unless the EDITOR environment variable is defined, in which case it will use whatever that points to.

You can single step:

>load matrix.bas
>tron
>ston
>run

Press enter to keep on stepping

After a run, you can show variables:

>list vars

I'm sure there are lots of bugs^H^H^H^Hfeatures, so beware!

The interpreter:
Code: QB64: [Select]
  1. ' QBASIC/QB64 subset interpreter by Ed Davis.
  2. ' ------------------------------------------------------------------------------------------
  3.  
  4.  
  5. '------------------------------------------------------------------------
  6. '  03 Jul 2021 todo
  7. '  [x] store/retrieve variables like eval-ed4
  8. '  [x] const id[$] = number|string {, const id[$] = number|string}
  9. '  [ ] consolidate loop handling data structures
  10. '  [x] arrays
  11. '      [x]  parse
  12. '      [x]  allocate 1 dimensional
  13. '      [x]  allocate 2 dimensional
  14. '      [x]  assign (idstmt, stridstmt)
  15. '      [x]  reference (strfactor, primary)
  16. '  [ ] Subs
  17. '  [ ] Functions
  18. '  [ ] Shared variables
  19. '  getvarindex& (getstrindex$), used in:
  20. '  forstmt:    to reference the "i" variable
  21. '  inputstmt:  to reference the "input" variable: input "", numeric_store(i)
  22. '  swapstmt:   reference: swap(numeric_store(i1), numeric_store(i2))
  23. '  assignment: numeric_store(i) = value
  24. '  primary:    primary# = numeric_store(i)
  25. 'idstmt (stridstmt) - only called by assignment
  26. '------------------------------------------------------------------------
  27. ' Currently supports:
  28. '
  29. ' Double and string variables only. No dim for these.
  30. ' One or two dimensional arrays.
  31. ' All standard operators, with hopefully the correct precedence.
  32. '
  33. ' String operators:
  34. ' +
  35. ' =, <>, <, >, <=, >=
  36. '
  37. '
  38. ' Numeric binary operators
  39. ' ^,
  40. ' *, /
  41. ' \
  42. ' mod,
  43. ' +, -,
  44. ' shl,<<, shr,>>
  45. ' =, <>, <, >, <=, >=,
  46. ' and,
  47. ' or,
  48. ' xor,
  49. ' eqv,
  50. ' imp,
  51. '
  52. ' Numeric unary operators
  53. ' not, -, +
  54. '
  55. ' Commands supported:
  56. '
  57. ' bye, quit - exits the interpreter
  58. ' clear     - clears variables
  59. ' dump      - shows info about arrays
  60. ' edit      - edits the current or default program
  61. ' files     - shows a list of files
  62. ' help      - simple help screen
  63. ' list      - lists current program
  64. ' list vars - iists variables
  65. ' load, old - loads a program into the interpreter
  66. ' new       - discards the current program
  67. ' reload    - reloads the current program from disk
  68. ' run       - runs the current program
  69. ' save      - saves the current program
  70. ' ston      - turns stepping on
  71. ' stoff     - turns stepping off
  72. ' tron      - turns tracing on
  73. ' troff     - turns tracing off
  74. '
  75. ' Statements:
  76. '
  77. ' Iteration:
  78. '   do [while|until]
  79. '     stmts
  80. '   loop
  81. '
  82. '   or
  83. '
  84. '   do
  85. '     stmts
  86. '   loop [while|until]
  87. '
  88. '   exit do
  89. '
  90. '   while stmts wend - exit while
  91. '
  92. '   for index = n to expr [step n]
  93. '   next
  94. '
  95. '   exit for
  96. '
  97. ' Control transfer:
  98. '   gosub, return
  99. '   goto - buggy if you jump outside of loops or multiline if
  100. '
  101. ' Selection:
  102. ' singleline or multiline if
  103. '   if elseif else end if
  104. '
  105. ' const - declare numeric or string constants
  106. '
  107. ' dim - declares double or string arrays
  108. '
  109. ' end, stop, system - exits program to interpreter
  110. '
  111. ' Other commands:
  112. '
  113. ' chdir circle cls color draw environ input line locate mid$ paint
  114. ' palette play preset print, ? pset randomize rem screen shell
  115. ' sleep sound swap view width window
  116. '
  117. ' QB64 commands:
  118. '
  119. ' _delay _display _freeimage _fullscreen _limit _printstring
  120. ' _screenmove _title
  121. '
  122. ' Numeric functions:
  123. '
  124. ' abs acos acosh acot acoth acsc acsch asc asec asech asin asinh
  125. ' atanh atn, atan cdbl cint clng cos cosh cot coth csc csch csng
  126. ' csrlin cvd cvi exp false frac fix instr int len ln log log10 peek
  127. ' point pos rnd screen sec sech sgn sin sinh sqr, sqrt tan tanh
  128. ' timer true ubound val
  129. '
  130. ' QB64 Numeric functions:
  131. '
  132. ' _atan2 _ceil _d2g _d2r _fontwidth _fontheight _g2d _g2r _height
  133. ' _instrrev _keydown _keyhit _mousebutton _mouseinput _mousex
  134. ' _mousey _newimage _pi _r2d _r2g _rgb _rgba _rgba32 _rgb32 _round
  135. ' _width
  136. '
  137. ' String Functions:
  138. '
  139. ' chr$ command$ date$ environ$ hex$ inkey$ lcase$ left$" lpad$
  140. ' ltrim$ mid$ mki$ oct$ replace$ right$ rpad$ rtrim$ space$ str$
  141. ' string$ time$ trim$ ucase$
  142. '
  143. ' QB64 string functions:
  144. '
  145. ' _clipboard$ _cwd$ _os$ _startdir$ _title$ _trim$
  146. '
  147. ' No other numeric data types besides double. Only suffix accepted is $ for strings.
  148. ' Only up to two dimensional arrays
  149. ' No subs or functions.
  150. ' No dim.
  151. ' Lots of other stuff missing.
  152. '------------------------------------------------------------------------------------------
  153.  
  154. declare function any_expr&(p as integer)
  155. declare function bool_expr&
  156. declare function numeric_expr#
  157. declare function numeric_expr2#(p as integer)
  158. declare function find_matching_else$
  159. declare function gettoeol$
  160. declare function instrfun&
  161. declare function is_multi_line_if&
  162. declare function is_stmt_end&
  163. declare function peek_ch$
  164. declare function pop_num#
  165. declare function pop_str$
  166. declare function primary#
  167. declare function storeline&
  168. declare function strexpression$
  169. declare function strfactor$
  170.  
  171. declare sub clearprog
  172. declare sub clearvars
  173. declare sub colorstmt
  174. declare sub docmd(interactive as integer)
  175. declare sub elsestmt
  176. declare sub endifstmt
  177. declare sub exitstmt
  178. declare sub expect(s as string)
  179. declare sub filesstmt
  180. declare sub find_matching_sline_if
  181. declare sub find_matching_pair(s1 as string, s2 as string)
  182. declare sub forstmt
  183. declare sub getsym
  184. declare sub gosubline(target as integer)
  185. declare sub gosubstmt
  186. declare sub gotoline(target as integer)
  187. declare sub gotostmt
  188. declare sub idstmt
  189. declare sub ifstmt
  190. declare sub initvars
  191. declare sub inputstmt
  192. declare sub lineinputstmt
  193. declare sub linestmt
  194. declare sub liststmt
  195. declare sub loadprog(fn as string)
  196. declare sub locatestmt
  197. declare sub midstmt
  198. declare sub multi_ifstmt(cond as integer)
  199. declare sub nextstmt
  200. declare sub printstmt
  201. declare sub randomizer
  202. declare sub returnstmt
  203. declare sub saveprog
  204. declare sub showhelp
  205. declare sub skiptoeol
  206. declare sub stridstmt
  207. declare sub validlinenum(n as integer)
  208. declare sub wendstmt
  209. declare sub whilestmt(first as integer)
  210.  
  211. const true = -1, false = 0
  212. const e         = 2.71828182845905
  213. const halfpi    = 1.5707963267949
  214. const pi        = 3.14159265358979
  215. const max_store = 512
  216. const varssize  = 64
  217. const stacksize = 512
  218. const pgmsize   = 3000
  219. const tyunknown=0, tyident=1, tystrident=2, tynum=3, tystring=4
  220. const left_side = 0, right_side = 1
  221.  
  222. dim shared the_ch as string    ' last char read from input
  223. dim shared sym as string       ' last symbol read
  224. dim shared symtype as integer  ' type of last symbol read
  225. dim shared the_num as double   ' last number read
  226. dim shared pgm(pgmsize) as string ' lines of text stored here
  227. dim shared curline as integer  ' number of current line in pgm
  228. dim shared thelin as string    ' text of current line
  229. dim shared textp as integer    ' positionn in thelin
  230. dim shared curr_filename as string
  231.  
  232. type do_loop_t
  233.   lline as integer
  234.   loff  as integer
  235.  
  236. ' do/while/for/if tracking
  237. dim shared loopvars(varssize) as integer, looplines(varssize) as integer
  238. dim shared loopmax(varssize) as double, loopstep(varssize) as double
  239. dim shared loopoff(varssize) as integer
  240. dim shared stackp as integer, loopp as integer
  241. dim shared gosubstack(stacksize) as integer, gosuboffstack(stacksize) as integer
  242. dim shared while_sp as integer, while_line(varssize) as integer, while_off(varssize) as integer
  243. dim shared do_sp as integer, do_loop(stacksize) as do_loop_t
  244. dim shared if_sp as integer, if_stack(stacksize) as integer
  245.  
  246. ' for arrays:  make sure the user specified index is between lo_bnd..hi_bnd inclusive
  247. ' then, computed index = v.index + user_index - v.lo_bnd
  248. type names_t
  249.     vname    as string
  250.     symtype  as integer ' variable name
  251.     index    as long    ' index into string table; numeric table; or string/numeric array table
  252.     is_const as integer
  253.     lo_bnd   as long
  254.     hi_bnd   as long
  255.     lo_bnd2  as long    ' only if 2 dimensional
  256.     hi_bnd2  as long    ' only if 2 dimensional
  257.     multi    as integer ' true if 2 dimensional
  258.     a_len    as long    ' non-zero if array
  259.     a_width  as long    ' used in computing index when 2 dimensional
  260.  
  261. ' variable names
  262. dim shared var_names(1 to max_store) as names_t, var_names_max as integer
  263.  
  264. ' string and numeric values
  265. dim shared string_store(1 to max_store) as string, str_store_max as integer
  266. dim shared numeric_store(1 to max_store) as double, num_store_max as integer
  267.  
  268. ' string and numeric arrays
  269. redim shared string_arr_store(0) as string: dim shared str_arr_stor_max as long
  270. redim shared numeric_arr_store(0) as double: dim shared num_arr_stor_max as long
  271.  
  272. ' used by expression parser
  273. dim shared str_stack(varssize) as string
  274. dim shared num_stack(varssize) as double
  275. dim shared str_st_ndx as integer, num_st_ndx as integer
  276.  
  277. dim shared endif_count as integer
  278. dim shared wend_count  as integer
  279. dim shared next_count  as integer
  280. dim shared loop_count  as integer
  281.  
  282. dim shared stepping as integer
  283. const right_assoc = 0, left_assoc = 1, unaryminus_prec = 13, unaryplus_prec = 13, unarynot_prec = 6
  284.  
  285. 'for performance timing
  286. 'dim shared scantime as double
  287. 'dim shared starttime as double
  288. 'dim shared nsyms as long
  289.  
  290. dim shared ctype_arr(255) as integer
  291. const ct_unknown=0, ct_alpha=1, ct_digit=2, ct_period=3, ct_punc1=4
  292. const ct_dquote=5, ct_squote=6, ct_amp=7, ct_lt=8, ct_gt=9
  293.  
  294. '---------------------------------------------------------------------------------------------------
  295. ' Listed here since I can not remember them:
  296. ' % = integer (16 bit)
  297. ' & = long    (32 bit)
  298. ' ! = single  (default)
  299. ' # = double
  300. ' $ = string
  301. '---------------------------------------------------------------------------------------------------
  302. ' Maybe add:
  303. ' min(x, x1, x2...), max(...), ave(...), sum(...)
  304. '#define floor(x) ((x*2.0-0.5)shr 1)
  305. '#define ceil(x) (-((-x*2.0-0.5)shr 1))
  306. '---------------------------------------------------------------------------------------------------
  307.  
  308. call init_scanner
  309. tracing = false
  310. stepping = false
  311.  
  312. str_st_ndx = 0
  313. num_st_ndx = 0
  314.  
  315. '------------------------------------------------------------------------
  316. ' main loop
  317. '------------------------------------------------------------------------
  318. dim cmd$
  319. quit = false
  320.  
  321. 'starttime = timer
  322. cmd$ = command$
  323. if command$(1) = "-t" then
  324.     cmd$ = ltrim$(rtrim$(mid$(command$, 4)))
  325.     if cmd$ <> "" then quit = true
  326.     _dest 0
  327.  
  328. if cmd$ <> "" then
  329.   pgm(0) = "run " + cmd$
  330.   call initgetsym(0, 1)
  331.   call docmd(false)
  332.   call showhelp
  333.  
  334. if quit then call showtime: if errors then system 1 else system
  335.  
  336.   line input "> ", pgm(0)
  337.   if pgm(0) <> "" then
  338.     call initgetsym(0, 1)
  339.     call docmd(true)
  340.   end if
  341.  
  342. ' show timings
  343. sub showtime
  344.   'dim total_time as double
  345.   'total_time = timer - starttime
  346.  
  347.   'print "Total time: "; total_time; " Scan time: "; scantime; " Parse time: "; total_time - scantime; " Symbols: "; nsyms
  348.   'sleep
  349.  
  350. function at_line$
  351.   at_line$ = "": if curline > 0 then at_line$ = "(" + str$(curline) + ")"
  352.  
  353. function rest_of_line$
  354.   rest_of_line$ = sym + " " + the_ch + " " + mid$(thelin, textp)
  355.  
  356. sub dump_tables
  357.  
  358.   print "name", "index", "lo", "hi", "len"
  359.   for i = 1 to var_names_max
  360.     print var_names(i).vname, var_names(i).index, var_names(i).lo_bnd, var_names(i).hi_bnd, var_names(i).a_len
  361.   next
  362.  
  363. '------------------------------------------------------------------------
  364. ' command processor
  365. '------------------------------------------------------------------------
  366. sub docmd(interactive as integer)
  367. 'print "docmd"
  368.   errors = false
  369.  
  370.   restart_loop:
  371.   stackp = 0    ' these were -1 ??? @review
  372.   loopp   = 0   ' these were -1 ??? @review
  373.   while_sp = 0
  374.   do_sp = 0
  375.   if_sp = 0
  376.  
  377.   do
  378.     loop_top:
  379.     if errors then exit sub
  380.     while sym = "" and curline > 0 and curline < pgmsize
  381.       call initgetsym(curline + 1, 1)
  382.     wend
  383.     if tracing then print "["; curline; "] "; sym; " "; the_ch; " "; ltrim$(mid$(thelin, textp))
  384.     if stepping then sleep
  385.     select case sym
  386.       case "":            exit sub
  387.       case "bye", "quit": call getsym: call showtime:  if errors then system 1 else system
  388.       case "clear":       call getsym: call clearvars: exit sub
  389.       case "edit":        call getsym: call editstmt:  exit sub
  390.       case "help":        call getsym: call showhelp:  exit sub
  391.       case "list":        call getsym: call liststmt:  exit sub
  392.       case "load", "old": call getsym: call loadprog(""):  exit sub
  393.       case "new":         call getsym: call initvars: call clearprog: tracing = false: exit sub
  394.       case "reload":      call getsym: call loadprog(curr_filename): exit sub
  395.       case "run":         call getsym: call runprog: interactive = false: goto restart_loop
  396.       case "save":        call getsym: call saveprog:  exit sub
  397.       case "stop", "end", "system": call getsym:       exit sub
  398.       case "dump":        call getsym: call dump_tables
  399.  
  400.       case "chdir":       call getsym: call chdircmd
  401.       case "circle":      call getsym: call circlestmt
  402.       case "cls":         call getsym: cls
  403.       case "color":       call getsym: call colorstmt
  404.       case "const":       call getsym: call conststmt
  405.       case "dim":         call getsym: call dimstmt
  406.       case "do":          call getsym: call dostmt(true)
  407.       case "draw":        call getsym: call drawstmt
  408.       case "else":        call getsym: call elsestmt
  409.       case "elseif":      call getsym: call elseifstmt
  410.       case "endif":       call getsym: call endifstmt
  411.       case "environ":     call getsym: call environstmt
  412.       case "exit":        call getsym: call exitstmt
  413.       case "for":         call getsym: call forstmt
  414.       case "gosub":       call getsym: call gosubstmt: goto loop_top
  415.       case "goto":        call getsym: call gotostmt:  goto loop_top
  416.       case "if":          call getsym: call ifstmt:    goto loop_top
  417.       case "input":       call getsym: call inputstmt
  418.       case "line":        call getsym: call lineinputstmt
  419.       case "loop":        call getsym: call loopstmt
  420.       case "locate":      call getsym: call locatestmt
  421.       case "mid$":        call getsym: call midstmt
  422.       case "next":        call getsym: call nextstmt
  423.       case "paint":       call getsym: call paintstmt
  424.       case "palette":     call getsym: call palettestmt
  425.       case "preset":      call getsym: call presetstmt
  426.       case "print", "?":  call getsym: call printstmt
  427.       case "pset":        call getsym: call psetstmt
  428.       case "randomize":   call getsym: call randomizer
  429.       case "rem", "'":    call getsym: call skiptoeol
  430.       case "return":      call getsym: call returnstmt: goto loop_top
  431.       case "screen":      call getsym: call screenstmt
  432.       case "shell":                    call shellstmt
  433.       case "sleep":       call getsym: call sleepstmt
  434.       case "swap":        call getsym: call swapstmt
  435.       case "view":        call getsym: call viewstmt
  436.       case "wend":        call getsym: call wendstmt
  437.       case "while":       call getsym: call whilestmt(true)
  438.       case "width":       call getsym: call widthstmt
  439.       case "window":      call getsym: call windowstmt
  440.  
  441.       case "files":       call getsym: call filesstmt
  442.       case "play":        call getsym: play strexpression$
  443.       case "sound":       call getsym: call soundstmt
  444.       case "_delay":      call getsym: _delay numeric_expr#
  445.       case "_display":    call getsym: _display
  446.       case "_freeimage":  call getsym: call freeimage
  447.       case "_fullscreen": call getsym: _fullscreen
  448.       case "_limit":      call getsym: call limitstmt
  449.       case "_printstring":call getsym: call printstringstmt
  450.       case "_screenmove": call getsym: call screenmovestmt
  451.       case "_title":      call getsym: call titlestmt
  452.  
  453.       case "troff": call getsym: tracing  = false
  454.       case "tron":  call getsym: tracing  = true
  455.       case "stoff": call getsym: stepping = false
  456.       case "ston":  call getsym: stepping = true
  457.  
  458.       ' need to account for:
  459.       '  - assignment
  460.       '    let ...
  461.       '    [str]ident = expression
  462.       '    [str]ident(expression [, expression]) = expression
  463.       '  - labels
  464.       '    ident:
  465.       '  - non-assignment, including labels
  466.       '
  467.       case else
  468.         if left$(sym, 1) = "_" then
  469.           print "Unknown command: "; sym: errors = true
  470.         elseif accept&("let") then
  471.           call assignment
  472.         elseif symtype = tyident or symtype = tystrident then
  473.           if peek_ch$ = "=" then
  474.             call assignment
  475.           elseif peek_ch$ = "(" and instr(mid$(pgm(curline), textp), "=") > 0 then
  476.             call array_assignment
  477.           elseif symtype = tyident and the_ch = ":" then
  478.             call getsym
  479.           elseif interactive then
  480.             call printstmt
  481.           elseif sym <> ":" and sym <> "" then
  482.             print at_line$; "Stmt expected, found:"; rest_of_line$: errors = true
  483.           end if
  484.         elseif interactive then
  485.           call printstmt
  486.         elseif sym <> ":" and sym <> "" then
  487.           print at_line$; "Stmt expected, found:"; rest_of_line$: errors = true
  488.         end if
  489.     end select
  490.  
  491.     if errors then
  492.       exit sub
  493.     elseif sym = ":" then
  494.       call getsym
  495.     elseif sym <> "else" and sym <> "" then
  496.       print at_line$; "Extra stmts:"; rest_of_line$: errors = true
  497.       print "symtype:"; symtype; " sym:"; sym; " ch:"; the_ch
  498.     end if
  499.   loop
  500.  
  501. '------------------------------------------------------------------------
  502. ' variable storage/retrieval
  503. '------------------------------------------------------------------------
  504.  
  505. ' find position of vname in var_names
  506. function find_vname&(vname as string)
  507.  
  508.   for i = 1 to var_names_max
  509.     if var_names(i).vname = vname then
  510.       find_vname& = i
  511.       exit function
  512.     end if
  513.   next
  514.  
  515.   find_vname& = 0
  516.  
  517. ' helper function for 2d arrays
  518. function ar_scale(i as long, lo as long)
  519.   ar_scale = i - (lo - 1)
  520.  
  521. ' get the index of "a" in either string_arr_store or numeric_arr_store
  522. ' pointing to: a(expr [, expr])
  523. function get_array_index&(ident as string)
  524.   dim i as integer, index as long, index2 as long, lo as long, lo2 as long
  525.   dim x as long
  526.  
  527.   call getsym
  528.   i = find_vname&(ident)
  529.   if i = 0 then print at_line$; "Array has not been declared: "; ident: errors = true: exit function
  530.   expect("(")
  531.   index = numeric_expr#
  532.  
  533.   if var_names(i).multi then
  534.     expect(",")
  535.     index2 = numeric_expr#
  536.   end if
  537.  
  538.   expect(")")
  539.   if var_names(i).a_len = 0 then
  540.     print at_line$; "'"; ident; "' is not declared as an array": errors = true: exit function
  541.   end if
  542.  
  543.   ' verfiy that the index is within range
  544.   if index < var_names(i).lo_bnd or index > var_names(i).hi_bnd then
  545.     print at_line$; "Index is out of range:"; index; "("; var_names(i).lo_bnd; ","; var_names(i).hi_bnd; ")": errors = true: exit function
  546.   end if
  547.   if var_names(i).multi then
  548.     if index2 < var_names(i).lo_bnd2 or index2 > var_names(i).hi_bnd2 then
  549.       print at_line$; "Index two is out of range:"; index2: errors = true: exit function
  550.     end if
  551.   end if
  552.  
  553.   ' compute the actual index
  554.   lo = var_names(i).lo_bnd
  555.   if var_names(i).multi then
  556.     lo2 = var_names(i).lo_bnd2
  557.     x = var_names(i).index + (var_names(i).a_width * (ar_scale(index2, lo2) - 1) + ar_scale(index, lo)) - 1
  558.   else
  559.     x = var_names(i).index + ar_scale(index, lo) - 1
  560.     'x = var_names(i).index + index - (var_names(i).lo_bnd - 1) - 1
  561.   end if
  562.   'print "index: "; x
  563.  
  564.   if tracing then print ident;"(";index;")[";x;"] =";
  565.   get_array_index& = x
  566.  
  567. ' primary: if var does not exist, create it.  Return the var store index
  568. ' sym is the numeric variable name
  569. function getvarindex&(side as integer)
  570.   dim i as integer, ident as string, ident_type as integer
  571.  
  572.   ident = sym: ident_type = symtype
  573.   call getsym
  574.  
  575.   if ident_type = tystrident then
  576.     print at_line$; "type mismatch": errors = true
  577.   elseif ident_type <> tyident then
  578.     print at_line$; "not a variable": errors = true
  579.   else
  580.     ' see if variable exists
  581.     i = find_vname&(ident)
  582.     if i > 0 then
  583.       getvarindex& = var_names(i).index
  584.       if side = left_side and var_names(i).is_const then print at_line$; "Cannot update const variable: "; ident: errors = true
  585.       exit function
  586.     end if
  587.  
  588.     'if side = right_side then print at_line$; "Reference to unassigned variable: "; ident: errors = true
  589.  
  590.     ' create a new variable
  591.     num_store_max = num_store_max + 1
  592.     var_names_max = var_names_max + 1
  593.  
  594.     var_names(var_names_max).vname   = ident
  595.     var_names(var_names_max).symtype = ident_type
  596.     var_names(var_names_max).index   = num_store_max
  597.     numeric_store(num_store_max)     = 0    ' default value
  598.  
  599.     getvarindex& = num_store_max
  600.   end if
  601.  
  602. function getstrindex&(side as integer)
  603.   dim i as integer, ident as string, ident_type as integer
  604.  
  605.   ident = sym: ident_type = symtype
  606.   call getsym
  607.  
  608.   if ident_type = tyident then
  609.     print at_line$; "type mismatch": errors = true
  610.   elseif ident_type <> tystrident then
  611.     print at_line$; "not a variable": errors = true
  612.   else
  613.     ' see if variable exists
  614.     i = find_vname&(ident)
  615.     if i > 0 then
  616.       getstrindex& = var_names(i).index
  617.       if side = left_side and var_names(i).is_const then print at_line$; "Cannot update const variable: "; ident: errors = true
  618.       exit function
  619.     end if
  620.  
  621.     'if side = right_side then print at_line$; "Reference to unassigned variable: "; ident: errors = true
  622.  
  623.     ' create a new variable
  624.     str_store_max = str_store_max + 1
  625.     var_names_max = var_names_max + 1
  626.  
  627.     var_names(var_names_max).vname   = ident
  628.     var_names(var_names_max).symtype = ident_type
  629.     var_names(var_names_max).index   = str_store_max
  630.     string_store(str_store_max)      = ""    ' default value
  631.  
  632.     getstrindex& = str_store_max
  633.   end if
  634.  
  635. ' a(expr)
  636. ' when called, sym pointing at the ident
  637. function get_numeric_array_value#
  638.   dim ident as string, ident_type as integer, x as long, n as double
  639.  
  640.   ident = sym: ident_type = symtype
  641.   x = get_array_index&(ident)
  642.   n = numeric_arr_store(x)
  643.   get_numeric_array_value# = n
  644.  
  645. ' a(expr)
  646. ' when called, sym pointing at the ident
  647. function get_string_array_value$
  648.   dim ident as string, ident_type as integer, x as long, s as string
  649.  
  650.   ident = sym: ident_type = symtype
  651.   x = get_array_index&(ident)
  652.   s = string_arr_store(x)
  653.   get_string_array_value$ = s
  654.  
  655. sub stridstmt
  656.   dim i as integer, vname as string
  657.  
  658.   vname = sym
  659.   'print "stridstmt"
  660.   i = getstrindex&(left_side)
  661.   expect("=")
  662.   string_store(i) = strexpression$
  663.   if tracing then print vname, string_store(i)
  664.  
  665. sub idstmt
  666.   dim i as integer, vname as string
  667.  
  668.   vname = sym
  669.   i = getvarindex&(left_side)
  670.   expect("=")
  671.   numeric_store(i) = numeric_expr#
  672.   if tracing then print vname, numeric_store(i)
  673.  
  674. ' ident = expression
  675. sub assignment
  676.   if symtype = tyident then
  677.     call idstmt
  678.   elseif symtype = tystrident then
  679.     call stridstmt
  680.   else
  681.     print at_line$; "Expecting assignment stmt, found: "; sym: errors = true
  682.   end if
  683.  
  684. ' ident(expression [, expression]) = expression
  685. sub array_assignment
  686.   dim ident as string, ident_type as integer
  687.   dim s as string, n as double, x as long
  688.  
  689.   ident = sym: ident_type = symtype
  690.   x = get_array_index&(ident)
  691.  
  692.   expect("=")
  693.  
  694.   if ident_type = tystrident then
  695.     s = strexpression$
  696.     'assign string
  697.     string_arr_store(x) = s
  698.     if tracing then print s
  699.   else
  700.     n = numeric_expr#
  701.     'assign number
  702.     numeric_arr_store(x) = n
  703.     if tracing then print n
  704.   end if
  705.  
  706. '------------------------------------------------------------------------
  707. ' statement parsing
  708. '------------------------------------------------------------------------
  709.  
  710. sub showhelp
  711.   print "bye or quit -- exit"
  712.   print "help        -- show this screen"
  713.   print "clear       -- clear variables"
  714.   print "edit        -- edit current program"
  715.   print "list        -- show source"
  716.   print "list vars   -- show variables"
  717.   print "load        -- load program from disk"
  718.   print "new         -- clear program in memory"
  719.   print "reload      -- reload program from disk"
  720.   print "run         -- run program in memory"
  721.   print "save        -- save program to disk"
  722.   print ""
  723.   print "cls         -- clear screen"
  724.   print "tron        -- tracing on"
  725.   print "troff       -- tracing off"
  726.   print "ston        -- stepping on"
  727.   print "stoff       -- stepping off"
  728.  
  729. function getfn$(prompt as string)
  730.   dim filespec as string
  731.   if symtype = tystring or symtype = tystrident then
  732.     filespec = strexpression$
  733.   elseif sym <> "" then
  734.     filespec = sym                 ' gettoeol destroys sym
  735.     filespec = filespec + gettoeol$
  736.   else
  737.     print prompt; ": ";
  738.     line input filespec
  739.   end if
  740.   if filespec <> "" then
  741.     if instr(filespec, ".") = 0 then filespec = filespec + ".bas"
  742.   end if
  743.   getfn$ = filespec
  744.  
  745. sub clearvars
  746.  
  747.   for i = 1 to str_store_max
  748.     string_store(i) = ""
  749.   next
  750.  
  751.   for i = 1 to num_store_max
  752.     numeric_store(i) = 0
  753.   next
  754.  
  755. sub initvars
  756.  
  757.   clearvars
  758.   for i = 1 to var_names_max
  759.     var_names(i).vname = ""
  760.     var_names(i).index = 0
  761.   next
  762.  
  763.   str_store_max = 0: num_store_max = 0: var_names_max = 0
  764.  
  765. sub loadprog(fn as string)
  766.   initvars
  767.   clearprog
  768.  
  769.   if fn = "" then curr_filename = getfn$("Program file") else curr_filename = fn
  770.   if curr_filename = "" then exit sub
  771.   open curr_filename for input as 1
  772.  
  773.   n = 0
  774.   while not eof(1)
  775.     line input #1, pgm(0)
  776.     'if pgm(0) <> "" then
  777.       if storeline& then
  778.         n = the_num + 1
  779.       else
  780.         n = n + 1
  781.         pgm(n) = pgm(0)
  782.       end if
  783.     'end if
  784.   wend
  785.  
  786.   close #1
  787.   curline = 0
  788.  
  789. sub editstmt
  790.   dim editor as string
  791.   editor = environ$("EDITOR")
  792.   if editor = "" then editor = "notepad.exe"
  793.   if curr_filename = "" then curr_filename = "default.bas"
  794.   shell editor + " " + curr_filename
  795.   call loadprog(curr_filename)
  796.  
  797. sub runprog
  798.   if sym <> "" then call loadprog("")
  799.   call initgetsym(1, 1)
  800.  
  801. sub saveprog
  802.   dim filespec as string
  803.   filespec = getfn$("Save as")
  804.   if filespec = "" then exit sub
  805.   open filespec for output as 1
  806.   if err = 8 then
  807.      print at_line$; "*** error: you don't have permission to write to that file."
  808.      exit sub
  809.   end if
  810.   for i = 1 to pgmsize
  811.     if len(pgm(i)) then print #1, i; " "; pgm(i)
  812.   next
  813.   close #1
  814.  
  815. sub liststmt
  816.   if sym = "vars" then
  817.     for i = 1 to var_names_max
  818.       if var_names(i).a_len > 0 then
  819.           print "Array:"; var_names(i).vname, " index: "; var_names(i).index;
  820.           print string_store(var_names(i).index); " size: "; var_names(i).a_len;
  821.           print " type: "; var_names(i).symtype
  822.       elseif right$(var_names(i).vname, 1) = "$" then
  823.           print "String:"; var_names(i).vname, " index: "; var_names(i).index;
  824.           print string_store(var_names(i).index);
  825.           print " type: "; var_names(i).symtype
  826.       elseif var_names(i).vname <> "" then
  827.           print "Number:"; var_names(i).vname, " index: "; var_names(i).index;
  828.           print numeric_store(var_names(i).index);
  829.           print " type: "; var_names(i).symtype
  830.       end if
  831.     next
  832.   else
  833.     for i = 1 to pgmsize
  834.       if pgm(i) <> "" then print i; " "; pgm(i)
  835.     next
  836.   end if
  837.  
  838. sub chdircmd
  839.   chdir strexpression$
  840.  
  841. ' CIRCLE [STEP] (x!,y!),radius![,[color%] [,[start!] [,[end!] [,aspect!]]]]
  842. sub circlestmt
  843.   dim x as single, y as single, radius as single, clr as long
  844.   dim arcbeg as single, arcend as single, elipse as single
  845.  
  846.   expect("(")
  847.   x = numeric_expr#
  848.   expect(",")
  849.   y = numeric_expr#
  850.   expect(")")
  851.   expect(",")
  852.   radius = numeric_expr#
  853.  
  854.   '[,[color%] [,[start!] [,[end!] [,aspect!]]]]
  855.   if accept&(",") then           ' color
  856.     if accept&(",") then         ' arcbeg
  857.       if accept&(",") then       ' arcend
  858.         if accept&(",") then     ' elipse
  859.           elipse = numeric_expr#
  860.           circle (x, y), radius, , , , elipse
  861.         else
  862.           arcend = numeric_expr#
  863.           if accept&(",") then
  864.             elipse = numeric_expr#
  865.             circle (x, y), radius, , , arcend, elipse
  866.           else
  867.             circle (x, y), radius, , , arcend
  868.           end if
  869.         end if
  870.       else
  871.         arcbeg = numeric_expr#
  872.         if accept&(",") then       ' arcend
  873.           if accept&(",") then     ' elipse
  874.             elipse = numeric_expr#
  875.             circle (x, y), radius, , arcbeg, , elipse
  876.           else
  877.             arcend = numeric_expr#
  878.             if accept&(",") then
  879.               elipse = numeric_expr#
  880.               circle (x, y), radius, , arcbeg, arcend, elipse
  881.             else
  882.               circle (x, y), radius, , arcbeg, arcend
  883.             end if
  884.           end if
  885.         end if
  886.       end if
  887.     else
  888.       ' [,[start!] [,[end!] [,aspect!]]]]
  889.       clr = numeric_expr#
  890.       if accept&(",") then         ' arcbeg
  891.         if accept&(",") then       ' arcend
  892.           if accept&(",") then     ' elipse
  893.             elipse = numeric_expr#
  894.             circle (x, y), radius, clr, , , elipse
  895.           else
  896.             arcend = numeric_expr#
  897.             if accept&(",") then
  898.               elipse = numeric_expr#
  899.               circle (x, y), radius, clr, , arcend, elipse
  900.             else
  901.               circle (x, y), radius, clr, , arcend
  902.             end if
  903.           end if
  904.         else
  905.           arcbeg = numeric_expr#
  906.           if accept&(",") then       ' arcend
  907.             if accept&(",") then     ' elipse
  908.               elipse = numeric_expr#
  909.               circle (x, y), radius, clr, arcbeg, , elipse
  910.             else
  911.               arcend = numeric_expr#
  912.               if accept&(",") then
  913.                 elipse = numeric_expr#
  914.                 circle (x, y), radius, clr, arcbeg, arcend, elipse
  915.               else
  916.                 circle (x, y), radius, clr, arcbeg, arcend
  917.               end if
  918.             end if
  919.           else
  920.             circle (x, y), radius, clr, arcbeg
  921.           end if
  922.         end if
  923.       else
  924.         circle (x, y), radius, clr
  925.       end if
  926.     end if
  927.   else
  928.     circle (x, y), radius
  929.   end if
  930.  
  931. ' color [fore] [,back]
  932. sub colorstmt
  933.   dim back as long, fore as long
  934.   if accept&(",") then
  935.     back = numeric_expr#
  936.     color , back
  937.   else
  938.     fore = numeric_expr#
  939.     if accept&(",") then
  940.       back = numeric_expr#
  941.       color fore, back
  942.     else
  943.       color fore
  944.     end if
  945.   end if
  946.  
  947. sub get_array_bounds(lo as long, hi as long)
  948.     lo = numeric_expr#
  949.     if accept&("to") then
  950.       hi = numeric_expr#
  951.     else
  952.       hi = lo
  953.       lo = 0
  954.     end if
  955.  
  956. ' dim ident(numeric expression [to numeric expression]) {, ident(numeric expression [to numeric expression])}
  957. sub dimstmt
  958.   dim ident as string, ident_type as integer, lo as long, hi as long, lo2 as long, hi2 as long
  959.   dim a_len as long, index as long, i as integer, multi as integer, a_width as long
  960.  
  961.   do
  962.     ident = sym
  963.     ident_type = symtype
  964.     if symtype <> tyident and symtype <> tystrident then
  965.       print at_line$; " Expecting an identifier, but found: "; sym: errors = true: exit sub
  966.     end if
  967.     call getsym   ' skip array name
  968.  
  969.     expect("(")
  970.     call get_array_bounds(lo, hi)
  971.     lo2 = 0: hi2 = 0: multi = false
  972.     if accept&(",") then call get_array_bounds(lo2, hi2): multi = true
  973.     expect(")")
  974.  
  975.     ' see if it already exists
  976.     i = find_vname&(ident)
  977.     if i > 0 then print "Duplicate definition: "; ident: errors = true: exit sub
  978.  
  979.     ' add it
  980.     a_len = hi - lo + 1
  981.     if multi then
  982.         a_width = a_len
  983.         a_len = a_len * (hi2 - lo2 + 1)
  984.     end if
  985.  
  986.     var_names_max = var_names_max + 1
  987.     var_names(var_names_max).vname   = ident
  988.     var_names(var_names_max).symtype = ident_type
  989.     var_names(var_names_max).lo_bnd  = lo
  990.     var_names(var_names_max).hi_bnd  = hi
  991.     var_names(var_names_max).lo_bnd2 = lo2
  992.     var_names(var_names_max).hi_bnd2 = hi2
  993.     var_names(var_names_max).multi   = multi
  994.     var_names(var_names_max).a_len   = a_len
  995.     var_names(var_names_max).a_width = a_width
  996.  
  997.     if ident_type = tystrident then
  998.       index = str_arr_stor_max + 1
  999.       str_arr_stor_max = str_arr_stor_max + a_len
  1000.       redim _preserve string_arr_store(str_arr_stor_max)
  1001.     else
  1002.       index = num_arr_stor_max + 1
  1003.       num_arr_stor_max = num_arr_stor_max + a_len
  1004.       redim _preserve numeric_arr_store(num_arr_stor_max)
  1005.     end if
  1006.  
  1007.     var_names(var_names_max).index = index
  1008.  
  1009.     if sym <> "," then exit do
  1010.     call getsym
  1011.   loop
  1012.  
  1013. ' const id[$] = number|string {, const id[$] = number|string}
  1014. sub conststmt
  1015.  
  1016.   do
  1017.     i = find_vname&(sym)
  1018.     if i <> 0 then print at_line$; "var: "; sym; " already defined": errors = true: exit sub
  1019.     call assignment
  1020.     var_names(var_names_max).is_const = true
  1021.   loop while accept&(",")
  1022.  
  1023.  
  1024. sub drawstmt
  1025.   s = strexpression$
  1026.   draw s
  1027.  
  1028. sub environstmt
  1029.   environ strexpression$
  1030.  
  1031. ' need to account for loop [until|while expr] and next [i]
  1032. sub exitstmt
  1033.   if sym = "while" then
  1034.     call getsym
  1035.     if while_sp <= 0 then errors = true: print at_line$; "'exit while' without while": errors = true: exit sub
  1036.     while_sp = while_sp - 1
  1037.     call find_matching_pair("while", "wend")
  1038.     call getsym
  1039.   elseif sym = "do" then
  1040.     call getsym
  1041.     if do_sp <= 0 then errors = true: print at_line$; "'exit do' without do": errors = true: exit sub
  1042.     do_sp = do_sp - 1
  1043.     call find_matching_pair("do", "loop")
  1044.     call getsym
  1045.     if sym = "until" or sym = "while" then
  1046.       call getsym   ' skip until\while
  1047.       ' somehow skip over the until\while expression
  1048.       while sym <> ":" and sym <> ""
  1049.         call getsym
  1050.       wend
  1051.     end if
  1052.   elseif sym = "for" then
  1053.     call getsym
  1054.     if loopp <= 0 then errors = true: print at_line$; "'exit for' without do": errors = true: exit sub
  1055.     loopp = loopp - 1
  1056.     call find_matching_pair("for", "next")
  1057.     call getsym
  1058.     if symtype = tyident then call getsym
  1059.   else
  1060.     print at_line$; "'exit without do/for/while": errors = true: exit sub
  1061.   end if
  1062.  
  1063.   if endif_count > 0 and if_sp    > 0 then if_sp    = if_sp    - endif_count
  1064.   if loop_count  > 0 and do_sp    > 0 then do_sp    = do_sp    - loop_count
  1065.   if next_count  > 0 and loopp    > 0 then loopp    = loopp    - next_count
  1066.   if wend_count  > 0 and while_sp > 0 then while_sp = while_sp - wend_count
  1067.  
  1068.  
  1069. ' for xvar = -1.5 to 1.5 step .01
  1070. sub forstmt
  1071.   dim xvar as integer, i as integer
  1072.   xvar = getvarindex&(left_side)   ' get position of "i"
  1073.   if loopp >= 0 then
  1074.     for i = 0 to loopp - 1
  1075.       if loopvars(i) = xvar then
  1076.         print at_line$; "for index variable already in use": errors = true
  1077.         exit sub
  1078.       end if
  1079.     next
  1080.   end if
  1081.   expect("=")
  1082.   numeric_store(xvar) = numeric_expr#
  1083.   loopp = loopp + 1
  1084.   loopvars(loopp) = xvar
  1085.   looplines(loopp) = curline
  1086.   expect("to")
  1087.   loopmax(loopp) = numeric_expr#
  1088.   if accept&("step") then loopstep(loopp) = numeric_expr# else loopstep(loopp) = 1
  1089.   loopoff(loopp) = textp
  1090.   if len(sym) > 0 then loopoff(loopp) = textp - len(sym) - 1
  1091.  
  1092. ' finds target, using current sym
  1093. function get_target&
  1094.   if symtype = tynum then
  1095.     get_target = numeric_expr#
  1096.   else
  1097.     dim i as integer, lbl as string
  1098.     lbl = sym
  1099.     if right$(lbl, 1) <> ":" then lbl = lbl + ":"
  1100.     for i = 1 to pgmsize
  1101.       if lcase$(mid$(ltrim$(pgm(i)), 1, len(lbl))) = lbl then
  1102.         get_target& = i
  1103.         exit function
  1104.       end if
  1105.     next
  1106.     print at_line$; "Target of goto not found:"; sym: errors = true
  1107.     get_target& = 0
  1108.   end if
  1109.  
  1110. sub gosubstmt
  1111.   dim target as integer
  1112.  
  1113.   target = get_target&
  1114.   if not errors then
  1115.     validlinenum(target)
  1116.     stackp = stackp + 1
  1117.     if stackp > stacksize then print at_line$; "out of stack space": errors = true
  1118.     gosubstack(stackp) = curline
  1119.     ' 26 May 2021 was just textp
  1120.     gosuboffstack(stackp) = textp - 1
  1121.     'print "textp:"; textp; "=>"; pgm$(curline)
  1122.     'if sym = ":" then gosuboffstack(stackp) = textp
  1123.     call initgetsym(target, 1)
  1124.   end if
  1125.  
  1126. sub gotostmt
  1127.   dim target as integer
  1128.  
  1129.   target = get_target&
  1130.   gotoline(target)
  1131.  
  1132. ' single line if: if expr then if expr then if expr then s else s else s else s
  1133. sub ifstmt
  1134.   dim b as integer, level as integer, cond as integer
  1135.  
  1136.   level = 0
  1137.  
  1138.   begin:
  1139.  
  1140.   level = level + 1
  1141.   cond = numeric_expr#
  1142.   b = accept&("then")
  1143.   '*** multiline if processing ***
  1144.   if sym = "" then  'multiline if
  1145.     if level > 1 then
  1146.       print at_line$; "can't mix multi and single line 'if'": errors = true
  1147.       exit sub
  1148.     end if
  1149.     call multi_ifstmt(cond)
  1150.   '*** singleline if processing ***
  1151.   elseif cond then
  1152.     if symtype = tynum then
  1153.         gotoline(int(the_num))
  1154.     elseif accept&("if") then
  1155.         goto begin
  1156.     end if
  1157.   else
  1158.     call find_matching_sline_if
  1159.     ' if else found, pick up there, otherwise skip rest of stmt
  1160.     if not accept&("else") then skiptoeol
  1161.     if symtype = tynum then gotoline(int(the_num))
  1162.   end if
  1163.  
  1164. sub multi_ifstmt(cond as integer)
  1165.  
  1166.   if_sp = if_sp + 1
  1167.   if_stack(if_sp) = curline
  1168.   'print at_line$; "if after inc: if_sp: "; if_sp, pgm(curline)
  1169.  
  1170.   if cond then
  1171.     rem let docmd process these commands
  1172.   else
  1173.     'need to find the next corresponding 'elseif' or 'else' or 'endif'
  1174.     restart:
  1175.     ' on the "if" or "elseif" line, so skip it
  1176.     s = find_matching_else$ 'either elseif, else or endif
  1177.     'print at_line$; "found: "; sym
  1178.     if s = "" then print at_line$; "missing endif": errors = true: exit sub
  1179.     if tracing then print "["; curline; "] "; sym; " "; mid$(thelin, textp)
  1180.     if sym = "elseif" then
  1181.       'print sym; ": "; mid$(thelin, textp)
  1182.       call getsym 'skip "elseif"
  1183.       cond = numeric_expr#
  1184.       b = accept&("then")
  1185.       'print at_line$; "elseif evaluated to: "; cond
  1186.       if cond then
  1187.         rem let docmd process these commands, until next elseif/else/endif
  1188.       else
  1189.         goto restart
  1190.       end if
  1191.     elseif sym = "else" then
  1192.       rem - let docmd process these commands, until endif
  1193.       call getsym   ' skip the else, so docmd goes to next line
  1194.     elseif sym = "endif" then
  1195.       call endifstmt
  1196.     end if
  1197.   end if
  1198.  
  1199. ' called from docmd()
  1200. sub elseifstmt
  1201.  
  1202.   if if_sp = 0 then print at_line$; "endif without if": errors = true: exit sub
  1203.  
  1204.   'scan until matching endif
  1205.  
  1206.   ' but first, allow more "elseif"'s
  1207.   do
  1208.     s = find_matching_else$
  1209.   loop while s = "elseif"
  1210.  
  1211.   ' allow an "else"
  1212.   if s = "else" then
  1213.     s = find_matching_else$
  1214.   end if
  1215.  
  1216.   ' finally, need an "endif"
  1217.   if s = "endif" then
  1218.     ' pop the if stack
  1219.     if_sp = if_sp - 1
  1220.     call getsym  ' skip "endif"
  1221.     ' done
  1222.   else
  1223.     print at_line$; "Missing endif": errors = true: exit sub
  1224.   end if
  1225.  
  1226. ' called from docmd()
  1227. sub elsestmt
  1228.   'print at_line$; "else begin: if_sp: "; if_sp, pgm(curline)
  1229.  
  1230.   'part of a single-line if?
  1231.   call initgetsym(curline, 1)
  1232.   'if not "else", then single-line if
  1233.   if sym <> "else" then call skiptoeol: exit sub
  1234.  
  1235.   ' looks like multiline if - but have we seen the start of it?
  1236.   if if_sp = 0 then print at_line$; "else without if": errors = true: exit sub
  1237.  
  1238.   'scan until matching endif
  1239.   if find_matching_else$ <> "endif" then print at_line$; "else without endif": errors = true: exit sub
  1240.  
  1241.   call getsym 'skip the "endif"
  1242.   'pop the if stack
  1243.   if_sp = if_sp - 1
  1244.   'print at_line$; "else end: if_sp: "; if_sp, pgm(curline)
  1245.  
  1246. ' called from docmd()
  1247. sub endifstmt
  1248.   if if_sp = 0 then print at_line$; "endif without if": errors = true: exit sub
  1249.   if_sp = if_sp - 1
  1250.   'print at_line$; "endif: if_sp: "; if_sp, pgm(curline)
  1251.   call getsym 'skip "endif"
  1252.  
  1253. ' input [;] ["prompt" ;|,] variablelist
  1254. sub inputsetup
  1255.   if left$(sym, 1) = chr$(34) then
  1256.     print mid$(sym, 2, len(sym) - 1);
  1257.     call getsym
  1258.     if accept&(";") then
  1259.       print "? ";
  1260.     else
  1261.       expect(",")
  1262.     end if
  1263.   end if
  1264.  
  1265. ' input [;] ["prompt" ;|,] variablelist
  1266. sub inputstmt
  1267.   dim ident as string, ident_type as integer, i as long, x as long, st as string, n as double
  1268.  
  1269.   inputsetup
  1270.  
  1271.   ident = sym: ident_type = symtype
  1272.   if ident_type = tystrident then
  1273.     input "", st
  1274.   else
  1275.     input "", n
  1276.   end if
  1277.  
  1278.   i = find_vname&(ident)
  1279.   if i > 0 then
  1280.     if ident_type <> var_names(i).symtype then
  1281.       print at_line$; "Type mismatch: "; ident_type; " vs. table: "; var_names(i).symtype: errors = true: exit sub
  1282.     end if
  1283.     if var_names(i).a_len > 0 then ' array
  1284.       x = get_array_index&(ident)
  1285.  
  1286.       if ident_type = tystrident then
  1287.         'assign string
  1288.         string_arr_store(x) = st
  1289.         if tracing then print st
  1290.       else
  1291.         'assign number
  1292.         numeric_arr_store(x) = n
  1293.         if tracing then print n
  1294.       end if
  1295.  
  1296.       exit sub
  1297.  
  1298.     end if
  1299.   end if
  1300.  
  1301.   if ident_type = tystrident then
  1302.     i = getstrindex&(left_side)
  1303.     string_store(i) = st
  1304.   elseif ident_type = tyident then
  1305.     i = getvarindex&(left_side)
  1306.     numeric_store(i) = n
  1307.   else
  1308.     print at_line$; "Unknown type": errors = true: exit sub
  1309.   end if
  1310.  
  1311. ' line input [;] ["prompt";] variable$
  1312. sub lineinputstmt
  1313.   dim ident as string, ident_type as integer, i as long, x as long, st as string
  1314.  
  1315.   if not accept&("input") then linestmt: exit sub
  1316.   inputsetup
  1317.  
  1318.   ident = sym: ident_type = symtype
  1319.  
  1320.   if ident_type <> tystrident then print at_line$; "String variable expected": errors = true: exit sub
  1321.  
  1322.   line input st
  1323.  
  1324.   i = find_vname&(ident)
  1325.   if i > 0 then
  1326.     if ident_type <> var_names(i).symtype then
  1327.       print at_line$; "Type mismatch: "; ident_type; " vs. table: "; var_names(i).symtype: errors = true: exit sub
  1328.     end if
  1329.     if var_names(i).a_len > 0 then ' array
  1330.       x = get_array_index&(ident)
  1331.  
  1332.       'assign string
  1333.       string_arr_store(x) = st
  1334.       if tracing then print st
  1335.  
  1336.       exit sub
  1337.  
  1338.     end if
  1339.   end if
  1340.  
  1341.   i = getstrindex&(left_side)
  1342.   string_store(i) = st
  1343.  
  1344. ' line [[step](x1!,y1!)]-[step](x2!,y2!) [,[color%] [,[b | bf] [,style%]]]
  1345. ' ??? step is not currently supported
  1346. sub linestmt
  1347.   dim x1 as single, y1 as single, x2 as single, y2 as single, clr as long
  1348.   dim rect_type as string, step1 as integer, step2 as integer
  1349.  
  1350.   step1 = false: step2 = false
  1351.  
  1352.   if accept&("step") then step1 = true
  1353.   expect("(")
  1354.   x1 = numeric_expr#
  1355.   expect(",")
  1356.   y1 = numeric_expr#
  1357.   expect(")")
  1358.  
  1359.   expect("-")
  1360.   if accept&("step") then step2 = true
  1361.  
  1362.   expect("(")
  1363.   x2 = numeric_expr#
  1364.   expect(",")
  1365.   y2 = numeric_expr#
  1366.   expect(")")
  1367.  
  1368.   ' so far we have: line(x, y)-(x2, y2)
  1369.  
  1370.   if is_stmt_end& then line (x1, y1)-(x2, y2): exit sub
  1371.  
  1372.   '[,[color%] [,[b | bf] [,style%]]]
  1373.   ' only acceptable value is a ","
  1374.  
  1375.   '1) ,c
  1376.   '2) ,c,b
  1377.   '3) ,c,b,s
  1378.   '4) ,c,,s
  1379.   '5) ,,b
  1380.   '6) ,,b,s
  1381.   '7) ,,,s
  1382.  
  1383.   if accept&(",") then
  1384.     if accept&(",") then
  1385.       if accept&(",") then
  1386.         'must have s (7)
  1387.         line (x1, y1)-(x2, y2), , , numeric_expr#
  1388.       else
  1389.         'must have b
  1390.         rect_type = ucase$(sym)
  1391.         if rect_type <> "B" and rect_type <> "BF" then
  1392.           print at_line$; "line ... - expecting 'B' or 'BF', found: "; rect_type: errors = true: exit sub
  1393.         end if
  1394.         if accept&(",") then
  1395.           'must have s (6)
  1396.           if rect_type = "B" then
  1397.             line (x1, y1)-(x2, y2), , B, numeric_expr#
  1398.           else
  1399.             line (x1, y1)-(x2, y2), , BF, numeric_expr#
  1400.           end if
  1401.         else
  1402.           '(5)
  1403.           if rect_type = "B" then
  1404.             line (x1, y1)-(x2, y2), , B
  1405.           else
  1406.             line (x1, y1)-(x2, y2), , BF
  1407.           end if
  1408.           call getsym ' skip "B"
  1409.         end if
  1410.       end if
  1411.     else
  1412.       'must have c
  1413.       clr = numeric_expr#
  1414.       if accept&(",") then
  1415.         if accept&(",") then
  1416.           'must have s (4)
  1417.           line (x1, y1)-(x2, y2), clr, , numeric_expr#
  1418.         else
  1419.           'must have b
  1420.           rect_type = ucase$(sym)
  1421.           if rect_type <> "B" and rect_type <> "BF" then
  1422.             print at_line$; "line ... - expecting 'B' or 'BF', found: "; rect_type: errors = true: exit sub
  1423.           end if
  1424.           if accept&(",") then
  1425.             'must have s (3)
  1426.             if rect_type = "B" then
  1427.               line (x1, y1)-(x2, y2), clr , B, numeric_expr#
  1428.             else
  1429.               line (x1, y1)-(x2, y2), clr, BF, numeric_expr#
  1430.             end if
  1431.           else
  1432.             '(2)
  1433.             if rect_type = "B" then
  1434.               line (x1, y1)-(x2, y2), clr, B
  1435.             else
  1436.               line (x1, y1)-(x2, y2), clr, BF
  1437.             end if
  1438.             call getsym ' skip "B"
  1439.           end if
  1440.         end if
  1441.       else
  1442.         '(1)
  1443.         line (x1, y1)-(x2, y2), clr
  1444.       end if
  1445.     end if
  1446.   end if
  1447.  
  1448. sub locatestmt
  1449.   dim row as integer, col as integer
  1450.   if accept&(",") then
  1451.     col = numeric_expr#
  1452.     locate , col
  1453.   else
  1454.     row = numeric_expr#
  1455.     if accept&(",") then
  1456.       col = numeric_expr#
  1457.       locate row, col
  1458.     else
  1459.       locate row
  1460.     end if
  1461.   end if
  1462.  
  1463. ' mid$(s, i, n)
  1464. sub midstmt
  1465.   dim xvar as integer, start as integer, length as integer, nolength as integer
  1466.   expect("(")
  1467.   xvar = getstrindex&(left_side)
  1468.   expect(",")
  1469.   start = numeric_expr#
  1470.   if accept&(",") then length = numeric_expr# else nolength = -1
  1471.   expect(")")
  1472.   expect("=")
  1473.   if nolength then
  1474.     mid$(string_store(xvar), start) = strexpression$
  1475.   else
  1476.     mid$(string_store(xvar), start, length) = strexpression$
  1477.   end if
  1478.  
  1479. sub nextstmt
  1480.   dim cont as integer
  1481.  
  1482.   if symtype = tyident then call getsym
  1483.   if loopp < 0 then print at_line$; "next without for": errors = true: exit sub
  1484.   ' increment the current "i"
  1485.   numeric_store(loopvars(loopp)) = numeric_store(loopvars(loopp)) + loopstep(loopp)
  1486.   if tracing then print "["; curline; "] "; "next: "; numeric_store(loopvars(loopp))
  1487.  
  1488.   ' see if "for" should continue
  1489.   cont = false
  1490.   if loopstep(loopp) < 0 then
  1491.     if numeric_store(loopvars(loopp)) >= loopmax(loopp) then
  1492.       cont = true
  1493.     end if
  1494.   else
  1495.     if numeric_store(loopvars(loopp)) <= loopmax(loopp) then
  1496.       cont = true
  1497.     end if
  1498.   end if
  1499.  
  1500.   if cont then
  1501.     call initgetsym(looplines(loopp), loopoff(loopp))
  1502.   else
  1503.     loopp = loopp - 1
  1504.   end if
  1505.  
  1506.  
  1507. ' PAINT [STEP] (column%, row%), fillColor[, borderColor%]
  1508. sub paintstmt
  1509.   dim x as long, y as long, f as long
  1510.  
  1511.   expect("(")
  1512.   x = numeric_expr#
  1513.   expect(",")
  1514.   y = numeric_expr#
  1515.   expect(")")
  1516.   if accept&(",") then
  1517.     if accept&(",") then
  1518.       paint (x, y), , numeric_expr#
  1519.     else
  1520.       f = numeric_expr#
  1521.       if accept&(",") then
  1522.         paint (x, y), f, numeric_expr#
  1523.       else
  1524.         paint (x, y), f
  1525.       end if
  1526.     end if
  1527.   else
  1528.     paint (x, y)
  1529.   end if
  1530.  
  1531. ' palette [attribute%,color&]
  1532. sub palettestmt
  1533.     dim a as integer, c as long
  1534.  
  1535.     a = numeric_expr#
  1536.     expect(",")
  1537.     c = numeric_expr#
  1538.     palette a, c
  1539.  
  1540. sub printstmt
  1541.   dim val_type as integer, printed as integer
  1542.  
  1543.   printed = false
  1544.   if accept&(",") then print ,
  1545.   do while sym <> "" and sym <> ":" and sym <> "else"
  1546.     printed = true
  1547.     val_type = any_expr&(0)
  1548.  
  1549.     if accept&(",") then
  1550.       if val_type = tystring then
  1551.         print pop_str$,
  1552.       else
  1553.         print pop_num#,
  1554.       end if
  1555.     elseif accept&(";") then
  1556.       if val_type = tystring then
  1557.         print pop_str$;
  1558.       else
  1559.         print pop_num#;
  1560.       end if
  1561.     else
  1562.       if val_type = tystring then
  1563.         print pop_str$
  1564.       else
  1565.         print pop_num#
  1566.       end if
  1567.       exit do
  1568.     end if
  1569.   loop
  1570.   if not printed then print
  1571.  
  1572. ' preset   (column, row)
  1573. ' preset [step] (x!,y!) [,color%]
  1574. sub presetstmt
  1575.   expect("(")
  1576.   x = numeric_expr#
  1577.   expect(",")
  1578.   y = numeric_expr#
  1579.   expect(")")
  1580.   if accept&(",") then preset (x, y), numeric_expr# else preset (x, y)
  1581.  
  1582. ' pset   (column, row)
  1583. ' pset [step] (x!,y!) [,color%]
  1584. ' PSET [STEP] (x!,y!) [,color%]
  1585. sub psetstmt
  1586.   dim x as single, y as single, clr as long
  1587.   expect("(")
  1588.   x = numeric_expr#
  1589.   expect(",")
  1590.   y = numeric_expr#
  1591.   expect(")")
  1592.   if accept&(",") then
  1593.     clr = numeric_expr#
  1594.     pset (x, y), clr
  1595.   else
  1596.     pset (x, y)
  1597.   end if
  1598.  
  1599. sub randomizer
  1600.   if sym = "" then randomize timer else randomize numeric_expr#
  1601.  
  1602. sub returnstmt
  1603.   dim lin as integer, offs as integer
  1604.   if stackp < 0 then print at_line$; "return without gosub": errors = true: exit sub
  1605.   lin = gosubstack(stackp)
  1606.   offs = gosuboffstack(stackp)
  1607.   if tracing then print "returning to: "; lin; ": "; offs
  1608.   'print "["; curline; "] "; "returning to: "; lin; ": "; offs; " while_sp: "; while_sp
  1609.   stackp = stackp - 1
  1610.   if offs <= 1 then print at_line$; "returnstmt - offs <= 1": errors = true
  1611.   call initgetsym(lin, offs)
  1612.  
  1613. ' SCREEN mode% [,[colorswitch%] [,[activepage%] [,visualpage%]]]
  1614. sub screenstmt
  1615.   screen numeric_expr#
  1616.  
  1617. ' shell [string]
  1618. sub shellstmt
  1619.  
  1620.   s = ""
  1621.   while the_ch <> "" and the_ch <> ":"
  1622.     s = s + the_ch
  1623.     call getch
  1624.   wend
  1625.  
  1626.   shell s
  1627.   'print "shell: "; s
  1628.   call skiptoeol
  1629.  
  1630. ' sleep [seconds]
  1631. sub sleepstmt
  1632.   if is_stmt_end& then sleep else sleep numeric_expr#
  1633.  
  1634. ' swap v1, v2
  1635. sub swapstmt
  1636.   dim i1 as integer, i2 as integer
  1637.   dim symtype1 as integer, symtype2 as integer
  1638.   dim sym1 as string, sym2 as string
  1639.  
  1640.   sym1     = sym
  1641.   symtype1 = symtype
  1642.   if symtype = tyident then
  1643.     i1 = getvarindex&(left_side)
  1644.   else
  1645.     i1 = getstrindex&(left_side)
  1646.   end if
  1647.  
  1648.   expect(",")
  1649.  
  1650.   sym2     = sym
  1651.   symtype2 = symtype
  1652.  
  1653.   if symtype = tyident then
  1654.     i2 = getvarindex&(left_side)
  1655.   else
  1656.     i2 = getstrindex&(left_side)
  1657.   end if
  1658.  
  1659.   if symtype1 <> symtype2 then
  1660.     print at_line$; sym1; " and "; sym2; " are not the same data type": errors = true
  1661.     exit sub
  1662.   end if
  1663.  
  1664.   if symtype1 = tyident then
  1665.     swap numeric_store(i1), numeric_store(i2)
  1666.   else
  1667.     swap string_store(i1), string_store(i2)
  1668.   end if
  1669.  
  1670. ' VIEW [[SCREEN] (x1!,y1!)-(x2!,y2!) [,[color%] [,border%]]]
  1671. sub viewstmt
  1672.   dim x1 as long, y1 as long, x2 as long, y2 as long, clr as long, border as long
  1673.  
  1674.   expect("(")
  1675.   x1 = numeric_expr#
  1676.   expect(",")
  1677.   y1 = numeric_expr#
  1678.   expect(")")
  1679.  
  1680.   expect("-")
  1681.  
  1682.   expect("(")
  1683.   x2 = numeric_expr#
  1684.   expect(",")
  1685.   y2 = numeric_expr#
  1686.   expect(")")
  1687.  
  1688.   if accept&(",") then
  1689.     if accept&(",") then
  1690.       border = numeric_expr#
  1691.       view (x1, y1)-(x2, y2), , border
  1692.     else
  1693.       clr = numeric_expr#
  1694.       if accept&(",") then
  1695.         border = numeric_expr#
  1696.         view (x1, y1)-(x2, y2), clr, border
  1697.       else
  1698.         view (x1, y1)-(x2, y2), clr
  1699.       end if
  1700.     end if
  1701.   else
  1702.     view (x1, y1)-(x2, y2)
  1703.   end if
  1704.  
  1705. sub whilestmt(first as integer)
  1706.   if first then
  1707.     while_sp = while_sp + 1
  1708.     while_line(while_sp) = curline
  1709.     while_off(while_sp) = textp
  1710.     if len(sym) > 0 then while_off(while_sp) = textp - len(sym) - 1
  1711.   end if
  1712.   'print "["; curline; "] "; "*while:sym:";sym; " textp:";textp; " =>";mid$(pgm(curline), textp); " while_sp: "; while_sp
  1713.   if not bool_expr& then
  1714.     while_sp = while_sp - 1
  1715.     'print "["; curline; "] "; "*wend bool_expr is 0!"; " while_sp: "; while_sp
  1716.     call find_matching_pair("while", "wend")
  1717.     call getsym
  1718.   end if
  1719.  
  1720. sub wendstmt
  1721.   if while_sp <= 0 then errors = true: print at_line$; "wend without while": errors = true: exit sub
  1722.   call initgetsym(while_line(while_sp), while_off(while_sp))
  1723.   if tracing then print "["; curline; "] "; "wend"
  1724.   whilestmt(false)
  1725.  
  1726. ' do [(while|until) expr][:]
  1727. sub dostmt(first as integer)
  1728.   if first then
  1729.     do_sp = do_sp + 1
  1730.     do_loop(do_sp).lline = curline
  1731.  
  1732.     do_loop(do_sp).loff = textp
  1733.     if len(sym) > 0 then do_loop(do_sp).loff = textp - len(sym) - 1
  1734.     'print "*do:"; "sym:"; sym; " textp:";textp; "=>";mid$(pgm(curline), textp - len(sym))
  1735.   end if
  1736.  
  1737.   if sym = "while" then
  1738.     call getsym
  1739.     if not bool_expr& then
  1740.       do_sp = do_sp - 1
  1741.       call find_matching_pair("do", "loop")
  1742.       call getsym
  1743.     end if
  1744.   elseif sym = "until" then
  1745.     call getsym
  1746.     if bool_expr& then
  1747.       do_sp = do_sp - 1
  1748.       call find_matching_pair("do", "loop")
  1749.       call getsym
  1750.     end if
  1751.   end if
  1752.  
  1753. ' loop [(while|until) expr]
  1754. sub loopstmt
  1755.   if do_sp <= 0 then errors = true: print at_line$; "loop without do": errors = true: exit sub
  1756.  
  1757.   if sym = "while" then
  1758.     call getsym
  1759.     if not bool_expr& then
  1760.       do_sp = do_sp - 1
  1761.       exit sub
  1762.     end if
  1763.   elseif sym = "until" then
  1764.     call getsym
  1765.     if bool_expr& then
  1766.       do_sp = do_sp - 1
  1767.       exit sub
  1768.     end if
  1769.   end if
  1770.  
  1771.   call initgetsym(do_loop(do_sp).lline, do_loop(do_sp).loff)
  1772.   'print "loop line:"; curline; "off:"; do_loop(do_sp).loff; "==>"; pgm(curline)
  1773.   dostmt(false)
  1774.  
  1775. ' width , height
  1776. ' width width
  1777. ' width width, height
  1778. sub widthstmt
  1779.  
  1780.   if accept&(",") then
  1781.     width , numeric_expr#
  1782.   else
  1783.     w = numeric_expr#
  1784.     if accept&(",") then
  1785.       width w , numeric_expr#
  1786.     else
  1787.       width w
  1788.     end if
  1789.   end if
  1790.  
  1791. ' window [ [ screen] (x1!, y1!) - (x2!, y2!)]
  1792. sub windowstmt
  1793.     dim x1 as single, y1 as single, x2 as single, y2 as single
  1794.  
  1795.     if sym = "" then window: exit sub
  1796.  
  1797.     expect("(")
  1798.     x1 = numeric_expr#
  1799.     expect(",")
  1800.     y1 = numeric_expr#
  1801.     expect(")")
  1802.  
  1803.     expect("-")
  1804.  
  1805.     expect("(")
  1806.     x2 = numeric_expr#
  1807.     expect(",")
  1808.     y2 = numeric_expr#
  1809.     expect(")")
  1810.  
  1811.     window (x1, y1) - (x2, y2)
  1812.  
  1813. '------------------------------------------------------------------------
  1814. '  Various helper routines
  1815. '------------------------------------------------------------------------
  1816.  
  1817. sub skip_exit
  1818.     call getsym
  1819.     if sym = "do" or sym = "while" or sym = "for" then
  1820.         call getsym
  1821.     end if
  1822.  
  1823. sub find_matching_pair(s1 as string, s2 as string)
  1824.   dim level as integer
  1825.   dim more as integer
  1826.   dim have_sym as integer
  1827.  
  1828.   level = 1
  1829.   more = true
  1830.   have_sym = false
  1831.  
  1832.   endif_count = 0: wend_count = 0: next_count = 0: loop_count = 0
  1833.  
  1834.   do
  1835.     if sym = "exit" then
  1836.         call skip_exit
  1837.     elseif not have_sym then
  1838.         call getsym
  1839.         if sym = "exit" then call skip_exit
  1840.     end if
  1841.  
  1842.     have_sym = false
  1843.     'print at_line$; "matching, level"; level; "sym=>"; sym
  1844.     'if isalpha&(mid$(sym, 1, 1)) then print "fm: level: sym: "; level; ": '"; sym; "'  "; mid$(thelin, textp, 40)
  1845.  
  1846.     select case sym
  1847.         case s1: level = level + 1
  1848.         case s2: level = level - 1
  1849.     end select
  1850.  
  1851.     if level = 0 then exit do
  1852.  
  1853.     select case sym
  1854.         case "if"     ' need to only do "if" case if multiline if
  1855.           do
  1856.             call getsym
  1857.           loop until sym = "then" or sym = ""
  1858.           call getsym ' skip the "then"
  1859.           ' if nothing past "then", it is a multiline if
  1860.           if sym = "" then endif_count = endif_count - 1
  1861.         case "endif": endif_count = endif_count + 1
  1862.         case "while": wend_count  = wend_count  - 1
  1863.         case "wend":  wend_count  = wend_count  + 1
  1864.         case "for":   next_count  = next_count  - 1
  1865.         case "next":  next_count  = next_count  + 1
  1866.         case "do"
  1867.           loop_count  = loop_count  - 1
  1868.           if sym = "while" then call getsym
  1869.         case "loop"
  1870.           loop_count  = loop_count  + 1
  1871.           if sym = "while" then call getsym
  1872.     end select
  1873.  
  1874.     if sym = "" then
  1875.       if not more then exit sub
  1876.       while sym = "" and curline > 0 and curline < pgmsize
  1877.         call initgetsym(curline + 1, 1)
  1878.       wend
  1879.       if sym = "" then
  1880.         print at_line$; "Cannot find matching: "; s2: errors = true
  1881.         exit sub
  1882.       end if
  1883.       have_sym = true
  1884.     end if
  1885.   loop
  1886.  
  1887. ' find matching elseif/else/endif
  1888. function find_matching_else$
  1889.   dim level as integer
  1890.  
  1891.   find_matching_else$ = ""
  1892.   level = 0
  1893.   do
  1894.       call initgetsym(curline + 1, 1)
  1895.       'print "find_matching_else: "; curline; " sym: "; sym; " level: "; level; "textp: "; textp; " line:"; thelin
  1896.       if curline >= pgmsize then print "searching for endif, found eof": errors = true: exit do
  1897.       if is_multi_line_if& then
  1898.           level = level + 1
  1899.       elseif level = 0 and (sym = "elseif" or sym = "else" or sym = "endif") then
  1900.           find_matching_else = sym: exit do
  1901.       elseif level > 0 and sym = "endif" then
  1902.           level = level - 1
  1903.       elseif errors then
  1904.           exit do
  1905.       endif
  1906.   loop
  1907.  
  1908. sub find_matching_sline_if
  1909.   dim level as integer
  1910.   level = 1
  1911.   do
  1912.     'print "find_matching_sline_if level: "; level; " sym: "; sym
  1913.     if sym = "if" then
  1914.       level = level + 1
  1915.     elseif sym = "else" then
  1916.       level = level - 1
  1917.     end if
  1918.     if level = 0 or sym = "" then exit do
  1919.     call getsym
  1920.   loop
  1921.  
  1922. function is_multi_line_if&
  1923.     is_multi_line_if& = false
  1924.  
  1925.     if sym = "if" then
  1926.         ' is it single or multi line "if" - ignore single line if's
  1927.         do
  1928.             call getsym
  1929.             if sym = "" then print at_line$; "if missing then" : errors = true: exit do
  1930.             if sym = "then" then
  1931.                 call getsym
  1932.                 if sym = "" then
  1933.                     ' multi line "if"
  1934.                     is_multi_line_if& = true
  1935.                 end if
  1936.                 exit do
  1937.             end if
  1938.         loop
  1939.     end if
  1940.  
  1941. function accept&(s as string)
  1942.   accept& = false
  1943.   if sym = s then accept& = true: call getsym
  1944.  
  1945. sub expect(s as string)
  1946.   if not accept&(s) then print at_line$; "expecting "; s; " but found "; sym: errors = true
  1947.  
  1948. function is_stmt_end&
  1949.   is_stmt_end& = sym = "" or sym = ":"
  1950.  
  1951. sub validlinenum(n as integer)
  1952.   if n > 0 and n <= pgmsize then exit sub
  1953.   print at_line$; "line number out of range:"; the_num: errors = true
  1954.  
  1955. function storeline&
  1956. 'print "storeline"
  1957.   storeline& = false
  1958.   call initgetsym(0, 1)
  1959.   if symtype = tynum then
  1960.     validlinenum(int(the_num))
  1961.     pgm(the_num) = mid$(pgm(0), textp, len(pgm(0)) - textp + 1)
  1962.     storeline& = true
  1963.   end if
  1964.  
  1965. sub clearprog
  1966.   for i = 1 to pgmsize
  1967.     pgm(i) = ""
  1968.   next
  1969.  
  1970. sub gotoline(target as integer)
  1971.   validlinenum(target)
  1972.   call initgetsym(target, 1)
  1973.  
  1974. '------------------------------------------------------------------------
  1975. '------[QB64 specific functions]-----------------------------------------
  1976. '------------------------------------------------------------------------
  1977.  
  1978. ' _atan2(y, x)
  1979. function atan2fun#
  1980.  
  1981.   expect("(")
  1982.   y = numeric_expr#
  1983.   expect(",")
  1984.   x = numeric_expr#
  1985.   expect(")")
  1986.   atan2fun# = _atan2(y, x)
  1987.  
  1988. sub filesstmt
  1989.   s = ""
  1990.   if symtype = tystring or symtype = tystrident then s = strexpression$
  1991.   files s
  1992.  
  1993. ' freeimage [image]&
  1994. sub freeimage
  1995.   if sym <> "" and sym <> ":" then
  1996.     _freeimage numeric_expr#
  1997.   else
  1998.   end if
  1999.  
  2000. sub limitstmt
  2001.   _limit numeric_expr#
  2002.  
  2003. ' ([start], haystack, needle)
  2004. function instrrevfun&
  2005.   dim i as integer, haystack as string, needle as string
  2006.  
  2007.   expect("(")
  2008.   i = 0
  2009.   if symtype = tynum or symtype = tyident then
  2010.     i = numeric_expr#
  2011.     expect(",")
  2012.   end if
  2013.   haystack = strexpression$
  2014.   expect(",")
  2015.   needle = strexpression$
  2016.   expect(")")
  2017.   instrrevfun& = _instrrev(i, haystack, needle)
  2018.  
  2019. sub titlestmt
  2020.   _title strexpression$
  2021.  
  2022. ' _newimage(width&, height&[, {0|1|2|7|8|9|10|11|12|13|256|32}])
  2023. function newimagefun&
  2024.   dim w as long, h as long, mode as long
  2025.  
  2026.   expect("(")
  2027.   w = numeric_expr#
  2028.   expect(",")
  2029.   h = numeric_expr#
  2030.   if accept&(",") then
  2031.     mode = numeric_expr#
  2032.     newimagefun& = _newimage(w, h, mode)
  2033.   else
  2034.     newimagefun& = _newimage(w, h)
  2035.   end if
  2036.   expect(")")
  2037.  
  2038. 'colorIndex~& = _RGB(red&, green&, blue&[, imageHandle&])
  2039. function rgbfun~&
  2040.   dim r as long, g as long, b as long, h as long
  2041.   expect("(")
  2042.   r = numeric_expr#
  2043.   expect(",")
  2044.   g = numeric_expr#
  2045.   expect(",")
  2046.   b = numeric_expr#
  2047.   if accept&(",") then
  2048.     h = numeric_expr#
  2049.     rgbfun = _rgb(r, g, b, h)
  2050.   else
  2051.     rgbfun = _rgb(r, g, b)
  2052.   end if
  2053.   expect(")")
  2054.  
  2055. 'color32value~& = _RGB32(red&, green&, blue&, alpha&)
  2056. 'color32value~& = _RGB32(red&, green&, blue&)
  2057. 'color32value~& = _RGB32(intensity&, alpha&)
  2058. 'color32value~& = _RGB32(intensity&)
  2059. function rgb32fun~&
  2060.   dim r as long, g as long, b as long, a as long
  2061.   expect("(")
  2062.   r = numeric_expr#
  2063.   if accept&(")") then
  2064.     rgb32fun = _rgb32(r)
  2065.   else
  2066.     expect(",")
  2067.     g = numeric_expr#
  2068.     if accept&(")") then
  2069.       rgb32fun = _rgb32(r, g)
  2070.     else
  2071.       expect(",")
  2072.       b = numeric_expr#
  2073.       if accept&(")") then
  2074.         rgb32fun = _rgb32(r, g, b)
  2075.       else
  2076.         expect(",")
  2077.         a = numeric_expr#
  2078.         rgb32fun = _rgb32(r, g, b, a)
  2079.         expect(")")
  2080.       end if
  2081.     end if
  2082.   end if
  2083.  
  2084. '_RGBA(red&, green&, blue&, alpha&[, imageHandle&])
  2085. function rgbafun~&
  2086.   dim r as long, g as long, b as long, a as long, h as long
  2087.  
  2088.   expect("(")
  2089.   r = numeric_expr#
  2090.   expect(",")
  2091.  
  2092.   g = numeric_expr#
  2093.   expect(",")
  2094.  
  2095.   b = numeric_expr#
  2096.   expect(",")
  2097.  
  2098.   a = numeric_expr#
  2099.  
  2100.   if accept&(",") then
  2101.     h = numeric_expr#
  2102.     rgbafun = _rgba(r, g, b, a, h)
  2103.   else
  2104.     rgbafun = _rgba(r, g, b, a)
  2105.   end if
  2106.  
  2107.   expect(")")
  2108.  
  2109. 'color32value~& = _RGBA32(red&, green&, blue&, alpha&)
  2110. function rgba32fun~&
  2111.   dim r as long, g as long, b as long, a as long
  2112.  
  2113.   expect("(")
  2114.   r = numeric_expr#
  2115.   expect(",")
  2116.  
  2117.   g = numeric_expr#
  2118.   expect(",")
  2119.  
  2120.   b = numeric_expr#
  2121.   expect(",")
  2122.  
  2123.   a = numeric_expr#
  2124.  
  2125.   rgba32fun = _rgba32(r, g, b, a)
  2126.  
  2127.   expect(")")
  2128.  
  2129. '_PRINTSTRING(column, row), textExpression$[, imageHandle&]
  2130. sub printstringstmt
  2131.  
  2132.   expect("(")
  2133.   c = numeric_expr#
  2134.   expect(",")
  2135.   r = numeric_expr#
  2136.   expect(")")
  2137.   expect(",")
  2138.   ex = strexpression$
  2139.   if accept&(",") then
  2140.     _printstring (c, r), ex, numeric_expr#
  2141.   else
  2142.     _printstring (c, r), ex
  2143.   end if
  2144.  
  2145. ' _SCREENMOVE {column&, row&|_MIDDLE}
  2146. sub screenmovestmt
  2147.   dim c as long, r as long
  2148.  
  2149.   'print "screenmovestmt:"; sym
  2150.   if ucase$(sym) = "_MIDDLE" then
  2151.     call getsym         'and skip over _middle
  2152.   else
  2153.     c = numeric_expr#
  2154.     expect(",")
  2155.     r = numeric_expr#
  2156.     _screenmove c, r
  2157.   end if
  2158.  
  2159. ' sound frequence, duration
  2160. sub soundstmt
  2161.   dim f as long, d as single
  2162.  
  2163.   f = numeric_expr#
  2164.   expect(",")
  2165.   d = numeric_expr#
  2166.   sound f, d
  2167.  
  2168. '------------------------------------------------------------------------
  2169. '  various functions called from primary
  2170. '------------------------------------------------------------------------
  2171.  
  2172. function sinh#(z as double)
  2173.   sinh = (e ^ z - e ^ (-z)) / 2
  2174.  
  2175. function tanh#(z as double)
  2176.   tanh = (e ^ (2 * z) - 1) / (e ^ (2 * z) + 1)
  2177.  
  2178. function acosh#(z as double)
  2179.   acosh = log(z + sqr(z + 1) * sqr(z - 1))
  2180.  
  2181. function acoth#(z as double)
  2182.   acoth = .5 * (log(1 + 1 / z) - log(1 - 1 / z))
  2183.  
  2184. function acsch#(z as double)
  2185.   acsch = log(sqr(1 + z ^ (-2)) + z ^ (-1))
  2186.  
  2187. function asech#(z as double)
  2188.   asech = log(sqr(z ^ (-1) - 1) * sqr(z ^ (-1) + 1) + z ^ (-1))
  2189.  
  2190. function asin2#(i as double)
  2191.   if i = -1 then
  2192.     asin2 = -halfpi
  2193.   elseif i = 1 then
  2194.     asin2 = halfpi
  2195.   else
  2196.     asin2 = atn(i / sqr(1 - i * i))
  2197.   end if
  2198.  
  2199. function asinh#(z as double)
  2200.   asinh = log(z + sqr(1 + z ^ 2))
  2201.  
  2202. function atanh#(z as double)
  2203.   atanh = .5 * (log(1 + z) - log(1 - z))
  2204.  
  2205. function cosh#(z as double)
  2206.   cosh = (e ^ z + e ^ (-z)) / 2
  2207.  
  2208. function shlf#(x as double, n as double)
  2209.   shlf# = x
  2210.   if n >= 0 then shlf# = x * (2 ^ n)
  2211.  
  2212. function shrf#(x as double, n as double)
  2213.   shrf# = x
  2214.   if n >= 0 then shrf# = x \ (2 ^ n)
  2215.  
  2216. ' ([start,] haystack, needle)
  2217. function instrfun&
  2218.   dim i as integer, haystack as string, needle as string
  2219.  
  2220.   expect("(")
  2221.   i = 1
  2222.   if symtype = tynum or symtype = tyident then
  2223.     i = numeric_expr#
  2224.     expect(",")
  2225.   end if
  2226.   haystack = strexpression$
  2227.   expect(",")
  2228.   needle = strexpression$
  2229.   expect(")")
  2230.   instrfun& = instr(i, haystack, needle)
  2231.  
  2232. ' mid$(s$, start [, end])
  2233. function midfun$
  2234.  
  2235.   expect("(")
  2236.   i = strexpression$
  2237.   expect(",")
  2238.   x = numeric_expr#
  2239.   if accept&(",") then
  2240.     y = numeric_expr#
  2241.     midfun$ = mid$(i, x, y)
  2242.   else
  2243.     midfun$ = mid$(i, x)
  2244.   end if
  2245.   expect(")")
  2246.  
  2247. ' lpad$(s$, padded_len [, pad_string$])
  2248. function lpadfun$
  2249.   dim s as string, pad_string as string, padded_len as integer
  2250.   expect("(")
  2251.   s = strexpression$
  2252.   expect(",")
  2253.   padded_len = numeric_expr#
  2254.   pad_string = " "
  2255.   if accept&(",") then
  2256.     pad_string = strexpression$
  2257.   end if
  2258.   expect(")")
  2259.  
  2260.   lpadfun$ = s
  2261.   if len(s) > padded_len then
  2262.     lpadfun$ = mid$(s, 1, padded_len)
  2263.   else
  2264.     lpadfun$ = string$(padded_len - len(s), mid$(pad_string, 1, 1)) + s
  2265.   end if
  2266.  
  2267. ' result = peek(string)
  2268. function peekfun#(s as string)
  2269.     case "for index"         : peekfun# = loopp
  2270.     case "do index"          : peekfun# = do_sp
  2271.     case "while index"       : peekfun# = while_sp
  2272.     case "if index"          : peekfun# = if_sp
  2273.     case "gosub index"       : peekfun# = stackp
  2274.     case "numeric var total" : peekfun# = num_store_max
  2275.     case "string var total"  : peekfun# = str_store_max
  2276.     case "variables total"   : peekfun# = var_names_max
  2277.     case else                : peekfun# = -1
  2278.  
  2279. 'result = Point( coord_x, coord_y [,buffer] )
  2280. 'result = Point( function_index )
  2281. function pointfun#
  2282.  
  2283.   expect("(")
  2284.   x = numeric_expr#
  2285.   if accept&(",") then
  2286.     pointfun# = point(x, numeric_expr#)
  2287.   else
  2288.     pointfun# = point(x)
  2289.   end if
  2290.   expect(")")
  2291.  
  2292. function posfun#
  2293.   expect("(")
  2294.   posfun# = pos(numeric_expr#)
  2295.   expect(")")
  2296.  
  2297. ' rpad$(s$, padded_len [, pad_string$])
  2298. function rpadfun$
  2299.   dim s as string, pad_string as string, padded_len as integer
  2300.   expect("(")
  2301.   s = strexpression$
  2302.   expect(",")
  2303.   padded_len = numeric_expr#
  2304.   pad_string = " "
  2305.   if accept&(",") then
  2306.     pad_string = strexpression$
  2307.   end if
  2308.   expect(")")
  2309.  
  2310.   rpadfun$ = s
  2311.   if len(s) > padded_len then
  2312.     rpadfun$ = mid$(s, 1, padded_len)
  2313.   else
  2314.     rpadfun$ = string$(padded_len - len(s), mid$(pad_string, 1, 1)) + s
  2315.   end if
  2316.  
  2317. ' replace$(haystack$, needle$ [, newst$])
  2318. function replacefun$
  2319.   dim haystack as string, needle as string, newst as string, start as integer, p as integer
  2320.   expect("(")
  2321.   haystack = strexpression$
  2322.   expect(",")
  2323.   needle = strexpression$
  2324.  
  2325.   newst = ""
  2326.   if accept&(",") then
  2327.     newst = strexpression$
  2328.   end if
  2329.   expect(")")
  2330.  
  2331.   start = 1
  2332.   do
  2333.     p = instr(start, haystack, needle)
  2334.     if p = 0 then exit do
  2335.     haystack = mid$(haystack, 1, p - 1) + newst + mid$(haystack, p + len(needle))
  2336.     start = p + len(newst) + 1
  2337.   loop
  2338.  
  2339.   replacefun$ = haystack
  2340.  
  2341. ' ubound(array-name)
  2342. function uboundfun&
  2343.   dim i as long
  2344.   expect("(")
  2345.   i = find_vname(sym)
  2346.   if i = 0 then
  2347.     print at_line$; "ubound: not an array: "; sym: errors = true
  2348.   else
  2349.     uboundfun& = var_names(i).hi_bnd
  2350.   end if
  2351.   call getsym
  2352.   expect(")")
  2353.  
  2354. ' screen(row, col)
  2355. function screenfun&
  2356.   dim row as long, col as long
  2357.   expect("(")
  2358.   row = numeric_expr#
  2359.   expect(",")
  2360.   col = numeric_expr#
  2361.   expect(")")
  2362.   screenfun& = screen(row, col)
  2363.  
  2364. '------------------------------------------------------------------------
  2365. ' expression parser
  2366. '------------------------------------------------------------------------
  2367.  
  2368. function binary_prec&(op as string)
  2369.   select case op
  2370.     case "^":                              binary_prec& = 14
  2371.     case "*", "/":                         binary_prec& = 12
  2372.     case "\" :                             binary_prec& = 11
  2373.     case "mod":                            binary_prec& = 10
  2374.     case "+", "-":                         binary_prec& = 9
  2375.     case ">>", "<<", "shl", "shr":         binary_prec& = 8
  2376.     case "=", "<>", "<", ">", "<=", ">=":  binary_prec& = 7
  2377.     case "and":                            binary_prec& = 5
  2378.     case "or":                             binary_prec& = 4
  2379.     case "xor":                            binary_prec& = 3
  2380.     case "eqv":                            binary_prec& = 2
  2381.     case "imp":                            binary_prec& = 1
  2382.     case else:                             binary_prec& = 0
  2383.  
  2384. function strfactor$
  2385.  
  2386.   select case sym
  2387.     case "chr$":       call getsym: expect("("): strfactor$ = chr$(numeric_expr#):      expect(")")
  2388.     case "command$":   call getsym: strfactor$ = command$
  2389.     case "date$":      call getsym: strfactor$ = date$
  2390.     case "environ$":   call getsym: expect("("): strfactor$ = environ$(strexpression$): expect(")")
  2391.     case "hex$":       call getsym: expect("("): strfactor$ = hex$(numeric_expr#):      expect(")")
  2392.     case "inkey$":     call getsym: strfactor$ = inkey$
  2393.     case "lcase$":     call getsym: expect("("): strfactor$ = lcase$(strexpression$): expect(")")
  2394.     case "left$"
  2395.       call getsym:
  2396.       expect("(")
  2397.       s = strexpression$
  2398.       expect(",")
  2399.       x = numeric_expr#
  2400.       strfactor$ = left$(s, x)
  2401.       expect(")")
  2402.     case "lpad$":      call getsym: strfactor$ = lpadfun$
  2403.     case "ltrim$":     call getsym: expect("("): strfactor$ = ltrim$(strexpression$): expect(")")
  2404.     case "mid$":       call getsym: strfactor$ = midfun$
  2405.     case "mki$":       call getsym: expect("("): strfactor$ = mki$(numeric_expr#):      expect(")")
  2406.     case "oct$":       call getsym: expect("("): strfactor$ = oct$(numeric_expr#):      expect(")")
  2407.     case "replace$":   call getsym: strfactor$ = replacefun$
  2408.     case "right$"
  2409.       call getsym
  2410.       expect("(")
  2411.       s = strexpression$
  2412.       expect(",")
  2413.       x = numeric_expr#
  2414.       strfactor$ = right$(s, x)
  2415.       expect(")")
  2416.     case "rpad$":      call getsym: strfactor$ = rpadfun$
  2417.     case "rtrim$":     call getsym: expect("("): strfactor$ = rtrim$(strexpression$): expect(")")
  2418.     case "space$"
  2419.       call getsym
  2420.       expect("(")
  2421.       strfactor$ = space$(numeric_expr#)
  2422.       expect(")")
  2423.     case "str$":       call getsym: expect("("): strfactor$ = str$(numeric_expr#):      expect(")")
  2424.     case "string$"
  2425.       call getsym ' string$(n [, strexpr])
  2426.       expect("(")
  2427.       x = numeric_expr#
  2428.       expect(",")
  2429.       if symtype = tystring or symtype = tystrident then
  2430.         strfactor$ = string$(x, strexpression$)
  2431.       else
  2432.         strfactor$ = string$(x, numeric_expr#)
  2433.       end if
  2434.       expect(")")
  2435.     case "time$":      call getsym: strfactor$ = time$
  2436.     case "trim$":      call getsym: expect("("): strfactor$ = ltrim$(rtrim$(strexpression$)): expect(")")
  2437.     case "ucase$":     call getsym: expect("("): strfactor$ = ucase$(strexpression$): expect(")")
  2438.  
  2439.     case "_clipboard$": call getsym: strfactor$ = _clipboard$
  2440.     case "_cwd$":       call getsym: strfactor$ = _cwd$
  2441.     case "_os$":        call getsym: strfactor$ = _os$
  2442.     case "_startdir$":  call getsym: strfactor$ = _startdir$
  2443.     case "_title$":     call getsym: strfactor$ = _title$
  2444.     case "_trim$":      call getsym: expect("("): strfactor$ = ltrim$(rtrim$(strexpression$)): expect(")")
  2445.  
  2446.     case else
  2447.       if symtype = tystring then
  2448.         strfactor$ = mid$(sym, 2, len(sym) - 1)
  2449.         call getsym
  2450.       elseif symtype = tystrident then
  2451.         if peek_ch$ = "(" then
  2452.           strfactor$ = get_string_array_value$
  2453.         else
  2454.           strfactor$ = string_store(getstrindex&(right_side))
  2455.         end if
  2456.       else
  2457.         print at_line$; "In strfactor, expecting an operand, found: "; sym; " symtype is: "; symtype: errors = true
  2458.         call getsym
  2459.       end if
  2460.  
  2461. function frac#(n as double)
  2462.     frac# = n - fix(n)
  2463.  
  2464. function primary#
  2465.  
  2466.   select case sym
  2467.     case "-":     call getsym: primary# =    -numeric_expr2#(unaryminus_prec)
  2468.     case "+":     call getsym: primary# =     numeric_expr2#(unaryplus_prec)
  2469.     case "not":   call getsym: primary# = not numeric_expr2#(unarynot_prec)
  2470.     case "abs":   call getsym: expect("("): primary# = abs(numeric_expr#):                expect(")")
  2471.     case "acos":  call getsym: expect("("): primary# = halfpi - asin2(numeric_expr#):     expect(")")
  2472.     case "acosh": call getsym: expect("("): primary# = acosh(numeric_expr#):              expect(")")
  2473.     case "acot":  call getsym: expect("("): primary# = halfpi - atn(numeric_expr#):       expect(")")
  2474.     case "acoth": call getsym: expect("("): primary# = acoth(numeric_expr#):              expect(")")
  2475.     case "acsc":  call getsym: expect("("): primary# = asin2(1 / numeric_expr#):          expect(")")
  2476.     case "acsch": call getsym: expect("("): primary# = acsch(numeric_expr#):              expect(")")
  2477.     case "asc":   call getsym: expect("("): primary# = asc(strexpression$):               expect(")")
  2478.     case "asec":  call getsym: expect("("): primary# = halfpi - asin2(1 / numeric_expr#): expect(")")
  2479.     case "asech": call getsym: expect("("): primary# = asech(numeric_expr#):              expect(")")
  2480.     case "asin":  call getsym: expect("("): primary# = asin2(numeric_expr#):              expect(")")
  2481.     case "asinh": call getsym: expect("("): primary# = asinh(numeric_expr#):              expect(")")
  2482.     case "atanh": call getsym: expect("("): primary# = atanh(numeric_expr#):              expect(")")
  2483.     case "atn", "atan": call getsym: expect("("): primary# = atn(numeric_expr#):          expect(")")
  2484.     case "cdbl":  call getsym: expect("("): primary# = cdbl(numeric_expr#):               expect(")")
  2485.     case "cint":  call getsym: expect("("): primary# = cint(numeric_expr#):               expect(")")
  2486.     case "clng":  call getsym: expect("("):primary# = clng(numeric_expr#):                expect(")")
  2487.     case "cos":   call getsym: expect("("): primary# = cos(numeric_expr#):       expect(")")
  2488.     case "cosh":  call getsym: expect("("): primary# = cosh(numeric_expr#):      expect(")")
  2489.     case "cot":   call getsym: expect("("): primary# = 1 / tan(numeric_expr#):   expect(")")
  2490.     case "coth":  call getsym: expect("("): primary# = 1 / tanh(numeric_expr#):  expect(")")
  2491.     case "csc":   call getsym: expect("("): primary# = 1 / sin(numeric_expr#):   expect(")")
  2492.     case "csch":  call getsym: expect("("): primary# = 1 / sinh(numeric_expr#):  expect(")")
  2493.     case "csng":  call getsym: expect("("): primary# = csng(numeric_expr#):      expect(")")
  2494.     case "csrlin":call getsym: primary# = csrlin
  2495.     case "cvd":   call getsym: expect("("): primary# = cvd(strexpression$):    expect(")")
  2496.     case "cvi":   call getsym: expect("("): primary# = cvi(strexpression$):    expect(")")
  2497.     case "exp":   call getsym: expect("("): primary# = exp(numeric_expr#):       expect(")")
  2498.     case "false": call getsym: primary# = false
  2499.     case "frac":  call getsym: expect("("): primary# = frac#(numeric_expr#):     expect(")")
  2500.     case "fix":   call getsym: expect("("): primary# = fix(numeric_expr#):       expect(")")
  2501.     case "instr": call getsym: primary# = instrfun&
  2502.     case "int":   call getsym: expect("("): primary# = int(numeric_expr#):       expect(")")
  2503.     case "len":   call getsym: expect("("): primary# = len(strexpression$):    expect(")")
  2504.     case "ln":    call getsym: expect("("): primary# = log(numeric_expr#):       expect(")")
  2505.     case "log"
  2506.       call getsym:
  2507.       expect("(")
  2508.       i = log(numeric_expr#)
  2509.       if accept&(",") then
  2510.         primary# = i / log(numeric_expr#)
  2511.       else
  2512.         primary# = i
  2513.       end if
  2514.       expect(")")
  2515.     case "log10": call getsym: expect("("): primary# = log(numeric_expr#) / log(10): expect(")")
  2516.     case "peek":  call getsym: expect("("): primary# = peekfun#(strexpression$): expect(")")
  2517.     case "point": call getsym: primary# = pointfun#
  2518.     case "pos":   call getsym: primary# = posfun#
  2519.     case "rnd"
  2520.       call getsym:
  2521.       if accept&("(") then
  2522.         primary# = rnd(numeric_expr#)
  2523.         expect(")")
  2524.       else
  2525.         primary# = rnd
  2526.       end if
  2527.     case "screen":call getsym: primary# = screenfun&
  2528.     case "sec":   call getsym: expect("("): primary# = 1 / cos(numeric_expr#):   expect(")")
  2529.     case "sech":  call getsym: expect("("): primary# = 1 / cosh(numeric_expr#):  expect(")")
  2530.     case "sgn":   call getsym: expect("("): primary# = sgn(numeric_expr#):       expect(")")
  2531.     case "sin":   call getsym: expect("("): primary# = sin(numeric_expr#):       expect(")")
  2532.     case "sinh":  call getsym: expect("("): primary# = sinh(numeric_expr#):      expect(")")
  2533.     case "sqr", "sqrt": call getsym: expect("("): primary# = sqr(numeric_expr#): expect(")")
  2534.     case "tan":   call getsym: expect("("): primary# = tan(numeric_expr#):       expect(")")
  2535.     case "tanh":  call getsym: expect("("): primary# = tanh(numeric_expr#):      expect(")")
  2536.     case "timer": call getsym: primary# = timer
  2537.     case "true":  call getsym: primary# = true
  2538.     case "ubound": call getsym: primary# = uboundfun
  2539.     case "val":   call getsym: expect("("): primary# = val(strexpression$):    expect(")")
  2540.  
  2541.     case "_atan2": call getsym: primary# = atan2fun#
  2542.     case "_ceil": call getsym: expect("("): primary# = _ceil(numeric_expr#):     expect(")")
  2543.     case "_d2g":  call getsym: expect("("): primary# = _d2g(numeric_expr#):      expect(")")
  2544.     case "_d2r":  call getsym: expect("("): primary# = _d2r(numeric_expr#):      expect(")")
  2545.     case "_fontwidth": call getsym: primary# = _fontwidth
  2546.     case "_fontheight": call getsym: primary# = _fontheight
  2547.     case "_g2d":  call getsym: expect("("): primary# = _g2d(numeric_expr#):      expect(")")
  2548.     case "_g2r":  call getsym: expect("("): primary# = _g2r(numeric_expr#):      expect(")")
  2549.     case "_height": call getsym: primary# = _height
  2550.     case "_instrrev": call getsym: primary# = instrrevfun&
  2551.     case "_keydown": call getsym: expect("("): primary# = _keydown(numeric_expr#): expect(")")
  2552.     case "_keyhit": call getsym: primary# = _keyhit
  2553.     case "_mousebutton": call getsym: expect("("): primary# = _mousebutton(numeric_expr#): expect(")")
  2554.     case "_mouseinput": call getsym: primary# = _mouseinput
  2555.     case "_mousex": call getsym: primary# = _mousex
  2556.     case "_mousey": call getsym: primary# = _mousey
  2557.     case "_newimage": call getsym: primary# = newimagefun&
  2558.     case "_pi":   call getsym: primary# = _PI
  2559.     case "_r2d":  call getsym: expect("("): primary# = _r2d(numeric_expr#):      expect(")")
  2560.     case "_r2g":  call getsym: expect("("): primary# = _r2g(numeric_expr#):      expect(")")
  2561.     case "_rgb":  call getsym: primary# = rgbfun
  2562.     case "_rgba": call getsym: primary# = rgbafun
  2563.     case "_rgba32":call getsym: primary# = rgba32fun
  2564.     case "_rgb32":call getsym: primary# = rgb32fun
  2565.  
  2566.     case "_round": call getsym: expect("("): primary# = _round(numeric_expr#):    expect(")")
  2567.     case "_width": call getsym: primary# = _width
  2568.  
  2569.     case else
  2570.       if left$(sym, 1) = "_" then
  2571.         print "Unknown function: "; sym: errors = true: call getsym
  2572.       elseif symtype = tynum then
  2573.         primary# = the_num
  2574.         call getsym
  2575.       elseif symtype = tyident then
  2576.         if peek_ch$ = "(" then
  2577.           primary# = get_numeric_array_value#
  2578.         else
  2579.           primary# = numeric_store(getvarindex&(right_side))
  2580.         end if
  2581.       else
  2582.         print at_line$; "In primary, expecting an operand, found: "; sym; " symtype is: "; symtype: errors = true
  2583.         call getsym
  2584.       end if
  2585.  
  2586. function strexpression$
  2587.   s = strfactor$
  2588.   while accept&("+")
  2589.     s = s + strfactor$
  2590.   wend
  2591.   strexpression$ = s
  2592.  
  2593. '-------------------------------------------------------------------------------------------------
  2594.  
  2595. sub push_str(s as string)
  2596.   str_st_ndx = str_st_ndx + 1
  2597.   str_stack(str_st_ndx) = s
  2598.  
  2599. sub push_num(n as double)
  2600.   num_st_ndx = num_st_ndx + 1
  2601.   num_stack(num_st_ndx) = n
  2602.  
  2603. function pop_str$
  2604.   pop_str = str_stack(str_st_ndx)
  2605.   str_st_ndx = str_st_ndx - 1
  2606.  
  2607. function pop_num#
  2608.   pop_num = num_stack(num_st_ndx)
  2609.   num_st_ndx = num_st_ndx - 1
  2610.  
  2611. function evalstrexpr&(op as string)
  2612.   dim s as string, s2 as string, n as double
  2613.  
  2614.   s2 = pop_str$
  2615.   s = pop_str$
  2616.   select case op
  2617.     case "=":   n = s = s2
  2618.     case "<>":  n = s <> s2
  2619.     case "<":   n = s <  s2
  2620.     case ">":   n = s >  s2
  2621.     case "<=":  n = s <= s2
  2622.     case ">=":  n = s >= s2
  2623.     case else
  2624.       print at_line$; "In expr, expecting a string operator, found: "; op; " symtype is: "; symtype: errors = true
  2625.       call getsym
  2626.   push_num(n)
  2627.   evalstrexpr& = tynum
  2628.  
  2629. function evalnumericexpr&(op as string)
  2630.   dim n as double, n2 as double
  2631.  
  2632.   n2 = pop_num#
  2633.   n = pop_num#
  2634.   select case op
  2635.     case "^":   n = n ^   n2
  2636.     case "*":   n = n *   n2
  2637.     case "/":   if n2 = 0 then print at_line$; "division by 0": errors = true else n = n /   n2
  2638.     case "\":   if n2 = 0 then print at_line$; "division by 0": errors = true else n = n \   n2
  2639.     case "mod": if n2 = 0 then print at_line$; "division by 0": errors = true else n = n mod n2
  2640.     case "+":   n = n +   n2
  2641.     case "-":   n = n -   n2
  2642.     case "=":   n = n =   n2
  2643.     case "<>":  n = n <>  n2
  2644.     case "<":   n = n <   n2
  2645.     case ">":   n = n >   n2
  2646.     case "<=":  n = n <=  n2
  2647.     case ">=":  n = n >=  n2
  2648.     case "and": n = n and n2
  2649.     case "or":  n = n or  n2
  2650.     case "xor": n = n xor n2
  2651.     case "eqv": n = n eqv n2
  2652.     case "imp": n = n imp n2
  2653.     case "shl","<<": n = shlf#(n, n2)
  2654.     case "shr",">>": n = shrf#(n, n2)
  2655.     case else
  2656.       print at_line$; "In expr, expecting a numeric operator, found: "; op; " symtype is: "; symtype: errors = true
  2657.       call getsym
  2658.   push_num(n)
  2659.   evalnumericexpr& = tynum
  2660.  
  2661. ' return the type of expression, either string or numeric; result is on the stack
  2662. function any_expr&(p as integer)
  2663.   dim left_type as integer
  2664.  
  2665.   ' we need to decide which primary to call - numeric or string
  2666.   ' leading parens don't tell us which primary, so just do recursive call
  2667.   if accept&("(") then
  2668.     left_type = any_expr&(0)
  2669.     expect(")")
  2670.   elseif symtype = tystring or symtype = tystrident then
  2671.     push_str(strexpression$)
  2672.     left_type = tystring
  2673.   elseif symtype = tynum or symtype = tyident or sym = "-" or sym = "+" or sym = "not" then
  2674.     push_num(primary#)
  2675.     left_type = tynum
  2676.   elseif sym = "" then
  2677.     print at_line$; "In expr, unexpected end-of-line found: "; pgm(curline): errors = true
  2678.   else
  2679.     print at_line$; "In expr, expecting an expr, found: "; sym; " symtype is: "; symtype; " - near column: "; textp
  2680.     errors = true
  2681.     call getsym
  2682.   end if
  2683.  
  2684.   do      ' while binary operator and precedence(sym) >= p
  2685.     dim op as string
  2686.     dim right_type as integer, prec as integer
  2687.  
  2688.     prec = binary_prec&(sym)
  2689.     if prec = 0 or prec < p then exit do
  2690.  
  2691.     op = sym
  2692.  
  2693.     call getsym
  2694.  
  2695.     ' all operators are left associative in qbasic
  2696.     prec = prec + 1
  2697.  
  2698.     right_type = any_expr&(prec)
  2699.  
  2700.     if left_type = tystring and right_type = tystring then
  2701.       left_type = evalstrexpr&(op)
  2702.     elseif left_type = tynum and right_type = tynum then
  2703.       left_type = evalnumericexpr&(op)
  2704.     else
  2705.       print at_line$; "type missmatch in expr - left_type:"; left_type; " right_type:"; right_type: errors = true
  2706.       call getsym
  2707.     end if
  2708.   loop
  2709.   any_expr& = left_type
  2710.  
  2711. function numeric_expr2#(p as integer)
  2712.   if any_expr&(p) = tynum then
  2713.     numeric_expr2# = pop_num#
  2714.   else
  2715.     print at_line$; "numeric expression expected": errors = true
  2716.   end if
  2717.  
  2718. ' process and return a numeric expression
  2719. function numeric_expr#
  2720.   numeric_expr# = numeric_expr2#(0)
  2721.  
  2722. function bool_expr&
  2723.   bool_expr& = (numeric_expr# <> 0)
  2724.  
  2725. '------------------------------------------------------------------------
  2726. '  scanner
  2727. '------------------------------------------------------------------------
  2728. sub init_scanner
  2729.  
  2730.   for i = 0 to 255
  2731.     ctype_arr(i) = ct_unknown
  2732.   next
  2733.  
  2734.   ' alpha
  2735.   for i = asc("a") to asc("z")
  2736.     ctype_arr(i) = ct_alpha
  2737.   next
  2738.   for i = asc("A") to asc("Z")
  2739.     ctype_arr(i) = ct_alpha
  2740.   next
  2741.   ctype_arr(asc("_")) = ct_alpha
  2742.  
  2743.   ' num
  2744.   for i = asc("0") to asc("9")
  2745.     ctype_arr(i) = ct_digit
  2746.   next
  2747.  
  2748.   ctype_arr(asc(".")) = ct_period
  2749.   ctype_arr(asc(",")) = ct_punc1
  2750.   ctype_arr(asc(";")) = ct_punc1
  2751.   ctype_arr(asc("=")) = ct_punc1
  2752.   ctype_arr(asc("+")) = ct_punc1
  2753.   ctype_arr(asc("-")) = ct_punc1
  2754.   ctype_arr(asc("*")) = ct_punc1
  2755.   ctype_arr(asc("/")) = ct_punc1
  2756.   ctype_arr(asc("\")) = ct_punc1
  2757.   ctype_arr(asc("^")) = ct_punc1
  2758.   ctype_arr(asc("(")) = ct_punc1
  2759.   ctype_arr(asc(")")) = ct_punc1
  2760.   ctype_arr(asc("?")) = ct_punc1
  2761.   ctype_arr(asc(":")) = ct_punc1
  2762.   ctype_arr(asc("<")) = ct_lt
  2763.   ctype_arr(asc(">")) = ct_gt
  2764.   ctype_arr(asc("&")) = ct_amp
  2765.   ctype_arr(asc(chr$(34))) = ct_dquote
  2766.   ctype_arr(asc(chr$(39))) = ct_squote
  2767.  
  2768. function peek_ch$
  2769.   peek_ch$ = left$(ltrim$(the_ch) + ltrim$(mid$(pgm(curline), textp)), 1)
  2770.  
  2771. ' other code relies on textp always being incremented; so do it even on EOL
  2772. sub getch
  2773.   the_ch = ""
  2774.   if textp <= len(thelin) then
  2775.     the_ch = mid$(thelin, textp, 1)
  2776.   end if
  2777.   textp = textp + 1
  2778. 'print "getch: textp: "; textp; " the_ch: "; the_ch; " thelin: "; thelin
  2779.  
  2780. sub readident
  2781.   sym = ""
  2782.   do while the_ch <> ""
  2783.     if ctype_arr(asc(the_ch)) <> ct_alpha and ctype_arr(asc(the_ch)) <> ct_digit then exit do
  2784.     sym = sym + lcase$(the_ch)
  2785.     getch
  2786.   loop
  2787.  
  2788.   symtype = tyident
  2789.  
  2790.   select case the_ch
  2791.     case "%", "&", "!", "#":        sym = sym + the_ch: getch ' just ignore
  2792.     case "$": symtype = tystrident: sym = sym + the_ch: getch ' string
  2793.       ' see if we have "end if", if so, convert to "endif"
  2794.     case " "
  2795.       if sym = "end" then
  2796.         if lcase$(mid$(thelin, textp, 2)) = "if" then
  2797.           sym = "endif"
  2798.           getch ' skip " "
  2799.           getch ' skip "i"
  2800.           getch ' skip "f"
  2801.         end if
  2802.       end if
  2803.  
  2804. sub readnumber
  2805.   sym = ""
  2806.   do while the_ch <> ""
  2807.     if ctype_arr(asc(the_ch)) <> ct_digit then exit do
  2808.     sym = sym + the_ch
  2809.     getch
  2810.   loop
  2811.   if the_ch = "." then
  2812.     sym = sym + the_ch
  2813.     getch
  2814.     do while the_ch <> ""
  2815.       if ctype_arr(asc(the_ch)) <> ct_digit then exit do
  2816.       sym = sym + the_ch
  2817.       getch
  2818.     loop
  2819.   end if
  2820.   if lcase$(the_ch) = "e" then
  2821.     sym = sym + "e"
  2822.     getch
  2823.     if the_ch = "+" or the_ch = "-" then sym = sym + the_ch: getch
  2824.     do while the_ch <> ""
  2825.       if ctype_arr(asc(the_ch)) <> ct_digit then exit do
  2826.       sym = sym + the_ch
  2827.       getch
  2828.     loop
  2829.   end if
  2830.   the_num = val(sym)
  2831.   symtype = tynum
  2832.  
  2833. ' on entry pointing to 'h'
  2834. sub readhex
  2835.   sym = "&h"
  2836.   getch     ' skip the 'h'
  2837.   do while the_ch <> ""
  2838.     if ctype_arr(asc(the_ch)) <> ct_digit and instr("abcdefABCDEF", the_ch) = 0 then exit do
  2839.     sym = sym + the_ch
  2840.     getch
  2841.   loop
  2842.   the_num = val(sym)
  2843.   symtype = tynum
  2844.  
  2845. sub readstr
  2846.   sym = chr$(34)
  2847.   getch
  2848.   while the_ch <> chr$(34)
  2849.     if the_ch = "" then
  2850.       print at_line$; "string not terminated": errors = true
  2851.       exit sub
  2852.     end if
  2853.     sym = sym + the_ch
  2854.     getch
  2855.   wend
  2856.   getch
  2857.   symtype = tystring
  2858.  
  2859. sub skiptoeol
  2860.   textp = len(thelin) + 1
  2861.   the_ch = ""
  2862.   sym = ""
  2863.   symtype = tyunknown
  2864.  
  2865. function gettoeol$
  2866.   s = ""
  2867.   while the_ch <> ""
  2868.     s = s + the_ch
  2869.     getch
  2870.   wend
  2871.   call getsym
  2872.   gettoeol$ = s
  2873.  
  2874. ' symtype: unknown, tystring, tynum, tyident, tystrident
  2875. ' sym: the symbol just read, above, and punctuation
  2876. sub getsym
  2877. 'print "in getsym"
  2878.   'dim ttt as double
  2879.   'ttt = timer
  2880.   'nsyms = nsyms + 1
  2881.   sym = ""
  2882.   symtype = tyunknown
  2883.   ' skip white space
  2884.   while the_ch <= " "
  2885.     if the_ch = "" then exit sub else getch
  2886.   wend
  2887.   sym = the_ch
  2888.   select case ctype_arr(asc(the_ch))
  2889.     case ct_punc1:            getch       'punctuation
  2890.     case ct_alpha:            readident   'identifier
  2891.     case ct_digit, ct_period: readnumber  'number
  2892.     case ct_dquote:           readstr     'double quote
  2893.     case ct_squote:           skiptoeol   'comment
  2894.     case ct_lt
  2895.       getch
  2896.       if instr("=><", the_ch) > 0 then sym = sym + the_ch: getch '<=, <> <<
  2897.     case ct_gt
  2898.       getch
  2899.       if the_ch = "=" or the_ch = ">" then sym = sym + the_ch: getch ' >=, >>
  2900.     case ct_amp:
  2901.       getch
  2902.       if the_ch = "H" or the_ch = "h" then
  2903.         readhex
  2904.       else
  2905.         print at_line$; "getsym: '& found, expecting 'h' but found:"; the_ch: errors = true
  2906.       end if
  2907.     case else
  2908.       print at_line$; "getsym: unexpected character read:"; the_ch: errors = true
  2909.       getch
  2910.   'scantime = scantime + (timer - ttt)
  2911.  
  2912. sub initgetsym(n as long, col as integer)
  2913. 'print "initgetsym"
  2914.   curline = n
  2915.   textp = col
  2916.   thelin = pgm(curline)
  2917.   the_ch = " "
  2918.   call getsym
  2919.  

Sample programs:
Fireworks by Ken G.

Code: QB64: [Select]
  1.     SCREEN _NEWIMAGE(800, 600, 32)
  2.     CLS
  3.     '_FULLSCREEN
  4.     PRINT: PRINT: PRINT
  5.     PRINT "                                  FIREWORKS"
  6.     PRINT: PRINT: PRINT
  7.     PRINT "                                  By  Ken G."
  8.     PRINT: PRINT: PRINT
  9.     PRINT "                    The show lasts around 3 minutes total."
  10.     PRINT "                    Or press Esc to end anytime."
  11.     PRINT "                    There's some surprises at the end."
  12.     PRINT: PRINT: PRINT
  13.     INPUT "                    Press Enter to begin.", bg$
  14.     CLS
  15.     'Start Loop Here
  16.     go:
  17.     a$ = INKEY$
  18.     IF a$ = CHR$(27) THEN END
  19.     x2 = INT(RND * 780) + 10
  20.     y2 = INT(RND * 580) + 10
  21.  
  22.     SOUND 100, .5
  23.     _DELAY .1
  24.     SOUND 100, .5
  25.     _DELAY .1
  26.     SOUND 100, .5
  27.     _DELAY .1
  28.     SOUND 100, .5
  29.  
  30.     dxx = (RND * 6) + -3
  31.     dyy = (RND * 6) + -3
  32.     dxx2 = (RND * 6) + -3
  33.     dyy2 = (RND * 6) + -3
  34.     dxx3 = (RND * 6) + -3
  35.     dyy3 = (RND * 6) + -3
  36.     dxx4 = (RND * 6) + -3
  37.     dyy4 = (RND * 6) + -3
  38.     dxx5 = (RND * 6) + -3
  39.     dyy5 = (RND * 6) + -3
  40.     dxx6 = (RND * 6) + -3
  41.     dyy6 = (RND * 6) + -3
  42.     dxx7 = (RND * 6) + -3
  43.     dyy7 = (RND * 6) + -3
  44.     dxx8 = (RND * 6) + -3
  45.     dyy8 = (RND * 6) + -3
  46.     dxx9 = (RND * 6) + -3
  47.     dyy9 = (RND * 6) + -3
  48.     dxx10 = (RND * 6) + -3
  49.     dyy10 = (RND * 6) + -3
  50.     dxx11 = (RND * 6) + -3
  51.     dyy11 = (RND * 6) + -3
  52.     dxx12 = (RND * 6) + -3
  53.     dyy12 = (RND * 6) + -3
  54.     dxx13 = (RND * 6) + -3
  55.     dyy13 = (RND * 6) + -3
  56.     dxx14 = (RND * 6) + -3
  57.     dyy14 = (RND * 6) + -3
  58.     dxx15 = (RND * 6) + -3
  59.     dyy15 = (RND * 6) + -3
  60.     dxx16 = (RND * 6) + -3
  61.     dyy16 = (RND * 6) + -3
  62.     dxx17 = (RND * 6) + -3
  63.     dyy17 = (RND * 6) + -3
  64.     dxx18 = (RND * 6) + -3
  65.     dyy18 = (RND * 6) + -3
  66.     dxx19 = (RND * 6) + -3
  67.     dyy19 = (RND * 6) + -3
  68.     dxx20 = (RND * 6) + -3
  69.     dyy20 = (RND * 6) + -3
  70.     dxx21 = (RND * 6) + -3
  71.     dyy21 = (RND * 6) + -3
  72.     dxx22 = (RND * 6) + -3
  73.     dyy22 = (RND * 6) + -3
  74.     dxx23 = (RND * 6) + -3
  75.     dyy23 = (RND * 6) + -3
  76.     dxx24 = (RND * 6) + -3
  77.     dyy24 = (RND * 6) + -3
  78.  
  79.     c1 = INT(RND * 200) + 55
  80.     c2 = INT(RND * 200) + 55
  81.     c3 = INT(RND * 200) + 55
  82.     c4 = INT(RND * 200) + 55
  83.     c5 = INT(RND * 200) + 55
  84.     c6 = INT(RND * 200) + 55
  85.     c7 = INT(RND * 200) + 55
  86.     c8 = INT(RND * 200) + 55
  87.     c9 = INT(RND * 200) + 55
  88.     c10 = INT(RND * 200) + 55
  89.     c11 = INT(RND * 200) + 55
  90.     c12 = INT(RND * 200) + 55
  91.     c13 = INT(RND * 200) + 55
  92.     c14 = INT(RND * 200) + 55
  93.     c15 = INT(RND * 200) + 55
  94.     c16 = INT(RND * 200) + 55
  95.     c17 = INT(RND * 200) + 55
  96.     c18 = INT(RND * 200) + 55
  97.     c19 = INT(RND * 200) + 55
  98.     c20 = INT(RND * 200) + 55
  99.     c21 = INT(RND * 200) + 55
  100.     c22 = INT(RND * 200) + 55
  101.     c23 = INT(RND * 200) + 55
  102.     c24 = INT(RND * 200) + 55
  103.     c25 = INT(RND * 200) + 55
  104.     c26 = INT(RND * 200) + 55
  105.     c27 = INT(RND * 200) + 55
  106.     c28 = INT(RND * 200) + 55
  107.     c29 = INT(RND * 200) + 55
  108.     c30 = INT(RND * 200) + 55
  109.     c31 = INT(RND * 200) + 55
  110.     c32 = INT(RND * 200) + 55
  111.     c33 = INT(RND * 200) + 55
  112.     c34 = INT(RND * 200) + 55
  113.     c35 = INT(RND * 200) + 55
  114.     c36 = INT(RND * 200) + 55
  115.     c37 = INT(RND * 200) + 55
  116.     c38 = INT(RND * 200) + 55
  117.     c39 = INT(RND * 200) + 55
  118.     c40 = INT(RND * 200) + 55
  119.     c41 = INT(RND * 200) + 55
  120.     c42 = INT(RND * 200) + 55
  121.     c43 = INT(RND * 200) + 55
  122.     c44 = INT(RND * 200) + 55
  123.     c45 = INT(RND * 200) + 55
  124.     c46 = INT(RND * 200) + 55
  125.     c47 = INT(RND * 200) + 55
  126.     c48 = INT(RND * 200) + 55
  127.     c49 = INT(RND * 200) + 55
  128.     c50 = INT(RND * 200) + 55
  129.     c51 = INT(RND * 200) + 55
  130.     c52 = INT(RND * 200) + 55
  131.     c53 = INT(RND * 200) + 55
  132.     c54 = INT(RND * 200) + 55
  133.     c55 = INT(RND * 200) + 55
  134.     c56 = INT(RND * 200) + 55
  135.     c57 = INT(RND * 200) + 55
  136.     c58 = INT(RND * 200) + 55
  137.     c59 = INT(RND * 200) + 55
  138.     c60 = INT(RND * 200) + 55
  139.     c61 = INT(RND * 200) + 55
  140.     c62 = INT(RND * 200) + 55
  141.     c63 = INT(RND * 200) + 55
  142.     c64 = INT(RND * 200) + 55
  143.     c65 = INT(RND * 200) + 55
  144.     c66 = INT(RND * 200) + 55
  145.     c67 = INT(RND * 200) + 55
  146.     c68 = INT(RND * 200) + 55
  147.     c69 = INT(RND * 200) + 55
  148.     c70 = INT(RND * 200) + 55
  149.     c71 = INT(RND * 200) + 55
  150.     c72 = INT(RND * 200) + 55
  151.  
  152.  
  153.  
  154.     explosion:
  155.     dd = dd + 1
  156.     dxx = dxx + dxx / 4
  157.     dxx2 = dxx2 + dxx2 / 4
  158.     dxx3 = dxx3 + dxx3 / 4
  159.     dxx4 = dxx4 + dxx4 / 4
  160.     dxx5 = dxx5 + dxx5 / 4
  161.     dxx6 = dxx6 + dxx6 / 4
  162.     dyy = dyy + dyy / 4
  163.     dyy2 = dyy2 + dyy2 / 4
  164.     dyy3 = dyy3 + dyy3 / 4
  165.     dyy4 = dyy4 + dyy4 / 4
  166.     dyy5 = dyy5 + dyy5 / 4
  167.     dyy6 = dyy6 + dyy6 / 4
  168.  
  169.     dxx7 = dxx7 + dxx7 / 4
  170.     dxx8 = dxx8 + dxx8 / 4
  171.     dxx9 = dxx9 + dxx9 / 4
  172.     dxx10 = dxx10 + dxx10 / 4
  173.     dxx11 = dxx11 + dxx11 / 4
  174.     dxx12 = dxx12 + dxx12 / 4
  175.     dyy7 = dyy7 + dyy7 / 4
  176.     dyy8 = dyy8 + dyy8 / 4
  177.     dyy9 = dyy9 + dyy9 / 4
  178.     dyy10 = dyy10 + dyy10 / 4
  179.     dyy11 = dyy11 + dyy11 / 4
  180.     dyy12 = dyy12 + dyy12 / 4
  181.  
  182.  
  183.     dxx13 = dxx13 + dxx13 / 4
  184.     dxx14 = dxx14 + dxx14 / 4
  185.     dxx15 = dxx15 + dxx15 / 4
  186.     dxx16 = dxx16 + dxx16 / 4
  187.     dxx17 = dxx17 + dxx17 / 4
  188.     dxx18 = dxx18 + dxx18 / 4
  189.     dyy13 = dyy13 + dyy13 / 4
  190.     dyy14 = dyy14 + dyy14 / 4
  191.     dyy15 = dyy15 + dyy15 / 4
  192.     dyy16 = dyy16 + dyy16 / 4
  193.     dyy17 = dyy17 + dyy17 / 4
  194.     dyy18 = dyy18 + dyy18 / 4
  195.  
  196.     dxx19 = dxx19 + dxx19 / 4
  197.     dxx20 = dxx20 + dxx20 / 4
  198.     dxx21 = dxx21 + dxx21 / 4
  199.     dxx22 = dxx22 + dxx22 / 4
  200.     dxx23 = dxx23 + dxx23 / 4
  201.     dxx24 = dxx24 + dxx24 / 4
  202.     dyy19 = dyy19 + dyy19 / 4
  203.     dyy20 = dyy20 + dyy20 / 4
  204.     dyy21 = dyy21 + dyy21 / 4
  205.     dyy22 = dyy22 + dyy22 / 4
  206.     dyy23 = dyy23 + dyy23 / 4
  207.     dyy24 = dyy24 + dyy24 / 4
  208.  
  209.  
  210.     FOR c = .25 TO 2 STEP .25
  211.         CIRCLE (x2 + dxx, y2 + dyy), c, _RGB32(c1, c2, c3)
  212.         CIRCLE (x2 + dxx2, y2 + dyy2), c, _RGB32(c4, c5, c6)
  213.         CIRCLE (x2 + dxx3, y2 + dyy3), c, _RGB32(c7, c8, c9)
  214.         CIRCLE (x2 + dxx4, y2 + dyy4), c, _RGB32(c10, c11, c12)
  215.  
  216.         CIRCLE (x2 + dxx5, y2 + dyy5), c, _RGB32(c13, c14, c15)
  217.         CIRCLE (x2 + dxx6, y2 + dyy6), c, _RGB32(c16, c17, c18)
  218.         CIRCLE (x2 + dxx7, y2 + dyy7), c, _RGB32(c19, c20, c21)
  219.         CIRCLE (x2 + dxx8, y2 + dyy8), c, _RGB32(c22, c23, c24)
  220.  
  221.         CIRCLE (x2 + dxx9, y2 + dyy9), c, _RGB32(c25, c26, c27)
  222.         CIRCLE (x2 + dxx10, y2 + dyy10), c, _RGB32(c28, c29, c30)
  223.         CIRCLE (x2 + dxx11, y2 + dyy11), c, _RGB32(c31, c32, c33)
  224.         CIRCLE (x2 + dxx12, y2 + dyy12), c, _RGB32(c34, c35, c36)
  225.  
  226.         CIRCLE (x2 + dxx13, y2 + dyy13), c, _RGB32(c37, c38, c39)
  227.         CIRCLE (x2 + dxx14, y2 + dyy14), c, _RGB32(c40, c41, c42)
  228.         CIRCLE (x2 + dxx15, y2 + dyy15), c, _RGB32(c43, c44, c45)
  229.         CIRCLE (x2 + dxx16, y2 + dyy16), c, _RGB32(c46, c47, c48)
  230.  
  231.         CIRCLE (x2 + dxx17, y2 + dyy17), c, _RGB32(c49, c50, c51)
  232.         CIRCLE (x2 + dxx18, y2 + dyy18), c, _RGB32(c52, c53, c54)
  233.         CIRCLE (x2 + dxx19, y2 + dyy19), c, _RGB32(c55, c56, c57)
  234.         CIRCLE (x2 + dxx20, y2 + dyy20), c, _RGB32(c58, c59, c60)
  235.  
  236.         CIRCLE (x2 + dxx21, y2 + dyy21), c, _RGB32(c61, c62, c63)
  237.         CIRCLE (x2 + dxx22, y2 + dyy22), c, _RGB32(c64, c65, c66)
  238.         CIRCLE (x2 + dxx23, y2 + dyy23), c, _RGB32(c67, c68, c69)
  239.         CIRCLE (x2 + dxx24, y2 + dyy24), c, _RGB32(c70, c71, c72)
  240.  
  241.     NEXT c
  242.     _DELAY .05
  243.     FOR cc = .25 TO 2 STEP .25
  244.  
  245.         CIRCLE (x2 + dxx, y2 + dyy), cc, _RGB32(0, 0, 0)
  246.         CIRCLE (x2 + dxx2, y2 + dyy2), cc, _RGB32(0, 0, 0)
  247.         CIRCLE (x2 + dxx3, y2 + dyy3), cc, _RGB32(0, 0, 0)
  248.         CIRCLE (x2 + dxx4, y2 + dyy4), cc, _RGB32(0, 0, 0)
  249.  
  250.         CIRCLE (x2 + dxx5, y2 + dyy5), cc, _RGB32(0, 0, 0)
  251.         CIRCLE (x2 + dxx6, y2 + dyy6), cc, _RGB32(0, 0, 0)
  252.         CIRCLE (x2 + dxx7, y2 + dyy7), cc, _RGB32(0, 0, 0)
  253.         CIRCLE (x2 + dxx8, y2 + dyy8), cc, _RGB32(0, 0, 0)
  254.  
  255.         CIRCLE (x2 + dxx9, y2 + dyy9), cc, _RGB32(0, 0, 0)
  256.         CIRCLE (x2 + dxx10, y2 + dyy10), cc, _RGB32(0, 0, 0)
  257.         CIRCLE (x2 + dxx11, y2 + dyy11), cc, _RGB32(0, 0, 0)
  258.         CIRCLE (x2 + dxx12, y2 + dyy12), cc, _RGB32(0, 0, 0)
  259.  
  260.         CIRCLE (x2 + dxx13, y2 + dyy13), cc, _RGB32(0, 0, 0)
  261.         CIRCLE (x2 + dxx14, y2 + dyy14), cc, _RGB32(0, 0, 0)
  262.         CIRCLE (x2 + dxx15, y2 + dyy15), cc, _RGB32(0, 0, 0)
  263.         CIRCLE (x2 + dxx16, y2 + dyy16), cc, _RGB32(0, 0, 0)
  264.  
  265.         CIRCLE (x2 + dxx17, y2 + dyy17), cc, _RGB32(0, 0, 0)
  266.         CIRCLE (x2 + dxx18, y2 + dyy18), cc, _RGB32(0, 0, 0)
  267.         CIRCLE (x2 + dxx19, y2 + dyy19), cc, _RGB32(0, 0, 0)
  268.         CIRCLE (x2 + dxx20, y2 + dyy20), cc, _RGB32(0, 0, 0)
  269.  
  270.         CIRCLE (x2 + dxx21, y2 + dyy21), cc, _RGB32(0, 0, 0)
  271.         CIRCLE (x2 + dxx22, y2 + dyy22), cc, _RGB32(0, 0, 0)
  272.         CIRCLE (x2 + dxx23, y2 + dyy23), cc, _RGB32(0, 0, 0)
  273.         CIRCLE (x2 + dxx24, y2 + dyy24), cc, _RGB32(0, 0, 0)
  274.  
  275.  
  276.     NEXT cc
  277.  
  278.     IF dd > 25 THEN GOTO goingback
  279.     GOTO explosion:
  280.     goingback:
  281.     dd = 0
  282.     ee = ee + 1
  283.     IF ee > 60 THEN GOTO finalboom:
  284.     tt = tt + 1
  285.     IF tt > 40 THEN tm = 0: GOTO delay:
  286.     tm = (RND * 2) + .01
  287.     delay:
  288.     _DELAY tm
  289.     GOTO go:
  290.  
  291.     'FINAL BOOM!
  292.  
  293.     finalboom:
  294.     x3 = INT(RND * 600) + 100
  295.     y3 = INT(RND * 400) + 100
  296.     boom:
  297.     ccl1 = INT(RND * 100) + 155
  298.     ccl2 = INT(RND * 100) + 155
  299.     ccl3 = INT(RND * 100) + 155
  300.  
  301.     SOUND 100, .5
  302.     _DELAY .1
  303.     SOUND 100, .5
  304.     _DELAY .1
  305.     SOUND 100, .5
  306.     _DELAY .1
  307.     SOUND 100, .5
  308.     FOR sz = 2 TO 30
  309.         aa$ = INKEY$
  310.         IF aa$ = CHR$(27) THEN END
  311.         CIRCLE (x3, y3), sz * 2, _RGB32(ccl1, ccl2, ccl3)
  312.         _DELAY .02
  313.     NEXT sz
  314.     FOR sz = 2 TO 30
  315.         CIRCLE (x3, y3), sz * 2, _RGB32(0, 0, 0)
  316.         _DELAY .02
  317.     NEXT sz
  318.     f = f + 1
  319.     IF f = 20 THEN GOTO face:
  320.     GOTO finalboom:
  321.     face:
  322.     CLS
  323.     SCREEN _NEWIMAGE(800, 600, 13)
  324.  
  325.     'Make the face.
  326.     CIRCLE (400, 300), 100, 10
  327.     CIRCLE (350, 250), 20, 10
  328.     CIRCLE (450, 250), 20, 10
  329.     CIRCLE (400, 300), 15, 10
  330.     CIRCLE (400, 350), 30, 10
  331.  
  332.     'Explode the face!
  333.     FOR xt = 249 TO 551
  334.         FOR yt = 149 TO 451
  335.             a2$ = INKEY$
  336.             IF a2$ = CHR$(27) THEN END
  337.             IF POINT(xt, yt) > 0 AND POINT(xt, yt) <> 4 THEN
  338.                 _LIMIT 5000
  339.                 SOUND 100, .5
  340.                 FOR b = 1 TO 40 STEP 2
  341.                     CIRCLE (xt, yt), b, 4
  342.                     _DELAY .002
  343.                 NEXT b
  344.                 FOR b = 1 TO 40 STEP 2
  345.                     CIRCLE (xt, yt), b, 0
  346.                     _DELAY .002
  347.                 NEXT b
  348.             END IF
  349.         NEXT yt
  350.     NEXT xt
  351.  
  352.     END
  353.  
  354.  
  355.  

Snake by Johnno and BPlus

Code: QB64: [Select]
  1. _TITLE "SNAKE:  " + STR$(score) '       <----- Display initial score in title  >>>>>>>>>>>>. B+ mod this
  2.  
  3. 'from Johnno's mod:
  4. ' 2019-02-27 B+ mod more snake colors, green garden, fruit white
  5. ' put back in snake death when reverses itself, ie the head enters the body
  6. ' put back in snake dies when head hit another segment of body
  7. ' put back in outer game restart loop after delay
  8.  
  9. ' added worm holes at corners!!!!!!!!!!!!!!!!
  10. ' ADDED escape clause or q to quit game!!!!!!!!!!!!
  11.  
  12. DIM snake(1 TO 500, 0 TO 1)
  13.  
  14.     ' initialize game
  15.     for i = 1 to 500
  16.         for j = 0 to 1
  17.             snake(i, j) = 0
  18.         next
  19.     next
  20.  
  21.     x = 15: y = 3: died = 0: score = 0
  22.  
  23.     '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> dont put fruit at snake position
  24.     fy = INT(RND * 27) + 2: fx = INT(RND * 75) + 3
  25.     WHILE fx = x AND fy = y
  26.         fy = INT(RND * 27) + 2: fx = INT(RND * 75) + 3
  27.     WEND
  28.     'fx = 3: fy = 2   '>>>>>>>>>>> test corner boundry, OK
  29.     'fx = 77: fy = 28 '>>>>>>>>>>> test corner boundry, OK
  30.     yd = 1: xd = 0: snakelength = 1
  31.  
  32.     DO
  33.  
  34.         '>>>>>>>>>>>>>>>>>>>>> The snake really does have to die if it's headed back into it's body
  35.         keypress$ = INKEY$
  36.         IF keypress$ = CHR$(0) + CHR$(72) THEN 'up
  37.             IF yd = 1 THEN died = -1 ELSE xd = 0: yd = -1
  38.         ELSEIF keypress$ = CHR$(0) + CHR$(80) THEN 'down
  39.             IF yd = -1 THEN died = -1 ELSE xd = 0: yd = 1
  40.         ELSEIF keypress$ = CHR$(0) + CHR$(77) THEN 'right
  41.             IF xd = -1 THEN died = -1 ELSE xd = 1: yd = 0
  42.         ELSEIF keypress$ = CHR$(0) + CHR$(75) THEN 'left
  43.             IF xd = 1 THEN died = -1 ELSE xd = -1: yd = 0
  44.         ELSEIF keypress$ = "q" OR keypress$ = CHR$(27) THEN
  45.             END '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> here is quit or escape clause!!!!
  46.         END IF
  47.  
  48.         ' update snake position
  49.         x = x + xd
  50.         y = y + yd
  51.  
  52.         ' did snake just die by hitting wall /boundry?
  53.         IF x < 3 OR x > 77 THEN died = -1
  54.         IF y < 2 OR y > 28 THEN died = -1
  55.  
  56.         ' did snake run into itself >>> DIES!
  57.         FOR sn = 2 TO snakelength
  58.             IF y = snake(sn, 0) AND x = snake(sn, 1) THEN died = -1
  59.         NEXT
  60.  
  61.         ' did snake eat fruit
  62.         IF x = fx AND y = fy THEN
  63.             score = score + 1 '     <-------  Increase score
  64.             WHILE fx = x AND fy = y '>>>>>>>>>>>>>>>>>>> dont put fruit at snake position
  65.                 fy = INT(RND * 27) + 2: fx = INT(RND * 75) + 3
  66.             WEND
  67.             snakelength = snakelength + 1
  68.         END IF
  69.  
  70.         'did snake disappear into worm holes at corners  >>>>>>>>>>>>>>>>>>>> B+ mod
  71.         IF (x = 3 AND y = 2) OR (x = 77 AND y = 2) OR (x = 77 AND y = 28) OR (x = 3 AND y = 28) THEN
  72.             x = 37: y = 13 'move snake to screen center, same direction as in corner
  73.         END IF
  74.  
  75.         IF died THEN EXIT DO
  76.  
  77.         '>>>>>>>>>> Now for the drawing!!!!!!!!!!!!!!!!!!!
  78.         COLOR 15, 0 '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  black out to show garden boundries
  79.         CLS
  80.  
  81.         'show garden >>>>  use garden color as back color for small boxes and snake head
  82.         LINE (10, 14)-(616, 448), 2, BF '       <------- "GREEN" garden  >>>>>>>>>>>>> B+ darker BF
  83.  
  84.         'show fruit
  85.         LOCATE fy, fx: COLOR 15, 2: PRINT CHR$(254) '      <------ small red square   >>>> to white
  86.  
  87.         'show snake
  88.         snake(1, 0) = y: snake(1, 1) = x
  89.         FOR sn = snakelength TO 1 STEP -1
  90.             snake(sn + 1, 0) = snake(sn, 0): snake(sn + 1, 1) = snake(sn, 1)
  91.             COLOR (sn MOD 13) + 3, 2 '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>       colorize all segments different!!!
  92.             LOCATE snake(sn, 0), snake(sn, 1): PRINT CHR$(254) '       <------- small square
  93.         NEXT
  94.         COLOR 0, 2 '>>>>>>>>>>>>>> black O for head
  95.         LOCATE y, x: PRINT "O"
  96.  
  97.         _TITLE "SNAKE:  " + STR$(score) '   <------  Update score in "TITLE"  >>> moved to last part of draw update
  98.         _DISPLAY
  99.  
  100.         _LIMIT 9 '>>>>>>>>>>>>>>>>>>>>>>>>>>> adjust to level user wants for challnge
  101.     LOOP UNTIL keypress$ = CHR$(27)
  102.     _DELAY 3
  103.  
  104.  
  105.  

Laser Show by Sierra Ken:

Code: QB64: [Select]
  1. _TITLE "Laser Show - by SierraKen - Press Esc to end."
  2. SCREEN _NEWIMAGE(800, 600, 32)
  3. c1 = 255
  4. c2 = 0
  5. c3 = 0
  6. c4 = 255
  7. c5 = 0
  8. c6 = 0
  9.  
  10. c7 = 255
  11. c8 = 0
  12. c9 = 0
  13. c10 = 255
  14. c11 = 0
  15. c12 = 0
  16.  
  17.     _LIMIT 10
  18.     a$ = INKEY$
  19.     IF a$ = CHR$(27) THEN END
  20.     col = INT(RND * 100) + 1
  21.     IF col > 90 THEN
  22.         c = INT(RND * 7) + 1
  23.         IF c = 1 THEN
  24.             c1 = 255: c2 = 0: c3 = 0
  25.         END IF
  26.         IF c = 2 THEN
  27.             c1 = 0: c2 = 255: c3 = 0
  28.         END IF
  29.         IF c = 3 THEN
  30.             c1 = 0: c2 = 0: c3 = 255
  31.         END IF
  32.         IF c = 4 THEN
  33.             c1 = 0: c2 = 255: c3 = 255
  34.         END IF
  35.         IF c = 5 THEN
  36.             c1 = 255: c2 = 255: c3 = 0
  37.         END IF
  38.         IF c = 6 THEN
  39.             c1 = 255: c2 = 0: c3 = 255
  40.         END IF
  41.         IF c = 7 THEN
  42.             c1 = 255: c2 = 255: c3 = 255
  43.         END IF
  44.     END IF
  45.     oldx = x
  46.     oldy = y
  47.     x = RND * 800
  48.     y = RND * 600
  49.     LINE (oldx, oldy)-(x, y), _RGB32(c1, c2, c3)
  50.     col2 = INT(RND * 100) + 1
  51.     IF col2 > 90 THEN
  52.         c2 = INT(RND * 7) + 1
  53.         IF c2 = 1 THEN
  54.             c4 = 255: c5 = 0: c6 = 0
  55.         END IF
  56.         IF c2 = 2 THEN
  57.             c4 = 0: c5 = 255: c6 = 0
  58.         END IF
  59.         IF c2 = 3 THEN
  60.             c4 = 0: c5 = 0: c6 = 255
  61.         END IF
  62.         IF c2 = 4 THEN
  63.             c4 = 0: c5 = 255: c6 = 255
  64.         END IF
  65.         IF c2 = 5 THEN
  66.             c4 = 255: c5 = 255: c6 = 0
  67.         END IF
  68.         IF c2 = 6 THEN
  69.             c4 = 255: c5 = 0: c6 = 255
  70.         END IF
  71.         IF c2 = 7 THEN
  72.             c4 = 255: c5 = 255: c6 = 255
  73.         END IF
  74.     END IF
  75.     oldx2 = x2
  76.     oldy2 = y2
  77.     x2 = RND * 800
  78.     y2 = RND * 600
  79.     LINE (oldx2, oldy2)-(x2, y2), _RGB32(c4, c5, c6)
  80.  
  81.     col3 = INT(RND * 100) + 1
  82.     IF col3 > 90 THEN
  83.         c3 = INT(RND * 7) + 1
  84.         IF c3 = 1 THEN
  85.             c7 = 255: c8 = 0: c9 = 0
  86.         END IF
  87.         IF c3 = 2 THEN
  88.             c7 = 0: c8 = 255: c9 = 0
  89.         END IF
  90.         IF c3 = 3 THEN
  91.             c7 = 0: c8 = 0: c9 = 255
  92.         END IF
  93.         IF c3 = 4 THEN
  94.             c7 = 0: c8 = 255: c9 = 255
  95.         END IF
  96.         IF c3 = 5 THEN
  97.             c7 = 255: c8 = 255: c9 = 0
  98.         END IF
  99.         IF c3 = 6 THEN
  100.             c7 = 255: c8 = 0: c9 = 255
  101.         END IF
  102.         IF c3 = 7 THEN
  103.             c7 = 255: c8 = 255: c9 = 255
  104.         END IF
  105.     END IF
  106.     oldx3 = x3
  107.     oldy3 = y3
  108.     x3 = RND * 800
  109.     y3 = RND * 600
  110.     LINE (oldx3, oldy3)-(x3, y3), _RGB32(c7, c8, c9)
  111.     col4 = INT(RND * 100) + 1
  112.     IF col4 > 90 THEN
  113.         c4 = INT(RND * 7) + 1
  114.         IF c4 = 1 THEN
  115.             c10 = 255: c11 = 0: c12 = 0
  116.         END IF
  117.         IF c4 = 2 THEN
  118.             c10 = 0: c11 = 255: c12 = 0
  119.         END IF
  120.         IF c4 = 3 THEN
  121.             c10 = 0: c11 = 0: c12 = 255
  122.         END IF
  123.         IF c4 = 4 THEN
  124.             c10 = 0: c11 = 255: c12 = 255
  125.         END IF
  126.         IF c4 = 5 THEN
  127.             c10 = 255: c11 = 255: c12 = 0
  128.         END IF
  129.         IF c4 = 6 THEN
  130.             c10 = 255: c11 = 0: c12 = 255
  131.         END IF
  132.         IF c4 = 7 THEN
  133.             c10 = 255: c11 = 255: c12 = 255
  134.         END IF
  135.     END IF
  136.     oldx4 = x4
  137.     oldy4 = y4
  138.     x4 = RND * 800
  139.     y4 = RND * 600
  140.     LINE (oldx4, oldy4)-(x4, y4), _RGB32(c10, c11, c12)
  141.  
  142.     LINE (0, 0)-(800, 600), _RGB32(0, 0, 0, 40), BF
  143.  
  144.  


Matrix by unknown:

Code: QB64: [Select]
  1. SCREEN _NEWIMAGE(800, 600, 32)
  2.  
  3. FOR i = 1 TO UBOUND(m)
  4.     m(i) = -INT(RND * _HEIGHT)
  5.  
  6. COLOR _RGB32(0, 255, 0)
  7.  
  8.     '_LIMIT 15
  9.     LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA32(0, 0, 0, 20), BF
  10.  
  11.     FOR i = 1 TO UBOUND(m)
  12.         m(i) = m(i) + _FONTHEIGHT
  13.         IF m(i) > 0 THEN
  14.             IF m(i) > _HEIGHT THEN m(i) = -INT(RND * _HEIGHT)
  15.             _PRINTSTRING (i * _FONTWIDTH - _FONTWIDTH, m(i)), CHR$(_CEIL(RND * 254))
  16.         END IF
  17.     NEXT
  18.  
  19.     _DISPLAY
  20.  

A Tiny Basic interpreter - very limited

Code: QB64: [Select]
  1. 'Circa Feb 2007.  Tiny Basic interpreter.  No subs or functions.
  2. 'By Ed Davis
  3.  
  4. dim pgm$(301)
  5. 'ch$
  6. 'thelin$
  7. 'tok$
  8.  
  9. dim stack(30)
  10. dim vars(26)
  11.  
  12. ' curline
  13. ' i
  14. ' n1
  15. ' n
  16. ' num
  17. ' printnl
  18. ' sp
  19. ' textp
  20. ' var
  21.  
  22. mainloop:
  23.   do
  24.     line input "$ ", pgm$(0)
  25.     if pgm$(0) <> "" then
  26.       num = 0
  27.       gosub initgetsym
  28.       if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
  29.         gosub validlinenum
  30.         pgm$(num) = mid$(pgm$(0), textp, len(pgm$(0)) - textp + 1)
  31.       else
  32.         gosub docmd
  33.       end if
  34.     end if
  35.   loop
  36.  
  37. docmd:
  38.   while tok$ = "" and curline <> 0 and curline < 300
  39.     num = curline + 1
  40.     gosub initgetsym
  41.   wend
  42.   if tok$ = "" and curline = 0 or curline >= 300 then return
  43.   if tok$ = "stop" or tok$ = "end" then return
  44.   if tok$ = "new" then
  45.     gosub clearvars
  46.     for i = 1 to 300
  47.       pgm$(i) = ""
  48.     next i
  49.     return
  50.   end if
  51.   if tok$ = "bye" or tok$ = "quit" then stop
  52.   if tok$ = "list" then gosub liststmt: goto docmd
  53.   if tok$ = "run" then
  54.     gosub clearvars
  55.     num = 1
  56.     gosub initgetsym
  57.     goto docmd
  58.   end if
  59.   if tok$ = "goto"  then gosub gotostmt:  goto docmd
  60.   if tok$ = "if"    then gosub ifstmt:    goto docmd
  61.   if tok$ = "input" then gosub inputstmt: goto docmd
  62.   if tok$ = "print" or tok$ = "?" then gosub printstmt: goto docmd
  63.   if tok$ = "rem"   then gosub skiptoeol: goto docmd
  64.   if left$(tok$, 1) >= "a" and left$(tok$, 1) <= "z" then
  65.     gosub idstmt
  66.     goto docmd
  67.   end if
  68.   print "Unknown token "; tok$; " at thelin "; curline
  69.  
  70. rem "print" [ expr  "," expr ] [","]
  71. rem expr can also be a literal string
  72. printstmt:
  73.   printnl = 1
  74.   gosub getsym
  75.   while tok$ <> ""
  76.     printnl = 1
  77.     if left$(tok$, 1) = chr$(34) then
  78.       print mid$(tok$, 2, len(tok$) - 1);
  79.       gosub getsym
  80.     else
  81.       gosub expression
  82.       print n;
  83.     end if
  84.  
  85.     if tok$ <> "," and tok$ <> ";" then exit while
  86.     gosub getsym
  87.     printnl = 0
  88.   wend
  89.   if printnl <> 0 then print
  90.  
  91. rem "input" [string ","] var
  92. inputstmt:
  93.   gosub getsym
  94.   if left$(tok$, 1) = chr$(34) then
  95.     print mid$(tok$, 2, len(tok$) - 1);
  96.     gosub getsym
  97.     if tok$ = "," then
  98.       gosub getsym
  99.     else
  100.       print "expecting ','"
  101.       return
  102.     end if
  103.   else
  104.     print "? ";
  105.   end if
  106.   gosub getvarindex
  107.   var = n
  108.   gosub getsym
  109.   input vars(var)
  110.  
  111. idstmt:
  112.   gosub getvarindex
  113.   var = n
  114.   gosub getsym
  115.   if tok$ = "=" then
  116.     gosub getsym
  117.   else
  118.     print "expecting '"'"
  119.     return
  120.   end if
  121.   gosub expression
  122.   vars(var) = n
  123.  
  124. liststmt:
  125.   gosub getsym
  126.   for i = 1 to 300
  127.     if pgm$(i) <> "" then print i; " "; pgm$(i)
  128.   next i
  129.  
  130. gotostmt:
  131.   gosub getsym
  132.   if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
  133.     gosub gotoline
  134.     return
  135.   end if
  136.   print "Line number must follow goto"
  137.  
  138. ifstmt:
  139.   gosub getsym
  140.   gosub expression
  141.   if n = 0 then gosub skiptoeol: return
  142.   if tok$ = "then" then gosub getsym
  143.   if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
  144.     gosub gotoline
  145.   end if
  146.  
  147. gotoline:
  148.   gosub validlinenum
  149.   gosub initgetsym
  150.  
  151. validlinenum:
  152.   if num > 0 and num <= 300 then return
  153.   print "Line number out of range"
  154.  
  155. clearvars:
  156.   for i = 1 to 26
  157.     vars(i) = 0
  158.   next i
  159.  
  160. expression:
  161.   sp = 0
  162.   gosub relexpr
  163.   gosub pop
  164.  
  165. relexpr:
  166.   gosub addexpr
  167.   if tok$ = "=" or tok$ = "<>" or tok$ = "<" or tok$ = "<=" or tok$ = ">" or tok$ = ">=" then
  168.     rel_oper$ = tok$
  169.     gosub relexprhlp
  170.     if rel_oper$ = "="  then n = n =  n1
  171.     if rel_oper$ = "<"  then n = n <  n1
  172.     if rel_oper$ = ">"  then n = n >  n1
  173.     if rel_oper$ = "<>" then n = n <> n1
  174.     if rel_oper$ = "<=" then n = n <= n1
  175.     if rel_oper$ = ">=" then n = n >= n1
  176.     gosub push
  177.   end if
  178.  
  179. relexprhlp:
  180.   gosub getsym
  181.   gosub addexpr
  182.   gosub pop
  183.   n1 = n
  184.   gosub pop
  185.  
  186. addexpr:
  187.   gosub term
  188.   while tok$ = "+" or tok$ = "-"
  189.     add_oper$ = tok$
  190.     gosub addexprhlp
  191.     if add_oper$ = "+" then n = n + n1
  192.     if add_oper$ = "-" then n = n - n1
  193.     gosub push
  194.   wend
  195.  
  196. addexprhlp:
  197.   gosub getsym
  198.   gosub term
  199.   gosub pop
  200.   n1 = n
  201.   gosub pop
  202.  
  203. term:
  204.   gosub factor
  205.   while tok$ = "*" or tok$ = "/"
  206.     mul_oper$ = tok$
  207.     gosub termhlp
  208.     if mul_oper$ = "*" then n = n * n1
  209.     if mul_oper$ = "/" then n = n / n1
  210.     gosub push
  211.   wend
  212.  
  213. termhlp:
  214.   gosub getsym
  215.   gosub factor
  216.   gosub pop
  217.   n1 = n
  218.   gosub pop
  219.  
  220. factor:
  221.   if tok$ = "-" then
  222.     gosub getsym
  223.     gosub factor
  224.     gosub pop
  225.     n = -n
  226.     gosub push
  227.     return
  228.   end if
  229.   if tok$ = "(" then
  230.     gosub getsym
  231.     gosub expression
  232.     if tok$ = ")" then gosub getsym: return
  233.     print "expecting ')'": return
  234.   end if
  235.   if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
  236.     n = num
  237.     gosub push
  238.     gosub getsym
  239.     return
  240.   end if
  241.   if left$(tok$, 1) >= "a" and left$(tok$, 1) <= "z" then
  242.     gosub getvarindex
  243.     n = vars(n)
  244.     gosub push
  245.     gosub getsym
  246.     return
  247.   end if
  248.   print "Unexpected sym "; tok$; " in factor"
  249.  
  250. getvarindex:
  251.   if left$(tok$, 1) < "a" or left$(tok$, 1) > "z" then
  252.     print "Not a variable"
  253.     return
  254.   end if
  255.   n = asc(left$(tok$, 1)) - asc("a")
  256.  
  257. push:
  258.   sp = sp + 1
  259.   stack(sp) = n
  260.  
  261. pop:
  262.   n = stack(sp)
  263.   sp = sp - 1
  264.  
  265. initgetsym:
  266.   curline = num
  267.   textp = 1
  268.   thelin$ = pgm$(curline)
  269.   ch$ = " "
  270.   gosub getsym
  271.  
  272. skiptoeol:
  273.   while ch$ <> ""
  274.     gosub getch
  275.   wend
  276.   gosub getsym
  277.  
  278. getsym:
  279.   tok$ = ""
  280.   while ch$ <= " " and ch$ <> ""
  281.     gosub getch
  282.   wend
  283.   if ch$ = "" then return
  284.  
  285.   tok$ = ch$
  286.   if instr(",;=+-*/()?", ch$) > 0 then gosub getch: return
  287.   if ch$ = "<" then
  288.     gosub getch
  289.     if ch$ = "=" or ch$ = ">" then
  290.       tok$ = tok$ + ch$
  291.       gosub getch
  292.     end if
  293.     return
  294.   end if
  295.   if ch$ = ">" then
  296.     gosub getch
  297.     if ch$ = "=" then tok$ = tok$ + ch$: gosub getch
  298.     return
  299.   end if
  300.   if ch$ = chr$(34) then gosub readstr: return
  301.   if ch$ >= "a" and ch$ <= "z" then gosub readident: return
  302.   if ch$ >= "0" and ch$ <= "9" then gosub readint: return
  303.   print "What->"; ch$
  304.  
  305. readstr:
  306.   tok$ = chr$(34)
  307.   gosub getch
  308.   while ch$ <> chr$(34) and ch$ <> ""
  309.     tok$ = tok$ + ch$
  310.     gosub getch
  311.   wend
  312.   if ch$ = "" then print "String not terminated": return
  313.   gosub getch
  314.  
  315. readint:
  316.   tok$ = ""
  317.   while ch$ >= "0" and ch$ <= "9"
  318.     tok$ = tok$ + ch$
  319.     gosub getch
  320.   wend
  321.   num = val(tok$)
  322.  
  323. readident:
  324.   tok$ = ""
  325.   while ch$ >= "a" and ch$ <= "z"
  326.     tok$ = tok$ + ch$
  327.     gosub getch
  328.   wend
  329.  
  330. getch:
  331.   if textp > len(thelin$) then ch$ = "": return
  332.   ch$ = mid$(thelin$, textp, 1)
  333.   textp = textp + 1
  334.  
  335.  

Offline Aurel

  • Forum Regular
  • Posts: 167
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #1 on: July 05, 2021, 02:08:48 am »
WOW
Well done Ed !
3000 lines of code ..
this one is more featured than toy interpreter.
also show that i am lazy (shame on me)
I tried snake game ..it work well
..and matrix is amazing...

all best!
subset_Interpreter_EdDavis.png
* subset_Interpreter_EdDavis.png (Filesize: 203.12 KB, Dimensions: 1272x938, Views: 141)
« Last Edit: July 05, 2021, 04:04:21 am by Aurel »
//////////////////////////////////////////////////////////////////
https://aurelsoft.ucoz.com
https://www.facebook.com/groups/470369984111370
//////////////////////////////////////////////////////////////////

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #2 on: July 05, 2021, 07:47:39 am »
Cant wait to try! :)
Has stepping on/ off! Does it show variable values as stepping?

Offline Aurel

  • Forum Regular
  • Posts: 167
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #3 on: July 05, 2021, 10:13:28 am »
I don't try uncomment part of code and check is work or not
i guess...
//////////////////////////////////////////////////////////////////
https://aurelsoft.ucoz.com
https://www.facebook.com/groups/470369984111370
//////////////////////////////////////////////////////////////////

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #4 on: August 03, 2021, 12:08:46 pm »
Finally got around to testing, I tried a recursive gosub for factorial and stepping:
 
Test Eds Interpreter.PNG
 
test eds stepping.PNG


Nice!

Offline Aurel

  • Forum Regular
  • Posts: 167
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #5 on: August 11, 2021, 03:55:26 pm »
anyone tried this on Linux ?
//////////////////////////////////////////////////////////////////
https://aurelsoft.ucoz.com
https://www.facebook.com/groups/470369984111370
//////////////////////////////////////////////////////////////////

Offline Aurel

  • Forum Regular
  • Posts: 167
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #6 on: August 17, 2021, 04:04:16 am »
Hello Ed
Do you maybe  made some benchmarks with interpreter?
//////////////////////////////////////////////////////////////////
https://aurelsoft.ucoz.com
https://www.facebook.com/groups/470369984111370
//////////////////////////////////////////////////////////////////

Offline Ed Davis

  • Newbie
  • Posts: 40
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #7 on: August 26, 2021, 10:27:21 pm »
Hello Ed
Do you maybe  made some benchmarks with interpreter?

It is pretty slow.  Nothing is stored, e.g., the scanner rescans the input each time, and the parser re-parses the output of the scanner each time.

For instance, it is _many_ times slower than Toy, even the QB64 version of Toy.

I did some experiments, building a simple AST and interpreting that.  Of course it was much faster.
But it is hard to handle goto's from an AST, so I abandoned it.

Offline Dav

  • Forum Resident
  • Posts: 792
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #8 on: August 27, 2021, 10:01:31 am »
This is marvelous work, Ed!  Pretty compact interpreter too for what it does.  Well done! 

- Dav

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #9 on: August 27, 2021, 11:13:44 am »
This is marvelous work, Ed!  Pretty compact interpreter too for what it does.  Well done! 

- Dav

+1 I luv it when you can use an interpreter to build another, in this case, Tiny Basic.bas :)
« Last Edit: August 27, 2021, 11:15:02 am by bplus »

Offline Aurel

  • Forum Regular
  • Posts: 167
    • View Profile
Re: QBASIC/QB64 subset interpreter
« Reply #10 on: August 29, 2021, 06:16:09 am »
Quote
and the parser re-parses the output of the scanner each time.

hmm ...i do not much in that part of code ...i was looking into array
so that is the case ..it is not parsed once then ran trough tokens as i do in microA.
well that explain a lot..but in all...interpreter is excellent it contain most usual features...!!!
i like it !
//////////////////////////////////////////////////////////////////
https://aurelsoft.ucoz.com
https://www.facebook.com/groups/470369984111370
//////////////////////////////////////////////////////////////////