home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / DRI-archive / roche / PCWPATB.ASM < prev    next >
Assembly Source File  |  2009-12-11  |  46KB  |  1,681 lines
  1. From: "Arobase, Salle multimΘdia" <salle.arob...@wanadoo.fr>
  2. Newsgroups: comp.os.cpm
  3. Subject: Source Code of Palo Alto Tiny BASIC
  4. Date: Sat, 7 Jun 2003 10:29:05 +0200
  5. Organization: Wanadoo, l'internet avec France Telecom
  6. Lines: 1666
  7. Message-ID: <bbs7dp$s7n$1@news-reader12.wanadoo.fr>
  8. Reply-To: "Arobase, Salle multimΘdia" <salle.arob...@wanadoo.fr>
  9. NNTP-Posting-Host: apoitiers-106-2-3-61.w81-248.abo.wanadoo.fr
  10. X-Trace: news-reader12.wanadoo.fr 1054974201 28919 81.248.43.61 (7 Jun 2003 08:23:21 GMT)
  11. X-Complaints-To: abuse@wanadoo.fr
  12. NNTP-Posting-Date: 7 Jun 2003 08:23:21 GMT
  13. X-Priority: 3
  14. X-MSMail-Priority: Normal
  15. X-Newsreader: Microsoft Outlook Express 6.00.2600.0000
  16. X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2600.0000
  17.  
  18. ; PCWPATB.ASM
  19. ; -----------
  20. ;
  21. ; SOFTWARE: ED, MAC, SID
  22. ; HARDWARE: Amstrad PCW8256, CP/M Plus v1.4
  23. ; (The only hardware specific part is the
  24. ;  SID restart point, at label SID:)
  25. ;
  26. ; Palo Alto Tiny BASIC Interpreter Version 3.0
  27. ;
  28. ; See "Dr. DOBB's Journal" Vol.1 No.1 to 5.
  29. ; My advice is to buy the Volume 1 of DDJ:
  30. ; M&T Publishing Inc.
  31. ; 501 Galveston Drive
  32. ; REDWOOD CITY
  33. ; CA 94063
  34. ; USA
  35. ; ---
  36. ;
  37. ; CP/M port by Emmanuel ROCHE in mid-JUNE 1990!
  38. ; (Better late than never...)
  39. ;
  40. ; WARNING: run ONLY under SID.
  41. ;
  42. ;Usage: A>SID PCWPATB.HEX PCWPATB.SYM
  43. ; CP/M 3 SID - Version 3.0
  44. ; SYMBOLS
  45. ; NEXT MSZE  PC  END
  46. ; C834 C834 0100 D4C5
  47. ; #G100
  48. ;
  49. ; PALO ALTO TINY BASIC V3.0
  50. ; OK
  51. ; >
  52. ;
  53. ;Type Palo Alto Tiny BASIC commands in upper cases.
  54. ;
  55. ; >SID<CR> will return you to SID (added by ROCHE).
  56. ;
  57. ;-------------------------------
  58. ;
  59. CR equ 0DH
  60. LF equ 0AH
  61. ;
  62. ;-------------------------------
  63. ;
  64. tstc macro char, label
  65.  call tstch
  66.  db char
  67.  db low label-$-1
  68.  endm
  69. ;
  70. ;-------------------------------
  71. ;
  72. item macro first, second
  73.  if nul first
  74.   db  high second
  75.   db  low  second
  76.  else
  77.   db  first
  78.   db  high second
  79.   db  low  second
  80.  endif
  81.  endm
  82. ;
  83. ;The following is the original code (slighty edited for CP/M).
  84. ;---------------------------------------------------------------
  85. ;
  86. ;        P A T B
  87. ;    PALO ALTO TINY BASIC INTERPRETER
  88. ;       VERSION 3.0
  89. ;     FOR 8080 SYSTEM
  90. ;       LI-CHEN WANG
  91. ;      26 APRIL, 1977
  92. ;
  93. ;---------------------------------------------------------------
  94. ;
  95. ;  *** MEMORY USAGE ***
  96. ;
  97. ;  0080-01FF are for variables, input line and stack
  98. ;  2000-3FFF are for Tiny BASIC text & array
  99. ;  F000-F7FF are for PATB code
  100. ;
  101. ;ROCHE> I have added an offset of 1000H, and set BOTROM at
  102. ;ROCHE> C000H, in order to be under PCWPATB.SYM under SID.
  103. ;
  104. botscr equ 01080H  ;BOTtom SCRatch
  105. topscr equ 01200H  ;TOP SCRatch
  106. botram equ 03000H  ;BOTtom Random Access Memory
  107. dftlmt equ 05000H  ;DeFaulT LiMiT
  108. botrom equ 0C000H  ;BOTtom Read Only Memory
  109. ;
  110. ; Define variables, buffer and stack in RAM
  111. ;
  112.  ORG BOTSCR
  113. ;
  114. keywrd ds 1  ;was INIT done?
  115. txtlmt ds 2  ;-> limit of text area
  116. varbgn ds 2*26  ;TB variables A-Z
  117. currnt ds 2  ;points to current line
  118. stkgos ds 2  ;saves SP in 'GOSUB'
  119. varnxt ds 0  ;temporary storage
  120. stkinp ds 2  ;saves SP in 'INPUT'
  121. lopvar ds 2  ;'FOR' loop save area
  122. lopinc ds 2  ;increment
  123. loplmt ds 2  ;limit
  124. lopln ds 2  ;line number
  125. loppt ds 2  ;text pointer
  126. ranpnt ds 2  ;random number pointer
  127.  ds 1  ;extra byte for buffer
  128. buffer ds 132  ;input buffer
  129. bufend ds 0  ;buffer end
  130.  ds 4  ;extra bytes for stack
  131. stklmt ds 0  ;soft limit for stack
  132. ;
  133.  ORG TOPSCR
  134. ;
  135. stack ds 0  ;stack starts here
  136. ;
  137.  ORG BOTRAM
  138. ;
  139. txtunf ds 2  ;unfilled text save area
  140. text ds 2  ;text save area
  141. ;
  142. ;---------------------------------------------------------------
  143. ;
  144. ; *** INITIALIZE
  145. ;
  146.  ORG 100H  ;ROCHE>
  147. ;
  148.  JMP INIT  ;ROCHE>
  149. ;
  150.  ORG BOTROM
  151. ;
  152. INIT: LXI SP, STACK
  153.  CALL CRLF
  154.  LXI H, KEYWRD ;at power-on, KEYWRD is
  155.  MVI A, 0C3H  ;probably not 0C3H
  156.  CMP M
  157.  JZ TELL  ;it is 0C3H, continue
  158.  MOV M, A  ;no, set it to 0C3H
  159.  LXI H, DFTLMT ;and set default value
  160.  SHLD TXTLMT  ;in 'TXTLMT'
  161.  MVI A, HIGH BOTROM ;initialize RANPNT
  162.  STA RANPNT+1
  163. PURGE: LXI H, TEXT+4 ;purge text area
  164.  SHLD TXTUNF
  165.  MVI H, 0FFH
  166.  SHLD TEXT
  167. TELL: LXI D, MSG  ;tell user
  168.  CALL PRTSTG  ;*************************
  169.  JMP RSTART  ;***** jmp user init *****
  170.     ;*************************
  171. ;-------------------------------
  172. SID: RST 6  ;ROCHE> because Amstrad PCW
  173.     ;uses Mode 1 Interrupts
  174. ;-------------------------------
  175. MSG: db 'PALO '
  176.  db 'ALTO '
  177.  db 'TINY '
  178.  db 'BASIC'
  179.  db ' V3.0'
  180.  db CR
  181. ;
  182. OK: db 'OK'
  183.  db CR
  184. ;
  185. WHAT: db 'WHAT?'
  186.  db CR
  187. ;
  188. HOW: db 'HOW?'
  189.  db CR
  190. ;
  191. SORRY: db 'SORRY'
  192.  db CR
  193. ;
  194. ;---------------------------------------------------------------
  195. ;
  196. ; *** DIRECT COMMAND / TEXT COLLECTER ***
  197. ;
  198. ; PATB prints out "OK(CR)", and then it prompts ">" and reads
  199. ; a line. If the line starts with a non-zero number, this
  200. ; number is the line number. The line number (in 16 bit
  201. ; binary) and the rest of the line (including CR) is stored
  202. ; in the memory. If a line with the same line number is already
  203. ; there, it is replaced by the new one. If the rest of the line
  204. ; consists of a CR only, it is not stored and any existing line
  205. ; with the same line number is deleted.
  206. ;
  207. ; After a line is inserted, replaced, or deleted, the program
  208. ; loops back and ask for another line. This loop will be
  209. ; terminated when it reads a line with zero or no line number;
  210. ; and control is transfered to "DIRECT".
  211. ;
  212. ; Tiny BASIC program save area starts at the memory location
  213. ; labeled "TEXT". The end of text is marked by 2 bytes XX FF.
  214. ; Following these are 2 bytes reserved for the array element
  215. ; @(0). The content of location labeled "TXTUNF" points to one
  216. ; after @(0).
  217. ;
  218. ; The memory location "CURRNT" points to the line number that
  219. ; is currently being interpreted. While we are in this loop
  220. ; or while we are interpreting a direct command (see next
  221. ; section), "CURRNT" should point to a 0.
  222. ;
  223. RSTART: LXI SP, STACK ;re-initialize stack
  224.  LXI H, ST1+1 ;literal 0
  225.  SHLD CURRNT  ;CURRNT->line # = 0
  226. ST1: LXI H, 0
  227.  SHLD LOPVAR
  228.  SHLD STKGOS
  229.  LXI D, OK  ;DE->string
  230.  CALL PRTSTG  ;print string until CR
  231. ST2: MVI A, '>'  ;prompt '>' and
  232.  CALL GETLN  ;read a line
  233.  PUSH D  ;DE->end of line
  234.  LXI D, BUFFER ;DE->beginning of line
  235.  CALL TSTNUM  ;test if it is a number
  236.  CALL IGNBLK
  237.  MOV A, H  ;HL=value of the # or
  238.  ORA L  ;0 if no # was found
  239.  POP B  ;BC->end of line
  240.  JZ DIRECT
  241.  DCX D  ;backup DE and save
  242.  MOV A, H  ;value of line # there
  243.  STAX D
  244.  DCX D
  245.  MOV A, L
  246.  STAX D
  247.  PUSH B  ;BC, DE -> begin, end
  248.  PUSH D
  249.  MOV A, C
  250.  SUB E
  251.  PUSH PSW  ;A=# of bytes in line
  252.  CALL FNDLN  ;find this line in save
  253.  PUSH D  ;area, DE->save area
  254.  JNZ ST3  ;NZ=not found, insert
  255.  PUSH D  ;Z=found, delete it
  256.  CALL FNDNXT  ;set DE->next line
  257.  POP B  ;BC->line to be deleted
  258.  LHLD TXTUNF  ;HL->unfilled save area
  259.  CALL MVUP  ;move up to delete
  260.  MOV H, B  ;TXTUNF->unfilled area
  261.  MOV L, C
  262.  SHLD TXTUNF  ;update
  263. ST3: POP B  ;get ready to insert
  264.  LHLD TXTUNF  ;but first check if
  265.  POP PSW  ;the length of new line
  266.  PUSH H  ;is 3 (line # and CR)
  267.  CPI 3  ;then do not insert
  268.  JZ RSTART  ;must clear the stack
  269.  ADD L  ;compute new TXTUNF
  270.  MOV E, A
  271.  MVI A, 0
  272.  ADC H
  273.  MOV D, A  ;DE->new unfilled area
  274.  LHLD TXTLMT  ;check to see if there
  275.  XCHG
  276.  CALL COMP  ;is enough space
  277.  JNC QSORRY  ;sorry, no room for it
  278.  SHLD TXTUNF  ;ok, update TXTUNF
  279.  POP D  ;DE->old unfilled area
  280.  CALL MVDOWN
  281.  POP D  ;DE->begin, HL->end
  282.  POP H
  283.  CALL MVUP  ;move new line to
  284.  JMP ST2  ;save area
  285. ;
  286. ;---------------------------------------------------------------
  287. ;
  288. ; *** DIRECT *** & EXEC ***
  289. ;
  290. ; This section of the code tests a string against a table.
  291. ; When a match is found, control is transfered to the section
  292. ; of code according to the table.
  293. ;
  294. ; At 'EXEC', DE should point to the string and HL should point
  295. ; to the table-1. At 'DIRECT', DE should point to the string,
  296. ; HL will be set up to point to tab1-1, which is the table of
  297. ; all direct and statement commands.
  298. ;
  299. ; A '.' in the string will terminate the test and the partial
  300. ; match will be considered as a match, e.g., 'P.', 'PR.',
  301. ; 'PRI.', 'PRIN.' or 'PRINT' will all match 'PRINT'.
  302. ;
  303. ; The table consists of any number of items. Each item is a
  304. ; string of characters with bit 7 set to 0 and a jump address
  305. ; stored hi-low with bit 7 of the high byte set to 1.
  306. ;
  307. ; End of table is an item with a jump address only. If the
  308. ; string does not match any of the other items, it will match
  309. ; this null item as default.
  310. ;
  311. DIRECT: LXI H, TAB1-1 ;*** DIRECT ***
  312. ;
  313. EXEC: CALL IGNBLK  ;*** EXEC ***
  314.  PUSH D  ;save pointer
  315. EX1: LDAX D  ;if found '.' in string
  316.  INX D  ;before any mismatch
  317.  CPI '.'  ;we declare a match
  318.  JZ EX3
  319.  INX H  ;HL->table
  320.  CMP M  ;if match, test next
  321.  JZ EX1
  322.  MVI A, 07FH  ;else, see if bit 7
  323.  DCX D  ;of table is set, which
  324.  CMP M  ;is the jump address (HIGH)
  325.  JC EX5  ;C=yes, matched
  326. EX2: INX H  ;NC=no, find jump address
  327.  CMP M
  328.  JNC EX2
  329.  INX H  ;bump to next table item
  330.  POP D  ;restore string pointer
  331.  JMP EXEC  ;test again next item
  332. EX3: MVI A, 07FH  ;partial match, find
  333. EX4: INX H  ;jump address, which is
  334.  CMP M  ;flagged by bit 7
  335.  JNC EX4
  336. EX5: MOV A, M  ;load HL with the jump
  337.  INX H  ;address from the table
  338.  MOV L, M  ;****************
  339.  ANI 0FFH  ;*** ANI 07FH ***
  340.  MOV H, A  ;****************
  341.  POP PSW  ;clean up the garbage
  342.  PCHL   ;and we go do it
  343. ;
  344. ;---------------------------------------------------------------
  345. ;
  346. ; What follows is the code to execute direct and statement
  347. ; commands. Control is transfered to these points via the
  348. ; command table lookup code of 'DIRECT' and 'EXEC' in last
  349. ; section. After the command is executed, control is transfered
  350. ; to other sections as follows:
  351. ;
  352. ; For 'LIST', 'NEW', and 'STOP': go back to 'RSTART'.
  353. ; For 'RUN': go execute the first stored line if any;
  354. ;      else go back to 'RSTART'.
  355. ; For 'GOTO' and 'GOSUB': go execute the target line.
  356. ; For 'RETURN' and 'NEXT': go back to saved return line.
  357. ; For all others: if 'CURRNT' -> 0, go to 'RSTART',
  358. ;     else go execute next command. (This is done in 'FINISH'.)
  359. ;
  360. ;---------------------------------------------------------------
  361. ;
  362. ; *** NEW *** STOP *** RUN (& friends) *** & GOTO ***
  363. ;
  364. ; 'NEW(CR)' resets 'TXTUNF'.
  365. ;
  366. ; 'STOP(CR)' goes back to 'RSTART'.
  367. ;
  368. ; 'RUN(CR)' finds the first stored line, store its address
  369. ; (in 'CURRNT'), and start execute it. Note that only those
  370. ; commands in TAB2 are legal for stored program.
  371. ;
  372. ; There are 3 more entries in 'RUN':
  373. ; 'RUNNXL' finds next line, stores its address and executes it.
  374. ; 'RUNTSL' stores the address of this line and execute it.
  375. ; 'RUNSML' continues the execution on same line.
  376. ;
  377. ; 'GOTO expr(CR)' evaluates the expression, find the target
  378. ; line, and jump to 'RUNTSL' to do it.
  379. ;
  380. NEW: CALL ENDCHK  ;*** NEW(CR) ***
  381.  JMP PURGE
  382. ;
  383. STOP: CALL ENDCHK  ;*** STOP(CR) ***
  384.  JMP RSTART
  385. ;
  386. RUN: CALL ENDCHK  ;*** RUN(CR) ***
  387.  LXI D, TEXT  ;first saved line
  388. ;
  389. RUNNXL: LXI H, 0  ;*** RUNNXL ***
  390.  CALL FNDLP  ;find whatever line #
  391.  JC RSTART  ;C=passed TXTUNF, quit
  392. ;
  393. RUNTSL: XCHG   ;*** RUNTSL ***
  394.  SHLD CURRNT  ;set 'CURRNT'->line #
  395.  XCHG
  396.  INX D  ;bump pass line #
  397.  INX D
  398. ;
  399. RUNSML: CALL CHKIO  ;*** RUNSML ***
  400.  LXI H, TAB2-1 ;find command in TAB2
  401.  JMP EXEC  ;and execute it
  402. ;
  403. GOTO: CALL EXPR  ;*** GOTO expr ***
  404.  PUSH D  ;save for error routine
  405.  CALL ENDCHK  ;must find a CR
  406.  CALL FNDLN  ;find the target line
  407.  JNZ AHOW  ;no such line #
  408.  POP PSW  ;clear the "PUSH DE"
  409.  JMP RUNTSL  ;go do it
  410. ;
  411. ;---------------------------------------------------------------
  412. ;
  413. ; *** LIST *** & PRINT ***
  414. ;
  415. ; LIST has three forms:
  416. ; 'LIST(CR)' lists all saved lines.
  417. ; 'LIST n(CR)' start list at line n.
  418. ; 'LIST n1, n2(CR)' start list at line n1 for n2 lines.
  419. ; (You can stop the listing by Control-C key.)
  420. ;
  421. ; PRINT command is 'PRINT .....;' or 'PRINT ....(CR)'
  422. ; where '...' is a list of expressions, formats, and/or strings.
  423. ; These items are separated by commas.
  424. ;
  425. ; A format is a number sign followed by a number. It controls
  426. ; the number of spaces the value of a expression is going
  427. ; to be printed. It stays effective for the rest of the print
  428. ; command unless changed by another format. If no format is
  429. ; specified, 8 positions will be used.
  430. ;
  431. ; A string is quoted in a pair of single quotes or a pair of
  432. ; double quotes.
  433. ;
  434. ; Control characters and lower case letters can be included
  435. ; inside the quotes. Another (better) way of generating control
  436. ; characters on the output is use the up-arrow character
  437. ; followed by a letter.  L means FF,  I means HT,
  438. ;  G means BELL, etc.
  439. ;
  440. ; A (CRLF) is generated after the entire list has been printed
  441. ; or if the list is a null list. Howewer if the list ended with
  442. ; a comma, no (CRLF) is generated.
  443. ;
  444. LIST: CALL TSTNUM  ;test if there is a #
  445.  PUSH H
  446.  LXI H, 0FFFFH
  447.  tstc ',', ls1
  448.  CALL TSTNUM
  449. LS1: XTHL
  450.  CALL ENDCHK  ;if no #, we get a 0
  451.  CALL FNDLN  ;find this or next line
  452. LS2: JC RSTART  ;C=passed TXTUNF
  453.  XTHL
  454.  MOV A, H
  455.  ORA L
  456.  JZ RSTART
  457.  DCX H
  458.  XTHL
  459.  CALL PRTLN  ;print the line
  460.  CALL PRTSTG
  461.  CALL CHKIO
  462.  CALL FNDLP  ;find next line
  463.  JMP LS2  ;and loop back
  464. ;
  465. PRINT: MVI C, 8  ;C=# of spaces
  466.  tstc ';', PR1 ;if null list & ";"
  467.  CALL CRLF  ;give CR-LF and
  468.  JMP RUNSML  ;continue same line
  469. PR1: tstc CR, PR6  ;if null list (CR)
  470.  CALL CRLF  ;also give CR-LF and
  471.  JMP RUNNXL  ;go to next line
  472. PR2: tstc '#', PR4 ;else, is it format?
  473. PR3: CALL EXPR  ;yes, evaluate expr.
  474.  MVI A, 0C0H
  475.  ANA L
  476.  ORA H
  477.  JNZ QHOW
  478.  MOV C, L  ;and save it in C
  479.  JMP PR5  ;look for more to print
  480. PR4: CALL QTSTG  ;or is it a string?
  481.  JMP PR9  ;if not, must be expr.
  482. PR5: tstc ',', PR8 ;if ",", go find next
  483. PR6: tstc ',', PR7
  484.  MVI A, ' '
  485.  CALL OUTCH
  486.  JMP PR6
  487. PR7: CALL FIN  ;in the list
  488.  JMP PR2  ;list continues
  489. PR8: CALL CRLF  ;list ends
  490.  JMP FINISH
  491. PR9: CALL EXPR  ;evaluate the expr
  492.  PUSH B
  493.  CALL PRTNUM  ;print the value
  494.  POP B
  495.  JMP PR5  ;more to print?
  496. ;
  497. ;---------------------------------------------------------------
  498. ;
  499. ; *** GOSUB *** & RETURN ***
  500. ;
  501. ; 'GOSUB expr;' or 'GOSUB expr (CR)' is like the 'GOTO' command,
  502. ; except that the current text pointer, stack pointer etc. are
  503. ; save so that execution can be continued after the subroutine
  504. ; 'RETURN'. In order that 'GOSUB' can be nested (and even
  505. ; recursive), the save area must be stacked. The stack pointer
  506. ; is saved in 'STKGOS'. The old 'STKGOS' is saved in the stack.
  507. ; If we are in the main routine, 'STKGOS' is zero (this was done
  508. ; by the "main" section of the code), but we still save it as
  509. ; a flag for no further 'RETURN's.
  510. ;
  511. ; 'RETURN(CR)' undos everything that 'GOSUB' did, and thus
  512. ; return the execution to the command after the most recent
  513. ; 'GOSUB'. If 'STKGOS' is zero, it indicates that we never
  514. ; had a 'GOSUB' and is thus an error.
  515. ;
  516. GOSUB: CALL PUSHA  ;save the current "FOR"
  517.  CALL EXPR  ;parameters
  518.  PUSH D  ;and text pointer
  519.  CALL FNDLN  ;find the target line
  520.  JNZ AHOW  ;not there, say "HOW?"
  521.  LHLD CURRNT  ;save old
  522.  PUSH H  ;'CURRNT' old 'STKGOS'
  523.  LHLD STKGOS
  524.  PUSH H
  525.  LXI H, 0  ;and load new ones
  526.  SHLD LOPVAR
  527.  DAD SP
  528.  SHLD STKGOS
  529.  JMP RUNTSL  ;then run that line
  530. ;
  531. RETURN: CALL ENDCHK  ;there must be a CR
  532.  LHLD STKGOS  ;old stack pointer
  533.  MOV A, H  ;0 means not exist
  534.  ORA L
  535.  JZ QWHAT  ;so, we say: "WHAT?"
  536.  SPHL   ;else, restore it
  537. RESTOR: POP H
  538.  SHLD STKGOS  ;and the old 'STKGOS'
  539.  POP H
  540.  SHLD CURRNT  ;and the old 'CURRNT'
  541.  POP D  ;old text pointer
  542.  CALL POPA  ;old "FOR" parameters
  543.  JMP FINISH
  544. ;
  545. ;---------------------------------------------------------------
  546. ;
  547. ; *** FOR *** & NEXT ***
  548. ;
  549. ; 'FOR' has two forms: 'FOR VAR=EXP1 TO EXP2 STEP EXP3' and
  550. ; 'FOR VAR=EXP1 TO EXP2' the second form means the same thing
  551. ; as the first form with EXP3=1 (i.e., with a step of +1).
  552. ; PATB will find the variable var. and set its value to the
  553. ; current value of EXP1. It also evaluates EXP2 and EXP3 and
  554. ; save all these together with the text pointer etc. in the
  555. ; 'FOR' save area, which consists of 'LOPVAR', 'LOPINC',
  556. ; 'LOPLMT', 'LOPLN', and 'LOPPT'. If there is already some-
  557. ; thing in the save area (this is indicated by a non-zero
  558. ; 'LOPVAR'), then the old save area is saved in the stack
  559. ; before the new one overwrites it. PATB will then dig in the
  560. ; stack and find out if this same variable was used in another
  561. ; currently active 'FOR' loop. If that is the case, then the
  562. ; old 'FOR' loop is deactivated (Purged from the stack).
  563. ;
  564. ; 'NEXT var' serves as the logical (not necessarilly physical)
  565. ; end of the 'FOR' loop. The control variable var. is checked
  566. ; with the 'LOPVAR'. If they are not the same, PATB digs in the
  567. ; stack to find the right one and purges all those that did not
  568. ; match. Either way, PATB then adds the 'STEP' to that variable
  569. ; and check the result with the limit. If it is within the limit,
  570. ; control loops back to the command following the 'FOR'.
  571. ; If outside the limit, the save area is purged and execution
  572. ; continues.
  573. ;
  574. FOR: CALL PUSHA  ;save the old save area
  575.  CALL SETVAL  ;set the control var.
  576.  DCX H  ;HL is its address
  577.  SHLD LOPVAR  ;save that
  578.  LXI H, TAB4-1 ;use 'EXEC' to look
  579.  JMP EXEC  ;for the word 'TO'
  580. FR1: CALL EXPR  ;evaluate the limit
  581.  SHLD LOPLMT  ;save that
  582.  LXI H, TAB5-1 ;use 'EXEC' to look
  583.  JMP EXEC  ;for the word 'STEP'
  584. FR2: CALL EXPR  ;found it, get step
  585.  JMP FR4
  586. FR3: LXI H, 1  ;not found, set to 1
  587. FR4: SHLD LOPINC  ;save that too
  588.  LHLD CURRNT  ;save current line #
  589.  SHLD LOPLN
  590.  XCHG   ;and text pointer
  591.  SHLD LOPPT
  592.  LXI B, 10  ;dig into stack to
  593.  LHLD LOPVAR  ;find 'LOPVAR'
  594.  XCHG
  595.  MOV H, B
  596.  MOV L, B  ;HL=0 now
  597.  DAD SP  ;here is the stack
  598.  JMP FR6
  599. FR5: DAD B  ;each level is 10 deep
  600. FR6: MOV A, M  ;get that old 'LOPVAR'
  601.  INX H
  602.  ORA M
  603.  JZ FR7  ;0 says no more in it
  604.  MOV A, M
  605.  DCX H
  606.  CMP D  ;same as this one?
  607.  JNZ FR5
  608.  MOV A, M  ;the other half?
  609.  CMP E
  610.  JNZ FR5
  611.  XCHG   ;yes, found one
  612.  LXI H, 0
  613.  DAD SP  ;try to move SP
  614.  MOV B, H
  615.  MOV C, L
  616.  LXI H, 10
  617.  DAD D
  618.  CALL MVDOWN  ;and purge 10 words
  619.  SPHL   ;in the stack
  620. FR7: LHLD LOPPT  ;job done, restore DE
  621.  XCHG
  622.  JMP FINISH  ;and continue
  623. ;
  624. NEXT: CALL TSTV  ;get address of var.
  625.  JC QWHAT  ;no variable, "WHAT?"
  626.  SHLD VARNXT  ;yes, save it
  627. NX1: PUSH D  ;save text pointer
  628.  XCHG
  629.  LHLD LOPVAR  ;get var. in 'FOR'
  630.  MOV A, H
  631.  ORA L  ;0 says never had one
  632.  JZ AWHAT  ;so we ask: "WHAT?"
  633.  CALL COMP  ;else, we check them
  634.  JZ NX2  ;ok, they agree
  635.  POP D  ;no, let's see
  636.  CALL POPA  ;purge current loop
  637.  LHLD VARNXT  ;and pop one level
  638.  JMP NX1  ;go check again
  639. NX2: MOV E, M  ;come here when agreed
  640.  INX H
  641.  MOV D, M  ;DE=value of var.
  642.  LHLD LOPINC
  643.  PUSH H
  644.  MOV A, H
  645.  XRA D  ;S=sign differ
  646.  MOV A, D  ;A=sign of DE
  647.  DAD D  ;add one step
  648.  JM NX3  ;cannot overflow
  649.  XRA H  ;may overflow
  650.  JM NX5  ;and it did
  651. NX3: XCHG
  652.  LHLD LOPVAR  ;put it back
  653.  MOV M, E
  654.  INX H
  655.  MOV M, D
  656.  LHLD LOPLMT  ;HL=limit
  657.  POP PSW  ;old HL
  658.  ORA A
  659.  JP NX4  ;step > 0
  660.  XCHG   ;step < 0
  661. NX4: CALL CKHLDE  ;compare with limit
  662.  POP D  ;restore text pointer
  663.  JC NX6  ;outside limit
  664.  LHLD LOPLN  ;within limit, so
  665.  SHLD CURRNT  ;back to the saved
  666.  LHLD LOPPT  ;'CURRNT' and text
  667.  XCHG   ;pointer
  668.  JMP FINISH
  669. NX5: POP H  ;overflow, purge
  670.  POP D  ;garbage in stack
  671. NX6: CALL POPA  ;purge this loop
  672.  JMP FINISH
  673. ;
  674. ;---------------------------------------------------------------
  675. ;
  676. ; *** REM *** IF *** INPUT *** & LET (& DEFLT) ***
  677. ;
  678. ; 'REM' can be followed by anything and is ignored by PATB.
  679. ; PATB treats it like an 'IF' with a false condition.
  680. ;
  681. ; 'IF' is followed by an expression as a condition and one or
  682. ; more commands (including other 'IF's) separated by semi-colons.
  683. ; Note that the word 'THEN' is not used. PATB evaluates the expr.
  684. ; If it is non-zero, execution continues. If the expr. is zero,
  685. ; the commands that follows are ignored and execution continues
  686. ; at the next line.
  687. ;
  688. ; 'INPUT' command is like the 'PRINT' command, and is followed
  689. ; by a list of items. If the item is a string in single or
  690. ; double quotes, or is an up-arrow, it has the same effect as
  691. ; in 'PRINT'. If an item is a variable, this variable name is
  692. ; printed out followed by a colon. Then PATB waits for an expr.
  693. ; to be typed in. The variable is then set to the value of this
  694. ; expr. If the variable is proceded by a string (again in single
  695. ; or double quotes), the string will be printed followed by a
  696. ; colon. PATB then waits for input expr. and set the variable
  697. ; to the value of the expr.
  698. ;
  699. ; If the input expression is invalid, PATB will print "WHAT?",
  700. ; "HOW?" or "SORRY" and reprint the prompt and redo the input.
  701. ; The execution will not terminate unless you type Control-C.
  702. ; This is handled in 'INPERR'.
  703. ;
  704. ; 'LET' is followed by a list of items separated by commas.
  705. ; Each item consists of a variable, an equal sign, and an expr.
  706. ; PATB evaluates the expr. and set the variable to that value.
  707. ; PATB will also handle 'LET' command without the word 'LET'.
  708. ; This is done by 'DEFLT'.
  709. ;
  710. REM: LXI H, 0  ;*** REM ***
  711.  JMP IF1  ;this is like 'IF 0'
  712. ;
  713. IFF: CALL EXPR  ;*** IF ***
  714. IF1: MOV A, H  ;is the expression = 0?
  715.  ORA L
  716.  JNZ RUNSML  ;no, continue
  717.  CALL FNDSKP  ;yes, skip rest of line
  718.  JNC RUNTSL  ;and run the next line
  719.  JMP RSTART  ;if no next, re-start
  720. ;
  721. INPERR: LHLD STKINP  ;*** INPERR ***
  722.  SPHL   ;restore old SP
  723.  POP H  ;and old 'CURRNT'
  724.  SHLD CURRNT
  725.  POP D  ;and old text pointer
  726.  POP D  ;read input
  727. ;
  728. INPUT: ds 0
  729. IP1: PUSH D  ;save in case of error
  730.  CALL QTSTG  ;is next item a string?
  731.  JMP IP8  ;no
  732. IP2: CALL TSTV  ;yes, but followed by a
  733.  JC IP5  ;variable? no.
  734. IP3: CALL IP12
  735.  LXI D, BUFFER ;points to buffer
  736.  CALL EXPR  ;evaluate input
  737.  CALL ENDCHK
  738.  POP D  ;ok, get old HL
  739.  XCHG
  740.  MOV M, E  ;save value in var.
  741.  INX H
  742.  MOV M, D
  743. IP4: POP H  ;get old 'CURRNT'
  744.  SHLD CURRNT
  745.  POP D  ;and old text pointer
  746. IP5: POP PSW  ;purge junk in stack
  747. IP6: tstc ',', IP7 ;is next char. ","?
  748.  JMP INPUT  ;yes, more items.
  749. IP7: JMP FINISH
  750. IP8: PUSH D  ;save for 'PRTSTG'
  751.  CALL TSTV  ;must be variable now
  752.  JNC IP11
  753. IP10: JMP QWHAT  ;"WHAT?" it is not?
  754. IP11: MOV B, E
  755.  POP D
  756.  CALL PRTCHS  ;print those as prompt
  757.  JMP IP3  ;yes, input variable
  758. IP12: POP B  ;return address
  759.  PUSH D  ;save text pointer
  760.  XCHG
  761.  LHLD CURRNT  ;also save 'CURRNT'
  762.  PUSH H
  763.  LXI H, IP1  ;a negative number
  764.  SHLD CURRNT  ;as a flag
  765.  LXI H, 0  ;save SP too
  766.  DAD SP
  767.  SHLD STKINP
  768.  PUSH D  ;old HL
  769.  MVI A, ' '  ;print a space
  770.  PUSH B
  771.  JMP GETLN  ;and get a line
  772. ;
  773. DEFLT: LDAX D  ;*** DEFLT ***
  774.  CPI CR  ;empty line is ok
  775.  JZ LT4  ;else, it is 'LET'
  776. ;
  777. LET: ds 0  ;*** LET ***
  778. LT2: CALL SETVAL
  779. LT3: tstc ',', LT4 ;set value to var.
  780.  JMP LET  ;item by item
  781. LT4: JMP FINISH  ;until finish
  782. ;
  783. ;---------------------------------------------------------------
  784. ;
  785. ; *** EXPR ***
  786. ;
  787. ; 'EXPR' evaluates arithmetical or logical expressions.
  788. ; <EXPR>::=<EXPR1>
  789. ;    <EXPR1><REL.OP.><EXPR1>
  790. ; where <REL.OP.> is one of the operators in TAB6 and the result
  791. ; of these operations is 1 if true and 0 if false.
  792. ; <EXPR1>::=(+ or -)<EXPR2>(+ or -<EXPR2>)(.....)
  793. ; where () are optional and (.....) are optional repeats.
  794. ; <EXPR2>::=<EXPR3>(<* or /><EXPR3>)(.....)
  795. ; <EXPR3>::=<VARIABLE>
  796. ;      <FUNCTION>
  797. ;      (<EXPR>)
  798. ; <EXPR> is recursive so that variable '@' can have an <EXPR>
  799. ; as index. Functions can have an <EXPR> as arguments,
  800. ; and <EXPR3> can be an <EXPR> in parenthese.
  801. ;
  802. EXPR: CALL EXPR1  ;*** EXPR ***
  803.  PUSH H  ;save <EXPR1> value
  804.  LXI H, TAB6-1 ;lookup REL.OP.
  805.  JMP EXEC  ;go do it
  806. XPR1: CALL XPR8  ;REL.OP.">="
  807.  RC   ;no, return HL=0
  808.  MOV L, A  ;yes, return HL=1
  809.  RET
  810. XPR2: CALL XPR8  ;REL.OP."#"
  811.  RZ   ;false, return HL=0
  812.  MOV L, A  ;true, return HL=1
  813.  RET
  814. XPR3: CALL XPR8  ;REL.OP.">"
  815.  RZ   ;false
  816.  RC   ;also false, HL=0
  817.  MOV L, A  ;true, HL=1
  818.  RET
  819. XPR4: CALL XPR8  ;REL.OP."<="
  820.  MOV L, A  ;set HL=1
  821.  RZ   ;REL.OP. true, return
  822.  RC
  823.  MOV L, H  ;else, set HL=0
  824.  RET
  825. XPR5: CALL XPR8  ;REL.OP."="
  826.  RNZ   ;false, return HL=0
  827.  MOV L, A  ;else set HL=1
  828.  RET
  829. XPR6: CALL XPR8  ;REL.OP."<"
  830.  RNC   ;false, return HL=0
  831.  MOV L, A  ;else set HL=1
  832.  RET
  833. XPR7: POP H  ;not REL.OP.
  834.  RET   ;return HL=<EXPR1>
  835. XPR8: MOV A, C  ;subroutine for all
  836.  POP H  ;REL.OP.'s
  837.  POP B
  838.  PUSH H  ;reverse top of stack
  839.  PUSH B
  840.  MOV C, A
  841.  CALL EXPR1  ;set 2nd <EXPR1>
  842.  XCHG   ;value in DE now
  843.  XTHL   ;1st <EXPR1> in HL
  844.  CALL CKHLDE  ;compare 1st with 2nd
  845.  POP D  ;restore text pointer
  846.  LXI H, 0  ;set HL=0, A=1
  847.  MVI A, 1
  848.  RET
  849. ;
  850. EXPR1: tstc '-', XP11 ;negative sign?
  851.  LXI H,0  ;yes, fake '0-'
  852.  JMP XP16  ;treat like subtract
  853. XP11: tstc '+', XP12 ;positive sign? ignore
  854. XP12: CALL EXPR2  ;1st <EXPR2>
  855. XP13: tstc '+', XP15 ;add?
  856.  PUSH H  ;yes, save value
  857.  CALL EXPR2  ;get 2nd <EXPR2>
  858. XP14: XCHG   ;2nd in DE
  859.  XTHL   ;1st in HL
  860.  MOV A, H  ;compare sign
  861.  XRA D
  862.  MOV A, D
  863.  DAD D
  864.  POP D  ;restore text pointer
  865.  JM XP13  ;1st 2nd sign differ
  866.  XRA H  ;1st 2nd sign equal
  867.  JP XP13  ;so is equal
  868.  JMP QHOW  ;else, we have overflow
  869. XP15: tstc '-', XPR9 ;subtract?
  870. XP16: PUSH H  ;yes, save 1st <EXPR2>
  871.  CALL EXPR2  ;get 2nd <EXPR2>
  872.  CALL CHGSGN  ;negate
  873.  JMP XP14  ;and add them
  874. ;
  875. EXPR2: CALL EXPR3  ;get 1st <EXPR3>
  876. XP21: tstc '*', XP24 ;multiply?
  877.  PUSH H  ;yes, save 1st
  878.  CALL EXPR3  ;and get 2nd <EXPR3>
  879.  MVI B, 0  ;clear B for sign
  880.  CALL CHKSGN  ;check sign
  881.  XTHL   ;1st in HL
  882.  CALL CHKSGN  ;check sign of 1st
  883.  XCHG
  884.  XTHL
  885.  MOV A, H  ;is HL > 255 ?
  886.  ORA A
  887.  JZ XP22  ;no
  888.  MOV A, D  ;yes, how about DE
  889.  ORA D
  890.  XCHG   ;put smaller in HL
  891.  JNZ AHOW  ;also >, will overflow
  892. XP22: MOV A, L  ;this is dump
  893.  LXI H, 0  ;clear result
  894.  ORA A  ;add and count
  895.  JZ XP25
  896. XP23: DAD D
  897.  JC AHOW  ;overflow
  898.  DCR A
  899.  JNZ XP23
  900.  JMP XP25  ;finished
  901. XP24: tstc '/', XPR9 ;divide?
  902.  PUSH H  ;yes, save 1st <EXPR3>
  903.  CALL EXPR3  ;and get 2nd one
  904.  MVI B, 0  ;clear B for sign
  905.  CALL CHKSGN  ;check sign of 2nd
  906.  XTHL   ;get 1st in HL
  907.  CALL CHKSGN  ;check sign of 1st
  908.  XCHG
  909.  XTHL
  910.  XCHG
  911.  MOV A, D  ;divide by 0?
  912.  ORA E
  913.  JZ AHOW  ;say "HOW?"
  914.  PUSH B  ;else, save sign
  915.  CALL DIVIDE  ;use subroutine
  916.  MOV H, B  ;result in HL now
  917.  MOV L, C
  918.  POP B  ;get sign back
  919. XP25: POP D  ;and text pointer
  920.  MOV A, H  ;HL must be +
  921.  ORA A
  922.  JM QHOW  ;else, it is overflow
  923.  MOV A, B
  924.  ORA A
  925.  CM CHGSGN  ;change sign if needed
  926.  JMP XP21  ;look for more terms
  927. ;
  928. EXPR3: LXI H, TAB3-1 ;find function in TAB3
  929.  JMP EXEC  ;and go do it
  930. NOTF: CALL TSTV  ;no, not a function
  931.  JC XP32  ;nor a variable
  932.  MOV A, M  ;variable
  933.  INX H
  934.  MOV H, M  ;value in HL
  935.  MOV L, A
  936.  RET
  937. XP32: CALL TSTNUM  ;or is it a number
  938.  MOV A, B  ;# of digit
  939.  ORA A
  940.  RNZ   ;ok
  941. PARN: tstc '(', XPR0 ;no digit, must be
  942. PARNP: CALL EXPR  ;"(EXPR)"
  943.  tstc ')', XPR0
  944. XPR9: RET
  945. XPR0: JMP QWHAT  ;else, say: "WHAT?"
  946. ;
  947. RND: CALL PARN  ;*** RND(EXPR) ***
  948.  MOV A, H  ;expr must be +
  949.  ORA A
  950.  JM QHOW
  951.  ORA L  ;and non-zero
  952.  JZ QHOW
  953.  PUSH D  ;save both
  954.  PUSH H
  955.  LHLD RANPNT  ;get memory as random
  956.  LXI D, RANEND
  957.  CALL COMP
  958.  JC RA1  ;wrap around if last
  959.  LXI H, BOTROM
  960. RA1: MOV E, M
  961.  INX H
  962.  MOV D, M
  963.  SHLD RANPNT
  964.  POP H
  965.  XCHG
  966.  PUSH B
  967.  CALL DIVIDE  ;RND(N)=MOD(M,N)+1
  968.  POP B
  969.  POP D
  970.  INX H
  971.  RET
  972. ;
  973. ABS: CALL PARN  ;*** ABS(EXPR) ***
  974.  DCX D
  975.  CALL CHKSGN  ;check sign
  976.  INX D
  977.  RET
  978. ;
  979. SIZE: LHLD TXTUNF  ;*** SIZE ***
  980.  PUSH D  ;get the number of free
  981.  XCHG   ;bytes between 'TXTUNF'
  982.  LHLD TXTLMT  ;and 'TXTLMT'
  983.  CALL SUBDE
  984.  POP D
  985.  RET
  986. ;
  987. ;---------------------------------------------------------------
  988. ;
  989. ; *** DIVIDE *** SUBDE *** CHKSGN *** CHGSGN *** & CKHLDE ***
  990. ;
  991. ; 'DIVIDE' divides HL by DE. Result in BC, remainder in HL.
  992. ;
  993. ; 'SUBDE' subtracts DE from HL.
  994. ;
  995. ; 'CHKSGN' checks sign of HL. If +, no change. If -, change sign
  996. ; and flip sign of B.
  997. ;
  998. ; 'CHGSGN' changes sign of HL and B unconditionnally.
  999. ;
  1000. ; 'CKHLDE' checks sign of HL and DE. If different, HL and DE
  1001. ; are interchanged. If same sign, not interchanged. Either case,
  1002. ; HL DE are then compared to set the flags.
  1003. ;
  1004. DIVIDE: PUSH H  ;*** DIVIDE ***
  1005.  MOV L, H  ;divide H by DE
  1006.  MVI H, 0
  1007.  CALL DV1
  1008.  MOV B, C  ;save result in B
  1009.  MOV A, L  ;(remainder+L)/DE
  1010.  POP H
  1011.  MOV H, A
  1012. DV1: MVI C, -1  ;result in C
  1013. DV2: INR C  ;dumb routine
  1014.  CALL SUBDE  ;divide by subtract
  1015.  JNC DV2  ;and count
  1016.  DAD D
  1017.  RET
  1018. ;
  1019. SUBDE: MOV A, L  ;*** SUBDE ***
  1020.  SUB E  ;subtract DE from
  1021.  MOV L, A  ;HL
  1022.  MOV A, H
  1023.  SBB D
  1024.  MOV H, A
  1025.  RET
  1026. ;
  1027. CHKSGN: MOV A, H  ;*** CHKSGN ***
  1028.  ORA A  ;check sign of HL
  1029.  RP   ;if ), change sign
  1030. ;
  1031. CHGSGN: MOV A, H  ;*** CHGSGN ***
  1032.  ORA L
  1033.  RZ
  1034.  MOV A, H
  1035.  PUSH PSW
  1036.  CMA   ;change sign of HL
  1037.  MOV H, A
  1038.  MOV A, L
  1039.  CMA
  1040.  MOV L, A
  1041.  INX H
  1042.  POP PSW
  1043.  XRA H
  1044.  JP QHOW
  1045.  MOV A, B  ;and also flip B
  1046.  XRI 80H
  1047.  MOV B, A
  1048.  RET
  1049. ;
  1050. CKHLDE: MOV A, H  ;*** CKHLDE ***
  1051.  XRA D  ;same sign?
  1052.  JP CK1  ;yes, compare
  1053.  XCHG   ;no, xch and comp
  1054. CK1: CALL COMP
  1055.  RET
  1056. ;
  1057. COMP: MOV A, H  ;*** COMP ***
  1058.  CMP D  ;compare HL with DE
  1059.  RNZ   ;return correct C and
  1060.  MOV A, L  ;Z flags
  1061.  CMP E  ;but old A is lost
  1062.  RET
  1063. ;
  1064. ;---------------------------------------------------------------
  1065. ;
  1066. ; *** SETVAL *** FIN *** ENDCHK *** & ERROR (& friends) ***
  1067. ;
  1068. ; 'SETVAL' expects a variable, followed by an equal sign and
  1069. ; then an expr. It evaluates the expr. and set the variable
  1070. ; to that value.
  1071. ;
  1072. ; 'FIN' checks the end of a command. If it ended with ";",
  1073. ; execution continues. If it ended with a CR, it finds the next
  1074. ; line and continue from there.
  1075. ;
  1076. ; 'ENDCHK' checks if a command is ended with CR. This is
  1077. ; required in certain commands. (GOTO, RETURN, and STOP etc.)
  1078. ;
  1079. ; 'ERROR' prints the string pointed by DE (and ends with CR).
  1080. ; It then prints the line pointed by 'CURRNT' with a "?"
  1081. ; inserted at where the old text pointer (should be on top of
  1082. ; the stack) points to. Execution of TB is stopped and PATB is
  1083. ; restarted. Howewer, if 'CURRNT' -> zero (indicating a direct
  1084. ; command), the direct command is not printed, and if 'CURRNT'
  1085. ; -> negative # (indicating 'INPUT' command), the input line is
  1086. ; not printed and execution is not terminated but continued at
  1087. ; 'INPERR'.
  1088. ;
  1089. ; Related to 'ERROR' are the following: 'QWHAT' saves text
  1090. ; pointer in stack and get message "WHAT?". 'AWHAT' just get
  1091. ; message "WHAT?" and jump to 'ERROR'. 'QSORRY' and 'ASORRY'
  1092. ; do same kind of thing. 'QHOW' and 'AHOW' in the zero page
  1093. ; section also do this.
  1094. ;
  1095. SETVAL: CALL TSTV  ;*** SETVAL ***
  1096.  JC QWHAT  ;"WHAT?" no variable
  1097.  PUSH H  ;push address of var.
  1098.  tstc '=', SV1 ;pass "=" sign
  1099.  CALL EXPR  ;evaluate expr.
  1100.  MOV B, H  ;value in BC now
  1101.  MOV C, L
  1102.  POP H  ;get address
  1103.  MOV M, C  ;save value
  1104.  INX H
  1105.  MOV M, B
  1106.  RET
  1107. ;
  1108. FINISH: CALL FIN  ;check end of command
  1109. SV1: JMP QWHAT  ;print "WHAT?" if wrong
  1110. ;
  1111. FIN: tstc ';', FI1 ;*** FIN ***
  1112.  POP PSW  ;";", purge RET address
  1113.  JMP RUNSML  ;continue same line
  1114. FI1: tstc CR, FI2  ;not ";", is it CR?
  1115.  POP PSW  ;yes, purge RET address
  1116.  JMP RUNNXL  ;run next line
  1117. FI2: RET   ;else, return to caller
  1118. ;
  1119. IGNBLK: LDAX D  ;*** IGNBLK ***
  1120.  CPI ' '  ;ignore blanks
  1121.  RNZ   ;in text (where DE->)
  1122.  INX D  ;and return the first
  1123.  JMP IGNBLK  ;non-blank char. in A
  1124. ;
  1125. ENDCHK: CALL IGNBLK  ;*** ENDCHK ***
  1126.  CPI CR  ;end with CR?
  1127.  RZ   ;ok, else say: "WHAT?"
  1128. ;
  1129. QWHAT: PUSH D  ;*** QWHAT ***
  1130. AWHAT: LXI D, WHAT  ;*** AWHAT ***
  1131. ERROR: CALL CRLF
  1132.  CALL PRTSTG  ;print error message
  1133.  LHLD CURRNT  ;get current line #
  1134.  PUSH H
  1135.  MOV A, M  ;check the value
  1136.  INX H
  1137.  ORA M
  1138.  POP D
  1139.  JZ TELL  ;if zero, just restart
  1140.  MOV A, M  ;if negative
  1141.  ORA A
  1142.  JM INPERR  ;redo input
  1143.  CALL PRTLN  ;else print the line
  1144.  POP B
  1145.  MOV B, C
  1146.  CALL PRTCHS
  1147.  MVI A, '?'  ;print a "?"
  1148.  CALL OUTCH
  1149.  CALL PRTSTG  ;line
  1150.  JMP TELL  ;then restart
  1151. QSORRY: PUSH D  ;*** QSORRY ***
  1152. ASORRY: LXI D, SORRY ;*** ASORRY ***
  1153.  JMP ERROR
  1154. ;
  1155. ;---------------------------------------------------------------
  1156. ;
  1157. ; *** FNDLN (& friends) ***
  1158. ;
  1159. ; 'FNDLN' finds a line with a given line # (in HL) in the text
  1160. ; save area. DE is used as the text pointer. If the line is
  1161. ; found, DE will point to the beginning of that line (i.e., the
  1162. ; low byte of the line #), and flags are NC & Z. If that line is
  1163. ; not there and a line with a higher line # is found, DE points
  1164. ; to there and flags are NC & NZ. If we reached the end of text
  1165. ; save area and cannot find the line, flags are C & NZ. 'FNDLN'
  1166. ; will initialize DE to the beginning of the text save area to
  1167. ; start the search. Some other entries of this routine will not
  1168. ; initialize DE and do the search. 'FNDLP' will start with DE
  1169. ; and search for the line #. 'FNDNXT' will bump DE by 2, find
  1170. ; a CR and then start search. 'FNDSKP' use DE to find a CR,
  1171. ; and then start search.
  1172. ;
  1173. FNDLN: MOV A, H  ;*** FNDLN ***
  1174.  ORA A  ;check sign of HL
  1175.  JM QHOW  ;it cannot be -
  1176.  LXI D, TEXT  ;init. text pointer
  1177. ;
  1178. FNDLP: INX D  ;is it EOT mark?
  1179.  LDAX D
  1180.  DCX D
  1181.  ADD A
  1182.  RC   ;C, NZ passed. end.
  1183.  LDAX D  ;we did not, get byte 1
  1184.  SUB L  ;is this the line?
  1185.  MOV B, A  ;compare low order
  1186.  INX D
  1187.  LDAX D  ;get byte 2
  1188.  SBB H  ;compare high order
  1189.  JC FL1  ;no, not there yet
  1190.  DCX D  ;else we either found
  1191.  ORA B  ;it, or it is not there
  1192.  RET   ;NC, Z=found; NC, NZ=no
  1193. ;
  1194. FNDNXT: INX D  ;find next line
  1195. FL1: INX D  ;just passed byte 1 & 2
  1196. ;
  1197. FNDSKP: LDAX D  ;*** FNDSKP ***
  1198.  CPI CR  ;try to find CR
  1199.  JNZ FL1  ;keep looking
  1200.  INX D  ;found CR, skip over
  1201.  JMP FNDLP  ;check if end of text
  1202. ;
  1203. TSTV: CALL IGNBLK  ;*** TSTV ***
  1204.  SUI '@'  ;test variables
  1205.  RC   ;C=not a variable
  1206.  JNZ TV1  ;not "@" array
  1207.  INX D  ;it is the "@" array
  1208.  CALL PARN  ;@ should be followed
  1209.  DAD H  ;by (EXPR) as its index
  1210.  JC QHOW  ;is index too big?
  1211. TSTB: PUSH D  ;will it fit?
  1212.  XCHG
  1213.  CALL SIZE  ;find size of free
  1214.  CALL COMP  ;and check that
  1215.  JC ASORRY  ;if not, say: "SORRY"
  1216.  CALL LOCR  ;if fits, get address
  1217.  DAD D  ;of @(EXPR) and put it
  1218.  POP D  ;in HL
  1219.  RET   ;C flag is cleared
  1220. TV1: CPI 27  ;not @, is it A to Z?
  1221.  CMC   ;if not return C flag
  1222.  RC
  1223.  INX D  ;if A through Z
  1224.  LXI H, VARBGN-2
  1225.  RLC   ;HL->variable
  1226.  ADD L  ;return
  1227.  MOV L, A  ;with C flag cleared
  1228.  MVI A, 0
  1229.  ADC H
  1230.  MOV H, A
  1231.  RET
  1232. ;
  1233. ;---------------------------------------------------------------
  1234. ;
  1235. ; *** TSTCH *** TSTNUM ***
  1236. ;
  1237. ; 'TSTCH' is used to test non-blank character in the text
  1238. ; (pointed by DE) against the character that follows the call.
  1239. ; If they do not match, n bytes of code will be skipped over,
  1240. ; where n is between 0 and 255 and is stored in the second byte
  1241. ; following the call.
  1242. ;
  1243. ; 'TSTNUM' is used to chack wether the text (pointed by DE) is a
  1244. ; number. If a number is found, B will be non-zero and HL will
  1245. ; contain the value (in binary) of the number, else B and HL
  1246. ; are 0.
  1247. ;
  1248. TSTCH: XTHL   ;*** TSTCH ***
  1249.  CALL IGNBLK  ;ignore leading blanks
  1250.  CMP M  ;and test the character
  1251.  INX H  ;compare the byte that
  1252.  JZ TC1  ;follows the call inst.
  1253.  PUSH B  ;with the text (DE->)
  1254.  MOV C, M  ;if not =, add the 2nd
  1255.  MVI B, 0  ;byte that follows the
  1256.  DAD B  ;call to the old PC
  1257.  POP B  ;i.e., do a relative
  1258.  DCX D  ;jump if not =
  1259. TC1: INX D  ;if =, skip those bytes
  1260.  INX H  ;and continue
  1261.  XTHL
  1262.  RET
  1263. ;
  1264. TSTNUM: LXI H, 0  ;*** TSTNUM ***
  1265.  MOV B, H  ;test if the text is
  1266.  CALL IGNBLK  ;a number
  1267. TN1: CPI '0'  ;if not, return 0 in
  1268.  RC   ;B and HL
  1269.  CPI 03AH  ;if numbers, convert
  1270.  RNC   ;to binary in HL and
  1271.  MVI A, 0F0H  ;set B to # of digits
  1272.  ANA H  ;if H>255, there is no
  1273.  JNZ QHOW  ;room for next digit
  1274.  INR B  ;B counts # of digits
  1275.  PUSH B
  1276.  MOV B, H  ;HL=10*HL+(new digit)
  1277.  MOV C, L
  1278.  DAD H  ;where 10* is done by
  1279.  DAD H  ;shift and add
  1280.  DAD B
  1281.  DAD H
  1282.  LDAX D  ;and (digit) is from
  1283.  INX D  ;stripping the ASCII
  1284.  ANI 0FH  ;code
  1285.  ADD L
  1286.  MOV L, A
  1287.  MVI A, 0
  1288.  ADC H
  1289.  MOV H, A
  1290.  POP B
  1291.  LDAX D  ;do this digit after
  1292.  JP TN1  ;digit. S say overflow
  1293. QHOW: PUSH D  ;*** QHOW ***
  1294. AHOW: LXI D, HOW  ;*** AHOW ***
  1295.  JMP ERROR
  1296. ;
  1297. ;---------------------------------------------------------------
  1298. ;
  1299. ; *** MVUP *** MVDOWN *** POPA *** & PUSHA ***
  1300. ;
  1301. ; 'MVUP' moves a block up from where DE-> to where BC-> until
  1302. ; DE = HL.
  1303. ;
  1304. ; 'MVDOWN' moves a block down from where DE-> to where HL->
  1305. ; until DE = BC.
  1306. ;
  1307. ; 'POPA' restores the 'FOR' loop variable save area from the
  1308. ; stack
  1309. ;
  1310. ; 'PUSHA' stacks the 'FOR' loop variable save area into the
  1311. ; stack.
  1312. ;
  1313. MVUP: CALL COMP  ;*** MVUP ***
  1314.  RZ   ;DE = HL, return
  1315.  LDAX D  ;get one byte
  1316.  STAX B  ;move it
  1317.  INX D  ;increase both pointers
  1318.  INX B
  1319.  JMP MVUP  ;until done
  1320. ;
  1321. MVDOWN: MOV A, B  ;*** MVDOWN ***
  1322.  SUB D  ;test if DE = BC
  1323.  JNZ MD1  ;no, go move
  1324.  MOV A, C  ;maybe, other byte?
  1325.  SUB E
  1326.  RZ   ;yes, return
  1327. MD1: DCX D  ;else move a byte
  1328.  DCX H  ;but first decrease
  1329.  LDAX D  ;both pointers and
  1330.  MOV M, A  ;then do it
  1331.  JMP MVDOWN  ;loop back
  1332. ;
  1333. POPA: POP B  ;BC = return address
  1334.  POP H  ;restore LOPVAR, but
  1335.  SHLD LOPVAR  ;=0 means no more
  1336.  MOV A, H
  1337.  ORA L
  1338.  JZ PP1  ;yep, go return
  1339.  POP H  ;nop, restore others
  1340.  SHLD LOPINC
  1341.  POP H
  1342.  SHLD LOPLMT
  1343.  POP H
  1344.  SHLD LOPLN
  1345.  POP H
  1346.  SHLD LOPPT
  1347. PP1: PUSH B  ;BC = return address
  1348.  RET
  1349. ;
  1350. PUSHA: LXI H, STKLMT ;*** PUSHA ***
  1351.  CALL CHGSGN
  1352.  POP B  ;BC = return address
  1353.  DAD SP  ;is stack near the top?
  1354.  JNC QSORRY  ;yes, sorry for that.
  1355.  LHLD LOPVAR  ;esle, save loop var.s
  1356.  MOV A, H  ;but if lopvar is 0
  1357.  ORA L  ;that will be all
  1358.  JZ PU1
  1359.  LHLD LOPPT  ;else, more to save
  1360.  PUSH H
  1361.  LHLD LOPLN
  1362.  PUSH H
  1363.  LHLD LOPLMT
  1364.  PUSH H
  1365.  LHLD LOPINC
  1366.  PUSH H
  1367.  LHLD LOPVAR
  1368. PU1: PUSH H
  1369.  PUSH B  ;BC = return address
  1370.  RET
  1371. LOCR: LHLD TXTUNF
  1372.  DCX H
  1373.  DCX H
  1374.  RET
  1375. ;
  1376. ;---------------------------------------------------------------
  1377. ;
  1378. ; *** PRTSTG *** *** QTSTG *** *** PRTNUM *** & PRTLN ***
  1379. ;
  1380. ; 'PRTSTG' prints a string pointed by DE. It stops printing and
  1381. ; returns to caller when either a CR is printed or when the next
  1382. ; byte is zero. Registers A and B are changed. Register DE
  1383. ; points to what follows the CR or to the zero.
  1384. ;
  1385. ; 'QTSTG' looks for up-arrow, single quote, or double-quote.
  1386. ; If none of these, return to caller. If up-arrow, output a
  1387. ; control character. If single or double quote, print the
  1388. ; string in the quote and demands a matching unquote.
  1389. ; After the printing, the next 3 bytes of the caller is
  1390. ; skipped over (usually a jump instruction).
  1391. ;
  1392. ; 'PRTNUM' prints the number in HL. Leading blanks are added
  1393. ; if needed to pad the number of spaces to the number in C.
  1394. ; Howewer, if the number of digits is larger than the number
  1395. ; in C, all digits are printed anyway. Negative sign is also
  1396. ; printed and counted in. Positive sign is not.
  1397. ;
  1398. ; 'PRTLN' finds a saved line, prints the line number and
  1399. ; a space.
  1400. ;
  1401. PRTSTG: SUB A  ;*** PRTSTG ***
  1402. PS1: MOV B, A
  1403. PS2: LDAX D  ;get a character
  1404.  INX D  ;bump pointer
  1405.  CMP B  ;same as old A?
  1406.  RZ   ;yes, return
  1407.  CALL OUTCH  ;else, print it
  1408.  CPI CR  ;was it a CR?
  1409.  JNZ PS2  ;no, next
  1410.  RET   ;yes, return
  1411. ;
  1412. QTSTG: tstc '"', QT3 ;*** QTSTG ***
  1413.  MVI A, '"'  ;it is a " (double quote)
  1414. QT1: CALL PS1  ;print until another
  1415. QT2: CPI CR  ;was last one a CR?
  1416.  POP H  ;return address
  1417.  JZ RUNNXL  ;was CR, run next line
  1418.  INX H  ;skip 3 bytes on return
  1419.  INX H
  1420.  INX H
  1421.  PCHL   ;return
  1422. QT3: tstc 27H, QT4 ;is it a ' (single quote) ?
  1423.  MVI A, 27H  ;yes, do same
  1424.  JMP QT1  ;as in "
  1425. QT4: tstc 5EH, QT5 ;is it an up-arrow?
  1426.  LDAX D  ;yes, convert character
  1427.  XRI 40H  ;to control-char.
  1428.  CALL OUTCH
  1429.  LDAX D  ;just in case it is a CR
  1430.  INX D
  1431.  JMP QT2
  1432. QT5: RET   ;none of the above
  1433. PRTCHS: MOV A, E
  1434.  CMP B
  1435.  RZ
  1436.  LDAX D
  1437.  CALL OUTCH
  1438.  INX D
  1439.  JMP PRTCHS
  1440. ;
  1441. PRTNUM ds 0  ;*** PRTNUM ***
  1442. PN3: MVI B, 0  ;B=sign
  1443.  CALL CHKSGN  ;check sign
  1444.  JP PN4  ;no sign
  1445.  MVI B, '-'  ;B=sign
  1446.  DCR C  ;'-' takes space
  1447. PN4: PUSH D
  1448.  LXI D, 10  ;decimal
  1449.  PUSH D  ;save as a flag
  1450.  DCR C  ;C=spaces
  1451.  PUSH B  ;save sign & space
  1452. PN5: CALL DIVIDE  ;divide HL by 10
  1453.  MOV A, B  ;result O?
  1454.  ORA C
  1455.  JZ PN6  ;yes, we got all
  1456.  XTHL   ;no, save remainder
  1457.  DCR L  ;and count space
  1458.  PUSH H  ;HL is old BC
  1459.  MOV H, B  ;move result to BC
  1460.  MOV L, C
  1461.  JMP PN5  ;and divide by 10
  1462. PN6: POP B  ;we got all digits in
  1463. PN7: DCR C  ;the stack
  1464.  MOV A, C  ;look at space count
  1465.  ORA A
  1466.  JM PN8  ;no leading blanks
  1467.  MVI A, ' '  ;leading blanks
  1468.  CALL OUTCH
  1469.  JMP PN7  ;more?
  1470. PN8: MOV A, B  ;print sign?
  1471.  ORA A
  1472.  CNZ OUTCH  ;maybe - or null
  1473.  MOV E, L  ;last remainder in E
  1474. PN9: MOV A, E  ;check digit in E
  1475.  CPI 10  ;10 is flag for no more
  1476.  POP D
  1477.  RZ   ;if so, return
  1478.  ADI '0'  ;else, convert to ASCII
  1479.  CALL OUTCH  ;and print the digit
  1480.  JMP PN9  ;go back for more
  1481. ;
  1482. PRTLN: LDAX D  ;*** PRTLN ***
  1483.  MOV L, A  ;low order line #
  1484.  INX D
  1485.  LDAX D  ;high order
  1486.  MOV H, A
  1487.  INX D
  1488.  MVI C, 4  ;print 4 digit line #
  1489.  CALL PRTNUM
  1490.  MVI A, ' '  ;followed by a blank
  1491.  CALL OUTCH
  1492.  RET
  1493. ;
  1494. TAB1: item 'LIST', list ;direct commands
  1495.  item 'NEW', new
  1496.  item 'RUN', run
  1497.  item 'SID', sid ;added by ROCHE
  1498. ;
  1499. TAB2: item 'NEXT', next ;direct/statement
  1500.  item 'LET', let
  1501.  item 'IF', iff
  1502.  item 'GOTO', goto
  1503.  item 'GOSUB',gosub
  1504.  item 'RETURN',return
  1505.  item 'REM', rem
  1506.  item 'FOR', for
  1507.  item 'INPUT',input
  1508.  item 'PRINT',print
  1509.  item 'STOP', stop
  1510.  item , morec
  1511. ;    ;************************
  1512. MOREC: JMP DEFLT  ;*** JMP USER-COMMAND ***
  1513. ;    ;************************
  1514. TAB3: item 'RND', rnd ;functions
  1515.  item 'ABS', abs
  1516.  item 'SIZE', size
  1517.  item , moref
  1518. ;    ;*************************
  1519. MOREF: JMP NOTF  ;*** JMP USER-FUNCTION ***
  1520.     ;*************************
  1521. TAB4: item 'TO', FR1 ;"FOR" command
  1522.  item , QWHAT
  1523. ;
  1524. TAB5: item 'STEP', FR2 ;"FOR" command
  1525.  item , FR3
  1526. ;
  1527. TAB6: item '>=', XPR1 ;relation operators
  1528.  item '#', XPR2
  1529.  item '>', XPR3
  1530.  item '=', XPR5
  1531.  item '<=', XPR4
  1532.  item '<', XPR6
  1533.  item , XPR7
  1534. ;
  1535. RANEND EQU $
  1536. ;
  1537. ;PATB original code>
  1538. ;---------------------------------------------------------------
  1539. ;
  1540. ; *** INPUT OUTPUT ROUTINES ***
  1541. ;
  1542. ; User must verify and/or modify these routines
  1543. ;
  1544. ;---------------------------------------------------------------
  1545. ;
  1546. ; *** CRLF *** OUTCH ***
  1547. ;
  1548. ; 'CRLF' will output a CR. Only A & flags may change at return.
  1549. ;
  1550. ; 'OUTCH' will output the character in A. If the character is CR,
  1551. ; it will also outut a LF and three nulls. Flags may change at
  1552. ; return. Others registers do not.
  1553. ;
  1554. ; *** CHKIO *** GETLN ***
  1555. ;
  1556. ; 'CHKIO' checks to see if there is any input. If no input,
  1557. ; it returns with Z flag. If there is input, it further checks
  1558. ; wether input is Control-C. If not Control-C, it returns the
  1559. ; character in A with Z flag cleared. If input is Control-C,
  1560. ; 'CHKIO' jumps to 'INIT' and will not return. Only A & flags
  1561. ; may change at return.
  1562. ;
  1563. ; 'GETLN' reads a input line into 'BUFFER'. It first prompt the
  1564. ; character in A (given by the caller), then it fills the buffer
  1565. ; and echos. Back-space is used to delete the last character
  1566. ; (if there is one). CR signals the end of the line, and cause
  1567. ; 'GETLN' to return. When buffer is full, 'GETLN' will accept
  1568. ; back-space or CR only and will ignore (and will not echo)
  1569. ; other characters. After the input line is stored in the buffer
  1570. ; two more bytes of FF are also stored and DE points to the
  1571. ; last FF. A & flags are also changed at return.
  1572. ;
  1573. CRLF: MVI A, 0DH  ;CR in A
  1574. ;    ;***********************
  1575. OUTCH: JMP USEOUT  ;*** JMP USER-OUTPUT ***
  1576. ;    ;***********************
  1577. CHKIO: JMP USEINP  ;*** JMP USER-INPUT  ***
  1578. ;    ;***********************
  1579. GETLN: LXI D, BUFFER ;*** MODIFY THIS *******
  1580. ;    ;***********************
  1581. GL1: CALL OUTCH  ;prompt or echo
  1582. GL2: CALL CHKIO  ;get a character
  1583.  JZ GL2  ;wait for input
  1584.  CPI LF
  1585.  JZ GL2
  1586. L3: STAX D  ;save char.
  1587.  CPI 08H  ;is it Back-Space?
  1588.  JNZ GL4  ;no, more tests
  1589.  MOV A, E  ;yes, delete?
  1590.  CPI LOW BUFFER
  1591.  JZ GL2  ;nothing to delete
  1592.  LDAX D  ;delete
  1593.  DCX D
  1594.  JMP GL1
  1595. GL4: CPI CR  ;was it CR?
  1596.  JZ GL5  ;yes, end of line
  1597.  MOV A, E  ;else, more free room?
  1598.  CPI LOW BUFEND
  1599.  JZ GL2  ;no, wait for CR/Rub-Out
  1600.  LDAX D  ;yes, bump pointer
  1601.  INX D
  1602.  JMP GL1
  1603. GL5: INX D  ;end of line
  1604.  INX D  ;bump pointer
  1605.  MVI A, 0FFH  ;put marker after it
  1606.  STAX D
  1607.  DCX D
  1608.  JMP CRLF
  1609. ;-------------------------------
  1610. ;I/O Routines using CP/M, Cf.
  1611. ;"8080/Z80 Assembly Language"
  1612. ;by Alan R. MILLER, SYBEX, 1981
  1613. ;-------------------------------
  1614. ;MILLER> (OUT4, p.92)
  1615. USEOUT:
  1616.  push h  ;save registers
  1617.  push d
  1618.  push b
  1619.  mov c, a  ;move byte
  1620.  push psw
  1621.  lxi h, out5  ;return address
  1622.  push h  ;put on stack
  1623.  lhld 1  ;BIOS entry
  1624.  lxi d, 9  ;offset to output
  1625.  dad d  ;add together
  1626.  pchl   ;call BIOS
  1627. out5: pop psw  ;restore registers
  1628.  pop b
  1629.  pop d
  1630.  pop h
  1631. ;-------------------------------
  1632. ;PATB original code>
  1633.  CPI CR  ;was it CR?
  1634.  RNZ   ;no, return
  1635.  MVI A, LF  ;yes, give LF
  1636.  CALL USEOUT
  1637.  MVI A, CR
  1638.  RET
  1639. ;-------------------------------
  1640. ;MILLER> (INSTAT, p.92)
  1641. USEINP:
  1642.  push h  ;save registers
  1643.  push d
  1644.  push b
  1645.  lxi h, st5  ;return address
  1646.  push h  ;put on stack
  1647.  lhld 1  ;BIOS entry
  1648.  lxi d, 3  ;offset to status
  1649.  dad d  ;add to addr
  1650.  pchl   ;call BIOS
  1651. st5: pop b  ;restore registers
  1652.  pop d
  1653.  pop h
  1654.  ora a
  1655. ;-------------------------------
  1656. ;PATB original code>
  1657.  RZ   ;no input, return zero
  1658. ;-------------------------------
  1659. ;MILLER> (INPUT2, p.91)
  1660.  push h  ;save registers
  1661.  push d
  1662.  push b
  1663.  lxi h, in5  ;return address
  1664.  push h  ;put on stack
  1665.  lhld 1  ;BIOS warm start
  1666.  lxi d, 6  ;offset to input
  1667.  dad d  ;add in
  1668.  pchl   ;call BIOS
  1669. in5: pop b  ;restore registers
  1670.  pop d
  1671.  pop h
  1672. ;-------------------------------
  1673. ;PATB original code>
  1674.  ANI 7FH
  1675.  CPI 3  ;is it Control-C?
  1676.  RNZ   ;no, return char
  1677.  JMP INIT  ;yes, restart
  1678. ;-------------------------------
  1679. ;ROCHE>
  1680.  END 100H  ;for HEX file end
  1681.