OpenCores
URL https://opencores.org/ocsvn/cpu8080/cpu8080/trunk

Subversion Repositories cpu8080

[/] [cpu8080/] [trunk/] [project/] [tinybasic.asm] - Blame information for rev 12

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 11 samiam9512
!**************************************************************
2
!*
3
!*                tiny basic for intel 8080
4
!*                      version 1.0
5
!*                    by li-chen wang
6
!*                     10 june, 1976
7
!*                       @copyleft
8
!*                  all wrongs reserved
9
!*
10
!**************************************************************
11
!*
12
!*  !*** zero page subroutines ***
13
!*
14
!*  the 8080 instruction set lets you have 8 routines in low
15
!*  memory that may be called by rst n, n being 0 through 7.
16
!*  this is a one byte instruction and has the same power as
17
!*  the three byte instruction call llhh.  tiny basic will
18
!*  use rst 0 as start and rst 1 through rst 7 for
19
!*  the seven most frequently used subroutines.
20
!*  two other subroutines (crlf and tstnum) are also in this
21
!*  section.  they can be reached only by 3-byte calls.
22
!
23
! Note: this version was extensively damaged to adapt to CP/M,
24
! I am attempting to find other copies to reference to in order
25
! to correct it.
26
!
27
!*
28
       jmp  ninit     ! go main start
29
       alignp 8
30
*
31
       xthl           !*** tstc or rst 1 ***
32
       rst  5         !ignore blanks and
33
       cmp  m         !test character
34
       jmp  tc1       !rest of this is at tc1
35
*
36
crlf:  mvi  a,0dh     !*** crlf ***
37
*
38
       push psw       !*** outc or rst 2 ***
39
       lda  ocsw      !print character only
40
       ora  a         !iff ocsw switch is on
41
       jmp  oc2       !rest of this is at oc2
42
*
43
       call expr2     !*** expr or rst 3 ***
44
       push h         !evaluate an expresion
45
       jmp  expr1     !rest of it is at expr1
46
       defb 'w'
47
*
48
       mov  a,h       !*** comp or rst 4 ***
49
       cmp  d         !compare hl with de
50
       rnz            !return correct c and
51
       mov  a,l       !z flags
52
       cmp  e         !but old a is lost
53
       ret
54
       defb 'an'
55
*
56
ss1:   ldax d         !*** ignblk/rst 5 ***
57
       cpi  40q       !ignore blanks
58
       rnz            !in text (where de->)
59
       inx  d         !and return the first
60
       jmp  ss1       !non-blank char. in a
61
*
62
       pop  psw       !*** finish/rst 6 ***
63
       call fin       !check end of command
64
       jmp  qwhat     !print "what?" iff wrong
65
       defb 'g'
66
*
67
       rst  5         !*** tstv or rst 7 ***
68
       sui  100q      !test variables
69
       rc             !c:not a variable
70
*
71
tstv1: jnz  tv1       !not "@" array
72
       inx  d         !it is the "@" array
73
       call parn      !@ should be followed
74
       dad  h         !by (expr) as its index
75
       jc   qhow      !is index too big?
76
       push d         !will it overwrite
77
       xchg           !text?
78
       call size      !find size of free
79
       rst  4         !and check that
80
       jc   asorry    !iff so, say "sorry"
81
ss1a:  lxi  h,varbgn  !iff not, get address
82
       call subde     !of @(expr) and put it
83
       pop  d         !in hl
84
       ret            !c flag is cleared
85
tv1:   cpi  33q       !not @, is it a to z?
86
       cmc            !iff not return c flag
87
       rc
88
       inx  d         !iff a through z
89
tv1a:  lxi  h,varbgn  !compute address of
90
       rlc            !that variable
91
       add  l         !and return it in hl
92
       mov  l,a       !with c flag cleared
93
       mvi  a,0
94
       adc  h
95
       mov  h,a
96
       ret
97
!*
98
!*                 tstc   xch  hl,(sp)   !*** tstc or rst 1 ***
99
!*                        ignblk         this is at loc. 8
100
!*                        cmp  m         and then jmp here
101
tc1:   inx  h         !compare the byte that
102
       jz   tc2       !follows the rst inst.
103
       push b         !with the text (de->)
104
       mov  c,m       !iff not =, add the 2nd
105
       mvi  b,0       !byte that follows the
106
       dad  b         !rst to the old pc
107
       pop  b         !i.e., do a relative
108
       dcx  d         !jump iff not =
109
tc2:   inx  d         !iff =, skip those bytes
110
       inx  h         !and continue
111
       xthl
112
       ret
113
!*
114
tstnum:lxi  h,0       !*** tstnum ***
115
       mov  b,h       !test iff the text is
116
       rst  5         !a number
117
tn1:   cpi  60q       !iff not, return 0 in
118
       rc             !b and hl
119
       cpi  72q       !iff numbers, convert
120
       rnc            !to binary in hl and
121
       mvi  a,360q    !set a to # of digits
122
       ana  h         !iff h>255, there is no
123
       jnz  qhow      !room for next digit
124
       inr  b         !b counts # of digits
125
       push b
126
       mov  b,h       !hl=10!*hl+(new digit)
127
       mov  c,l
128
       dad  h         !where 10!* is done by
129
       dad  h         !shift and add
130
       dad  b
131
       dad  h
132
       ldax d         !and (digit) is from
133
       inx  d         !stripping the ascii
134
       ani  17q       !code
135
       add  l
136
       mov  l,a
137
       mvi  a,0
138
       adc  h
139
       mov  h,a
140
       pop  b
141
       ldax d         !do this digit after
142
       jp   tn1       !digit. s says overflow
143
qhow:  push d         !*** error: "how?" ***
144
ahow:  lxi  d,how
145
       jmp  error
146
how:   defb 'how?',0dh
147
ok:    defb 'ok',0dh
148
what:  defb 'what?',0dh
149
sorry: defb 'sorry',0dh
150
!*
151
!**************************************************************
152
!*
153
!* *** main ***
154
!*
155
!* this is the main loop that collects the tiny basic program
156
!* and stores it in the memory.
157
!*
158
!* at start, it prints out "(cr)ok(cr)", and initializes the
159
!* stack and some other internal variables.  then it prompts
160
!* ">" and reads a line.  iff the line starts with a non-zero
161
!* number, this number is the line number.  the line number
162
!* (in 16 bit binary) and the rest of the line (including cr)
163
!* is stored in the memory.  iff a line with the same line
164
!* number is alredy there, it is replaced by the new one.  if
165
!* the rest of the line consists of a 0dhonly, it is not stored
166
!* and any existing line with the same line number is deleted.
167
!*
168
!* after a line iss inserted, replaced, or deleted, the program
169
!* loops back and ask for another line.  this loop will be
170
!* terminated when it reads a line with zero or no line
171
!* number! and control is transfered to "dirct".
172
!*
173
!* tiny basic program save area starts at the memory location
174
!* labeled "txtbgn" and ended at "txtend".  we always fill this
175
!* area starting at "txtbgn", the unfilled portion is pointed
176
!* by the content of a memory location labeled "txtunf".
177
!*
178
!* the memory location "currnt" points to the line number
179
!* that is currently being interpreted.  while we are in
180
!* this loop or while we are interpreting a direct command
181
!* (see next section), "currnt" should point to a 0.
182
!*
183
rstart:lxi  sp,stack  !set stack pointer
184
st1:   call crlf      !and jump to here
185
       lxi  d,ok      !de->string
186
       sub  a         !a=0
187
       call prtstg    !print string until 0dh
188
       lxi  h,st2+1   !literal 0
189
       shld currnt    !currnt->line # = 0
190
st2:   lxi  h,0
191
       shld lopvar
192
       shld stkgos
193
st3:   mvi  a,76q     !prompt '>' and
194
       call getln     !read a line
195
       push d         !de->end of line
196
st3a:  lxi  d,buffer  !de->beginning of line
197
       call tstnum    !test iff it is a number
198
       rst  5
199
       mov  a,h       !hl=value of the # or
200
       ora  l         !0 iff no # was found
201
       pop  b         !bc->end of line
202
       jz   direct
203
       dcx  d         !backup de and save
204
       mov  a,h       !value of line # there
205
       stax d
206
       dcx  d
207
       mov  a,l
208
       stax d
209
       push b         !bc,de->begin, end
210
       push d
211
       mov  a,c
212
       sub  e
213
       push psw       !a=# of bytes in line
214
       call fndln     !find this line in save
215
       push d         !area, de->save area
216
       jnz  st4       !nz:not found, insert
217
       push d         !z:found, delete it
218
       call fndnxt    !find next line
219
!*                                       de->next line
220
       pop  b         !bc->line to be deleted
221
       lhld txtunf    !hl->unfilled save area
222
       call mvup      !move up to delete
223
       mov  h,b       !txtunf->unfilled area
224
       mov  l,c
225
       shld txtunf    !update
226
st4:   pop  b         !get ready to insert
227
       lhld txtunf    !but firt check if
228
       pop  psw       !the length of new line
229
       push h         !is 3 (line # and cr)
230
       cpi  3         !then do not insert
231
       jz   rstart    !must clear the stack
232
       add  l         !compute new txtunf
233
       mov  l,a
234
       mvi  a,0
235
       adc  h
236
       mov  h,a       !hl->new unfilled area
237
st4a:  lxi  d,txtend  !check to see if there
238
       rst  4         !is enough space
239
       jnc  qsorry    !sorry, no room for it
240
       shld txtunf    !ok, update txtunf
241
       pop  d         !de->old unfilled area
242
       call mvdown
243
       pop  d         !de->begin, hl->end
244
       pop  h
245
       call mvup      !move new line to save
246
       jmp  st3       !area
247
!*
248
!**************************************************************
249
!*
250
!* *** tables *** direct *** & exec ***
251
!*
252
!* this section of the code tests a string against a table.
253
!* when a match is found, control is transfered to the section
254
!* of code according to the table.
255
!*
256
!* at 'exec', de should point to the string ad hl should point
257
!* to the table-1.  at 'direct', de should point to the string,
258
!* hl will be set up to point to tab1-1, which is the table of
259
!* all direct and statement commands.
260
!*
261
!* a '.' in the string will terminate the test and the partial
262
!* match will be considered as a match.  e.g., 'p.', 'pr.',
263
!* 'pri.', 'prin.', or 'print' will all match 'print'.
264
!*
265
!* the table consists of any number of items.  each item
266
!* is a string of characters with bit 7 set to 0 and
267
!* a jump address stored hi-low with bit 7 of the high
268
!* byte set to 1.
269
!*
270
!* end of table is an item with a jump address only.  iff the
271
!* string does not match any of the other items, it will
272
!* match this null item as default.
273
!*
274
tab1:  equ  $         !direct commands
275
       defb 'list'
276
       defb list shr 8 + 128,list and 0ffh
277
       defb 'run'
278
       defb run shr 8 + 128,run and 255
279
       defb 'new'
280
       defb new shr 8 + 128,new and 255
281
       defb 'load'
282
       defb dload shr 8 + 128,dload and 255
283
       defb 'save'
284
       defb dsave shr 8 + 128,dsave and 255
285
       defb 'bye',80h,0h   !go back to cpm
286
tab2:  equ  $         !direct/tatement
287
       defb 'next'
288
       defb next shr 8 + 128,next and 255
289
       defb 'let'
290
       defb let shr 8 + 128,let and 255
291
       defb 'out'
292
       defb outcmd shr 8 + 128,outcmd and 255
293
       defb 'poke'
294
       defb poke shr 8 + 128,poke and 255
295
       defb 'wait'
296
       defb waitcm shr 8 + 128,waitcm and 255
297
       defb 'if'
298
       defb iff shr 8 + 128,iff and 255
299
       defb 'goto'
300
       defb goto shr 8 + 128,goto and 255
301
       defb 'gosub'
302
       defb gosub shr 8 + 128,gosub and 255
303
       defb 'return'
304
       defb return shr 8 + 128,return and 255
305
       defb 'rem'
306
       defb rem shr 8 + 128,rem and 255
307
       defb 'for'
308
       defb for shr 8 + 128,for and 255
309
       defb 'input'
310
       defb input shr 8 + 128,input and 255
311
       defb 'print'
312
       defb print shr 8 + 128,print and 255
313
       defb 'stop'
314
       defb stop shr 8 + 128,stop and 255
315
       defb deflt shr 8 + 128,deflt and 255
316
       defb 'you can add more' !commands but
317
            !remember to move default down.
318
tab4:  equ  $         !functions
319
       defb 'rnd'
320
       defb rnd shr 8 + 128,rnd and 255
321
       defb 'inp'
322
       defb inp shr 8 + 128,inp and 255
323
       defb 'peek'
324
       defb peek shr 8 + 128,peek and 255
325
       defb 'usr'
326
       defb usr shr 8 + 128,usr and 255
327
       defb 'abs'
328
       defb abs shr 8 + 128,abs and 255
329
       defb 'size'
330
       defb size shr 8 + 128,size and 255
331
       defb xp40 shr 8 + 128,xp40 and 255
332
       defb 'you can add more' !functions but remember
333
                      !to move xp40 down
334
tab5:  equ  $         !"to" in "for"
335
       defb 'to'
336
       defb fr1 shr 8 + 128,fr1 and 255
337
       defb qwhat shr 8 + 128,qwhat and 255
338
tab6:  equ  $         !"step" in "for"
339
       defb 'step'
340
       defb fr2 shr 8 + 128,fr2 and 255
341
       defb fr3 shr 8 + 128,fr3 and 255
342
tab8:  equ  $         !relation operators
343
       defb '>='
344
       defb xp11 shr 8 + 128,xp11 and 255
345
       defb '#'
346
       defb xp12 shr 8 + 128,xp12 and 255
347
       defb '>'
348
       defb xp13 shr 8 + 128,xp13 and 255
349
       defb '='
350
       defb xp15 shr 8 + 128,xp15 and 255
351
       defb '<='
352
       defb xp14 shr 8 + 128,xp14 and 255
353
       defb '<'
354
       defb xp16 shr 8 + 128,xp16 and 255
355
       defb xp17 shr 8 + 128,xp17 and 255
356
!*
357
direct:lxi  h,tab1-1  !*** direct ***
358
!*
359
exec:  equ  $         !*** exec ***
360
ex0:   rst  5         !ignore leading blanks
361
       push d         !save pointer
362
ex1:   ldax d         !iff found '.' in string
363
       inx  d         !before any mismatch
364
       cpi  56q       !we declare a match
365
       jz   ex3
366
       inx  h         !hl->table
367
       cmp  m         !iff match, test next
368
       jz   ex1
369
       mvi  a,177q    !else, see iff bit 7
370
       dcx  d         !of tableis set, which
371
       cmp  m         !is the jump addr. (hi)
372
       jc   ex5       !c:yes, matched
373
ex2:   inx  h         !nc:no, find jump addr.
374
       cmp  m
375
       jnc  ex2
376
       inx  h         !bump to next tab. item
377
       pop  d         !restore string pointer
378
       jmp  ex0       !test against next item
379
ex3:   mvi  a,177q    !partial match, find
380
ex4:   inx  h         !jump addr., which is
381
       cmp  m         !flagged by bit 7
382
       jnc  ex4
383
ex5:   mov  a,m       !load hl with the jump
384
       inx  h         !address from the table
385
       mov  l,m
386
       ani  177q      !mask off bit 7
387
       mov  h,a
388
       pop  psw       !clean up the gabage
389
       pchl           !and we go do it
390
!*
391
!**************************************************************
392
!*
393
!* what follows is the code to execute direct and statement
394
!* commands.  control is transfered to these points via the
395
!* command table lookup code of 'direct' and 'exec' in last
396
!* section.  after the command is executed, control is
397
!* tansfered to other sections as follows:
398
!*
399
!* for 'list', 'new', and 'stop': go back to 'rstart'
400
!* for 'run': go execute the first stored line iff any! else
401
!* go back to 'rstart'.
402
!* for 'goto' and 'gosub': go execute the target line.
403
!* for 'return' and 'next': go back to saved return line.
404
!* for all others: iff 'currnt' -> 0, go to 'rstart', else
405
!* go execute next command.  (this is done in 'finish'.)
406
!*
407
!**************************************************************
408
!*
409
!* *** new *** stop *** run (& friends) *** & goto ***
410
!*
411
!* 'new(cr)' sets 'txtunf' to point to 'txtbgn'
412
!*
413
!* 'stop(cr)' goes back to 'rstart'
414
!*
415
!* 'run(cr)' finds the first stored line, store its address (in
416
!* 'currnt'), and start execute it.  note that only those
417
!* commands in tab2 are legal for stored program.
418
!*
419
!* there are 3 more entries in 'run':
420
!* 'runnxl' finds next line, stores its addr. and executes it.
421
!* 'runtsl' stores the address of this line and executes it.
422
!* 'runsml' continues the execution on same line.
423
!*
424
!* 'goto expr(cr)' evaluates the expression, find the target
425
!* line, and jump to 'runtsl' to do it.
426
!* 'dload' loads a named program from disk.
427
!* 'dsave' saves a named program on disk.
428
!* 'fcbset' sets up the file control block for subsequent disk i/o.
429
!*
430
new:   call endchk    !*** new(cr) ***
431
       lxi  h,txtbgn
432
       shld txtunf
433
!*
434
stop:  call endchk    !*** stop(cr) ***
435
       jmp rstart
436
!*
437
run:   call endchk    !*** run(cr) ***
438
       lxi  d,txtbgn  !first saved line
439
!*
440
runnxl:lxi  h,0       !*** runnxl ***
441
       call fndlnp    !find whatever line #
442
       jc   rstart    !c:passed txtunf, quit
443
!*
444
runtsl:xchg           !*** runtsl ***
445
       shld currnt    !set 'currnt'->line #
446
       xchg
447
       inx  d         !bump pass line #
448
       inx  d
449
!*
450
runsml:call chkio     !*** runsml ***
451
       lxi  h,tab2-1  !find command in tab2
452
       jmp  exec      !and execute it
453
!*
454
goto:  rst  3         !*** goto expr ***
455
       push d         !save for error routine
456
       call endchk    !must find a 0dh
457
       call fndln     !find the target line
458
       jnz  ahow      !no such line #
459
       pop  psw       !clear the "push de"
460
       jmp  runtsl    !go do it
461
cpm:   equ  5         !disk parameters
462
fcb:   equ  5ch
463
setdma:equ  26
464
open:  equ  15
465
readd: equ  20
466
writed:equ  21
467
close: equ  16
468
make:  equ  22
469
delete:equ  19
470
!*
471
dload: rst  5         !ignore blanks
472
       push h         !save h
473
       call fcbset    !set up file control block
474
       push d         !save the rest
475
       push b
476
       lxi  d,fcb     !get fcb address
477
       mvi  c,open    !prepare to open file
478
       call cpm       !open it
479
       cpi  0ffh      !is it there?
480
       jz   qhow      !no, send error
481
       xra  a         !clear a
482
       sta  fcb+32    !start at record 0
483
       lxi  d,txtunf  !get beginning
484
load:  push d         !save dma address
485
       mvi  c,setdma  !
486
       call cpm       !set dma address
487
       mvi  c,readd   !
488
       lxi  d,fcb
489
       call cpm       !read sector
490
       cpi  1         !done?
491
       jc   rdmore    !no, read more
492
       jnz  qhow      !bad read
493
       mvi  c,close
494
       lxi  d,fcb
495
       call cpm       !close file
496
       pop  d         !throw away dma add.
497
       pop  b         !get old registers back
498
       pop  d
499
       pop  h
500
       rst  6         !finish
501
rdmore:pop  d         !get dma address
502
       lxi  h,80h     !get 128
503
       dad  d         !add 128 to dma add.
504
       xchg           !put it back in d
505
       jmp  load      !and read some more
506
!*
507
dsave: rst  5         !ignore blanks
508
       push h         !save h
509
       call fcbset    !setup fcb
510
       push d
511
       push b         !save others
512
       lxi  d,fcb
513
       mvi  c,delete
514
       call cpm       !erase file if it exists
515
       lxi  d,fcb
516
       mvi  c,make
517
       call cpm       !make a new one
518
       cpi  0ffh      !is there space?
519
       jz   qhow      !no, error
520
       xra  a         !clear a
521
       sta  fcb+32    !start at record 0
522
       lxi  d,txtunf  !get beginning
523
save:  push d         !save dma address
524
       mvi  c,setdma  !
525
       call cpm       !set dma address
526
       mvi  c,writed
527
       lxi  d,fcb
528
       call cpm       !write sector
529
       ora  a         !set flags
530
       jnz  qhow      !if not zero, error
531
       pop  d         !get dma add. back
532
       lda  txtunf+1  !and msb of last add.
533
       cmp  d         !is d smaller?
534
       jc   savdon    !yes, done
535
       jnz  writmor   !dont test e if not equal
536
       lda  txtunf    !is e smaller?
537
       cmp  e
538
       jc   savdon    !yes, done
539
writmor:lxi  h,80h
540
       dad  d         !add 128 to dma add.
541
       xchg           !get it back in d
542
       jmp  save      !write some more
543
savdon:mvi  c,close
544
       lxi  d,fcb
545
       call cpm       !close file
546
       pop  b         !get registers back
547
       pop  d
548
       pop  h
549
       rst  6         !finish
550
!*
551
fcbset:lxi  h,fcb     !get file control block address
552
       mvi  m,0       !clear entry type
553
fnclr: inx  h         !next location
554
       mvi  m,' '     !clear to space
555
       mvi  a,fcb+8 and 255
556
       cmp  l         !done?
557
       jnz  fnclr     !no, do it again
558
       inx  h         !next
559
       mvi  m,'t'     !set file type to 'tbi'
560
       inx  h
561
       mvi  m,'b'
562
       inx  h
563
       mvi  m,'i'
564
exrc:  inx  h         !clear rest of fcb
565
       mvi  m,0
566
       mvi  a,fcb+15 and 255
567
       cmp  l         !done?
568
       jnz  exrc      !no, continue
569
       lxi  h,fcb+1   !get filename start
570
fn:    ldax d         !get character
571
       cpi  0dh       !is it a 'cr'
572
       rz             !yes, done
573
       cpi  '!'       !legal character?
574
       jc   qwhat     !no, send error
575
       cpi  '['       !again
576
       jnc  qwhat     !ditto
577
       mov  m,a        !save it in fcb
578
       inx  h         !next
579
       inx  d
580
       mvi  a,fcb+9 and 255
581
       cmp  l         !last?
582
       jnz  fn        !no, continue
583
       ret            !truncate at 8 characters
584
!*
585
!*************************************************************
586
!*
587
!* *** list *** & print ***
588
!*
589
!* list has two forms:
590
!* 'list(cr)' lists all saved lines
591
!* 'list #(cr)' start list at this line #
592
!* you can stop the listing by control c key
593
!*
594
!* print command is 'print ....!' or 'print ....(cr)'
595
!* where '....' is a list of expresions, formats, back-
596
!* arrows, and strings.  these items are seperated by commas.
597
!*
598
!* a format is a pound sign followed by a number.  it controlss
599
!* the number of spaces the value of a expresion is going to
600
!* be printed.  it stays effective for the rest of the print
601
!* command unless changed by another format.  iff no format is
602
!* specified, 6 positions will be used.
603
!*
604
!* a string is quoted in a pair of single quotes or a pair of
605
!* double quotes.
606
!*
607
!* a back-arrow means generate a (cr) without (lf)
608
!*
609
!* a (crlf) is generated after the entire list has been
610
!* printed or iff the list is a null list.  however iff the list
611
!* ended with a comma, no (crl) is generated.
612
!*
613
list:  call tstnum    !test iff there is a #
614
       call endchk    !iff no # we get a 0
615
       call fndln     !find this or next line
616
ls1:   jc   rstart    !c:passed txtunf
617
       call prtln     !print the line
618
       call chkio     !stop iff hit control-c
619
       call fndlnp    !find next line
620
       jmp  ls1       !and loop back
621
!*
622
print: mvi  c,6       !c = # of spaces
623
       rst  1         !iff null list & "!"
624
       defb 73q
625
       defb 6q
626
       call crlf      !give cr-lf and
627
       jmp  runsml    !continue same line
628
pr2:   rst  1         !iff null list (cr)
629
       defb 0dh
630
       defb 6q
631
       call crlf      !also give cr-lf and
632
       jmp  runnxl    !go to next line
633
pr0:   rst  1         !else is it format?
634
       defb '#'
635
       defb 5q
636
       rst  3         !yes, evaluate expr.
637
       mov  c,l       !and save it in c
638
       jmp  pr3       !look for more to print
639
pr1:   call qtstg     !or is it a string?
640
       jmp  pr8       !iff not, must be expr.
641
pr3:   rst  1         !iff ",", go find next
642
       defb ','
643
       defb 6q
644
       call fin       !in the list.
645
       jmp  pr0       !list continues
646
pr6:  call crlf      !list ends
647
       rst  6
648
pr8:   rst  3         !evaluate the expr
649
       push b
650
       call prtnum    !print the value
651
       pop  b
652
       jmp  pr3       !more to print?
653
!*
654
!**************************************************************
655
!*
656
!* *** gosub *** & return ***
657
!*
658
!* 'gosub expr!' or 'gosub expr (cr)' is like the 'goto'
659
!* command, except that the current text pointer, stack pointer
660
!* etc. are save so that execution can be continued after the
661
!* subroutine 'return'.  in order that 'gosub' can be nested
662
!* (and even recursive), the save area must be stacked.
663
!* the stack pointer is saved in 'stkgos'. the old 'stkgos' is
664
!* saved in the stack.  iff we are in the main routine, 'stkgos'
665
!* is zero (this was done by the "main" section of the code),
666
!* but we still save it as a flag forr no further 'return's.
667
!*
668
!* 'return(cr)' undos everyhing that 'gosub' did, and thus
669
!* return the excution to the command after the most recent
670
!* 'gosub'.  iff 'stkgos' is zero, it indicates that we
671
!* never had a 'gosub' and is thus an error.
672
!*
673
gosub: call pusha     !save the current "for"
674
       rst  3         !parameters
675
       push d         !and text pointer
676
       call fndln     !find the target line
677
       jnz  ahow      !not there. say "how?"
678
       lhld currnt    !found it, save old
679
       push h         !'currnt' old 'stkgos'
680
       lhld stkgos
681
       push h
682
       lxi  h,0       !and load new ones
683
       shld lopvar
684
       dad  sp
685
       shld stkgos
686
       jmp  runtsl    !then run that line
687
return:call endchk    !there must be a 0dh
688
       lhld stkgos    !old stack pointer
689
       mov  a,h       !0 means not exist
690
       ora  l
691
       jz   qwhat     !so, we say: "what?"
692
       sphl           !else, restore it
693
       pop  h
694
       shld stkgos    !and the old 'stkgos'
695
       pop  h
696
       shld currnt    !and the old 'currnt'
697
       pop  d         !old text pointer
698
       call popa      !old "for" parameters
699
       rst  6         !and we are back home
700
!*
701
!**************************************************************
702
!*
703
!* *** for *** & next ***
704
!*
705
!* 'for' has two forms:
706
!* 'for var=exp1 to exp2 step exp1' and 'for var=exp1 to exp2'
707
!* the second form means the same thing as the first form with
708
!* exp1=1.  (i.e., with a step of +1.)
709
!* tbi will find the variable var. and set its value to the
710
!* current value of exp1.  it also evaluates expr2 and exp1
711
!* and save all these together with the text pointerr etc. in
712
!* the 'for' save area, which consists of 'lopvar', 'lopinc',
713
!* 'loplmt', 'lopln', and 'loppt'.  iff there is already some-
714
!* thing in the save area (this is indicated by a non-zero
715
!* 'lopvar'), then the old save area is saved in the stack
716
!* before the new one overwrites it.
717
!* tbi will then dig in the stack and find out iff this same
718
!* variable was used in another currently active 'for' loop.
719
!* iff that is the case then the old 'for' loop is deactivated.
720
!* (purged from the stack..)
721
!*
722
!* 'next var' serves as the logical (not necessarilly physical)
723
!* end of the 'for' loop.  the control variable var. is checked
724
!* with the 'lopvar'.  iff they are not the same, tbi digs in
725
!* the stack to find the rightt one and purges all those that
726
!* did not match.  either way, tbi then adds the 'step' to
727
!* that variable and check the result with the limit.  iff it
728
!* is within the limit, control loops back to the command
729
!* following the 'for'.  iff outside the limit, the save arer
730
!* is purged and execution continues.
731
!*
732
for:   call pusha     !save the old save area
733
       call setval    !set the control var.
734
       dcx  h         !hl is its address
735
       shld lopvar    !save that
736
       lxi  h,tab5-1  !use 'exec' to look
737
       jmp  exec      !for the word 'to'
738
fr1:   rst  3         !evaluate the limit
739
       shld loplmt    !save that
740
       lxi  h,tab6-1  !use 'exec' to look
741
       jmp  exec      !for the word 'step'
742
fr2:   rst  3         !found it, get step
743
       jmp  fr4
744
fr3:   lxi  h,1q      !not found, set to 1
745
fr4:   shld lopinc    !save that too
746
fr5:   lhld currnt    !save current line #
747
       shld lopln
748
       xchg           !and text pointer
749
       shld loppt
750
       lxi  b,12q     !dig into stack to
751
       lhld lopvar    !find 'lopvar'
752
       xchg
753
       mov  h,b
754
       mov  l,b       !hl=0 now
755
       dad  sp        !here is the stack
756
       defb 76q
757
fr7:   dad  b         !each level is 10 deep
758
       mov  a,m       !get that old 'lopvar'
759
       inx  h
760
       ora  m
761
       jz   fr8       !0 says no more in it
762
       mov  a,m
763
       dcx  h
764
       cmp  d         !same as this one?
765
       jnz  fr7
766
       mov  a,m       !the other half?
767
       cmp  e
768
       jnz  fr7
769
       xchg           !yes, found one
770
       lxi  h,0q
771
       dad  sp        !try to move sp
772
       mov  b,h
773
       mov  c,l
774
       lxi  h,12q
775
       dad  d
776
       call mvdown    !and purge 10 words
777
       sphl           !in the stack
778
fr8:   lhld loppt     !job done, restore de
779
       xchg
780
       rst  6         !and continue
781
!*
782
next:  rst  7         !get address of var.
783
       jc   qwhat     !no variable, "what?"
784
       shld varnxt    !yes, save it
785
nx0:   push d         !save text pointer
786
       xchg
787
       lhld lopvar    !get var. in 'for'
788
       mov  a,h
789
       ora  l         !0 says never had one
790
       jz   awhat     !so we ask: "what?"
791
       rst  4         !else we check them
792
       jz   nx3       !ok, they agree
793
       pop  d         !no, let's see
794
       call popa      !purge current loop
795
       lhld varnxt    !and pop one level
796
       jmp  nx0       !go check again
797
nx3:   mov  e,m       !come here when agreed
798
       inx  h
799
       mov  d,m       !de=value of var.
800
       lhld lopinc
801
       push h
802
       dad  d         !add one step
803
       xchg
804
       lhld lopvar    !put it back
805
       mov  m,e
806
       inx  h
807
       mov  m,d
808
       lhld loplmt    !hl->limit
809
       pop  psw       !old hl
810
       ora  a
811
       jp   nx1       !step > 0
812
       xchg
813
nx1:   call ckhlde    !compare with limit
814
       pop  d         !restore text pointer
815
       jc   nx2       !outside limit
816
       lhld lopln     !within limit, go
817
       shld currnt    !back to the saved
818
       lhld loppt     !'currnt' and text
819
       xchg           !pointer
820
       rst  6
821
nx2:   call popa      !purge this loop
822
       rst  6
823
!*
824
!**************************************************************
825
!*
826
!* *** rem *** iff *** input *** & let (& deflt) ***
827
!*
828
!* 'rem' can be followed by anything and is ignored by tbi.
829
!* tbi treats it like an 'if' with a false condition.
830
!*
831
!* 'if' is followed by an expr. as a condition and one or more
832
!* commands (including outher 'if's) seperated by semi-colons.
833
!* note that the word 'then' is not used.  tbi evaluates the
834
!* expr. iff it is non-zero, execution continues.  iff the
835
!* expr. is zero, the commands that follows are ignored and
836
!* execution continues at the next line.
837
!*
838
!* 'iput' command is like the 'print' command, and is followed
839
!* by a list of items.  iff the item is a string in single or
840
!* double quotes, or is a back-arrow, it has the same effect as
841
!* in 'print'.  iff an item is a variable, this variable name is
842
!* printed out followed by a colon.  then tbi waits for an
843
!* expr. to be typed in.  the variable iss then set to the
844
!* value of this expr.  iff the variable is proceded by a string
845
!* (again in single or double quotes), the string will be
846
!* printed followed by a colon.  tbi then waits for input expr.
847
!* and set the variable to the value of the expr.
848
!*
849
!* iff the input expr. is invalid, tbi will print "what?",
850
!* "how?" or "sorry" and reprint the prompt and redo the input.
851
!* the execution will not terminate unless you type control-c.
852
!* this is handled in 'inperr'.
853
!*
854
!* 'let' is followed by a list of items seperated by commas.
855
!* each item consists of a variable, an equal sign, and an expr.
856
!* tbi evaluates the expr. and set the varible to that value.
857
!* tb will also handle 'let' command without the word 'let'.
858
!* this is done by 'deflt'.
859
!*
860
rem:   lxi  h,0q      !*** rem ***
861
       defb 76q
862
!*
863
iff:    rst  3         !*** iff ***
864
       mov  a,h       !is the expr.=0?
865
       ora  l
866
       jnz  runsml    !no, continue
867
       call fndskp    !yes, skip rest of line
868
       jnc  runtsl
869
       jmp  rstart
870
!*
871
inperr:lhld stkinp    !*** inperr ***
872
       sphl           !restore old sp
873
       pop  h         !and old 'currnt'
874
       shld currnt
875
       pop  d         !and old text pointer
876
       pop  d         !redo input
877
!*
878
input: equ  $         !*** input ***
879
ip1:   push d         !save in case of error
880
       call qtstg     !is next item a string?
881
       jmp  ip2       !no
882
       rst  7         !yes. but followed by a
883
       jc   ip4       !variable?   no.
884
       jmp  ip3       !yes.  input variable
885
ip2:   push d         !save for 'prtstg'
886
       rst  7         !must be variable now
887
       jc   qwhat     !"what?" it is not?
888
       ldax d         !get ready for 'rtstg'
889
       mov  c,a
890
       sub  a
891
       stax d
892
       pop  d
893
       call prtstg    !print string as prompt
894
       mov  a,c       !restore text
895
       dcx  d
896
       stax d
897
ip3:   push d         !save in case of error
898
       xchg
899
       lhld currnt    !also save 'currnt'
900
       push h
901
       lxi  h,ip1     !a negative number
902
       shld currnt    !as a flag
903
       lxi  h,0q      !save sp too
904
       dad  sp
905
       shld stkinp
906
       push d         !old hl
907
       mvi  a,72q     !print this too
908
       call getln     !and get a line
909
ip3a:  lxi  d,buffer  !points to buffer
910
       rst  3         !evaluate input
911
       nop            !can be 'call endchk'
912
       nop
913
       nop
914
       pop  d         !ok, get old hl
915
       xchg
916
       mov  m,e       !save value in var.
917
       inx  h
918
       mov  m,d
919
       pop  h         !get old 'currnt'
920
       shld currnt
921
       pop  d         !and old text pointer
922
ip4:   pop  psw       !purge junk in stack
923
       rst  1         !is next ch. ','?
924
       defb ','
925
       defb 3q
926
       jmp  ip1       !yes, more items.
927
ip5:   rst  6
928
!*
929
deflt: ldax d         !*** deflt ***
930
       cpi  0dh       !empty line is ok
931
       jz   lt1       !else it is 'let'
932
!*
933
let:   call setval    !*** let ***
934
       rst  1         !set value to var.
935
       defb ','
936
       defb 3q
937
       jmp  let       !item by item
938
lt1:   rst  6         !until finish
939
!*
940
!**************************************************************
941
!*
942
!* *** expr ***
943
!*
944
!* 'expr' evaluates arithmetical or logical expressions.
945
!* ::=
946
!*          
947
!* where  is one of the operatorss in tab8 and the
948
!* result of these operations is 1 iff true and 0 iff false.
949
!* ::=(+ or -)(+ or -)(....)
950
!* where () are optional and (....) are optional repeats.
951
!* ::=(<* or />)(....)
952
!* ::=
953
!*           
954
!*           ()
955
!*  is recursive so that variable '@' can have an 
956
!* as index, fnctions can have an  as arguments, and
957
!*  can be an  in paranthese.
958
!*
959
!*                 expr   call expr2     this is at loc. 18
960
!*                        push hl        save  value
961
expr1: lxi  h,tab8-1  !lookup rel.op.
962
       jmp  exec      !go do it
963
xp11:  call xp18      !rel.op.">="
964
       rc             !no, return hl=0
965
       mov  l,a       !yes, return hl=1
966
       ret
967
xp12:  call xp18      !rel.op."#"
968
       rz             !false, return hl=0
969
       mov  l,a       !true, return hl=1
970
       ret
971
xp13:  call xp18      !rel.op.">"
972
       rz             !false
973
       rc             !also false, hl=0
974
       mov  l,a       !true, hl=1
975
       ret
976
xp14:  call xp18      !rel.op."<="
977
       mov  l,a       !set hl=1
978
       rz             !rel. true, return
979
       rc
980
       mov  l,h       !else set hl=0
981
       ret
982
xp15:  call xp18      !rel.op."="
983
       rnz            !false, retrun hl=0
984
       mov  l,a       !else set hl=1
985
       ret
986
xp16:  call xp18      !rel.op."<"
987
       rnc            !false, return hl=0
988
       mov  l,a       !else set hl=1
989
       ret
990
xp17:  pop  h         !not rel.op.
991
       ret            !return hl=
992
xp18:  mov  a,c       !subroutine for all
993
       pop  h         !rel.op.'s
994
       pop  b
995
       push h         !reverse top of stack
996
       push b
997
       mov  c,a
998
       call expr2     !get 2nd 
999
       xchg           !value in de now
1000
       xthl           !1st  in hl
1001
       call ckhlde    !compare 1st with 2nd
1002
       pop  d         !restore text pointer
1003
       lxi  h,0q      !set hl=0, a=1
1004
       mvi  a,1
1005
       ret
1006
!*
1007
expr2: rst  1         !negative sign?
1008
       defb '-'
1009
       defb 6q
1010
       lxi  h,0q      !yes, fake '0-'
1011
       jmp  xp26      !treat like subtract
1012
xp21:  rst  1         !positive sign?  ignore
1013
       defb '+'
1014
       defb 0q
1015
xp22:  call expr3     !1st 
1016
xp23:  rst  1         !add?
1017
       defb '+'
1018
       defb 25q
1019
       push h         !yes, save value
1020
       call expr3     !get 2nd
1021
xp24:  xchg           !2nd in de
1022
       xthl           !1st in hl
1023
       mov  a,h       !compare sign
1024
       xra  d
1025
       mov  a,d
1026
       dad  d
1027
       pop  d         !restore text pointer
1028
       jm   xp23      !1st 2nd sign differ
1029
       xra  h         !1st 2nd sign equal
1030
       jp   xp23      !so isp result
1031
       jmp  qhow      !else we have overflow
1032
xp25:  rst  1         !subtract?
1033
       defb '-'
1034
       defb 203q
1035
xp26:  push h         !yes, save 1st 
1036
       call expr3     !get 2nd 
1037
       call chgsgn    !negate
1038
       jmp  xp24      !and add them
1039
!*
1040
expr3: call expr4     !get 1st 
1041
xp31:  rst  1         !multiply?
1042
       defb '*'
1043
       defb 54q
1044
       push h         !yes, save 1st
1045
       call expr4     !and get 2nd 
1046
       mvi  b,0q      !clear b for sign
1047
       call chksgn    !check sign
1048
       xchg           !2nd in de now
1049
       xthl           !1st in hl
1050
       call chksgn    !check sign of 1st
1051
       mov  a,h       !is hl > 255 ?
1052
       ora  a
1053
       jz   xp32      !no
1054
       mov  a,d       !yes, how about de
1055
       ora  d
1056
       xchg           !put smaller in hl
1057
       jnz  ahow      !also >, will overflow
1058
xp32:  mov  a,l       !this is dumb
1059
       lxi  h,0q      !clear result
1060
       ora  a         !add and count
1061
       jz   xp35
1062
xp33:  dad  d
1063
       jc   ahow      !overflow
1064
       dcr  a
1065
       jnz  xp33
1066
       jmp  xp35      !finished
1067
xp34:  rst  1         !divide?
1068
       defb '/'
1069
       defb 104q
1070
       push h         !yes, save 1st 
1071
       call expr4     !and get 2nd one
1072
       mvi  b,0q      !clear b for sign
1073
       call chksgn    !check sign of 2nd
1074
       xchg           !put 2nd in de
1075
       xthl           !get 1st in hl
1076
       call chksgn    !check sign of 1st
1077
       mov  a,d       !divide by 0?
1078
       ora  e
1079
       jz   ahow      !say "how?"
1080
       push b         !else save sign
1081
       call divide    !use subroutine
1082
       mov  h,b       !result in hl now
1083
       mov  l,c
1084
       pop  b         !get sign back
1085
xp35:  pop  d         !and text pointer
1086
       mov  a,h       !hl must be +
1087
       ora  a
1088
       jm   qhow      !else it is overflow
1089
       mov  a,b
1090
       ora  a
1091
       cm   chgsgn    !change sign iff needed
1092
       jmp  xp31      !look or more terms
1093
!*
1094
expr4: lxi  h,tab4-1  !find function in tab4
1095
       jmp  exec      !and go do it
1096
xp40:  rst  7         !no, not a function
1097
       jc   xp41      !nor a variable
1098
       mov  a,m       !variable
1099
       inx  h
1100
       mov  h,m       !value in hl
1101
       mov  l,a
1102
       ret
1103
xp41:  call tstnum    !or is it a number
1104
       mov  a,b       !# of digit
1105
       ora  a
1106
       rnz            !ok
1107
parn:  rst  1         !no digit, must be
1108
       defb '('
1109
       defb 5q
1110
       rst  3         !"(expr)"
1111
       rst  1
1112
       defb ')'
1113
       defb 1q
1114
xp42:  ret
1115
xp43:  jmp  qwhat     !else say: "what?"
1116
!*
1117
rnd:   call parn      !*** rnd(expr) ***
1118
       mov  a,h       !expr must be +
1119
       ora  a
1120
       jm   qhow
1121
       ora  l         !and non-zero
1122
       jz   qhow
1123
       push d         !save both
1124
       push h
1125
       lhld ranpnt    !get memory as random
1126
       lxi  d,lstrom  !number
1127
       rst  4
1128
       jc   ra1       !wrap around iff last
1129
       lxi  h,start
1130
ra1:   mov  e,m
1131
       inx  h
1132
       mov  d,m
1133
       shld ranpnt
1134
       pop  h
1135
       xchg
1136
       push b
1137
       call divide    !rnd(n)=mod(m,n)+1
1138
       pop  b
1139
       pop  d
1140
       inx  h
1141
       ret
1142
!*
1143
abs:   call parn      !*** abs(expr) ***
1144
       call chksgn    !check sign
1145
       mov  a,h       !note that -32768
1146
       ora  h         !cannot change sign
1147
       jm   qhow      !so say: "how?"
1148
       ret
1149
size:  lhld txtunf    !*** size ***
1150
       push d         !get the number of free
1151
       xchg           !bytes between 'txtunf'
1152
sizea: lxi  h,varbgn  !and 'varbgn'
1153
       call subde
1154
       pop  d
1155
       ret
1156
!*
1157
!*********************************************************
1158
!*
1159
!*   *** out *** inp *** wait *** poke *** peek *** & usr
1160
!*
1161
!*  out i,j(,k,l)
1162
!*
1163
!*  outputs expression 'j' to port 'i', and may be repeated
1164
!*  as in data 'l' to port 'k' as many times as needed
1165
!*  this command modifies !*  this command modifies
1166
!*  this command modify's a small section of code located
1167
!*  just above address 2k
1168
!*
1169
!*  inp (i)
1170
!*
1171
!*  this function returns data read from input port 'i' as
1172
!*  it's value.
1173
!*  it also modifies code just above 2k.
1174
!*
1175
!*  wait i,j,k
1176
!*
1177
!*  this command reads the status of port 'i', exclusive or's
1178
!*  the result with 'k' if there is one, or if not with 0,
1179
!*  and's with 'j' and returns when the result is nonzero.
1180
!*  its modified code is also above 2k.
1181
!*
1182
!*  poke i,j(,k,l)
1183
!*
1184
!*  this command works like out except that it puts data 'j'
1185
!*  into memory location 'i'.
1186
!*
1187
!*  peek (i)
1188
!*
1189
!*  this function works like inp except it gets it's value
1190
!*  from memory location 'i'.
1191
!*
1192
!*  usr (i(,j))
1193
!*
1194
!*  usr calls a machine language subroutine at location 'i'
1195
!*  if the optional parameter 'j' is used its value is passed
1196
!*  in h&l.  the value of the function should be returned in h&l.
1197
!*
1198
!************************************************************
1199
!*
1200
outcmd:rst  3
1201
       mov  a,l
1202
       sta  outio + 1
1203
       rst  1
1204
       defb ','
1205
       defb 2fh
1206
       rst  3
1207
       mov  a,l
1208
       call outio
1209
       rst  1
1210
       defb ','
1211
       defb 03h
1212
       jmp  outcmd
1213
       rst  6
1214
waitcm:rst  3
1215
       mov  a,l
1216
       sta  waitio + 1
1217
       rst  1
1218
       defb ','
1219
       defb 1bh
1220
       rst  3
1221
       push h
1222
       rst  1
1223
       defb ','
1224
       defb 7h
1225
       rst  3
1226
       mov  a,l
1227
       pop  h
1228
       mov  h,a
1229
       jmp  $ + 2
1230
       mvi  h,0
1231
       jmp  waitio
1232
inp:   call parn
1233
       mov  a,l
1234
       sta  inpio + 1
1235
       mvi  h,0
1236
       jmp  inpio
1237
       jmp  qwhat
1238
poke:  rst  3
1239
       push h
1240
       rst  1
1241
       defb ','
1242
       defb 12h
1243
       rst  3
1244
       mov  a,l
1245
       pop  h
1246
       mov  m,a
1247
       rst  1
1248
       defb ',',03h
1249
       jmp  poke
1250
       rst 6
1251
peek:  call parn
1252
       mov  l,m
1253
       mvi  h,0
1254
       ret
1255
       jmp  qwhat
1256
usr:   push b
1257
       rst  1
1258
       defb '(',28d    !qwhat
1259
       rst  3          !expr
1260
       rst  1
1261
       defb ')',7      !pasparm
1262
       push d
1263
       lxi  d,usret
1264
       push d
1265
       push h
1266
       ret             !call usr routine
1267
pasprm:rst  1
1268
       defb ',',14d
1269
       push h
1270
       rst  3
1271
       rst  1
1272
       defb ')',9
1273
       pop  b
1274
       push d
1275
       lxi  d,usret
1276
       push d
1277
       push b
1278
       ret             !call usr routine
1279
usret: pop  d
1280
       pop  b
1281
       ret
1282
       jmp  qwhat
1283
!*
1284
!**************************************************************
1285
!*
1286
!* *** divide *** subde *** chksgn *** chgsgn *** & ckhlde ***
1287
!*
1288
!* 'divide' divides hl by de, result in bc, remainder in hl
1289
!*
1290
!* 'subde' subtracts de from hl
1291
!*
1292
!* 'chksgn' checks sign of hl.  iff +, no change.  iff -, change
1293
!* sign and flip sign of b.
1294
!*
1295
!* 'chgsgn' chnges sign of hl and b unconditionally.
1296
!*
1297
!* 'ckhle' checks sign of hl and de.  iff different, hl and de
1298
!* are interchanged.  iff same sign, not interchanged.  either
1299
!* case, hl de are then compared to set the flags.
1300
!*
1301
divide:push h         !*** divide ***
1302
       mov  l,h       !divide h by de
1303
       mvi  h,0
1304
       call dv1
1305
       mov  b,c       !save result in b
1306
       mov  a,l       !(remainder+l)/de
1307
       pop  h
1308
       mov  h,a
1309
dv1:   mvi  c,377q    !result in c
1310
dv2:   inr  c         !dumb routine
1311
       call subde     !divide by subtract
1312
       jnc  dv2       !and count
1313
       dad  d
1314
       ret
1315
!*
1316
subde: mov  a,l       !*** subde ***
1317
       sub  e         !subtract de from
1318
       mov  l,a       !hl
1319
       mov  a,h
1320
       sbb  d
1321
       mov  h,a
1322
       ret
1323
!*
1324
chksgn:mov  a,h       !*** chksgn ***
1325
       ora  a         !check sign of hl
1326
       rp             !iff -, change sign
1327
!*
1328
chgsgn:mov  a,h       !*** chgsgn ***
1329
       cma            !change sign of hl
1330
       mov  h,a
1331
       mov  a,l
1332
       cma
1333
       mov  l,a
1334
       inx  h
1335
       mov  a,b       !and also flip b
1336
       xri  200q
1337
       mov  b,a
1338
       ret
1339
!*
1340
ckhlde:mov  a,h
1341
       xra  d         !same sign?
1342
       jp   ck1       !yes, compare
1343
       xchg           !no, xch and comp
1344
ck1:   rst  4
1345
       ret
1346
!*
1347
!**************************************************************
1348
!*
1349
!* *** setval *** fin *** endchk *** & error (& friends) ***
1350
!*
1351
!* "setval" expects a variable, followed by an equal sign and
1352
!* then an expr.  it evaluates the expr. and set the variable
1353
!* to that value.
1354
!*
1355
!* "fin" checks the end of a command.  iff it ended with "!",
1356
!* execution continues.  iff it ended with a cr, it finds the
1357
!* next line and continue from there.
1358
!*
1359
!* "endchk" checks iff a command is ended with cr.  this is
1360
!* required in certain commands. (goto, return, and stop etc.)
1361
!*
1362
!* "error" prints the string pointed by de (and ends with cr).
1363
!* it then prints the line pointed by 'currnt' with a "?"
1364
!* inserted at where the old text pointer (should be on top
1365
!* o the stack) points to.  execution of tb is stopped
1366
!* and tbi is restarted.  however, iff 'currnt' -> zero
1367
!* (indicating a direct command), the direct command is not
1368
!*  printed.  and iff 'currnt' -> negative # (indicating 'input'
1369
!* command, the input line is not printed and execution is
1370
!* not terminated but continued at 'inperr'.
1371
!*
1372
!* related to 'error' are the following:
1373
!* 'qwhat' saves text pointer in stack and get message "what?"
1374
!* 'awhat' just get message "what?" and jump to 'error'.
1375
!* 'qsorry' and 'asorry' do same kind of thing.
1376
!* 'qhow' and 'ahow' in the zero page section also do this
1377
!*
1378
setval:rst  7         !*** setval ***
1379
       jc   qwhat     !"what?" no variable
1380
       push h         !save address of var.
1381
       rst  1         !pass "=" sign
1382
       defb '='
1383
       defb 10q
1384
       rst  3         !evaluate expr.
1385
       mov  b,h       !value in bc now
1386
       mov  c,l
1387
       pop  h         !get address
1388
       mov  m,c       !save value
1389
       inx  h
1390
       mov  m,b
1391
       ret
1392
sv1:   jmp  qwhat     !no "=" sign
1393
!*
1394
fin:   rst  1         !*** fin ***
1395
       defb 73q
1396
       defb 4q
1397
       pop  psw       !"!", purge ret addr.
1398
       jmp  runsml    !continue same line
1399
fi1:   rst  1         !not "!", is it cr?
1400
       defb 0dh
1401
       defb 4q
1402
       pop  psw       !yes, purge ret addr.
1403
       jmp  runnxl    !run next line
1404
fi2:   ret            !else return to caller
1405
!*
1406
endchk:rst  5         !*** endchk ***
1407
       cpi  0dh       !end with cr?
1408
       rz             !ok, else say: "what?"
1409
!*
1410
qwhat: push d         !*** qwhat ***
1411
awhat: lxi  d,what    !*** awhat ***
1412
error: sub  a         !*** error ***
1413
       call prtstg    !print 'what?', 'how?'
1414
       pop  d         !or 'sorry'
1415
       ldax d         !save the character
1416
       push psw       !at where old de ->
1417
       sub  a         !and put a 0 there
1418
       stax d
1419
       lhld currnt    !get current line #
1420
       push h
1421
       mov  a,m       !check the value
1422
       inx  h
1423
       ora  m
1424
       pop  d
1425
       jz   rstart    !iff zero, just rerstart
1426
       mov  a,m       !iff negative,
1427
       ora  a
1428
       jm   inperr    !redo input
1429
       call prtln     !else print the line
1430
       dcx  d         !upto where the 0 is
1431
       pop  psw       !restore the character
1432
       stax d
1433
       mvi  a,77q     !printt a "?"
1434
       rst  2
1435
       sub  a         !and the rest of the
1436
       call prtstg    !line
1437
       jmp  rstart
1438
qsorry:push d         !*** qsorry ***
1439
asorry:lxi  d,sorry   !*** asorry ***
1440
       jmp  error
1441
!*
1442
!**************************************************************
1443
!*
1444
!* *** getln *** fndln (& friends) ***
1445
!*
1446
!* 'getln' reads a input line into 'buffer'.  it first prompt
1447
!* the character in a (given by the caller), then it fills the
1448
!* the buffer and echos.  it ignores lf's and nulls, but still
1449
!* echos them back.  rub-out is used to cause it to delete
1450
!* the last charater (iff there is one), and alt-mod is used to
1451
!* cause it to delete the whole line and start it all over.
1452
!* 0dhsignals the end of a line, and caue 'getln' to return.
1453
!*
1454
!* 'fndln' finds a line with a given line # (in hl) in the
1455
!* text save area.  de is used as the text pointer.  iff the
1456
!* line is found, de will point to the beginning of that line
1457
!* (i.e., the low byte of the line #), and flags are nc & z.
1458
!* iff that line is not there and a line with a higher line #
1459
!* is found, de points to there and flags are nc & nz.  iff
1460
!* we reached the end of text save are and cannot find the
1461
!* line, flags are c & nz.
1462
!* 'fndln' will initialize de to the beginning of the text save
1463
!* area to start the search.  some other entries of this
1464
!* routine will not initialize de and do the search.
1465
!* 'fndlnp' will start with de and search for the line #.
1466
!* 'fndnxt' will bump de by 2, find a 0dhand then start search.
1467
!* 'fndskp' use de to find a cr, and then strart search.
1468
!*
1469
getln: rst  2         !*** getln ***
1470
       lxi  d,buffer  !prompt and init
1471
gl1:   call chkio     !check keyboard
1472
       jz   gl1       !no input, wait
1473
       cpi  177q      !delete lst character?
1474
       jz   gl3       !yes
1475
       cpi  12q       !ignore lf
1476
       jz   gl1
1477
       ora  a         !ignore null
1478
       jz   gl1
1479
       cpi  134q      !delete the whole line?
1480
       jz   gl4       !yes
1481
       stax d         !else, save input
1482
       inx  d         !and bump pointer
1483
       cpi  15q       !was it cr?
1484
       jnz  gl2       !no
1485
       mvi  a,12q     !yes, get line feed
1486
       rst  2         !call outc and line feed
1487
       ret            !we've got a line
1488
gl2:   mov  a,e       !more free room?
1489
       cpi  bufend and 0ffh
1490
       jnz  gl1       !yes, get next input
1491
gl3:   mov  a,e       !delete last character
1492
       cpi  buffer and 0ffh    !but do we have any?
1493
       jz   gl4       !no, redo whole line
1494
       dcx  d         !yes, backup pointer
1495
       mvi  a,'_'     !and echo a back-space
1496
       rst  2
1497
       jmp  gl1       !go get next input
1498
gl4:   call crlf      !redo entire line
1499
       mvi  a,136q    !cr, lf and up-arrow
1500
       jmp  getln
1501
!*
1502
fndln: mov  a,h       !*** fndln ***
1503
       ora  a         !check sign of hl
1504
       jm   qhow      !it cannt be -
1505
       lxi  d,txtbgn  !init. text pointer
1506
!*
1507
fndlnp:equ  $         !*** fndlnp ***
1508
fl1:   push h         !save line #
1509
       lhld txtunf    !check iff we passed end
1510
       dcx  h
1511
       rst  4
1512
       pop  h         !get line # back
1513
       rc             !c,nz passed end
1514
       ldax d         !we did not, get byte 1
1515
       sub  l         !is this the line?
1516
       mov  b,a       !compare low order
1517
       inx  d
1518
       ldax d         !get byte 2
1519
       sbb  h         !compare high order
1520
       jc   fl2       !no, not there yet
1521
       dcx  d         !else we either found
1522
       ora  b         !it, or it is not there
1523
       ret            !nc,z:found! nc,nz:no
1524
!*
1525
fndnxt:equ  $         !*** fndnxt ***
1526
       inx  d         !find next line
1527
fl2:   inx  d         !just passed byte 1 & 2
1528
!*
1529
fndskp:ldax d         !*** fndskp ***
1530
       cpi  0dh       !try to find 0dh
1531
       jnz  fl2       !keep looking
1532
       inx  d         !found cr, skip over
1533
       jmp  fl1       !check iff end of text
1534
!*
1535
!*************************************************************
1536
!*
1537
!* *** prtstg *** qtstg *** prtnum *** & prtln ***
1538
!*
1539
!* 'prtstg' prints a string pointed by de.  it stops printing
1540
!* and returns to calìer when either a 0dhis printed or when
1541
!* the next byte is the same as what was in a (given by the
1542
!* caller).  old a is stored in b, old b is lost.
1543
!*
1544
!* 'qtstg' looks for a back-arrow, single quote, or double
1545
!* quote.  iff none of these, return to caller.  iff back-arrow,
1546
!* output a 0dhwithout a lf.  iff single or double quote, print
1547
!* the string in the quote and demands a matching unquote.
1548
!* after the printing the next 3 bytes of the caller is skipped
1549
!* over (usually a jump instruction).
1550
!*
1551
!* 'prtnum' prints the number in hl.  leading blanks are added
1552
!* iff needed to pad the number of spaces to the number in c.
1553
!* however, iff the number of digits is larger than the # in
1554
!* c, all digits are printed anyway.  negative sign is also
1555
!* printed and counted in, positive sign is not.
1556
!*
1557
!* 'prtln' prinsra saved text line with line # and all.
1558
!*
1559
prtstg:mov  b,a       !*** prtstg ***
1560
ps1:   ldax d         !get a characterr
1561
       inx  d         !bump pointer
1562
       cmp  b         !same as old a?
1563
       rz             !yes, return
1564
       rst  2         !else print it
1565
       cpi  0dh       !was it a cr?
1566
       jnz  ps1       !no, next
1567
       ret            !yes, return
1568
!*
1569
qtstg: rst  1         !*** qtstg ***
1570
       defb '"'
1571
       defb 17q
1572
       mvi  a,42q     !it is a "
1573
qt1:   call prtstg    !print until another
1574
       cpi  0dh       !was last one a cr?
1575
       pop  h         !return address
1576
       jz   runnxl    !was cr, run next line
1577
qt2:   inx  h         !skip 3 bytes on return
1578
       inx  h
1579
       inx  h
1580
       pchl           !return
1581
qt3:   rst  1         !is it a ' ?
1582
       defb 47q
1583
       defb 5q
1584
       mvi  a,47q     !yes, do same
1585
       jmp  qt1       !as in "
1586
qt4:   rst  1         !is it back-arrow?
1587
       defb 137q
1588
       defb 10q
1589
       mvi  a,215q    !yes, 0dhwithout lf!!
1590
       rst  2         !do it twice to give
1591
       rst  2         !tty enough time
1592
       pop  h         !return address
1593
       jmp  qt2
1594
qt5:   ret            !none of above
1595
!*
1596
prtnum push d         !*** prtnum ***
1597
       lxi  d,12q     !decimal
1598
       push d         !save as a flag
1599
       mov  b,d       !b=sign
1600
       dcr  c         !c=spaces
1601
       call chksgn    !check sign
1602
       jp   pn1       !no sign
1603
       mvi  b,55q     !b=sign
1604
       dcr  c         !'-' takes space
1605
pn1:   push b         !save sign & space
1606
pn2:   call divide    !devide hl by 10
1607
       mov  a,b       !result 0?
1608
       ora  c
1609
       jz   pn3       !yes, we got all
1610
       xthl           !no, save remainder
1611
       dcr  l         !and count space
1612
       push h         !hl is old bc
1613
       mov  h,b       !move result to bc
1614
       mov  l,c
1615
       jmp  pn2       !and divide by 10
1616
pn3:   pop  b         !we got all digits in
1617
pn4:   dcr  c         !the stack
1618
       mov  a,c       !look at space count
1619
       ora  a
1620
       jm   pn5       !no leading blanks
1621
       mvi  a,40q     !leading blanks
1622
       rst  2
1623
       jmp  pn4       !more?
1624
pn5:   mov  a,b       !print sign
1625
       rst  2         !maybe - or null
1626
       mov  e,l       !last remainder in e
1627
pn6:   mov  a,e       !check digit in e
1628
       cpi  12q       !10 is flag for no more
1629
       pop  d
1630
       rz             !iff so, return
1631
       adi  60q         !else convert to ascii
1632
       rst  2         !and print the digit
1633
       jmp  pn6       !go back for more
1634
!*
1635
prtln: ldax d         !*** prtln ***
1636
       mov  l,a       !low order line #
1637
       inx  d
1638
       ldax d         !high order
1639
       mov  h,a
1640
       inx  d
1641
       mvi  c,4q      !print 4 digit line #
1642
       call prtnum
1643
       mvi  a,40q     !followed by a blank
1644
       rst  2
1645
       sub  a         !and then the text
1646
       call prtstg
1647
       ret
1648
!*
1649
!**************************************************************
1650
!*
1651
!* *** mvup *** mvdown *** popa *** & pusha ***
1652
!*
1653
!* 'mvup' moves a block up from here de-> to where bc-> until
1654
!* de = hl
1655
!*
1656
!* 'mvdown' moves a block down from where de-> to where hl->
1657
!* until de = bc
1658
!*
1659
!* 'popa' restores the 'for' loop variable save area from the
1660
!* stack
1661
!*
1662
!* 'pusha' stacks the 'for' loop variable save area into the
1663
!* stack
1664
!*
1665
mvup:  rst  4         !*** mvup ***
1666
       rz             !de = hl, return
1667
       ldax d         !get one byte
1668
       stax b         !move it
1669
       inx  d         !increase both pointers
1670
       inx  b
1671
       jmp  mvup      !until done
1672
!*
1673
mvdown:mov  a,b       !*** mvdown ***
1674
       sub  d         !test iff de = bc
1675
       jnz  md1       !no, go move
1676
       mov  a,c       !maybe, other byte?
1677
       sub  e
1678
       rz             !yes, return
1679
md1:   dcx  d         !else move a byte
1680
       dcx  h         !but first decrease
1681
       ldax d         !both pointers and
1682
       mov  m,a       !then do it
1683
       jmp  mvdown    !loop back
1684
!*
1685
popa:  pop  b         !bc = return addr.
1686
       pop  h         !restore lopvar, but
1687
       shld lopvar    !=0 means no more
1688
       mov  a,h
1689
       ora  l
1690
       jz   pp1       !yep, go return
1691
       pop  h         !nop, restore others
1692
       shld lopinc
1693
       pop  h
1694
       shld loplmt
1695
       pop  h
1696
       shld lopln
1697
       pop  h
1698
       shld loppt
1699
pp1:   push b         !bc = return addr.
1700
       ret
1701
!*
1702
pusha: lxi  h,stklmt  !*** pusha ***
1703
       call chgsgn
1704
       pop  b         !bc=return address
1705
       dad  sp        !is stack near the top?
1706
       jnc  qsorry    !yes, sorry for that.
1707
       lhld lopvar    !else save loop var.s
1708
       mov  a,h       !but iff lopvar is 0
1709
       ora  l         !that will be all
1710
       jz   pu1
1711
       lhld loppt     !else, more to save
1712
       push h
1713
       lhld lopln
1714
       push h
1715
       lhld loplmt
1716
       push h
1717
       lhld lopinc
1718
       push h
1719
       lhld lopvar
1720
pu1:   push h
1721
       push b         !bc = return addr.
1722
       ret
1723
!*
1724
!**************************************************************
1725
!*
1726
!* *** outc *** & chkio ****!
1727
!* these are the only i/o routines in tbi.
1728
!* 'outc' is controlled by a software switch 'ocsw'.  iff ocsw=0
1729
!* 'outc' will just return to the caller.  iff ocsw is not 0,
1730
!* it will output the byte in a.  iff that is a cr, a lf is also
1731
!* send out.  only the flags may be changed at return, all reg.
1732
!* are restored.
1733
!*
1734
!* 'chkio' checks the input.  iff no input, it will return to
1735
!* the caller with the z flag set.  iff there is input, z flag
1736
!* is cleared and the input byte is in a.  howerer, iff the
1737
!* input is a control-o, the 'ocsw' switch is complimented, and
1738
!* z flag is returned.  iff a control-c is read, 'chkio' will
1739
!* restart tbi and do not return to the caller.
1740
!*
1741
!*                 outc   push af        this is at loc. 10
1742
!*                        ld   a,ocsw    check software switch
1743
!*                        ior  a
1744
oc2:   jnz  oc3       !it is on
1745
       pop  psw       !it is off
1746
       ret            !restore af and return
1747
oc3:   pop  a         !get old a back
1748
       push b         !save b on stack
1749
       push d         !and d
1750
       push h         !and h too
1751
       sta  outcar    !save character
1752
       mov  e,a       !put char. in e for cpm
1753
       mvi  c,2       !get conout command
1754
       call cpm       !call cpm and do it
1755
       lda  outcar    !get char. back
1756
       cpi  0dh       !was it a 'cr'?
1757
       jnz  done      !no, done
1758
       mvi  e,0ah     !get linefeed
1759
       mvi  c,2       !and conout again
1760
       call cpm       !call cpm
1761
done:  lda  outcar    !get character back
1762
idone: pop  h         !get h back
1763
       pop  d         !and d
1764
       pop  b         !and b too
1765
       ret            !done at last
1766
chkio: push b         !save b on stack
1767
       push d         !and d
1768
       push h         !then h
1769
       mvi  c,11      !get constat word
1770
       call cpm       !call the bdos
1771
       ora  a         !set flags
1772
       jnz  ci1       !if ready get character
1773
       jmp  idone     !restore and return
1774
ci1:   mvi  c,1       !get conin word
1775
       call cpm       !call the bdos
1776
       cpi  0fh       !is it control-o?
1777
       jnz  ci2       !no, more checking
1778
       lda  ocsw      !control-o  flip ocsw
1779
       cma            !on to off, off to on
1780
       sta  ocsw      !and put it back
1781
       jmp  chkio     !and get another character
1782
ci2:   cpi  3         !is it control-c?
1783
       jnz  idone     !return and restore if not
1784
       jmp  rstart    !yes, restart tbi
1785
lstrom:equ  $         !all above can be rom
1786
outio: out  0ffh
1787
       ret
1788
waitio:in   0ffh
1789
       xra  h
1790
       ana  l
1791
       jz   waitio
1792
       rst  6
1793
inpio: in   0ffh
1794
       mov  l,a
1795
       ret
1796
outcar:defb 0         !output char. storage
1797
ocsw:  defb 0ffh      !switch for output
1798
currnt:defw 0         !points to current line
1799
stkgos:defw 0         !saves sp in 'gosub'
1800
varnxt:defw 0         !temporary storage
1801
stkinp:defw 0         !saves sp in 'input'
1802
lopvar:defw 0         !'for' loop save area
1803
lopinc:defw 0         !increment
1804
loplmt:defw 0         !limit
1805
lopln: defw 0         !line number
1806
loppt: defw 0         !text pointer
1807
ranpnt:defw start     !random number pointer
1808
txtunf:defw txtbgn    !->unfilled text area
1809
txtbgn:defvs 1         !text save area begins
1810
msg1:  defb 7fh,7fh,7fh,'Tiny basic ver. 3.1',0dh
1811
init:  mvi  a,0ffh
1812
       sta  ocsw      !turn on output switch
1813
       mvi  a,0ch     !get form feed
1814
       rst  2         !send to crt
1815
patlop:sub  a         !clear accumulator
1816
       lxi  d,msg1    !get init message
1817
       call prtstg    !send it
1818
lstram:lda  7         !get fbase for top
1819
       sta  rstart+2
1820
       dcr  a         !decrement for other pointers
1821
       sta  ss1a+2    !and fix them too
1822
       sta  tv1a+2
1823
       sta  st3a+2
1824
       sta  st4a+2
1825
       sta  ip3a+2
1826
       sta  sizea+2
1827
       sta  getln+3
1828
       sta  pusha+2
1829
       lxi  h,st1     !get new start jump
1830
       shld start+1   !and fix it
1831
       jmp  st1
1832
       jmp  qwhat     !print "what?" iff wrong
1833
txtend:equ  $         !text save area ends
1834
varbgn:defvs   2*27      !variable @(0)
1835
       defvs   1         !extra byte for buffer
1836
buffer:defvs   80        !input buffer
1837
bufend:equ  $         !buffer ends
1838
       defvs   40        !extra bytes for stack
1839
stklmt:equ  $         !top limit for stack
1840
       org  2000h
1841
stack: equ  $         !stack starts here

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.