QBASIC/QB64 subset interpreter

[Ed Davis]

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

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

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

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

Matrix by unknown:

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(800, 600, 32)
2. DIM m(1 TO INT(_WIDTH / _FONTWIDTH))
3.  
4. FOR i = 1 TO UBOUND(m)
5.     m(i) = -INT(RND * _HEIGHT)
6. NEXT
7.  
8. COLOR _RGB32(0, 255, 0)
9.  
10. DO
11.     '_LIMIT 15
12.     LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA32(0, 0, 0, 20), BF
13.  
14.     FOR i = 1 TO UBOUND(m)
15.         m(i) = m(i) + _FONTHEIGHT
16.         IF m(i) > 0 THEN
17.             IF m(i) > _HEIGHT THEN m(i) = -INT(RND * _HEIGHT)
18.             _PRINTSTRING (i * _FONTWIDTH - _FONTWIDTH, m(i)), CHR$(_CEIL(RND * 254))
19.         END IF
20.     NEXT
21.  
22.     _DISPLAY
23. LOOP UNTIL _KEYHIT = 27
24.  

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.   return
70.  
71. rem "print" [ expr  "," expr ] [","]
72. rem expr can also be a literal string
73. printstmt:
74.   printnl = 1
75.   gosub getsym
76.   while tok$ <> ""
77.     printnl = 1
78.     if left$(tok$, 1) = chr$(34) then
79.       print mid$(tok$, 2, len(tok$) - 1);
80.       gosub getsym
81.     else
82.       gosub expression
83.       print n;
84.     end if
85.  
86.     if tok$ <> "," and tok$ <> ";" then exit while
87.     gosub getsym
88.     printnl = 0
89.   wend
90.   if printnl <> 0 then print
91.   return
92.  
93. rem "input" [string ","] var
94. inputstmt:
95.   gosub getsym
96.   if left$(tok$, 1) = chr$(34) then
97.     print mid$(tok$, 2, len(tok$) - 1);
98.     gosub getsym
99.     if tok$ = "," then
100.       gosub getsym
101.     else
102.       print "expecting ','"
103.       return
104.     end if
105.   else
106.     print "? ";
107.   end if
108.   gosub getvarindex
109.   var = n
110.   gosub getsym
111.   input vars(var)
112.   return
113.  
114. idstmt:
115.   gosub getvarindex
116.   var = n
117.   gosub getsym
118.   if tok$ = "=" then
119.     gosub getsym
120.   else
121.     print "expecting '"'"
122.     return
123.   end if
124.   gosub expression
125.   vars(var) = n
126.   return
127.  
128. liststmt:
129.   gosub getsym
130.   for i = 1 to 300
131.     if pgm$(i) <> "" then print i; " "; pgm$(i)
132.   next i
133.   print
134.   return
135.  
136. gotostmt:
137.   gosub getsym
138.   if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
139.     gosub gotoline
140.     return
141.   end if
142.   print "Line number must follow goto"
143.   return
144.  
145. ifstmt:
146.   gosub getsym
147.   gosub expression
148.   if n = 0 then gosub skiptoeol: return
149.   if tok$ = "then" then gosub getsym
150.   if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
151.     gosub gotoline
152.   end if
153.   return
154.  
155. gotoline:
156.   gosub validlinenum
157.   gosub initgetsym
158.   return
159.  
160. validlinenum:
161.   if num > 0 and num <= 300 then return
162.   print "Line number out of range"
163.   return
164.  
165. clearvars:
166.   for i = 1 to 26
167.     vars(i) = 0
168.   next i
169.   return
170.  
171. expression:
172.   sp = 0
173.   gosub relexpr
174.   gosub pop
175.   return
176.  
177. relexpr:
178.   gosub addexpr
179.   if tok$ = "=" or tok$ = "<>" or tok$ = "<" or tok$ = "<=" or tok$ = ">" or tok$ = ">=" then
180.     rel_oper$ = tok$
181.     gosub relexprhlp
182.     if rel_oper$ = "="  then n = n =  n1
183.     if rel_oper$ = "<"  then n = n <  n1
184.     if rel_oper$ = ">"  then n = n >  n1
185.     if rel_oper$ = "<>" then n = n <> n1
186.     if rel_oper$ = "<=" then n = n <= n1
187.     if rel_oper$ = ">=" then n = n >= n1
188.     gosub push
189.   end if
190.   return
191.  
192. relexprhlp:
193.   gosub getsym
194.   gosub addexpr
195.   gosub pop
196.   n1 = n
197.   gosub pop
198.   return
199.  
200. addexpr:
201.   gosub term
202.   while tok$ = "+" or tok$ = "-"
203.     add_oper$ = tok$
204.     gosub addexprhlp
205.     if add_oper$ = "+" then n = n + n1
206.     if add_oper$ = "-" then n = n - n1
207.     gosub push
208.   wend
209.   return
210.  
211. addexprhlp:
212.   gosub getsym
213.   gosub term
214.   gosub pop
215.   n1 = n
216.   gosub pop
217.   return
218.  
219. term:
220.   gosub factor
221.   while tok$ = "*" or tok$ = "/"
222.     mul_oper$ = tok$
223.     gosub termhlp
224.     if mul_oper$ = "*" then n = n * n1
225.     if mul_oper$ = "/" then n = n / n1
226.     gosub push
227.   wend
228.   return
229.  
230. termhlp:
231.   gosub getsym
232.   gosub factor
233.   gosub pop
234.   n1 = n
235.   gosub pop
236.   return
237.  
238. factor:
239.   if tok$ = "-" then
240.     gosub getsym
241.     gosub factor
242.     gosub pop
243.     n = -n
244.     gosub push
245.     return
246.   end if
247.   if tok$ = "(" then
248.     gosub getsym
249.     gosub expression
250.     if tok$ = ")" then gosub getsym: return
251.     print "expecting ')'": return
252.   end if
253.   if left$(tok$, 1) >= "0" and left$(tok$, 1) <= "9" then
254.     n = num
255.     gosub push
256.     gosub getsym
257.     return
258.   end if
259.   if left$(tok$, 1) >= "a" and left$(tok$, 1) <= "z" then
260.     gosub getvarindex
261.     n = vars(n)
262.     gosub push
263.     gosub getsym
264.     return
265.   end if
266.   print "Unexpected sym "; tok$; " in factor"
267.   return
268.  
269. getvarindex:
270.   if left$(tok$, 1) < "a" or left$(tok$, 1) > "z" then
271.     print "Not a variable"
272.     return
273.   end if
274.   n = asc(left$(tok$, 1)) - asc("a")
275.   return
276.  
277. push:
278.   sp = sp + 1
279.   stack(sp) = n
280.   return
281.  
282. pop:
283.   n = stack(sp)
284.   sp = sp - 1
285.   return
286.  
287. initgetsym:
288.   curline = num
289.   textp = 1
290.   thelin$ = pgm$(curline)
291.   ch$ = " "
292.   gosub getsym
293.   return
294.  
295. skiptoeol:
296.   while ch$ <> ""
297.     gosub getch
298.   wend
299.   gosub getsym
300.   return
301.  
302. getsym:
303.   tok$ = ""
304.   while ch$ <= " " and ch$ <> ""
305.     gosub getch
306.   wend
307.   if ch$ = "" then return
308.  
309.   tok$ = ch$
310.   if instr(",;=+-*/()?", ch$) > 0 then gosub getch: return
311.   if ch$ = "<" then
312.     gosub getch
313.     if ch$ = "=" or ch$ = ">" then
314.       tok$ = tok$ + ch$
315.       gosub getch
316.     end if
317.     return
318.   end if
319.   if ch$ = ">" then
320.     gosub getch
321.     if ch$ = "=" then tok$ = tok$ + ch$: gosub getch
322.     return
323.   end if
324.   if ch$ = chr$(34) then gosub readstr: return
325.   if ch$ >= "a" and ch$ <= "z" then gosub readident: return
326.   if ch$ >= "0" and ch$ <= "9" then gosub readint: return
327.   print "What->"; ch$
328.   return
329.  
330. readstr:
331.   tok$ = chr$(34)
332.   gosub getch
333.   while ch$ <> chr$(34) and ch$ <> ""
334.     tok$ = tok$ + ch$
335.     gosub getch
336.   wend
337.   if ch$ = "" then print "String not terminated": return
338.   gosub getch
339.   return
340.  
341. readint:
342.   tok$ = ""
343.   while ch$ >= "0" and ch$ <= "9"
344.     tok$ = tok$ + ch$
345.     gosub getch
346.   wend
347.   num = val(tok$)
348.   return
349.  
350. readident:
351.   tok$ = ""
352.   while ch$ >= "a" and ch$ <= "z"
353.     tok$ = tok$ + ch$
354.     gosub getch
355.   wend
356.   return
357.  
358. getch:
359.   if textp > len(thelin$) then ch$ = "": return
360.   ch$ = mid$(thelin$, textp, 1)
361.   textp = textp + 1
362.   return
363.  
364.  

[Aurel]

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!

[bplus]

Cant wait to try! :)
Has stepping on/ off! Does it show variable values as stepping?

[Aurel]

I don't try uncomment part of code and check is work or not
i guess...

[bplus]

Finally got around to testing, I tried a recursive gosub for factorial and stepping:
 

 

Nice!

[Aurel]

anyone tried this on Linux ?

[Aurel]

Hello Ed
Do you maybe  made some benchmarks with interpreter?

[Ed Davis]

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.

[Dav]

This is marvelous work, Ed!  Pretty compact interpreter too for what it does.  Well done! 

- Dav

[bplus]

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 :)

[Aurel]

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 !