home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG018.ARK / CASUAL.ASM next >
Assembly Source File  |  1984-04-29  |  40KB  |  1,570 lines
  1. ;ABBREVIATIONS USED IN COMMENTS:
  2. ;
  3. ;->        INTO
  4. ;ABS( )        ABSOLUTE VALUE OF ( )
  5. ;ADR        ADDRESS
  6. ;ARG        ARGUMENT
  7. ;BUF        BUFFER
  8. ;BOTX        BEGINNING OF TEXT
  9. ;CR        CARRIAGE RETURN
  10. ;CRLF        CARRIAGE RETURN, LINE FEED
  11. ;CHR        CHARACTER
  12. ;CMPR        COMPARE
  13. ;DECR        DECREMENT
  14. ;EOP        END OF PROGRAM
  15. ;EXPR        EXPRESSION
  16. ;EOS        END OF STATEMENT, OR END OF STRING
  17. ;EOTX        END OF TEXT
  18. ;EOB        END OF BUFFER
  19. ;EOL        END OF LINE
  20. ;FC        FALSE CARRY
  21. ;FUN        FUNCTION
  22. ;FZ        FALSE ZERO
  23. ;INIT        INITIALIZE
  24. ;INFO        INFORMATION
  25. ;INCR        INCREMENT
  26. ;INST        INSTRUCTION
  27. ;INP        INPUT
  28. ;LANG        LANGUAGE
  29. ;LF        LINE FEED
  30. ;LINE #        LINE NUMBER
  31. ;LL        LINE LENGTH
  32. ;NEOTX        NEW END OF TEXT
  33. ;OEOTX        OLD END OF TEXT
  34. ;OP        OPERATOR
  35. ;OS        OPERATING SYSTEM
  36. ;PS        PARTIAL SUM
  37. ;PGM        PROGRAM
  38. ;QUO        QUOTIENT
  39. ;RETADR        RETURN ADDRESS
  40. ;RELOP        RELATIONAL OPPERATOR ( <, >, =, # )
  41. ;REG        REGISTER
  42. ;ROT        ROUTINE
  43. ;STK        STACK
  44. ;STMT        STATEMENT
  45. ;SONL        START OF NEXT LHNE
  46. ;SO>L        START OF GREATER THAN LINE
  47. ;SO<L        START OF LESS THAN LINE
  48. ;SOL        START OF LINE
  49. ;SUB        SUBTRACT
  50. ;SOS        START OF STATEMENT
  51. ;SR        SUBROUTINE
  52. ;SIG DIG    SIGNIFICANT DIGIT
  53. ;TXA        TEXT ADDRESS POINTER
  54. ;TST        TEST
  55. ;TZ        TRUE ZERO
  56. ;VAL        VALUE
  57. ;VAR        VARIABLE
  58. ;VARNAM        VARIABLE NAME
  59. ;
  60. ;
  61. ;        C A S U A L
  62. ;
  63. ;  CHICAGO AREA SMALL USERS ALGORITHMIC LANGUAGE
  64. ;
  65. ;  WRITTEN BY:    ROBERT A. VAN VALZAH
  66. ;        1140 HICKORY TRAIL
  67. ;        DOWNERS GROVE,    IL.
  68. ;                60515
  69. ;
  70. ;        H  (312) 852-0472
  71. ;        W  (312) 971-2010  X 227
  72. ;
  73.     JMP INIT    ;WILL BE POKED TO JMP ENTR
  74.     DW USRL    ;ADR OF ADR OF ADR OF USERS ML ROT
  75.     DW SUBS    ;ADR OF ROT USED TO GET USR FUN ARG
  76. ;
  77. ;RESTART SUBROUTINES.  0 IS SYSTEM RE-ENTRY.  7 IS OPEN.
  78. ;1 - 6 ARE USED.
  79. ;
  80. ;
  81. ;RESTART 1 IS THE TST FUNCTION.  IN SOURCE CODE IT MUST
  82. ;BE FOLLOWED BY AN IFNOT PSEUDO - OP.  IT APPEARS LIKE THIS:
  83. ;
  84. ;    TST '+'
  85. ;    IFNOT TRY-    ;CHR AT H IS NOT '+'',' JUMP TO TRY-
  86. ;    ;FALLS THROUGH TO HERE IF CHR AT H IS '+''
  87. ;COMPARED TO THE CHR POINTED TO BY H.  IF THE
  88. ;TEST IS TRUE, THE IFNOT ADDRESS IS IGNORED AND TST RETURNS.
  89. ;ALSO H IS BUMPED AND IT FALLS THROUGH TO NXTC TOSET FLAGS
  90. ;IF THE TEST IS FALSE, THE RETURN ADDRESS ON THE STACK
  91. ;IS IGNORED AND THE IFNOT ADDRESS IS RETURNED TO,
  92. ;WITHOUT BUMPING H.
  93. ;STACK USAGE:  2 BYTES.  MUNCHES A & FLAGS.
  94. ;
  95.     ORG    10Q
  96.     MOV A,M        ;FETCH TEST CHR
  97.     XTHL        ;TXA ON STK, REFERENCE ADR -> H
  98.     CMP M        ;COMPARE WITH REFERENCE
  99.     INX H        ;MOVE RETADR
  100.     JMP TST1    ;CONTINUES AT TST1
  101. ;
  102. ;RESTART 2 IS THE FETCH THE NEXT CHR ROUTINE.  H IS BUMPED
  103. ;BEFORE THE FETCH.  SPACES ARE IGNORED.  ON RETURN:  FC
  104. ;MEANS NON-NUMERIC (NOT 0 - 9), TZ IF A STATEMENT TERMINATOR
  105. ;(COLON OR END OF LINE NULL).  STACK USAGE:  2 BYTES.
  106. ;
  107.     ORG    20Q
  108. NXTC:    INX H        ;BUMP TXA TO NEXT CHR
  109.     MOV A,M        ;FETCH IT
  110.     CPI '9'+1    ;IS IT 0 - 9
  111.     RNC        ;>9  CARRY FALSE
  112.     JMP NXTD    ;CONTINUED AT NXTD
  113. ;
  114. ;RESTART 3 IS THE XPRESSION EVALUATOR.  THE VALUE IS
  115. ;RETURNED IN PHE DE REG.  SEE CONTINUATION FOR MORE INFO.
  116. ;
  117.     ORG    30Q
  118.     CALL EXPA    ;GET THE VALUE OF EXPR -> DE
  119.     XCHG        ;RESULT -> H, TXA -> DE
  120.     JMP EXP1    ;CONTINUED AT EXP1
  121. ;
  122. ;RESTART 4 IS THE DEVO (DEVICE OUTPUT) ROUTINE.  THE CHR
  123. ;IN THE A REG IS SENT TO THE OUTPUT DEVICE.  DOESN'T
  124. ;MUNCH ANY REGS OR FLAGS.  STACK USAGE: 4 BYTES.
  125. ;
  126.     ORG    40Q
  127.     PUSH PSW    ;SAVE A AND FLAGS
  128. DEVQ:    IN 17        ;GET READY STATUS -> A
  129. TORM:    ANI 1        ;MASK TO THE BIT WE WANT
  130.     JMP DEVP    ;CONTINUED AT DEVP
  131. ;
  132. ;RESTART 5 IS THE MESSAGE PRINTER.  IT SENDS CHRS
  133. ;FROM MEMORY IMMEDIATLY FOLLOWING THE CALL TO IT UNTIL ONE
  134. ;WITH BIT 7 HI COMES ALONG.  THE RETURN ADDRESS IS
  135. ;MODIFIED.  STACK USAGE:  6 BYTES.
  136. ;
  137.     ORG    50Q
  138. MSG:    XTHL    ;PRINT ADR -> H
  139. MSG1:    MOV A,M        ;FETCH A CHR
  140.     RST 4        ;SEND IT
  141.     INX H        ;BUMP TXA AND RETURN ADDRESS
  142.     ORA A        ;BIT 7 HI YET ?
  143.     JMP MSG2    ;CONTINUED AT MSG2
  144. ;
  145. ;RESTART 6 IS A 16 BIT UNSIGNED COMPARE (CMPR).  FLAGS ARE
  146. ;SET LIKE H - DE.  STACK USAGE:  2 BYTES.
  147. ;
  148.     ORG    60Q
  149.     MOV A,H
  150.     SUB D
  151.     RNZ
  152.     MOV A,L
  153.     SUB E
  154.     RET
  155.     DW SPRS    ;ADR OF ADR OF ADR OF STACK RESET
  156. ;
  157. ;RESTART 7 IS OPEN FOR INTERRUPT USE.
  158. ;A RETURN IS PUT THERE SO INTERRUPTS WILL BE IGNORED TILL
  159. ;IT IS PATCHED OUT.  THREE BYTES ARE LEFT FOR A JUMP
  160. ;PO AN INTERRUPT SERVICE ROUTINE.
  161. ;
  162.     ORG    70Q
  163.     RET
  164.     ORG    73Q
  165. EXP1:    SHLD LRES    ;SAVE RESULT
  166.     XCHG        ;RESTORE TXA
  167.     RET
  168. ;
  169. NXTD:    CPI ' '        ;IGNORE BLANKS
  170.     JZ NXTC
  171.     CPI '0'        ;<0?
  172.     CMC
  173.     INR A        ;SET FLAG WTIHOUT AFFECTING CARRY
  174.     DCR A
  175.     RET
  176. TST1:    JNZ NGOT    ;NO MATCH
  177.     INX H        ;MATCH - IGONRE IFNOT ADR
  178.     INX H
  179.     XTHL        ;RESTORE TXA
  180.     JMP NXTC    ;FOUND IT, INCR TXA AND SET FLAGS
  181. NGOT:    MOV A,M        ;LOW ORDER IFNOT ADR -> A
  182.     INX H
  183.     MOV H,M        ;IFNOT ADR ON STK, RESTORE TXA
  184.     MOV L,A
  185.     XTHL
  186.     RET
  187. ;
  188. MSG2:    JP MSG1    ;BIT 7 WAS LOW, PRINT MORE
  189.     XTHL        ;WAS HIGH, TIME TO RETURN
  190.     RET
  191. ;
  192. ;ERRO IS THE ERROR MESSAGE PRINTER.  IT MUST ALLWAYS BE
  193. ;CALLED, PHE RETURN ADDRESS IS USED AS THE ERROR NUMBER.
  194. ;
  195. SNER:    CALL ERRO    ;SYNTAX ERROR TO BE JUMPED TO
  196. ERRO:    RST 5        ;PRINT    'ERROR'
  197.     DB  15Q,12Q,'ERRO','R'+200Q
  198.     XTHL        ;PRINT ERROR ADDRESS
  199.     CALL HLPT
  200.     CALL INPT    ;PRINT LINE NUMBER OF ERROR
  201.     LHLD SSTM    ;START OF LAST STATEMENT -> H
  202.     DCX H
  203.     POP D        ;ERROR TXA -> DE
  204. ERRP:    RST 6        ;AT BAD SPOT YET?
  205.     JNZ ERRQ    ;NOPE - PRINT A CHR
  206.     RST 5        ;YUP - INSERT A '?'
  207.     DB '?'+200Q
  208. ERRQ:    RST 2        ;END OF STMT?
  209.     JZ ENTR    ;YUP - BACK TO COMMAND MODE
  210.     RST 4        ;NOPE - PRINT ONE CHR AND
  211.     JMP ERRP    ;KEEP TRYING
  212. ;
  213. ;MAIN INTERPRETER ENTRY AND RE-ENTRY POINT.  ENTR SENDS RLF
  214. ;AND ENTERS LINE INPUT MODE.  NOCR DOES SAME, WITHOUT CRLF.
  215. ;NUMBERED LINES ARE EDITED INTO TEXT BUFFER.
  216. ;UN-NUMBERED LINES ARE PASSED TO STMT FOR EXECUTION.
  217. ;
  218. ENTR:    CALL CRLF
  219. NOCR:    CALL    RSSP    ;RESET 8080 STACK
  220.     RST 5        ;PRINT PROMPT PERIOD '.'
  221.     DB '.'+200Q
  222.     LXI    H,-1    ;SET IMMEDIATE MODE FLAG
  223.     SHLD CURL
  224.     CALL GETL    ;FETCH AN INPUT LINE
  225.     RST 2        ;BLANK LINE?
  226.     JZ NOCR    ;YUP - IGNORE
  227.     JNC STMU    ;NOT NUMERIC - EXECUTE IT
  228. ;
  229. ;START OF LINE TEXT EDITOR
  230. ;
  231. ;TEXT BUFFER FORMAT:
  232. ;
  233. ;    000
  234. ;BOTX:    LINE 1
  235. ;    LINE 2
  236. ;    LINE 3
  237. ;    000
  238. ;EOTX:    000
  239. ;
  240. ;LINE STORAGE FORMAT:
  241. ;
  242. ;    LINE NUMBER LOW 8 BITS
  243. ;    LINE NUMBER HIGH 8 BITS
  244. ;    CHRS WHICH APPEAR ON LINE
  245. ;    000
  246. ;
  247.     CALL DEINT    ;GET LINE # -> DE
  248.     PUSH H        ;FIRST CHRADR SAVE
  249.     PUSH D        ;SAVE LINE #
  250.     PUSH PSW    ;ZERO TRUE IF BLANK LINE
  251.     LXI    B,2    ;LINE LENGTH 3 BYTE OVERHEAD
  252. EDT:    MOV A,M        ;COUNT UP LINE LENGTH -> B
  253.     ORA A
  254.     INX H
  255.     INX B
  256.     JNZ EDT        ;KEEP COUNTING
  257.     POP PSW    ;RESTORE FLAGS
  258.     PUSH B        ;SAVE LINE LENTH
  259.     PUSH PSW    ;SAVE FLAGS
  260.     CALL LFND    ;INSERT ADR -> @, SONL -> H
  261.     PUSH B        ;SAVE INSERT ADR
  262.     JNC EDT2    ;COULDN'T FIND, SO INSERT ONLY
  263.     XCHG        ;SONL -> DE
  264.     LHLD EOTX
  265. EDT1:    LDAX D        ;DELETE OLD LINE
  266.     STAX B
  267.     INX B
  268.     INX D
  269.     RST 6        ;DONE YET?
  270.     JNC    EDT1    ;NOPE
  271.     MOV    H,B    ;SAVE NEW EOTX
  272.     MOV L,C
  273.     DCX H
  274.     SHLD EOTX
  275. EDT2:    POP D        ;INSERT ADR -> DE
  276.     POP PSW    ;ANYTHING TO INSERT?
  277.     JZ NOCR    ;NOPE - EXIT EDITOR
  278.     LHLD EOTX
  279.     XTHL        ;EOTX -> B, LL -> H
  280.     POP B
  281.     DAD B        ;NEW EOTX -> H
  282.     PUSH H        ;SAVE IT
  283.     CALL EOM1    ;ROOM FOR THIS LINE?
  284.     PUSH B    
  285.     XTHL        ;OEOTX -> H, NEOTX -> B
  286.     POP B
  287. ED21:    RST 6        ;MOVE UP FOR NEW LINE
  288.     MOV A,M        ;FROM OEOTX -> NEOTX
  289.     STAX B
  290.     DCX B
  291.     DCX H
  292.     JNZ ED21    ;NOT DONE YET
  293.     POP H        ;RESTORE NEOTX
  294.     SHLD EOTX
  295.     XCHG        ;INSERT ADR -> H
  296.     POP D        ;LINE # -> DE
  297.     MOV M,E        ;PUT     N NEW LINE #
  298.     INX H
  299.     MOV M,D
  300.     INX H
  301.     POP D        ;ADROF TEXT ON LINE
  302. EDT3:    LDAX D        ;PUT IT IN BUFFER
  303.     MOV M,A
  304.     INX H
  305.     INX D
  306.     ORA A
  307.     JNZ EDT3    ;NOT DONE INSERTING
  308.     JMP NOCR    ;GET ANOTHER LINE
  309. ;
  310. ;LFND IS THE LINE FINDER.
  311. ;TRIES TO FIND THE LINE # IN DE IN THE BUFFER.
  312. ;IT WILL EITHER FIND IT, OR HIT THE EOB FIRST, OR GO
  313. ;ONE LINE PAST BUT NOT HIT EOB.  RETURN CONDITIONS FOLLOW:
  314. ;
  315. ;            IF
  316. ;            --
  317. ;        EOB    GOT IT    NEXT >
  318. ;        ---    ------    ------
  319. ;    HL    EOB    SONL    SO>L
  320. ;    BC    EOB    SOL    SO<L
  321. ;    CARRY    FALSE    TRUE    FALSE
  322. ;    ZERO    TRUE    TRUE    FALSE
  323. ;
  324. ;USES ALL REGS AND FLAGS EXCEPT DE.  STACK USAGE:  6 BYTES.
  325. ;
  326. LFND:    LHLD BOTX    ;START AT BEGINNING OF TEXT
  327. LFNE:    MOV B,H        ;SAVE START OF LINE -> B
  328.     MOV C,L
  329.     MOV A,M        ;EOB?
  330.     INX H
  331.     ORA M
  332.     DCX H
  333.     RZ        ;YUP - ZERO TRUE, CARRY FALSE
  334.     MOV A,M        ;RELOAD LOW ORDER -> A
  335.     INX H
  336.     PUSH H        ;SAVE SOL TXA+1
  337.     MOV H,M        ;LINE # -> H
  338.     MOV L,A
  339.     RST 6        ;LINE # WE WANT ?
  340.     POP H        ;SOL+1 -> H
  341.     PUSH PSW    ;SAVE RESULT OF COMPARE
  342.     INX H        ;START OF NEXT LINE -> H
  343.     CALL FSNL
  344.     POP PSW    ;RESTORE RESULT OF COMPARE
  345.     CMC        ;FOUND IT?
  346.     RZ        ;YUP - CARRY, ZERO TRUE
  347.     CMC        ;PAST IT?
  348.     RNC        ;YUP - CARRY, ZERO FALSE
  349.     JMP LFNE    ;NOPE - KEEP LOOKING
  350. ;
  351. ;THIS IS THE INTERPRETER CONTROL SECTION.
  352. ;
  353. ;STMT IS THE STATEMENT EXECUTOR.  ENTER IT ITH THE TXA
  354. ;OF THE STRING TO BE EXECUTED -1 IN H.    KEEPS GOING TILL:
  355. ;IT FINDS LINE # 0, CONTROL C (^C) ABORT, OR GOTO
  356. ;-1 (MINUS ONE).  IT PUSHES THE ADDRESS OF RTRN
  357. ;BEFORELEAVING, SO WHEN THE STMT HANDLER RETURNS, IT SHOWS
  358. ;UP AT RTRN.  AT RTRN, TXA SHOULD POINT TO COLON (:) OR
  359. ;END OF LINE NULL.
  360. ;
  361. RTRN:    CALL ABRT    ;TEST FOR CONTROL C (^C)
  362.     MOV A,M        ;MORE ON THIS LINE?
  363. COLN:    CPI ':'
  364.     JZ STMT    ;YUP - EXECUTE IT
  365.     ORA A        ;END OF LINE?
  366.     CNZ ERRO    ;NOPE - ILLEGAL TERMINATION CHR
  367.     INX H        ;MOVE TO SONL
  368.     CALL FELN    ;LINE # -> DE, RE-ENTER IF EOB
  369.     XCHG        ;MAKE IT CURRENT LINE
  370.     SHLD CURL
  371.     XCHG
  372. STMT:    RST 2
  373. STMU:    SHLD SSTM    ;SAVE THE START OF THIS STATEMENT
  374.     LXI D,RTRN    ;PUSH DESIRED RETURN ADR
  375.     PUSH D
  376.     RZ
  377.     RST 1
  378.     DB '?'        ;A PRINT STMT?
  379. SIPK:    DW NPRT    ;MIGHT BE POKED TO NPRU
  380. PRT1:    JZ CRLF
  381. CR1:    RZ        ;RETURN WITH NO CR IF TERMINATOR
  382.     RST 1
  383.     DB ';'
  384.     DW PCOM
  385.     JMP CR1        ;IGNORE SEMICOLONS - NO CR IF EOS
  386. PCOM:    RST 1
  387.     DB ':'        ;A COMMA ?
  388.     DW QUOT
  389.     MVI A,11        ;YUP - SEND A TAB
  390.     RST 4
  391.     JMP CR1        ;NO CR IF EOS
  392. QUOT:    MOV A,M        ;LEADING SLASH FOR LITERAL ?
  393.     CPI '/'
  394.     JNZ PXCL    ;NOPE - TRY CHR$
  395.     INX H        ;YUP - MOVE OVER SLASH
  396. QUOS:    MOV A,M        ;FETCH A CHR
  397.     ORA A        ;END OF LINE ?
  398.     CZ ERRO    ;YUP - NO CLOSING SLASH ERROR
  399.     INX H
  400.     CPI '/'        ;FINAL SLASH?
  401.     JZ PEXQ    ;YUP
  402.     RST 4        ;NOPE - SEND IT
  403.     JMP QUOS    ;DO MORE
  404. PXCL:    RST 1
  405.     DB '>'        ;A CHR$ FUNCTION ?
  406. PXPK:    DW PRI1    ;TRY STRING PRINT, MIGHT BE POKED
  407.     RST 3
  408.     MOV A,E        ;TRUNCATED EXPR -> A
  409.     RST 4        ;SEND IT
  410.     JMP PEXQ
  411. PEXP:    RST 3        ;MUST BE AN RST 3ESSION
  412.     PUSH H        ;SAVE H DURING PRINT
  413.     XCHG        ;NUMBER TO PRINT -> H
  414.     CALL SHLP    ;PRINT THE SIGNED NUMBER
  415.     POP H        ;RESTORE TXA
  416. PEXQ:    DCX H        ;SET Z FLAG IF EOS
  417.     RST 2
  418.     JMP PRT1
  419. NPRU:    PUSH H        ;SAVE SOL TXA ON STK
  420.     INX H
  421.     RST 1
  422.     DB '='        ;SECOND CHR '='' '?
  423.     DW CMD1    ;NOPE - MUST BE A COMMAND OR ARRAY
  424.     RST 3        ;YUP - EVALUATE RIGHT SIDE
  425.     XTHL        ;SOL -> H,  FOR 24 BETWEEN
  426. ;CURRENT EOTX AND SP. BOTH MUNCH PSW & A.
  427. ;
  428. EOM:    LHLD EOTX    ;CURRENT EOTX
  429. EOM1:    PUSH D        ;SAVE DE
  430.     XCHG        ;SAVE HIS H
  431.     LXI H,-24Q    ;LOOKING FOR 24 BYTES
  432.     DAD SP        ;ADD IN CURRENT SP
  433.     RST 6        ;SUBTRACT PASSED H
  434.     XCHG        ;RESTORE HIS H
  435.     POP D        ;RESOTRE DE
  436.     RNC        ;PLENTY OF ROOM LEFT - RETURN
  437.     CALL ERRO    ;OUT OF MEMORY ERROR
  438. ;
  439. ;THIS ROUTINE INPUTS A LINE OF TEXT AND PLACES IT
  440. ;AT LINB WHEN ENTERED AT GETL.    RUBOUT
  441. ;DELETES THE PREVIOUS CHR.  CONTROL U (^U) DELETES THE
  442. ;ENTIRE LINE BEING TTS LINE NUMBER
  443.     INX H
  444.     MOV H,M
  445.     MOV L,A
  446.     SHLD DLAD
  447.     JMP GOT        ;DO A GOTO
  448. MEMA:    RST 1
  449.     DB '!'        ;SET A MEMORY ADDRESS ?
  450.     DW POKT
  451.     XCHG        ;STORE NEW MEMORY ADDRESS
  452.     SHLD MADR
  453.     POP H        ;RESTORE EOS TXA
  454.     RET
  455. POKT:    RST 1
  456.     DB '&'        ;A POKE ?
  457.     DW OUT1
  458.     LHLD MADR    ;GET THE SET MEMORY ADDRESS
  459.     MOV M,E        ;POKE IT WITH LOW ORDER EXPR
  460.     POP H        ;RESTORE EOS TXA
  461.     RET
  462. OUT1:    RST 1
  463.     DB '_'        ;AN OUT INST ?
  464.     DW PAD1    ;NOPE
  465.     MVI A,323Q        ;OUT INST BINARY -> MEMORY (RAM)
  466.     STA RAMIO
  467.     MOV A,E        ;DATA TO OUTPUT -> A
  468.     POP H        ;RESTORE EOS TXA
  469.     JMP RAMIO    ;DO THE OUT, AND RETURN
  470. PAD1:    RST 1
  471.     DB '@'        ;SET PORT NUMBER ?
  472.     DW DEF1
  473.     MOV A,E        ;TRUNCATED EXPRESSION -> A
  474.     STA RAMIO+1    ;SET NEW PORT NUMBER INTO RAM
  475.     POP H        ;RESTORE EOS TXA
  476.     RET
  477. DEF1:    RST 1
  478.     DB '^'        ;DEFINE A FUNCTION ?
  479. DFPK:    DW BSES    ;MIGHT BE POKED TO LETS
  480.     INX H        ;MOVE TXA TO EXPRESSION
  481.     SHLD DEFF    ;SAVE FUNCTIONS TXA
  482.     POP H        ;RESTORE EOS TXA
  483.     RET
  484. LETS:    CALL LOKU    ;GET THE INDES OF THE VAR
  485.     MOV M,E        ;STORE THE VAL IN MEMORY
  486.     JNZ LETT    ;DON'T WRITE HI BYTE IF SINGLE ARRAY
  487.     INX H
  488.     MOV M,D
  489. LETT:    POP H        ;IGNORE TXA FROM LOKU
  490.     POP H        ;RESTORE EOS TXA
  491.     RET
  492. ;FSNL FINDS THE START OF THE NEXT LINE IN MEMORY.
  493. ;HL IS BUMPED TO POINT TO THE LO ORDER LINE NUMBER OF THAT
  494. ;LINE.    A & PSW GET MUNCHED.  STACK USAGE:  2 BYTES.
  495. ;
  496. FSNL:    MOV A,M
  497.     INX H
  498.     ORA A        ;ENDING NULL YET?
  499.     JNZ FSNL
  500.     RET
  501. ;
  502. ;EOM AND EOM1 CHECK TO MAKE SURE THAT THERE IS AT LEAST 24
  503. ;BYTES OF STK SPACE LEFT FOR NORMAL OPERATIONS.  EOM1 LOOKS
  504. ;FOR 24 BETWEEN H AND CURRENT SP.  EOM LOOKS FOR 24 BETWEEN
  505. ;CURRENT EOTX AND SP. BOTH MUNCH PSW & A.
  506. ;
  507. EOM:    LHLD EOTX    ;CURRENT EOTX
  508. EOM1:    PUSH D        ;SAVE DE
  509.     XCHG        ;SAVE HIS H
  510.     LXI H,-24Q    ;LOOKING FOR 24 BYTES
  511.     DAD SP        ;ADD IN CURRENT SP
  512.     RST 6        ;SUBTRACT PASSED H
  513.     XCHG        ;RESTORE HIS H
  514.     POP D        ;RESOTRE DE
  515.     RNC        ;PLENTY OF ROOM LEFT - RETURN
  516.     CALL ERRO    ;OUT OF MEMORY ERROR
  517. ;
  518. ;THIS ROUTINE INPUTS A LINE OF TEXT AND PLACES IT
  519. ;AT LINB WHEN ENTERED AT GETL.    RUBOUT
  520. ;DELETES THE PREVIOUS CHR.  CONTROL U (^U) DELETES THE
  521. ;ENTIRE LINE BEING TYPED AND STARTS OVER.  A MAXIMUM
  522. ;OF LBUL CHRS WILL BE ACCEPTED AFTER WHICH THE
  523. ;BELL WILL RING INSTEAD OF ECHOING CHRS AS NORMAL.
  524. ;CONTROL CHRS OTHER THAN CONTROL U, CONTROL G (BELL),
  525. ;AND CARRIAGE RETURN WILL NOT BE ECHOED BUT IGNORED.
  526. ;ROUTINE RETURNS ON ENTRY OF A CARRIAGE RETURN BY
  527. ;ECHOING A CRLF AND PLACING 3 NULLS AT THE END OF BUFFER.
  528. ;ON EXIT, H POINT LINB-1.  STACK USAGE:  10 BYTES.
  529. ;
  530. GETJ:    DCX H        ;DECR CHR POINTER
  531.     RST 5        ;SEND A BACK SLASH
  532.     DB '\'+200Q
  533.     DCR B        ;DECR CHR COUNTER
  534.     JNZ GETM    ;DELETED TOO MANY? - NOPE
  535. GETK:    CALL CRLF
  536. GETL:    LXI H,LINB    ;CHRS WILL GOHERE
  537.     MVI B,1        ;INITIALIZE CHR COUNT
  538. GETM:    CALL TTYI    ;GET CHR -> A
  539.     CPI 7        ;A BELL?
  540.     JZ GETN    ;YUP - PUT IN BUFFER
  541.     CPI 15Q        ;A CR?
  542.     JZ CRLE    ;YUP - EXIT THRU CRLF
  543.     CPI 25Q        ;CONTROL U?
  544.     JZ GETK    ;YUP - START OVER
  545.     CPI ' '        ;< SPACE, CONTROL CHR ?
  546.     JC GETM        ;YUP - IGNORE
  547.     CPI 177Q    ;RUBOUT?
  548.     JZ GETJ    ;YUP - IGNOR LAST CHR
  549. GETN:    MOV C,A        ;SAVE CHR
  550.     MOV A,B        ;GET LINE LENGTH -> A
  551.     CPI LBUL+1    ;COMPARE WITH MAXIMUM
  552.     MVI A,7        ;GET READY TO RING BELL IF TOO LONG
  553.     JNC GETO    ;RING IT
  554.     MOV A,C        ;RESTORE CHR
  555.     MOV M,C        ;PUT IT IN BUFFER
  556.     INX H        ;INCR BUFFER POINTER
  557.     INR B        ;INCR CHR COUNTER
  558. GETO:    RST 4        ;ECHO CHR
  559.     JMP GETM    ;DO SOME MORE
  560. ;
  561. ;THIS ROUTINE FETCHES A LINE NUMBER FROM MEMORY -> DE.
  562. ;IF IT IS LINE 0 (ZERO), THIS MEANS EOB AND IT GOES TO ENTR.
  563. ;IF NOT 0, JUST RETURN.  MUNCHES DE & A & FLAGS, BUMPS H.
  564. ;HL POINTS TO LOW ORDER ON ENTRY, HI ORDER ON EXIT.
  565. ;STACK USAGE:  2 BYTES.
  566. ;
  567. FELN:    MOV E,M        ;LO ORDER -> E
  568.     INX H
  569.     MOV D,M        ;HI ORDER -> D
  570.     MOV A,D        ;IS DE = 0 ?
  571.     ORA E
  572.     RNZ        ;NOPE - RETURN
  573.     RST 0        ;YUP - BACK TO COMMAND MODE
  574. ;
  575. ;
  576. ;EXPRESSION EVALUATOR.    USES ALL REGISTERS.  RESULT IS LEFT
  577. ;IN THE DE REGISTER.  WILL PROBABLY RECURSE AT LEAST ONCE.
  578. ;
  579. ;        HIERARCHY
  580. ;
  581. ;EVALUATED FIRST    ( )
  582. ;            *, /
  583. ;            +, -
  584. ;EVALUATED LAST        <, >, =, #
  585. ;
  586. ;OPERATORS ON THE SAME LEVEL ARE EVALUATED LEFT TO RIGHT.
  587. ;
  588. ;    <EXPR>    ::=    <SUM> I <SUM><<SUM> I <SUM>><SUM>
  589. ;            <SUM>=<SUM> I <SUM>#<SUM>
  590. ;
  591. ;STACK USAGE:  >= 10 BYTES.  CALLS EOM BEFORE RECURSING.
  592. ;
  593. EXPA:    CALL SUM        ;GET LEFT SUM
  594. EXPS:    RST 1
  595.     DB '<'        ;FOLLOWED BY '<'' '?
  596.     DW TRYG
  597.     CALL RSUM    ;GET RIGHT SUM AND COMPARE
  598.     RNC        ;FALSE - DE = 0
  599.     MOV E,A        ;TRUE - MAKE DE = 1
  600.     RET
  601. TRYG:    RST 1
  602.     DB '>'        ;GREATER THAN ?
  603.     DW TRYE
  604.     CALL RSUM    ;GET RIGHT SUM
  605.     RC        ;FALSE
  606.     RZ        ;EQUAL IS FALSE
  607.     MOV E,A        ;TRUE
  608.     RET
  609. TRYE:    RST 1
  610.     DB '='        ;EQUAL TO ?
  611.     DW TRYN
  612.     CALL RSUM    ;GET RIGHT SUM
  613.     RNZ        ;NOT EQUAL IS FALSE
  614.     MOV E,A
  615. RETI:    RET
  616. TRYN:    RST 1
  617.     DB '#'        ;NOT EQUAL TO  ?
  618.     DW RETI    ;NO RELOPS - RETURN
  619.     CALL RSUM    ;GET RIGHT SUM
  620.     RZ
  621.     MOV E,A
  622.     RET
  623. ;
  624. ;RSUM GETS THE RIGHT SUM AFTER A RELOP HAS BEEN FOUND.
  625. ;ENTER WITH LEFT SUM IN DE.  AFTER FETCHING THE RIGHT SUM,
  626. ;RIGHT AND LEFT ARE COMPARED WITH A 16 BIT SIGNED COMPARE.
  627. ;ON EXIT:  FLAGS ARE SET LIKE LEFT - RIGHT,
  628. ;DE = 0, A = 1, TXA POINTS TO END OF EXPRESSION.
  629. ;
  630. RSUM:    PUSH D        ;LEFT ON STK
  631.     CALL SUM        ;GET RIGHT SUM -> DE
  632.     XTHL        ;LEFT -> H, TXA ON STK
  633.     MOV A,H        ;COMPARE SIGN OF LEFT AND RIGHT
  634.     XRA D
  635.     JP SAMS    ;SAME SIGN - DON'T SWAP
  636.     XCHG
  637. SAMS:    RST 6        ;DO THE COMPARE
  638.     POP H        ;RESTORE TXA
  639.     LXI D,0    ;SETUP RESULT OF RELOP
  640.     MVI A,1        ;DO A LE A IF TRUE
  641.     RET
  642. ;
  643. ;SUM EVALUATOR.
  644. ;<SUM>    ::=    <TERM> I <SUM> + <TERM> I <SUM> - <TERM>
  645. ;
  646. ;THE VALUE OF THE SUM IS T IN DE ON EXIT.
  647. ;
  648. SUM:    CALL TERM    ;GET LEFT TERM
  649. SUMA:    RST 1
  650.     DB '+'        ;FOLLOWED BY A '+'' '?
  651.     DW SUN
  652.     PUSH D        ;SAVE LEFT HALF
  653.     CALL TERM    ;GET RIGHT HALF
  654. SUM1:    XTHL        ;LEFT -> H, TXA ON STACK
  655.     DAD D        ;RIGHT + LEFT -> H
  656.     XCHG        ;RESULT -> DE
  657.     POP H        ;RESTORE TXA
  658.     JMP SUMA    ;CHECK FOR MORE SUMS
  659. SUN:    RST 1
  660.     DB '-'        ;FOLLOWED BY '-'' '?
  661.     DW RETI    ;NOPE - DONEWITH ALL SUMS
  662.     PUSH D        ;SAVE LEFT TERM
  663.     CALL TERM    ;GETRIGHT HALF
  664.     CALL COMD    ;DE = -RIGHT
  665.     JMP SUM1    ;RESULT = -LEFT + RIGHT
  666. ;
  667. ;TERM EVALUATOR.
  668. ;<TERM>    ::=    <FACT> I <TERM> * <FACT> I <TERM> / <FACT>
  669. ;
  670. TERM:    CALL FACT    ;GET LEFT FACT
  671. TERA:    RST 1
  672.     DB '*'        ;FOLLOWED BY AN '*'' '?
  673.     DW TERN    ;NOPE - TRY DIVISION
  674.     PUSH D        ;SAVE LEFT FACT
  675.     CALL FACT    ;GET RIGNT FACT
  676.     XTHL        ;LEFT -> H, TXA ON STACK
  677.     PUSH H
  678.     LXI H,RAMIO    ;NUMBER OF BITS
  679.     MVI M,11H
  680.     LXI B,0    ;CLEAR PARTIAL PRODUCT
  681. LOOP:    MOV A,D        ;16 BIT DE ROTATE RIGHT
  682.     RAR
  683.     MOV D,A
  684.     MOV A,E
  685.     RAR
  686.     MOV E,A
  687.     DCR M        ;ONE BIT DONE
  688.     JZ MULS    ;ALL BITS DONE
  689.     XTHL
  690.     JNC SKIP    ;BIT NOT ONE - SKIP ADD
  691.     PUSH H
  692.     DAD B
  693.     MOV B,H
  694.     MOV C,L
  695.     POP H
  696. SKIP:    ORA A        ;CLEAR CARRY
  697.     MOV A,L        ;16 BIT H ROTATE LEFT
  698.     RAL
  699.     MOV L,A
  700.     MOV A,H
  701.     RAL
  702.     MOV H,A
  703.     XTHL
  704.     JMP LOOP
  705. MULS:    POP D        ;CLEAN JUNK OFFSTACK
  706.     MOV D,B        ;RESULT -> DE
  707.     MOV E,C
  708.     POP H        ;RESTORE TXA
  709.     JMP TERA    ;LOOK FOR ADDITIONAL OPERATORS
  710. TERN:    RST 1
  711.     DB '/'        ;FOLLOWED BY '/'' '?
  712.     DW RETI    ;NOPE - DONE WITH ALL FACTORS
  713.     PUSH D        ;SAVE LEFT FACT
  714.     CALL FACT    ;GET RIGHT FACT
  715.     CALL CHSG    ;CHANGE SIGN IF NEEDED
  716.     XTHL        ;TXA ON STK, LEFT -> H
  717.     XCHG        ;LEFT -> DE, ABS(RIGHT) -> H
  718.     CALL CHS1    ;ABS(LEFT) -> DE
  719.     PUSH B        ;SAVE SIGN OF RESULT
  720.     MOV B,H
  721.     MOV C,L        ;ABS(RIGHT) -> B
  722.     XCHG        ;ABS(LEFT) -> H
  723. DV02:    MOV A,B        ;DIVISION BY ZERO?
  724.     ORA C
  725.     CZ ERRO    ;YUP - ERROR
  726.     LXI D,0    ;CLEAR QUOTIENT
  727. DIV1:    MOV A,L        ;LEFT = LEFT -RIGHT
  728.     SUB C
  729.     MOV L,A
  730.     MOV A,H
  731.     SBB B
  732.     MOV H,A
  733.     INX D        ;QUO=QUO + 1
  734.     JNC DIV1    ;STILL POSITIVE - SUB AGAIN
  735.     DCX D        ;TOO FAR - QUO = QUO -1
  736.     DAD B        ;GET REMAINDER -> H
  737.     SHLD RMDR    ;SAVE IT
  738.     POP B        ;GET THE SIGN OF RESULT
  739.     MOV A,B
  740.     ORA A
  741.     CM COMD    ;COMPLIMENT RESULT MAYBE
  742.     POP H        ;RESTORE TXA
  743.     JMP TERA    ;LOOK FOR ADDITONAL OPERATORS
  744. ;
  745. ;
  746. ;FACTOREVALUATOR.
  747. ;<FACT>    ::=    <CONSTANT> I <VARIABLE> I -<FACT>
  748. ;        +<FACT> I (<EXPR>) I . I ? I $ I %
  749. ;         I & I @ I ^ I \
  750. ;
  751. ;VALUE OF FACTOR LEFT IN DE ON EXIT.
  752. ;
  753. FACT:    RST 1
  754.     DB '+'        ;UNARY PLUS ?
  755.     DW FACA    ;IGNORE IT
  756. FACA:    DCX H        ;IS THIS A CONSTANT?
  757.     RST 2        ;SET FLAGS, TC IS 0 - 9, TZ IS TERMN
  758.     JC DEINT    ;YUP - GET VAL -> DE AND EXIT
  759.     CZ ERRO    ;MISSING EXPRESSION ERROR
  760.     RST 1
  761.     DB '-'        ;UNARY MINUS ?
  762.     DW TRY2
  763.     CALL FACT    ;GET FACTOR TO NEGATE
  764.     JMP COMD    ;COMPLIMENT IT, RETURN FROM COMD
  765. TRY2:    RST 1
  766.     DB '.'        ;CURRENT LINE ?
  767.     DW TRY1
  768.     XCHG        ;SAVE TXA IN DE
  769.     LHLD CURL    ;GET CURRENT LINE # -> DE
  770.     XCHG        ;RESTORE TXA
  771.     RET
  772. TRY1:    RST 1
  773.     DB '$'        ;RETURN ADDRESS ?
  774.     DW TRY3
  775.     XCHG        ;SAVE TXA
  776.     LHLD DLAD    ;GET RETURN ADDRESS -> H
  777.     XCHG        ;RESTORE TXA
  778.     RET
  779. TRY3:    RST 1
  780.     DB '%'        ;DIVISION REMAINDER ?
  781.     DW TRY4
  782.     XCHG        ;SAVE TXA
  783.     LHLD RMDR    ;GET REMAINDER -> H
  784.     XCHG        ;RESTORE TXA
  785.     RET
  786. TRY4:    RST 1
  787.     DB '!'        ;PEEK ?
  788.     DW TRY5
  789.     XCHG        ;SAVE TXA
  790.     LHLD MADR    ;GET LAST MEMORY ADDRESS -> H
  791.     MOV A,M        ;PEEK -> A
  792.     XCHG        ;RESTORE TXA
  793.     JMP ARET    ;RETURN VALUE IN A REG
  794. TRY5:    RST 1
  795.     DB '&'        ;PORT INPUT ?
  796.     DW TRY6
  797.     MVI A,333Q
  798.     STA RAMIO    ;SETUP INP INST IN RAM
  799.     CALL RAMIO    ;EXECUTE IT
  800. ARET:    MOV E,A        ;SETUP TWO BYTE VALUE -> DE
  801.     MVI D,0
  802.     RET
  803. TRY6:    RST 1
  804.     DB '^'        ;USER DEFINED FUNCTION REFERENCE ?
  805.     DW TRY7
  806.     PUSH H        ;SAVE TXA
  807.     CALL EOM        ;VERIFY ROOM FOR RECURSION
  808.     LHLD DEFF    ;TXA OF DEFINITION
  809.     RST 3        ;EVALUATE THE FUNCTION
  810.     POP H        ;RESTORE TXA
  811.     RET
  812. TRY7:    RST 1
  813.     DB '_'        ;RESULT OF LAST EXPRESSION ?
  814.     DW USR1
  815.     XCHG        ;SAVE TXA
  816.     LHLD LRES    ;GET LAST EXPR RESULT -> H
  817.     XCHG
  818.     RET
  819. USR1:    RST 1
  820.     DB '@'        ;MACHINE LANGUAGE CALL ?
  821.     DW TRY8
  822.     PUSH H        ;SAVE TXA
  823.     CALL EOM        ;ENUF STACK SPACE ?
  824.     LHLD USRL    ;HIS ROT ADR ON STK, TXA -> H
  825.     XTHL
  826.     RET        ;GOTO TO HIS ROT
  827. ;
  828. ;SAMPLE USR ROT TO RETURN THE ASCII VALUE OF THE CHR
  829. ;FOLLOWING THE @.
  830. ;
  831. USR:    MOV E,M        ;SETUP TWO BYTE VALUE -> DE
  832.     MVI D,0
  833.     INX H        ;MOVE TXA OVER CHR
  834.     RET
  835. ;
  836. TRY8:    RST 1
  837.     DB '\'        ;SINGLE CHR INPUT ?
  838.     DW TRY9
  839.     CALL TTYI    ;GET THE INPUT -> A
  840.     JMP ARET
  841. TRY9:    RST 1
  842.     DB '('        ;EXPRESSION IN PARENTHESIS ?
  843.     DW TRY0
  844.     PUSH H        ;MAKE SURE THERE IS ROOM BEFORE
  845.     CALL EOM        ;RECURSING
  846.     POP H
  847.     RST 3        ;RECURSIVE
  848.     RST 1
  849.     DB ')'        ;GOT TO HAVE A RIGHT TO MATCH
  850.     DW SNER    ;NOPE - ERROR
  851.     RET
  852. TRYV:    CALL LOKU    ;GET THE VARIABLES INDES -> H
  853.     MOV E,M        ;VAR VAL -> DE
  854.     MVI D,0        ;CLEAR HIGH BITS IF SINGLE ARRAY
  855.     JNZ TRYW    ;SINGLE BYTE ARRAY, DON'T LOAD HI
  856.     INX H
  857.     MOV D,M
  858. TRYW:    POP H        ;RESTORE TXA, PUSHED BY LOKU
  859.     RET
  860. ;
  861. ;TRY0 WILL HANDLE THE INPUT OPERATOR IF PRESENT.  EXECUTION
  862. ;WILL STOP AND A '?'' 'WILL BE PRINTED ON THE OUTPUT DEVICE.
  863. ;THE USER RESPONDS WITH ANY VALID EXPRESSION, AND HITS
  864. ;BETURN.  IT IS NOT A GOOD IDEA TO TYPE QUESTION MARKS
  865. ;IN RESPONSE TO AN INPUT STMT.    MUNCHES LINB.
  866. ;
  867. TRY0:    RST 1
  868.     DB '?'        ;THE LINE INPUT OPERATOR ?
  869.     DW TRYV
  870.     RST 5        ;SEND THE QUESTION MARK
  871.     DB '?',' '+200Q
  872.     PUSH H        ;SAVE THE TXA
  873.     CALL EOM        ;VERIFY ROOM FOR RECURSION
  874.     CALL GETL    ;GET HIS INPUT
  875.     RST 2        ;GET FIRST CHR$ RETURN ?
  876.     JZ ENTR    ;YUP - CLEAR STK AND RE-ENTER
  877.     RST 3        ;EVALUATE HIS INPUT  RECURSIVE
  878.     POP H        ;RESTORE TXA
  879.     RET
  880. ;
  881. ;
  882. ;COMMAND PROCESSOR.
  883. ;
  884. CMD1:    RST 1
  885.     DB '['        ;ARRAY LET STMT ?
  886.     DW CMD    ;NOPE - IT'S A COMMAND
  887. LOP:    MOV A,M        ;MOVE TO RIGHT EXPR
  888.     INX H
  889.     CPI ']'
  890.     JNZ LOP
  891.     INX H        ;MOVE OVER '=''
  892.     RST 3        ;EXPR VALUE -> DE
  893.     XTHL        ;EOS TXA ON STK, SOS TXA -> H
  894.     JMP LETS    ;DO THE ASSIGNMENT
  895. CMD:    POP H        ;RESTORE SOL TXA
  896.     RST 1
  897.     DB 'L'        ;LIST COMMAND ?
  898.     DW NEW1
  899.     CALL DEINT    ;GET ARG -> DE, 0 IF NO ARG
  900.     CALL LFND    ;FIND THAT LINE
  901.     MOV H,B        ;START ADDRESS -> H
  902.     MOV L,C
  903.     DB 76Q        ;SETUP BOGUS LAI
  904. LISC:    INX H        ;SKIPPED FIRST TIME THRU, FROM LAI
  905. LISA:    CALL ABRT    ;CONTROL C (^C) CHECK
  906.     CALL CRLF
  907.     CALL FELN    ;FETCH LINE # -> DE, EXIT IF ZERO
  908.     PUSH H        ;SAVE DURING PRINT
  909.     XCHG        ;LINE # -> H
  910.     CALL NOSP    ;PRINT IT
  911.     POP H        ;FIRST CHR OF LINE
  912. LISB:    INX H        ;GET A CHR
  913.     MOV A,M
  914.     ORA A        ;EOL?
  915.     JZ LISC    ;LAST ON LINE - DO NEXT LINE
  916.     RST 4        ;NOT LAST - PRINT IT
  917.     JMP LISB    ;DO REST OF LINE
  918. ;
  919. NEW1:    RST 1
  920.     DB 'N'        ;NEW COMMAND ?
  921.     DW RUN1
  922.     LHLD BOTX    ;PUT EOB MARK IN BUFFER
  923.     XRA A        ;A=0
  924.     MOV M,A
  925.     INX H
  926.     MOV M,A
  927.     INX H
  928.     MOV M,A
  929.     SHLD EOTX
  930. RSSP:    POP B        ;RETURN ADDRESS -> B
  931.     LHLD SPRS    ;HOLDS STACK RESET ADDRESS
  932.     SPHL
  933.     PUSH B        ;RESTORE RETURN ADDESS
  934.     LHLD BOTX    ;INCASE THIS IS SUICIDAL
  935.     DCX H        ;BOTX - 1 -> H
  936.     RET
  937. ;
  938. RUN1:    RST 1
  939.     DB 'R'        ;RUN COMMAND ?
  940.     DW OS1
  941.     JZ RSSP    ;NO ARG - RESET STACK AND GO
  942.     RST 3        ;GET THE ARGUMENT
  943.     JMP GOTA    ;DO A GOTO
  944. ;
  945. ;THESE ROUTINES ARE USED TO PRINT THE 16 BITS IN THE
  946. ;H~EGISTER AS DECIMAL ASCII ON THE TERMINAL.  INPTPRINTS
  947. ;THE NUMBER IN CURL IF IT IS NOT 65535 (NOT IMMEDIATE MODE).
  948. ;THE WORD 'I'N' 'PRECEDES THE NUMBER IF IT IS PRINTED.    SHLP
  949. ;PRINTS A 15 BIT SIGNED NUMBER IN H (-32768 TO 32767).
  950. ;HLPT PRINTS THE 16 BIT UNSIGNED NUMBER IN H (0 TO 65535).
  951. ;NOSP PRINTS 16 BIT UNSIGNED NUMBERS IN H WITHOUT THE
  952. ;LEADING SPACE NORMALLY PRINTED.  ALL NUMBERS ARE FOLLOWED
  953. ;BY ONE TRAILING SPACE.  SHLP PRINTS A MINUS SIGN ('-'')'
  954. ;IN PLACE OF THE LEADING SPACE IF H IS NEGATIVE.
  955. ;STACK USAGE:  8 BYTES.  MUNCHES ALL REGS.
  956. ;
  957. INPT:    LHLD CURL    ;CURRENT LINE NUMBER -> H
  958.     MOV A,H        ;IS IT 377 377
  959.     ANA L
  960.     INR A
  961.     RZ        ;YUP - RETURN PRINT NOTHING
  962.     RST 5        ;NOPE - PRINT 'I'N'
  963.     DB 'I','N'+200Q
  964. HLPT:    RST 5        ;PRINT A SPACE
  965.     DB ' '+200Q
  966. NOSP:    LXI D,TENS    ;POINT TO POWERS OF TEN TABLE
  967.     PUSH D        ;PUT TABLE ADR ON STACK
  968.     MVI C,1        ;CLAR SIGNIFICANT DIGIT FLAG
  969. POSI:    XTHL        ;NUMBER ON STK, TABLE -> H
  970.     MOV E,M        ;POWER OF TEN -> DE
  971.     INX H
  972.     MOV D,M
  973.     INX H
  974.     XTHL        ;TABLE ON STK, NUMBER -> H
  975.     MVI B,0        ;THIS DIGIT = 0
  976. DIVD:    MOV A,L        ;16 BIT SUBTRACT H = H - DE
  977.     SUB E
  978.     MOV L,A
  979.     MOV A,H
  980.     SBB D
  981.     MOV H,A
  982.     INR B        ;INCREMENT THIS DIGIT
  983.     JNC DIVD    ;NOT NEGATIVE YET - KEEP SUBTRACING
  984.     DCR B        ;GONE ONE TOO FAR, DIGIT = DIGIT -1
  985.     DAD D        ;GONE TOO FAR, ADD BACK TEN POWER
  986.     XRA A        ;A=0
  987.     ORA B        ;IS THIS DIGIT ZERO ?
  988.     JNZ PRNT    ;NOPE - PRINT IT
  989.     ORA C        ;ANY SIGNIFICANT DIGITS YET ?
  990.     JNZ BYPA    ;NOPE - DON'T PRINT THIS ZERO
  991. PRNT:    ADI '0'        ;ADD IN ASCII BIAS
  992.     MVI C,0        ;SET SIGINIFICANT DIGIT FLAG
  993.     RST 4        ;SEND THIS DIGIT
  994. BYPA:    MOV A,E        ;ON THE LAST DIGIT ?
  995.     DCR A
  996.     JNZ POSI    ;NOPE - DO NEXT ONE
  997.     POP D        ;YUP - CLEAN UP STACK
  998.     MOV A,C        ;SIGNIFICANT DIGIT FLAG -> A
  999.     ORA A        ;HAVE WE SENT ANY SIG DIGS YET ?
  1000.     JZ SPOU    ;YUP - OUTPUT THE TRAILING SPACE
  1001.     RST 5    ;NOPE - WE'RE PRINTING A ZERO
  1002.     DB '0'+200Q    ;SEND A '0''
  1003. SPOU:    RST 5        ;PRINT A SPACE
  1004.     DB ' '+200Q
  1005.     RET
  1006. TENS:    DW 10000,1000,100,10,1
  1007. SHLP:    XCHG        ;NUMBER -> DE
  1008.     CALL CHSG    ;ABS(NUMBER) -> DE
  1009.     XCHG        ;ABS(NUMBER) -> H
  1010.     JP HLPT    ;WAS POSITIVE, PRINT SPACE
  1011.     RST 5        ;PRINT THE MINUS SIGN ('-'')'
  1012.     DB '-'+200Q
  1013.     JMP NOSP    ;PRINT THE NUMBER
  1014. ;
  1015. ;
  1016. ;DEINT TAKES ASCII FROM MEMORY INTO BINARY IN DE.
  1017. ;MOVES TXA UNTIL CHR IS NOT 0 - 9.
  1018. ;STACK USAGE:  4 BYTES.  MUNCHES ALL REGS EXCEPT B.
  1019. ;
  1020. DEINT:    DCX H        ;DECR FOR FETCH
  1021.     LXI D,0    ;CLEAR PARTIAL SUM
  1022. DEIM:    RST 2        ;RST 2 CHR    0 - 9?
  1023.     RNC        ;NOPE - DONE
  1024.     PUSH H        ;SAVE CHR ADR
  1025.     MOV H,D        ;PARTIAL SUM -> H
  1026.     MOV L,E
  1027.     DAD D        ;HL = DE * 10
  1028.     DAD H        ;PS = PS * 10
  1029.     DAD D
  1030.     DAD H
  1031.     SUI '0'        ;REMOVE ASCII BIAS
  1032.     MOV E,A        ;SETUP 16 BIT DIGIT -> DE
  1033.     MVI D,0
  1034.     DAD D        ;ADD IN NEW DIGIT
  1035.     XCHG        ;PARTIAL SUM -> DE
  1036.     POP H        ;RESOTRE TXA
  1037.     JMP DEIM
  1038. ;
  1039. ;CHS1 CHECKS THE SIGN OF DE REG.  IF POSITIVE, RETURN A
  1040. ;MUNCHED, SIGN BIT FALSE.  IF NEGATIVE, COMPLIMENT DE,
  1041. ;A MUNCHED, SIGN BIT SAME AS THAT OF B REG.  CHSG
  1042. ;CLEARS THE SIGN BIT OF B REG FIRST.  COMD UNCONDITIONALLY
  1043. ;COMPLIMENTS DE REG.  STACK USAGE:  2 BYTES.
  1044. ;
  1045. CHSG:    MVI B,0        ;CLEAR RESULT SIGN
  1046. CHS1:    MOV A,D        ;IS DE POSITIVE ?
  1047.     ORA A
  1048.     RP        ;YUP - RETURN
  1049.     MOV A,B        ;NOPE - FLIP SIGN OF B
  1050.     XRI 200Q
  1051.     MOV B,A        ;AND FALL THRU TO COMPLIMENT DE
  1052. COMD:    MOV A,D
  1053.     CMA
  1054.     MOV D,A
  1055.     MOV A,E
  1056.     CMA
  1057.     MOV E,A
  1058.     INX D
  1059.     RET
  1060. ;
  1061. ;
  1062. ;RAM DEFINITIONS
  1063. ;
  1064. BOTX:    DW EOP        ;ADR OF FIRST CHR IN BUFFER
  1065. EOTX:    DW EOP+2    ;ADR OF LAST CHR IN BUFFER
  1066. CURL:    DW -1    ;CURRENT LINE NUMBER
  1067. LBUL    EQU 72    ;INPUT LINE BUFFER LENGTH
  1068. OS    EQU  374Q*256    ;ADDRESS OF OPERATING SYSTEM
  1069. LINB:    DB 0        ;LEAVE SPACE FOR INPUT LINE BUF
  1070.     ORG $+LBUL+2
  1071. SPRS:    DW 10Q*256        ;ADDRESS OF STACK POINTER RESET
  1072. LRES:    DW 0        ;HOLDS RESULT OF LAST EXPR EVAL
  1073. DLAD:    DW 0        ;HOLDS RETURN LINE NUMBER FOR '$''
  1074. DEFF:    DW COLN+1    ;INITIALIZE TXA OF USER DEFINED FUN
  1075. USRL:    DW USR        ;ADROF USERS MACHINE LANG CALL
  1076. SSTM:    DW EOP        ;INITIALIZE START OF LAST STMT
  1077. RAMIO:    OUT 10        ;RAM AREA FOR INP AND OUT
  1078.     RET
  1079. MADR:    DW 0        ;SAVE AREA FOR PEEK / POKE ADDRESSES
  1080. RMDR:    DW 0        ;SAVE AREA FOR DIVISION REMAINDER
  1081. VART:    DB 0        ;LEAVE ROOM FOR PROGRAM VARIABLES
  1082.     ORG    $+51
  1083. ;
  1084. ;
  1085. ;
  1086. ;DEVO STARTS AT RESTART 4.
  1087. ;DEVO:    PUSH PSW
  1088. ;    IN 1
  1089. ;    ANI 2
  1090. DEVP:    JZ DEVQ    ;NOT READY
  1091.     POP PSW
  1092. TODP:    OUT 10H
  1093.     RET
  1094.     DW 0        ;PATCH ROOM
  1095. ;
  1096. ;TTYI GETS A CHR FROM THE INPUT DEVICE.  CAN MUNCH A AND
  1097. ;FLAGS.  STACK USAGE:  4 BYTES.
  1098. ;
  1099. TTYI:    CALL TRDY    ;IS INPUT READY ?
  1100. TIA:    JZ TTYI    ;NOPE - KEEP TRYING
  1101. TIDP:    IN 16
  1102.     ANI 177Q
  1103.     RET
  1104.     DW 0        ;LEAVE ROOM FOR PATCHES
  1105. ;
  1106. ;TEST TERMINAL INPUT READY BIT STATUS.    MUNCHES A & FLAGS.
  1107. ;STACK USAGE:  2 BYTES.
  1108. ;
  1109. TRDY:    IN 17        ;GET INPUT STATUS
  1110. TIRM:    ANI 2        ;MASK TO INPUT @EADY BIT
  1111.     RET        ;FZ MEANS READY, TZ MEANS NOT READY
  1112.     DW 0        ;ROOM FOR PATCHES
  1113. ;
  1114. CRLE:    XRA A        ;A CONTINUATION OF GETL
  1115.     MOV M,A        ;PUTS EOB/EOL MARK IN LINB
  1116.     INX H
  1117.     MOV M,A
  1118.     INX H
  1119.     MOV M,A
  1120.     LXI H,LINB-1
  1121. ;
  1122. ;CRLF SEND A CARRIAGE RETURN AND LINE FEED TO TERMINAL.
  1123. ;MUNCHES A & FLAGS.  STACK USAGE:  8 BYTES.
  1124. ;
  1125. CRLF:    RST 5
  1126.     DB 15Q,212Q
  1127.     RET
  1128. ;
  1129. ;ABRT CHECKS THE CONSOLE DEVICE FOR A CHR AND IF THERE,
  1130. ;CHECK IF IT'S A CONTROL C.  IF NOT, RETURN WITH A MUNCHED.
  1131. ;IF YES, FALL THROUGH TO STOP ROUTINE.
  1132. ;STACK USAGE:  6 BYTES.
  1133. ;
  1134. ABRT:    CALL TRDY    ;IS DATA READY FLAG UP ?
  1135. TIB:    RZ        ;NOPE - RETURN
  1136.     CALL TTYI    ;YUP - FETCH THE CHR
  1137.     CPI 3        ;A CONTROL C (^C) ?
  1138.     RNZ        ;NOPE - RETURN
  1139.     RST 0        ;BACK TO ENTRY POINT
  1140. ;
  1141. ;
  1142. OS1:    RST 1
  1143.     DB 'O'        ;JMP TO OS ?
  1144. OSPK:    DW SAV1    ;MIGHT BE POKED TO SNEB
  1145.     JMP OS
  1146. ;
  1147. ;LOKU GETS THE INDES OF THE VARIBLE POINTED TO BY H AND
  1148. ;RETUNS THEM IN H.  THE TXA IS BUMPED OVER THE VARNAM,
  1149. ;AND PUSHED BEFORE RETURNING. YOU MUST POP AFTER CALLING
  1150. ;LOKU.    USES ALL REGS EXCEPT DE.  STACK USAGE:    4 BYTES IF
  1151. ;VAR IS A - Z, >= 16 IF SUBSCRIPTED.  ZERO FLAG IS TRUE
  1152. ;IF IT IS DOUBLE BYTE VAR (SIMPLE OR DOUBLE ARRAY).  ZERO
  1153. ;IS FALSE IF SINGLE BYTE VARIABLE (SINGLE BYTE ARRAY).
  1154. ;
  1155. LOKU:    MOV A,M        ;VARNAM -> A
  1156.     SUI 'A'        ;IS IT A - Z ?
  1157. LKP1:    JC DARY    ;NOPE
  1158.     CPI 27        ;26 LETTERS + 1
  1159. LKP2:    JNC DARY    ;NOPE - TRY ARRAYS IF NOT POKED
  1160.     ;SAVE NEW TXA ON STACK BEFORE RETURNING
  1161.     INX H        ;MOVE TXA OVER VARNAM
  1162.     XTHL        ;PUT TXA ON STK
  1163.     PUSH H        ;PUT RETURN ADDRSS BACK
  1164.     LXI H,VART    ;BASE ADDRESS -> H
  1165.     RLC        ;MULTIPLY INDEX BY 2
  1166.     MOV C,A        ;TWO BYTE INDEX -> B
  1167.     MVI B,0
  1168.     DAD B        ;ADD IN INDEX TO BASE
  1169.     XRA A        ;SET ZERO FLAG, THIS IS DOUBLE BYTE
  1170.     RET
  1171. ;
  1172. EOP1    EQU $            ;THIS WILL BE BOTX-1 IF ARRAYS,
  1173.             ;STRING, AND TAPE / SAVE ARE DELETED
  1174. ;
  1175. DARY:    RST 1
  1176.     DB '"'        ;DOUBLEBYTE ARRAY ?
  1177.     DW SARY
  1178.     CALL SUBS    ;GET THE SUBSCRIPT -> B
  1179.     XTHL        ;INDES -> H, TXA ON STK
  1180.     PUSH H
  1181.     LHLD DBSE
  1182.     DAD B
  1183.     DAD B
  1184.     XRA A        ;SET ZERO FLAG, THIS IS DOUBLE BYTE
  1185.     RET
  1186. SARY:    RST 1
  1187.     DB ''''        ;SINGLE BYTE ARRAY ?
  1188.     DW SNER
  1189. SSUB:    CALL SUBS    ;SUBSCRIPT -> B
  1190.     XTHL        ;TXA ON STK, INDES -> H
  1191.     PUSH H
  1192.     LHLD SBSE
  1193.     DAD B
  1194.     ORI 1        ;RESET ZERO FLAG, TO SAY SINGLE BYTE
  1195.     RET
  1196. ;
  1197. ;SUBS GETS THE SUBSCRIPT FOR A STRING OR ARRAY -> B.
  1198. ;MUNCHES ALL REGS EXCEPT DE.  STACK USAGE:  >= 14 BYTES.
  1199. ;
  1200. SUBS:    PUSH D        ;SAVE DE
  1201.     RST 1
  1202.     DB '['        ;IGNORE '[''
  1203.     DW SUB0
  1204. SUB0:    RST 3        ;GET THE SUBSCRIPT -> DE
  1205.     MOV B,D        ;SUBSCRIPT -> B
  1206.     MOV C,E
  1207.     POP D        ;RESTORE DE
  1208.     RST 1
  1209.     DB ']'        ;IGNORE ']''
  1210.     DW SUB1
  1211. SUB1:    RET
  1212. ;
  1213. BSES:    RST 1
  1214.     DB ''''        ;SET SINGLE BYTE ARRAY BASE ?
  1215.     DW BSED
  1216.     XCHG        ;NEW BASE -> H
  1217.     SHLD SBSE    ;SAVE NEW BASE
  1218.     POP H        ;RESTORE EOS TXA
  1219.     RET
  1220. BSED:    RST 1
  1221.     DB '"'        ;SET DOUBLE BYTE ARRAY BASE ?
  1222.     DW LETS    ;MUST BE A LET
  1223.     XCHG        ;NEW BASE ->H
  1224.     SHLD DBSE    ;SAVE NEW BASE
  1225.     POP H        ;RESTORE EOS TXA
  1226.     RET
  1227. ;
  1228. SBSE:    DW 370Q*256+10Q    ;ADR OF SINGLE BYTE ARRAY BASE ADR
  1229. DBSE:    DW 370Q*256+10Q    ;ADR OF DOUBLE BYTE ARRAY BASE ADR
  1230. ;
  1231. EOP2    EQU $            ;THIS WILL BE BOTX-1 IF STRINGS AND
  1232.             ;TAPE / SAVE ARE DELETED.
  1233. ;
  1234. PRI1:    RST 1
  1235.     DB ')'        ;PRINT STRING ARRAY ?
  1236.     DW PEXP
  1237.     CALL SSUB    ;GET STRING TXA -> H, TXA ON STK
  1238.     XCHG        ;STRING TXA -> DE
  1239.     POP H        ;TXA BACK -> H
  1240. STRA:    LDAX D        ;GET A STRING CHR
  1241.     ORA A        ;EOS YET ?
  1242.     JZ PEXQ    ;YUP - DO MORE OF ? STMT
  1243.     RST 4        ;NOPE - PRINT IT
  1244.     INX D        ;BUMP STRING TXA
  1245.     JMP STRA    ;PRINT SOME MORE
  1246. ;
  1247. NPRT:    RST 1
  1248.     DB ')'        ;STRING INPUT ?
  1249.     DW NPRU
  1250.     CALL SSUB    ;GET STRING DESTINATION TXA -> H
  1251.     RST 5        ;PRINT PROMPT '-' '
  1252.     DB '-',' '+200Q
  1253.     CALL GETL+3    ;USE GETL TO INPUT STRING
  1254.     POP H        ;GET TXA BACK, (PUSHED BY SSUB)
  1255.     RET
  1256. ;
  1257. EOP3    EQU $            ;THIS WILL BOTX-1 IF SAVE / TAPE
  1258.             ;IS DELETED
  1259. ;
  1260. ;SAV1 PUNCHES TAPES OF THE CONTENTS OF THE TEXT
  1261. ;BUFFER.  RETURNS TO COMMAND MODE WHEN DONE.
  1262. ;COMMAND IS FOLLOWED BY A SINGLE CHR PROGRAM NAME SO
  1263. ;MORE THAN ONE PGM CAN BE PUT ON A TAPE.  IF CR IS
  1264. ;GIVEN FOR NAME, PUNCH NAME AS A NULL.
  1265. ;
  1266. ;TAPE FORMAT:
  1267. ;
  1268. ;    252    START CHR
  1269. ;    XXX    NAME OF PROGRAM, 000 IF NULL NAME
  1270. ;    NNN    DATA BYTES BETWEEN BOTX AND EOTX
  1271. ;    000
  1272. ;    000
  1273. ;    000    EOT IS MARKED BY THREE NULLS
  1274. ;
  1275. SAV1:    RST 1
  1276.     DB 'S'        ;SAVE COMMAND ?
  1277.     DW TAP1
  1278.     MVI A,252Q        ;START OF TAPE CHR
  1279.     CALL PNOU    ;SEND IT
  1280.     MOV A,M        ;PROGRAM NAME CHR -> A
  1281.     CALL PNOU    ;SEND IT
  1282.     LHLD EOTX    ;STOP ADDRESS -> DE
  1283.     XCHG
  1284.     LHLD BOTX    ;START OF TEXT ADR -> H
  1285. SAVA:    MOV A,M        ;CHR OF PROGRAM -> A
  1286.     CALL PNOU    ;SEND IT
  1287.     RST 6        ;DONE YET ?
  1288.     INX H        ;BUMP TXA
  1289.     JNZ SAVA    ;NOPE - KEEP SAVING
  1290.     RST 0        ;ALL DONE, RE-ENTER
  1291. ;
  1292. ;TAP1 READS A TAPE FROM THE READER INTO THE TEXT
  1293. ;BUFFER.  RETURNS TO COMMAND MODE WHEN DONE.  COMMAND IS
  1294. ;FOLLOWED BY A SINGLE CHR PROGRAM NAME, LIKE SAVE.
  1295. ;IT WILL SEARCH THE TAPE FOR A START CHR FOLLOWED BY THE
  1296. ;NAME GIVEN.  IF CR IS GIVEN FOR A NAME, TAKE FIRST ONE
  1297. ;FOUND.  IF THE NAMED PROGRAM CAN'T BE FOUND, THE TEXT
  1298. ;BUFFER IS LEFT ALONE.    WHEN READING STARTS, THE NAME
  1299. ;BYTE FROM TAPE IS ECHOED SO YOU'LL KNOW IT IS LOADING.
  1300. ;
  1301. TAP1:    RST 1
  1302.     DB 'T'        ;READ A TAPE COMMAND ?
  1303.     DW SNER
  1304. TAPA:    CALL CHIN    ;GET A CHR
  1305.     CPI 252Q        ;START CHR ?
  1306.     JNZ TAPA    ;NOPE - KEEP LOOKING
  1307.     CALL CHIN    ;YUP - GET NAME CHR
  1308.     CMP M        ;THE ONE WE WANT ?
  1309.     JZ TAPF    ;YUP - START READING
  1310.     MOV B,A        ;SAVE NAME IN B
  1311.     MOV A,M        ;DID HE GIVE DON'T CARE NAME ?
  1312.     ORA A
  1313.     MOV A,B        ;NAME FROM TAPE -> A
  1314.     JNZ TAPA    ;NOPE - DON'T READ THIS ONE IN
  1315. TAPF:    RST 4        ;SEND NAME OF PGM BEING READ
  1316.     LHLD BOTX    ;WHERE IT WILL GO
  1317. TAPB:    MVI C,3        ;INITIALIZE EOT NULL COUNTER
  1318. TAPC:    CALL CHIN    ;GET A CHR
  1319.     MOV M,A        ;PUT IN RAM
  1320.     CALL EOM1    ;PGM TOO BIG ?
  1321.     MOV A,M        ;GET CHR BACK
  1322.     INX H        ;BUMP
  1323.     ORA A        ;A NULL ?
  1324.     JNZ TAPB    ;NOPE - KEEP READING
  1325.     DCR C        ;DECR EOT NULL COUNT
  1326.     JNZ TAPC    ;NOT THIRD ONE - KEEP READING
  1327.     DCX H        ;STORE NEW EOTX
  1328.     SHLD EOTX
  1329.     RST 0        ;BACK TO COMMAND MODE
  1330. ;
  1331. ;PNOU IS THE PUNCH DRIVER USED BY SAVE.  ENTER WITH CHR TO
  1332. ;SEND IN A REG.  STACK USAGE:  2 BYTES.
  1333. ;
  1334. PNOU:    PUSH PSW    ;SAVE CHR TO SEND
  1335. PNOV:    IN 5        ;GET PUNCH STATUS
  1336. CORM:    ANI 2        ;READY YET ?
  1337. COA:    JZ PNOV
  1338.     POP PSW    ;IT'S READY, SEND THE CHR
  1339. CODP:    OUT 16
  1340.     RET
  1341. ;
  1342. ;CHIN IS THE READER INPUT ROUTINE CALLED BY THE SAVE
  1343. ;COMMAND.  IT MUNCHES A & FLAGS.  STACK USAGE:    2 BYTES.
  1344. ;
  1345. CHIN:    IN 5        ;GET READER STATUS
  1346. CIRM:    ANI 1        ;READY YET ?
  1347. CIA:    JZ CHIN    ;NOPE - WAIT FOR     T
  1348. CIDP:    IN 4        ;GOT A READY, GET THE INPUT
  1349.     RET
  1350. ;
  1351. PGE    EQU  7*256    ;PAGE FOR BINARY LOADER
  1352. EOP    EQU $            ;THIS IS BOTX-1 IF TAPE / SAVE ARE KEPT
  1353. ;
  1354. ;
  1355. ;INIT IS THE INITIALIZATION ROUTINE.  IT IS LOCATED IN THE
  1356. ;MIDDLE OF THE CASUAL PROGRAM STORAGE AREA.  IT IS ENTERED
  1357. ;WHEN CASUAL IS EXECUTED AFTER LOADING.  IT POKES OUT
  1358. ;THE JUMP TO IT.  RESPOND TO 'M'EM SIZ ?' 'WITH THE
  1359. ;DECIMAL NUMBER OF THE HIGHEST ADDRESS TO BE USED BY CASUAL
  1360. ;OR HIT CARRIAGE RETURN TO USE ALL RAM AVAILABLE.
  1361. ;
  1362. INIT:    LXI SP,PGE+256    ;SETUP TEMPORARY STACK POINTER
  1363.     RST 5        ;SEND 'M'EM SIZ? ' 'MESSAGE
  1364.     DB    15Q,12Q,'MEM SIZ','?'+200Q
  1365.     CALL GETL    ;GET HIS RESPONSE
  1366.     RST 2        ;FETCH FIRST CHR, A RETURN ?
  1367.     JNZ NUM        ;NOPE - GET A NUMBER
  1368.     LXI H,MMEM    ;START OF RAM SEARCH
  1369. INIS:    MOV A,M        ;GET A CHR FROM MEMORY
  1370.     CMA
  1371.     MOV M,A        ;WRITE IT BACK COMPLIMENTED
  1372.     CMP M        ;DID IT GO ?
  1373.     CMA        ;/RESTORE MEMORY
  1374.     MOV M,A
  1375.     JNZ INIU    ;NOPE - THIS IS END OF RAM
  1376.     INX H        ;YUP - KEEP TRYING
  1377.     JMP INIS
  1378. NUM:    CALL DEINT    ;GET NUMERIC ARGUMENT
  1379.     XCHG        ;REQUESTE ADDRESS -> H
  1380.     LXI D,MMEM    ;MINIMUM POSSIBLE ADR -> DE
  1381.     RST 6        ;REQUEST < MINIMUM ?
  1382.     JC INIT    ;YUP - GIVE THE CHUMP ANOTHER CHANCE
  1383.     DCX H        ;FIRST LOC FOR STACK
  1384.     MOV A,M        ;GET CONTENTS
  1385.     CMA
  1386.     MOV M,A        ;WRITE IT BACK COMPLIMENTED
  1387.     CMP M        ;DID IT GO ?
  1388.     CMA
  1389.     MOV M,A        ;RESTORE CONTENTS
  1390.     INX H
  1391.     JNZ INIT    ;NOPE - NO RAM WHERE HE SAYS
  1392. ;
  1393. MMEM    EQU $            ;LOWEST LOC FOR STACK RESET
  1394. ;
  1395. INIU:    SHLD SPRS    ;YUP - MAKE IT THE STACK RESET ADR
  1396.     LXI H,EOP    ;BOTX IF HE SAYS 'Y'ES'
  1397.     CALL WANT    ;ASK 'W'ANT SAVE / TAPE?'
  1398.     DB  'SAVE/TAPE','?'+200Q
  1399.     CALL YSNO    ;GET HIS ANSWER
  1400.     LXI H,SNER    ;HE SAID NO - POKE OUT TEST
  1401.     SHLD OSPK    ;FOR SAVE / TAPE
  1402.     LXI H,EOP3    ;BOTX IF HE SAYS YES -> H
  1403.     CALL WANT    ;ASK 'W'ANT STRING I/O'
  1404.     DB  'STR I/O','?'+200Q
  1405.     CALL YSNO    ;GET HIS ANSWER
  1406.     LXI H,PEXP    ;HE SAID NO, POKE OUT STRING PRINT
  1407.     SHLD PXPK
  1408.     LXI H,NPRU    ;POKE OUT STRING INPUT TEST
  1409.     SHLD SIPK
  1410.     LXI H,EOP2    ;BOTX IF HE SAYS YES -> H
  1411.     CALL WANT    ;ASK 'W'ANT ARRAYS? '
  1412.     DB  'ARRAYS','?'+200Q
  1413.     CALL YSNO    ;GET HIS ANSWER
  1414.     LXI H,SNER    ;HE SAID NO, POKE OUT ARRAY LOOKUP
  1415.     SHLD LKP1+1    ;MAKE IT A SYNTAX ERROR
  1416.     SHLD LKP2+1
  1417.     JMP ICON    ;CONTNUED AT ICON
  1418. ;
  1419.     ORG PGE        ;PUT IN JUMP TO BINL FOR BOOT
  1420.     JMP BINL
  1421. ;
  1422. ICON:    LXI H,LETS    ;MAKE ARRAY ASSIGNMENT ILLEGAL
  1423.     SHLD DFPK
  1424.     LXI H,EOP1    ;THIS IS BOTX -> H
  1425. INIV:    XRA A        ;DO A 'N'EW' 'COMMAND
  1426.     MOV M,A        ;BOTX WILL BE IN H
  1427.     INX H        ;NOW
  1428.     SHLD BOTX    ;SAVE IT
  1429.     MOV M,A        ;DO A NEW
  1430.     INX H
  1431.     MOV M,A
  1432.     INX H
  1433.     MOV M,A
  1434.     SHLD EOTX
  1435.     LXI H,ENTR    ;POKE OUT JMP TO INIT
  1436.     SHLD 1        ;MAKE IT A JUMP TO ENTR
  1437.     RST 5        ;PRINT SIGN ON MESSAGE
  1438.     DB  15Q,12Q,'CASUA','L'+200Q
  1439.     JMP ICN2    ;CONTINUED AT ICN2
  1440. ;
  1441. ;ROUTINE TO GET 'Y'' 'OR 'N'' 'ANSWER FROM TERMINAL.
  1442. ;TZ MEANS 'Y'',' FZ MEANS 'N''.'
  1443. ;
  1444. YSNO:    CALL TTYI    ;GET HIS CHR
  1445.     RST 4        ;ECHO IT
  1446.     CPI 'Y'        ;YES ?
  1447.     JZ INIV
  1448.     RET
  1449. WANT:    RST 5        ;SR TO PRINT 'W'ANT'
  1450.     DB  15Q,12Q,'WANT',' '+200Q
  1451.     JMP MSG
  1452. ;
  1453.     ORG    PGE+101Q;
  1454. ;THIS SECTION POKES THE BINARY LOADER TO THE SAME     /O
  1455. ;CONFIGURATION USED BY THE BOOTSTRAP LOADER AT ZERO.
  1456. ;THIS IS EXECUTED ONLY ONCE, UPON ENTRY FROM THE
  1457. ;BOOTSTRAP.  AFTER THE FIRST TIME EXECUTED, THE JUMP
  1458. ;AT WORD 0 OF THE BINARY LOADER PAGE IS POKED TO JUMP
  1459. ;AROUND THE I/O POKE.
  1460. ;
  1461. BINL:    LDA 7        ;INPUT STATUS PORT #-> A
  1462.     STA RDIN+1    ;POKE INPUT ROUTINE
  1463.     LHLD 11Q        ;STATUS MASK ->L, RFZ OR RTZ -> H
  1464.     MOV A,H        ;CHANGE RTZ OR RFZ INTO JFZ OR JTZ
  1465.     ADI 2
  1466.     MOV H,A
  1467.     SHLD POK1+1    ;POKE THE INPUT ROUTINE
  1468.     LDA 14Q        ;INPUT DATA PORT # -> A
  1469.     STA POK2+1    ;POKE THE INPUT ROUTINE
  1470.     LXI H,REAC    ;POKE OUT THE JUMP TO BINL
  1471.     SHLD PGE+1    ;MAKE IT A JUMP TO READ-3
  1472. REAC:    LXI SP,PGE+256
  1473. READ:    MVI C,0        ;CLEAR CHECKSUM
  1474.     CALL RDIN    ;GET A CHR FROM TAPE
  1475.     CPI 277Q        ;IS ITAN EOT CHR ?
  1476.     JZ GOTO    ;YUP - LOOK FOR START ADDRESS
  1477.     CPI 377Q        ;NOPE - IS IT A START OF BLOCK ?
  1478.     JNZ READ    ;NOPE - MUST BE LEADER, KEEP LOOKING
  1479.     CALL ADIN    ;GET THE LOAD ADDRESS -> H
  1480.     CALL RDIN    ;BLOCK LENGTH -> A
  1481.     ORA A        ;BLOCK LENGTH = 0 ?
  1482.     JZ CKSM    ;YUP - NO DATA, VERIFY CHECKSUM
  1483.     MOV E,A        ;MOVE BLOCK LENGTH -> E
  1484. DATA:    CALL RDIN    ;GET A DATA BYTE FROM TAPE
  1485.     MOV M,A        ;PUT IT INTO MEMORY
  1486.     CMP M        ;DID IT WRITE PROPERLY ?
  1487.     JNZ MERR    ;NOPE - GIVE A CAN'T WRITE ERROR
  1488.     ADD C        ;UPDATE CHECKSUM -> A
  1489.     MOV C,A        ;UPDATED CHECKSUM -> C
  1490.     INX H        ;BUMP THE LOAD ADDRESS
  1491.     DCR E        ;DONE WITH THIS BLOCK YET ?
  1492.     JNZ DATA    ;NOPE - GET MORE DATA BYTES
  1493. CKSM:    CALL RDIN    ;DONE WITH BLOCK, GET CHECKSUM -> A
  1494.     CMP C        ;DOES IT MATCH CALCULATED VALUE ?
  1495.     JZ READ    ;YUP - LOOK FOR ANOTHER BLOCK
  1496.     MVI A,'C'        ;NOPE - GIVE CHECKSUM ERROR
  1497.     DB 1        ;SETUP A BOGUS LXI B INSTRUCTION
  1498. MERR:    MVI A,'M'
  1499. ERR:    OUT 1
  1500.     OUT 10Q
  1501.     OUT 21Q
  1502.     OUT 23Q
  1503.     STA PGE+377Q
  1504.     JMP ERR        ;LOOP FOREVER
  1505. ;
  1506. ;THIS SUBROUTINE GETS TWO BYTES FROM TAPE INTO H.
  1507. ;
  1508. ADIN:    CALL RDIN    ;GET FIRST BYTE
  1509.     MOV L,A        ;MOVE IT INTO -> L
  1510.     CALL RDIN    ;GET SECOND BYTE
  1511.     MOV H,A        ;MOVE IT INTO -> H
  1512.     RET
  1513. ;
  1514. ;COMES HERE WHEN EOT CHR IS FOUND.  IF A 100 BYTE FOLLOWS
  1515. ;THE EOT, THE NEXT TWO BYTES ARE TAKEN TO BE A START ADDRESS
  1516. ;CONTROL IS TRANSFERRED TO THIS ADDRESS.  IF NO 100 BYTE IS
  1517. ;FOUND, WE ENTER AN INFINITE LOOP.
  1518. ;
  1519. GOTO:    CALL RDIN    ;GET A CHR FROM TAPE
  1520.     CPI 100Q        ;IS IT A 100 (OCTAL)
  1521. FORE:    JNZ FORE    ;NOPE - JUMP HERE FOREVER
  1522.     CALL ADIN    ;START ADDRESS -> H
  1523.     PCHL        ;INDIRECT JUMP TO START ADDRESS
  1524. ;
  1525. ;THIS SUBROUTINE FETCHES A CHR FROM THE INPUT DEVICE.
  1526. ;THE CHR IS RETURNED IN THE A REG.  MUNCHES A & PSW.
  1527. ;
  1528. RDIN:    IN 5        ;INPUT READY STATUS -> A
  1529. POK1:    ANI 1        ;MASK OFF UNNECESSARY BITS
  1530.     JZ RDIN    ;JUMP IF NOT READY, KEEP TRYING
  1531. POK2:    IN 4        ;IT'S READY - GET THE DATA -> A
  1532.     RET
  1533. LLOC    EQU $            ;SAVE ADDRESS OF LAST BYTE USED
  1534. ;
  1535. ICN2:    RST 5        ;CONTINUE SIGN ON MESSAGE
  1536.     DB ' V .16',15Q,212Q
  1537.     LHLD SPRS
  1538.     XCHG        ;LAST LOC -> DE
  1539.     LHLD BOTX    ;FIRST -> H
  1540.     MOV A,E        ;DIFFERENCE -> H
  1541.     SUB L
  1542.     MOV L,A
  1543.     MOV A,D
  1544.     SBB H
  1545.     MOV H,A
  1546.     CALL NOSP    ;PRINT DIFFERENCE
  1547.     RST 5        ;PRINT 'B'YTES FREE'
  1548.     DB  'BYTES FRE','E'+200Q
  1549.     RST 0        ;RESET STACK AND ENTER
  1550. ;
  1551. ;THIS IS THE ROUTINE USED TO PUNCH MEMORY IN BOOTSTRAP FMT.
  1552. ;
  1553.     ORG  PGE+512
  1554. MAKR:    LXI SP,$+256
  1555.     MVI B,377Q        ;SEND 255 LEADER CHRS
  1556. MAKS:    MVI A,LLOC AND 0FFH    ;LEADER CHR -> A
  1557.     CALL PNOU    ;SEND A CHR OF LEADER
  1558.     DCR B        ;DONE WITH LEADER YET ?
  1559.     JNZ MAKS    ;NOPE - SEND SOME MORE
  1560.     LXI H,LLOC-1    ;HIGHEST ADR TO SENT -> H
  1561. MAKT:    MOV A,M        ;GET A CHR TO PUNCH -> A
  1562.     CALL PNOU    ;PUNCH IT
  1563.     DCR L        ;PUNCHED IT ALL YET ?
  1564.     JNZ MAKT    ;NOPE - KEEP SENDING
  1565.     MOV A,M        ;SEND LAST CHR
  1566.     CALL PNOU
  1567.     JMP 7200H    ;ALL DONE, BACK TO MONITOR
  1568. ;
  1569.     END
  1570.