Subversion Repositories cpu8080

;**************************************************************

;*

;*                TINY BASIC FOR INTEL 8080

;*                      VERSION 1.0

;*                    BY LI-CHEN WANG

;*                     10 JUNE, 1976

;*                       @COPYLEFT

;*                  ALL WRONGS RESERVED

;*

;**************************************************************

;*

;*  ;*** ZERO PAGE SUBROUTINES ***

;*

;*  THE 8080 INSTRUCTION SET LETS YOU HAVE 8 ROUTINES IN LOW

;*  MEMORY THAT MAY BE CALLED BY RST N, N BEING 0 THROUGH 7.

;*  THIS IS A ONE BYTE INSTRUCTION AND HAS THE SAME POWER AS

;*  THE THREE BYTE INSTRUCTION CALL LLHH.  TINY BASIC WILL

;*  USE RST 0 AS START AND RST 1 THROUGH RST 7 FOR

;*  THE SEVEN MOST FREQUENTLY USED SUBROUTINES.

;*  TWO OTHER SUBROUTINES (CRLF AND TSTNUM) ARE ALSO IN THIS

;*  SECTION.  THEY CAN BE REACHED ONLY BY 3-BYTE CALLS.

;*  IN ORDER TO CONFIGURE THE SYSTEM FOR USE WITH CPM I HAVE

;*  MOVED SOME OF THE ROUTINES AROUND.  START WILL NOW BE AT

;*  LOCATION 100H AND THIS SECTION WILL END AT LOCATION 3FH

;*  WITH A JUMP TO 108H.

;*

;       ORG  8H

;       XTHL           ;*** TSTC OR RST 1 ***

;       RST  5         ;IGNORE BLANKS AND

;       CMP  M         ;TEST CHARACTER

;       JMP  TC1       ;REST OF THIS IS AT TC1

;*

;CRLF   MVI  A,0DH     ;*** CRLF ***

;*

;       PUSH PSW       ;*** OUTC OR RST 2 ***

;       LDA  OCSW      ;PRINT CHARACTER ONLY

;       ORA  A         ;IFF OCSW SWITCH IS ON

;       JMP  OC2       ;REST OF THIS IS AT OC2

;*

;       CALL EXPR2     ;*** EXPR OR RST 3 ***

;       PUSH H         ;EVALUATE AN EXPRESION

;       JMP  EXPR1     ;REST OF IT IS AT EXPR1

;       DB   'W'

;*

;       MOV  A,H       ;*** COMP OR RST 4 ***

;       CMP  D         ;COMPARE HL WITH DE

;       RNZ            ;RETURN CORRECT C AND

;       MOV  A,L       ;Z FLAGS

;       CMP  E         ;BUT OLD A IS LOST

;       RET

;       DB   'AN'

;*

;SS1    LDAX D         ;*** IGNBLK/RST 5 ***

;       CPI  40Q       ;IGNORE BLANKS

;       RNZ            ;IN TEXT (WHERE DE->)

;       INX  D         ;AND RETURN THE FIRST

;       JMP  SS1       ;NON-BLANK CHAR. IN A

;*

;       POP  PSW       ;*** FINISH/RST 6 ***

;       CALL FIN       ;CHECK END OF COMMAND

;       JMP  QWHAT     ;PRINT "WHAT?" IFF WRONG

;       DB   'G'

;*

;       RST  5         ;*** TSTV OR RST 7 ***

;       SUI  100Q      ;TEST VARIABLES

;       RC             ;C:NOT A VARIABLE

;       JMP  TSTV1     ;JUMP AROUND RESERVED AREA

       ORG  100H      ;OF CPM.

START  JMP  NINIT      ;GO TO INITIALIZATION ROUTINE.   JIF

TSTV1  JNZ  TV1       ;NOT "@" ARRAY

       INX  D         ;IT IS THE "@" ARRAY

       CALL PARN      ;@ SHOULD BE FOLLOWED

       DAD  H         ;BY (EXPR) AS ITS INDEX

       JC   QHOW      ;IS INDEX TOO BIG?

       PUSH D         ;WILL IT OVERWRITE

       XCHG           ;TEXT?

       CALL SIZE      ;FIND SIZE OF FREE

       RST  4         ;AND CHECK THAT

       JC   ASORRY    ;IFF SO, SAY "SORRY"

SS1A   LXI  H,VARBGN  ;IFF NOT, GET ADDRESS

       CALL SUBDE     ;OF @(EXPR) AND PUT IT

       POP  D         ;IN HL

       RET            ;C FLAG IS CLEARED

TV1    CPI  33Q       ;NOT @, IS IT A TO Z?

       CMC            ;IFF NOT RETURN C FLAG

       RC

       INX  D         ;IFF A THROUGH Z

TV1A   LXI  H,VARBGN  ;COMPUTE ADDRESS OF

       RLC            ;THAT VARIABLE

       ADD  L         ;AND RETURN IT IN HL

       MOV  L,A       ;WITH C FLAG CLEARED

       MVI  A,0

       ADC  H

       MOV  H,A

       RET

;*

;*                 TSTC   XCH  HL,(SP)   ;*** TSTC OR RST 1 ***

;*                        IGNBLK         THIS IS AT LOC. 8

;*                        CMP  M         AND THEN JMP HERE

TC1    INX  H         ;COMPARE THE BYTE THAT

       JZ   TC2       ;FOLLOWS THE RST INST.

       PUSH B         ;WITH THE TEXT (DE->)

       MOV  C,M       ;IFF NOT =, ADD THE 2ND

       MVI  B,0       ;BYTE THAT FOLLOWS THE

       DAD  B         ;RST TO THE OLD PC

       POP  B         ;I.E., DO A RELATIVE

       DCX  D         ;JUMP IFF NOT =

TC2    INX  D         ;IFF =, SKIP THOSE BYTES

       INX  H         ;AND CONTINUE

       XTHL

       RET

;*

TSTNUM LXI  H,0       ;*** TSTNUM ***

       MOV  B,H       ;TEST IFF THE TEXT IS

       RST  5         ;A NUMBER

TN1    CPI  60Q       ;IFF NOT, RETURN 0 IN

       RC             ;B AND HL

       CPI  72Q       ;IFF NUMBERS, CONVERT

       RNC            ;TO BINARY IN HL AND

       MVI  A,360Q    ;SET A TO # OF DIGITS

       ANA  H         ;IFF H>255, THERE IS NO

       JNZ  QHOW      ;ROOM FOR NEXT DIGIT

       INR  B         ;B COUNTS # OF DIGITS

       PUSH B

       MOV  B,H       ;HL=10;*HL+(NEW DIGIT)

       MOV  C,L

       DAD  H         ;WHERE 10;* IS DONE BY

       DAD  H         ;SHIFT AND ADD

       DAD  B

       DAD  H

       LDAX D         ;AND (DIGIT) IS FROM

       INX  D         ;STRIPPING THE ASCII

       ANI  17Q       ;CODE

       ADD  L

       MOV  L,A

       MVI  A,0

       ADC  H

       MOV  H,A

       POP  B

       LDAX D         ;DO THIS DIGIT AFTER

       JP   TN1       ;DIGIT. S SAYS OVERFLOW

QHOW   PUSH D         ;*** ERROR: "HOW?" ***

AHOW   LXI  D,HOW

       JMP  ERROR

HOW    DB   'HOW?',0DH

OK     DB   'OK',0DH

WHAT   DB   'WHAT?',0DH

SORRY  DB   'SORRY',0DH

;*

;**************************************************************

;*

;* *** MAIN ***

;*

;* THIS IS THE MAIN LOOP THAT COLLECTS THE TINY BASIC PROGRAM

;* AND STORES IT IN THE MEMORY.

;*

;* AT START, IT PRINTS OUT "(CR)OK(CR)", AND INITIALIZES THE

;* STACK AND SOME OTHER INTERNAL VARIABLES.  THEN IT PROMPTS

;* ">" AND READS A LINE.  IFF THE LINE STARTS WITH A NON-ZERO

;* NUMBER, THIS NUMBER IS THE LINE NUMBER.  THE LINE NUMBER

;* (IN 16 BIT BINARY) AND THE REST OF THE LINE (INCLUDING CR)

;* IS STORED IN THE MEMORY.  IFF A LINE WITH THE SAME LINE

;* NUMBER IS ALREDY THERE, IT IS REPLACED BY THE NEW ONE.  IF

;* THE REST OF THE LINE CONSISTS OF A 0DHONLY, IT IS NOT STORED

;* AND ANY EXISTING LINE WITH THE SAME LINE NUMBER IS DELETED.

;*

;* AFTER A LINE ISs INSERTED, REPLACED, OR DELETED, THE PROGRAM

;* LOOPS BACK AND ASK FOR ANOTHER LINE.  THIS LOOP WILL BE

;* TERMINATED WHEN IT READS A LINE WITH ZERO OR NO LINE

;* NUMBER; AND CONTROL IS TRANSFERED TO "DIRCT".

;*

;* TINY BASIC PROGRAM SAVE AREA STARTS AT THE MEMORY LOCATION

;* LABELED "TXTBGN" AND ENDED AT "TXTEND".  WE ALWAYS FILL THIS

;* AREA STARTING AT "TXTBGN", THE UNFILLED PORTION IS POINTED

;* BY THE CONTENT OF A MEMORY LOCATION LABELED "TXTUNF".

;*

;* THE MEMORY LOCATION "CURRNT" POINTS TO THE LINE NUMBER

;* THAT IS CURRENTLY BEING INTERPRETED.  WHILE WE ARE IN

;* THIS LOOP OR WHILE WE ARE INTERPRETING A DIRECT COMMAND

;* (SEE NEXT SECTION), "CURRNT" SHOULD POINT TO A 0.

;*

RSTART LXI  SP,STACK  ;SET STACK POINTER

ST1    CALL CRLF      ;AND JUMP TO HERE

       LXI  D,OK      ;DE->STRING

       SUB  A         ;A=0

       CALL PRTSTG    ;PRINT STRING UNTIL 0DH

       LXI  H,ST2+1   ;LITERAL 0

       SHLD CURRNT    ;CURRNT->LINE # = 0

ST2    LXI  H,0

       SHLD LOPVAR

       SHLD STKGOS

ST3    MVI  A,76Q     ;PROMPT '>' AND

       CALL GETLN     ;READ A LINE

       PUSH D         ;DE->END OF LINE

ST3A   LXI  D,BUFFER  ;DE->BEGINNING OF LINE

       CALL TSTNUM    ;TESt IFF IT IS A NUMBER

       RST  5

       MOV  A,H       ;HL=VALUE OF THE # OR

       ORA  L         ;0 IFF NO # WAS FOUND

       POP  B         ;BC->END OF LINE

       JZ   DIRECT

       DCX  D         ;BACKUP DE AND SAVE

       MOV  A,H       ;VALUE OF LINE # THERE

       STAX D

       DCX  D

       MOV  A,L

       STAX D

       PUSH B         ;BC,DE->BEGIN, END

       PUSH D

       MOV  A,C

       SUB  E

       PUSH PSW       ;A=# OF BYTES IN LINE

       CALL FNDLN     ;FIND THIS LINE IN SAVE

       PUSH D         ;AREA, DE->SAVE AREA

       JNZ  ST4       ;NZ:NOT FOUND, INSERT

       PUSH D         ;Z:FOUND, DELETE IT

       CALL FNDNXT    ;FIND NEXT LINE

;*                                       DE->NEXT LINE

       POP  B         ;BC->LINE TO BE DELETED

       LHLD TXTUNF    ;HL->UNFILLED SAVE AREA

       CALL MVUP      ;MOVE UP TO DELETE

       MOV  H,B       ;TXTUNF->UNFILLED AREA

       MOV  L,C

       SHLD TXTUNF    ;UPDATE

ST4    POP  B         ;GET READY TO INSERT

       LHLD TXTUNF    ;BUT FIRT CHECK IF

       POP  PSW       ;THE LENGTH OF NEW LINE

       PUSH H         ;IS 3 (LINE # AND CR)

       CPI  3         ;THEN DO NOT INSERT

       JZ   RSTART    ;MUST CLEAR THE STACK

       ADD  L         ;COMPUTE NEW TXTUNF

       MOV  L,A

       MVI  A,0

       ADC  H

       MOV  H,A       ;HL->NEW UNFILLED AREA

ST4A   LXI  D,TXTEND  ;CHECK TO SEE IF THERE

       RST  4         ;IS ENOUGH SPACE

       JNC  QSORRY    ;SORRY, NO ROOM FOR IT

       SHLD TXTUNF    ;OK, UPDATE TXTUNF

       POP  D         ;DE->OLD UNFILLED AREA

       CALL MVDOWN

       POP  D         ;DE->BEGIN, HL->END

       POP  H

       CALL MVUP      ;MOVE NEW LINE TO SAVE

       JMP  ST3       ;AREA

;*

;**************************************************************

;*

;* *** TABLES *** DIRECT *** & EXEC ***

;*

;* THIS SECTION OF THE CODE TESTS A STRING AGAINST A TABLE.

;* WHEN A MATCH IS FOUND, CONTROL IS TRANSFERED TO THE SECTION

;* OF CODE ACCORDING TO THE TABLE.

;*

;* AT 'EXEC', DE SHOULD POINT TO THE STRING AD HL SHOULD POINT

;* TO THE TABLE-1.  AT 'DIRECT', DE SHOULD POINT TO THE STRING,

;* HL WILL BE SET UP TO POINT TO TAB1-1, WHICH IS THE TABLE OF

;* ALL DIRECT AND STATEMENT COMMANDS.

;*

;* A '.' IN THE STRING WILL TERMINATE THE TEST AND THE PARTIAL

;* MATCH WILL BE CONSIDERED AS A MATCH.  E.G., 'P.', 'PR.',

;* 'PRI.', 'PRIN.', OR 'PRINT' WILL ALL MATCH 'PRINT'.

;*

;* THE TABLE CONSISTS OF ANY NUMBER OF ITEMS.  EACH ITEM

;* IS A STRING OF CHARACTERS WITH BIT 7 SET TO 0 AND

;* A JUMP ADDRESS STORED HI-LOW WITH BIT 7 OF THE HIGH

;* BYTE SET TO 1.

;*

;* END OF TABLE IS AN ITEM WITH A JUMP ADDRESS ONLY.  IFF THE

;* STRING DOES NOT MATCH ANY OF THE OTHER ITEMS, IT WILL

;* MATCH THIS NULL ITEM AS DEFAULT.

;*

TAB1   EQU  $         ;DIRECT COMMANDS

       DB   'LIST'

       DB   LIST SHR 8 + 128,LIST AND 0FFH

       DB   'RUN'

       DB   RUN SHR 8 + 128,RUN AND 255

       DB   'NEW'

       DB   NEW SHR 8 + 128,NEW AND 255

       DB   'LOAD'

       DB   DLOAD SHR 8 + 128,DLOAD AND 255

       DB   'SAVE'

       DB   DSAVE SHR 8 + 128,DSAVE AND 255

       DB   'BYE',80H,0H   ;GO BACK TO CPM

TAB2   EQU  $         ;DIRECT/TATEMENT

       DB   'NEXT'

       DB   NEXT SHR 8 + 128,NEXT AND 255

       DB   'LET'

       DB   LET SHR 8 + 128,LET AND 255

       DB   'OUT'

       DB   OUTCMD SHR 8 + 128,OUTCMD AND 255

       DB   'POKE'

       DB   POKE SHR 8 + 128,POKE AND 255

       DB   'WAIT'

       DB   WAITCM SHR 8 + 128,WAITCM AND 255

       DB   'IF'

       DB   IFF SHR 8 + 128,IFF AND 255

       DB   'GOTO'

       DB   GOTO SHR 8 + 128,GOTO AND 255

       DB   'GOSUB'

       DB   GOSUB SHR 8 + 128,GOSUB AND 255

       DB   'RETURN'

       DB   RETURN SHR 8 + 128,RETURN AND 255

       DB   'REM'

       DB   REM SHR 8 + 128,REM AND 255

       DB   'FOR'

       DB   FOR SHR 8 + 128,FOR AND 255

       DB   'INPUT'

       DB   INPUT SHR 8 + 128,INPUT AND 255

       DB   'PRINT'

       DB   PRINT SHR 8 + 128,PRINT AND 255

       DB   'STOP'

       DB   STOP SHR 8 + 128,STOP AND 255

       DB   DEFLT SHR 8 + 128,DEFLT AND 255

       DB   'YOU CAN ADD MORE' ;COMMANDS BUT

            ;REMEMBER TO MOVE DEFAULT DOWN.

TAB4   EQU  $         ;FUNCTIONS

       DB   'RND'

       DB   RND SHR 8 + 128,RND AND 255

       DB   'INP'

       DB   INP SHR 8 + 128,INP AND 255

       DB   'PEEK'

       DB   PEEK SHR 8 + 128,PEEK AND 255

       DB   'USR'

       DB   USR SHR 8 + 128,USR AND 255

       DB   'ABS'

       DB   ABS SHR 8 + 128,ABS AND 255

       DB   'SIZE'

       DB   SIZE SHR 8 + 128,SIZE AND 255

       DB   XP40 SHR 8 + 128,XP40 AND 255

       DB   'YOU CAN ADD MORE' ;FUNCTIONS BUT REMEMBER

                      ;TO MOVE XP40 DOWN

TAB5   EQU  $         ;"TO" IN "FOR"

       DB   'TO'

       DB   FR1 SHR 8 + 128,FR1 AND 255

       DB   QWHAT SHR 8 + 128,QWHAT AND 255

TAB6   EQU  $         ;"STEP" IN "FOR"

       DB   'STEP'

       DB   FR2 SHR 8 + 128,FR2 AND 255

       DB   FR3 SHR 8 + 128,FR3 AND 255

TAB8   EQU  $         ;RELATION OPERATORS

       DB   '>='

       DB   XP11 SHR 8 + 128,XP11 AND 255

       DB   '#'

       DB   XP12 SHR 8 + 128,XP12 AND 255

       DB   '>'

       DB   XP13 SHR 8 + 128,XP13 AND 255

       DB   '='

       DB   XP15 SHR 8 + 128,XP15 AND 255

       DB   '<='

       DB   XP14 SHR 8 + 128,XP14 AND 255

       DB   '<'

       DB   XP16 SHR 8 + 128,XP16 AND 255

       DB   XP17 SHR 8 + 128,XP17 AND 255

;*

DIRECT LXI  H,TAB1-1  ;*** DIRECT ***

;*

EXEC   EQU  $         ;*** EXEC ***

EX0    RST  5         ;IGNORE LEADING BLANKS

       PUSH D         ;SAVE POINTER

EX1    LDAX D         ;IFF FOUND '.' IN STRING

       INX  D         ;BEFORE ANY MISMATCH

       CPI  56Q       ;WE DECLARE A MATCH

       JZ   EX3

       INX  H         ;HL->TABLE

       CMP  M         ;IFF MATCH, TEST NEXT

       JZ   EX1

       MVI  A,177Q    ;ELSE, SEE IFF BIT 7

       DCX  D         ;OF TABLEIS SET, WHICH

       CMP  M         ;IS THE JUMP ADDR. (HI)

       JC   EX5       ;C:YES, MATCHED

EX2    INX  H         ;NC:NO, FIND JUMP ADDR.

       CMP  M

       JNC  EX2

       INX  H         ;BUMP TO NEXT TAB. ITEM

       POP  D         ;RESTORE STRING POINTER

       JMP  EX0       ;TEST AGAINST NEXT ITEM

EX3    MVI  A,177Q    ;PARTIAL MATCH, FIND

EX4    INX  H         ;JUMP ADDR., WHICH IS

       CMP  M         ;FLAGGED BY BIT 7

       JNC  EX4

EX5    MOV  A,M       ;LOAD HL WITH THE JUMP

       INX  H         ;ADDRESS FROM THE TABLE

       MOV  L,M

       ANI  177Q      ;MASK OFF BIT 7

       MOV  H,A

       POP  PSW       ;CLEAN UP THE GABAGE

       PCHL           ;AND WE GO DO IT

;*

;**************************************************************

;*

;* WHAT FOLLOWS IS THE CODE TO EXECUTE DIRECT AND STATEMENT

;* COMMANDS.  CONTROL IS TRANSFERED TO THESE POINTS VIA THE

;* COMMAND TABLE LOOKUP CODE OF 'DIRECT' AND 'EXEC' IN LAST

;* SECTION.  AFTER THE COMMAND IS EXECUTED, CONTROL IS

;* TANSFERED TO OTHER SECTIONS AS FOLLOWS:

;*

;* FOR 'LIST', 'NEW', AND 'STOP': GO BACK TO 'RSTART'

;* FOR 'RUN': GO EXECUTE THE FIRST STORED LINE IFF ANY; ELSE

;* GO BACK TO 'RSTART'.

;* FOR 'GOTO' AND 'GOSUB': GO EXECUTE THE TARGET LINE.

;* FOR 'RETURN' AND 'NEXT': GO BACK TO SAVED RETURN LINE.

;* FOR ALL OTHERS: IFF 'CURRNT' -> 0, GO TO 'RSTART', ELSE

;* GO EXECUTE NEXT COMMAND.  (THIS IS DONE IN 'FINISH'.)

;*

;**************************************************************

;*

;* *** NEW *** STOP *** RUN (& FRIENDS) *** & GOTO ***

;*

;* 'NEW(CR)' SETS 'TXTUNF' TO POINT TO 'TXTBGN'

;*

;* 'STOP(CR)' GOES BACK TO 'RSTART'

;*

;* 'RUN(CR)' FINDS THE FIRST STORED LINE, STORE ITS ADDRESS (IN

;* 'CURRNT'), AND START EXECUTE IT.  NOTE THAT ONLY THOSE

;* COMMANDS IN TAB2 ARE LEGAL FOR STORED PROGRAM.

;*

;* THERE ARE 3 MORE ENTRIES IN 'RUN':

;* 'RUNNXL' FINDS NEXT LINE, STORES ITS ADDR. AND EXECUTES IT.

;* 'RUNTSL' STORES THE ADDRESS OF THIS LINE AND EXECUTES IT.

;* 'RUNSML' CONTINUES THE EXECUTION ON SAME LINE.

;*

;* 'GOTO EXPR(CR)' EVALUATES THE EXPRESSION, FIND THE TARGET

;* LINE, AND JUMP TO 'RUNTSL' TO DO IT.

;* 'DLOAD' LOADS A NAMED PROGRAM FROM DISK.

;* 'DSAVE' SAVES A NAMED PROGRAM ON DISK.

;* 'FCBSET' SETS UP THE FILE CONTROL BLOCK FOR SUBSEQUENT DISK I/O.

;*

NEW    CALL ENDCHK    ;*** NEW(CR) ***

       LXI  H,TXTBGN

       SHLD TXTUNF

;*

STOP   CALL ENDCHK    ;*** STOP(CR) ***

       JMP RSTART

;*

RUN    CALL ENDCHK    ;*** RUN(CR) ***

       LXI  D,TXTBGN  ;FIRST SAVED LINE

;*

RUNNXL LXI  H,0       ;*** RUNNXL ***

       CALL FNDLNP    ;FIND WHATEVER LINE #

       JC   RSTART    ;C:PASSED TXTUNF, QUIT

;*

RUNTSL XCHG           ;*** RUNTSL ***

       SHLD CURRNT    ;SET 'CURRNT'->LINE #

       XCHG

       INX  D         ;BUMP PASS LINE #

       INX  D

;*

RUNSML CALL CHKIO     ;*** RUNSML ***

       LXI  H,TAB2-1  ;FIND COMMAND IN TAB2

       JMP  EXEC      ;AND EXECUTE IT

;*

GOTO   RST  3         ;*** GOTO EXPR ***

       PUSH D         ;SAVE FOR ERROR ROUTINE

       CALL ENDCHK    ;MUST FIND A 0DH

       CALL FNDLN     ;FIND THE TARGET LINE

       JNZ  AHOW      ;NO SUCH LINE #

       POP  PSW       ;CLEAR THE "PUSH DE"

       JMP  RUNTSL    ;GO DO IT

CPM    EQU  5         ;DISK PARAMETERS

FCB    EQU  5CH

SETDMA EQU  26

OPEN   EQU  15

READD  EQU  20

WRITED EQU  21

CLOSE  EQU  16

MAKE   EQU  22

DELETE EQU  19

;*

DLOAD  RST  5         ;IGNORE BLANKS

       PUSH H         ;SAVE H

       CALL FCBSET    ;SET UP FILE CONTROL BLOCK

       PUSH D         ;SAVE THE REST

       PUSH B

       LXI  D,FCB     ;GET FCB ADDRESS

       MVI  C,OPEN    ;PREPARE TO OPEN FILE

       CALL CPM       ;OPEN IT

       CPI  0FFH      ;IS IT THERE?

       JZ   QHOW      ;NO, SEND ERROR

       XRA  A         ;CLEAR A

       STA  FCB+32    ;START AT RECORD 0

       LXI  D,TXTUNF  ;GET BEGINNING

LOAD   PUSH D         ;SAVE DMA ADDRESS

       MVI  C,SETDMA  ;

       CALL CPM       ;SET DMA ADDRESS

       MVI  C,READD   ;

       LXI  D,FCB

       CALL CPM       ;READ SECTOR

       CPI  1         ;DONE?

       JC   RDMORE    ;NO, READ MORE

       JNZ  QHOW      ;BAD READ

       MVI  C,CLOSE

       LXI  D,FCB

       CALL CPM       ;CLOSE FILE

       POP  D         ;THROW AWAY DMA ADD.

       POP  B         ;GET OLD REGISTERS BACK

       POP  D

       POP  H

       RST  6         ;FINISH

RDMORE POP  D         ;GET DMA ADDRESS

       LXI  H,80H     ;GET 128

       DAD  D         ;ADD 128 TO DMA ADD.

       XCHG           ;PUT IT BACK IN D

       JMP  LOAD      ;AND READ SOME MORE

;*

DSAVE  RST  5         ;IGNORE BLANKS

       PUSH H         ;SAVE H

       CALL FCBSET    ;SETUP FCB

       PUSH D

       PUSH B         ;SAVE OTHERS

       LXI  D,FCB

       MVI  C,DELETE

       CALL CPM       ;ERASE FILE IF IT EXISTS

       LXI  D,FCB

       MVI  C,MAKE

       CALL CPM       ;MAKE A NEW ONE

       CPI  0FFH      ;IS THERE SPACE?

       JZ   QHOW      ;NO, ERROR

       XRA  A         ;CLEAR A

       STA  FCB+32    ;START AT RECORD 0

       LXI  D,TXTUNF  ;GET BEGINNING

SAVE   PUSH D         ;SAVE DMA ADDRESS

       MVI  C,SETDMA  ;

       CALL CPM       ;SET DMA ADDRESS

       MVI  C,WRITED

       LXI  D,FCB

       CALL CPM       ;WRITE SECTOR

       ORA  A         ;SET FLAGS

       JNZ  QHOW      ;IF NOT ZERO, ERROR

       POP  D         ;GET DMA ADD. BACK

       LDA  TXTUNF+1  ;AND MSB OF LAST ADD.

       CMP  D         ;IS D SMALLER?

       JC   SAVDON    ;YES, DONE

       JNZ  WRITMOR   ;DONT TEST E IF NOT EQUAL

       LDA  TXTUNF    ;IS E SMALLER?

       CMP  E

       JC   SAVDON    ;YES, DONE

WRITMOR LXI  H,80H

       DAD  D         ;ADD 128 TO DMA ADD.

       XCHG           ;GET IT BACK IN D

       JMP  SAVE      ;WRITE SOME MORE

SAVDON MVI  C,CLOSE

       LXI  D,FCB

       CALL CPM       ;CLOSE FILE

       POP  B         ;GET REGISTERS BACK

       POP  D

       POP  H

       RST  6         ;FINISH

;*

FCBSET LXI  H,FCB     ;GET FILE CONTROL BLOCK ADDRESS

       MVI  M,0       ;CLEAR ENTRY TYPE

FNCLR  INX  H         ;NEXT LOCATION

       MVI  M,' '     ;CLEAR TO SPACE

       MVI  A,FCB+8 AND 255

       CMP  L         ;DONE?

       JNZ  FNCLR     ;NO, DO IT AGAIN

       INX  H         ;NEXT

       MVI  M,'T'     ;SET FILE TYPE TO 'TBI'

       INX  H

       MVI  M,'B'

       INX  H

       MVI  M,'I'

EXRC   INX  H         ;CLEAR REST OF FCB

       MVI  M,0

       MVI  A,FCB+15 AND 255

       CMP  L         ;DONE?

       JNZ  EXRC      ;NO, CONTINUE

       LXI  H,FCB+1   ;GET FILENAME START

FN     LDAX D         ;GET CHARACTER

       CPI  0DH       ;IS IT A 'CR'

       RZ             ;YES, DONE

       CPI  '!'       ;LEGAL CHARACTER?

       JC   QWHAT     ;NO, SEND ERROR

       CPI  '['       ;AGAIN

       JNC  QWHAT     ;DITTO

       MOV  M,A        ;SAVE IT IN FCB

       INX  H         ;NEXT

       INX  D

       MVI  A,FCB+9 AND 255

       CMP  L         ;LAST?

       JNZ  FN        ;NO, CONTINUE

       RET            ;TRUNCATE AT 8 CHARACTERS

;*

;*************************************************************

;*

;* *** LIST *** & PRINT ***

;*

;* LIST HAS TWO FORMS:

;* 'LIST(CR)' LISTS ALL SAVED LINES

;* 'LIST #(CR)' START LIST AT THIS LINE #

;* YOU CAN STOP THE LISTING BY CONTROL C KEY

;*

;* PRINT COMMAND IS 'PRINT ....;' OR 'PRINT ....(CR)'

;* WHERE '....' IS A LIST OF EXPRESIONS, FORMATS, BACK-

;* ARROWS, AND STRINGS.  THESE ITEMS ARE SEPERATED BY COMMAS.

;*

;* A FORMAT IS A POUND SIGN FOLLOWED BY A NUMBER.  IT CONTROLSs

;* THE NUMBER OF SPACES THE VALUE OF A EXPRESION IS GOING TO

;* BE PRINTED.  IT STAYS EFFECTIVE FOR THE REST OF THE PRINT

;* COMMAND UNLESS CHANGED BY ANOTHER FORMAT.  IFF NO FORMAT IS

;* SPECIFIED, 6 POSITIONS WILL BE USED.

;*

;* A STRING IS QUOTED IN A PAIR OF SINGLE QUOTES OR A PAIR OF

;* DOUBLE QUOTES.

;*

;* A BACK-ARROW MEANS GENERATE A (CR) WITHOUT (LF)

;*

;* A (CRLF) IS GENERATED AFTER THE ENTIRE LIST HAS BEEN

;* PRINTED OR IFF THE LIST IS A NULL LIST.  HOWEVER IFF THE LIST

;* ENDED WITH A COMMA, NO (CRL) IS GENERATED.

;*

LIST   CALL TSTNUM    ;TEST IFF THERE IS A #

       CALL ENDCHK    ;IFF NO # WE GET A 0

       CALL FNDLN     ;FIND THIS OR NEXT LINE

LS1    JC   RSTART    ;C:PASSED TXTUNF

       CALL PRTLN     ;PRINT THE LINE

       CALL CHKIO     ;STOP IFF HIT CONTROL-C

       CALL FNDLNP    ;FIND NEXT LINE

       JMP  LS1       ;AND LOOP BACK

;*

PRINT  MVI  C,6       ;C = # OF SPACES

       RST  1         ;IFF NULL LIST & ";"

       DB   73Q

       DB   6Q

       CALL CRLF      ;GIVE CR-LF AND

       JMP  RUNSML    ;CONTINUE SAME LINE

PR2    RST  1         ;IFF NULL LIST (CR)

       DB   0DH

       DB   6Q

       CALL CRLF      ;ALSO GIVE CR-LF AND

       JMP  RUNNXL    ;GO TO NEXT LINE

PR0    RST  1         ;ELSE IS IT FORMAT?

       DB   '#'

       DB   5Q

       RST  3         ;YES, EVALUATE EXPR.

       MOV  C,L       ;AND SAVE IT IN C

       JMP  PR3       ;LOOK FOR MORE TO PRINT

PR1    CALL QTSTG     ;OR IS IT A STRING?

       JMP  PR8       ;IFF NOT, MUST BE EXPR.

PR3    RST  1         ;IFF ",", GO FIND NEXT

       DB   ','

       DB   6Q

       CALL FIN       ;IN THE LIST.

       JMP  PR0       ;LIST CONTINUES

PR6    CALL CRLF      ;LIST ENDS

       RST  6

PR8    RST  3         ;EVALUATE THE EXPR

       PUSH B

       CALL PRTNUM    ;PRINT THE VALUE

       POP  B

       JMP  PR3       ;MORE TO PRINT?

;*

;**************************************************************

;*

;* *** GOSUB *** & RETURN ***

;*

;* 'GOSUB EXPR;' OR 'GOSUB EXPR (CR)' IS LIKE THE 'GOTO'

;* COMMAND, EXCEPT THAT THE CURRENT TEXT POINTER, STACK POINTER

;* ETC. ARE SAVE SO THAT EXECUTION CAN BE CONTINUED AFTER THE

;* SUBROUTINE 'RETURN'.  IN ORDER THAT 'GOSUB' CAN BE NESTED

;* (AND EVEN RECURSIVE), THE SAVE AREA MUST BE STACKED.

;* THE STACK POINTER IS SAVED IN 'STKGOS'. THE OLD 'STKGOS' IS

;* SAVED IN THE STACK.  IFF WE ARE IN THE MAIN ROUTINE, 'STKGOS'

;* IS ZERO (THIS WAS DONE BY THE "MAIN" SECTION OF THE CODE),

;* BUT WE STILL SAVE IT AS A FLAG FORr NO FURTHER 'RETURN'S.

;*

;* 'RETURN(CR)' UNDOS EVERYHING THAT 'GOSUB' DID, AND THUS

;* RETURN THE EXCUTION TO THE COMMAND AFTER THE MOST RECENT

;* 'GOSUB'.  IFF 'STKGOS' IS ZERO, IT INDICATES THAT WE

;* NEVER HAD A 'GOSUB' AND IS THUS AN ERROR.

;*

GOSUB  CALL PUSHA     ;SAVE THE CURRENT "FOR"

       RST  3         ;PARAMETERS

       PUSH D         ;AND TEXT POINTER

       CALL FNDLN     ;FIND THE TARGET LINE

       JNZ  AHOW      ;NOT THERE. SAY "HOW?"

       LHLD CURRNT    ;FOUND IT, SAVE OLD

       PUSH H         ;'CURRNT' OLD 'STKGOS'

       LHLD STKGOS

       PUSH H

       LXI  H,0       ;AND LOAD NEW ONES

       SHLD LOPVAR

       DAD  SP

       SHLD STKGOS

       JMP  RUNTSL    ;THEN RUN THAT LINE

RETURN CALL ENDCHK    ;THERE MUST BE A 0DH

       LHLD STKGOS    ;OLD STACK POINTER

       MOV  A,H       ;0 MEANS NOT EXIST

       ORA  L

       JZ   QWHAT     ;SO, WE SAY: "WHAT?"

       SPHL           ;ELSE, RESTORE IT

       POP  H

       SHLD STKGOS    ;AND THE OLD 'STKGOS'

       POP  H

       SHLD CURRNT    ;AND THE OLD 'CURRNT'

       POP  D         ;OLD TEXT POINTER

       CALL POPA      ;OLD "FOR" PARAMETERS

       RST  6         ;AND WE ARE BACK HOME

;*

;**************************************************************

;*

;* *** FOR *** & NEXT ***

;*

;* 'FOR' HAS TWO FORMS:

;* 'FOR VAR=EXP1 TO EXP2 STEP EXP1' AND 'FOR VAR=EXP1 TO EXP2'

;* THE SECOND FORM MEANS THE SAME THING AS THE FIRST FORM WITH

;* EXP1=1.  (I.E., WITH A STEP OF +1.)

;* TBI WILL FIND THE VARIABLE VAR. AND SET ITS VALUE TO THE

;* CURRENT VALUE OF EXP1.  IT ALSO EVALUATES EXPR2 AND EXP1

;* AND SAVE ALL THESE TOGETHER WITH THE TEXT POINTERr ETC. IN

;* THE 'FOR' SAVE AREA, WHICH CONSISTS OF 'LOPVAR', 'LOPINC',

;* 'LOPLMT', 'LOPLN', AND 'LOPPT'.  IFF THERE IS ALREADY SOME-

;* THING IN THE SAVE AREA (THIS IS INDICATED BY A NON-ZERO

;* 'LOPVAR'), THEN THE OLD SAVE AREA IS SAVED IN THE STACK

;* BEFORE THE NEW ONE OVERWRITES IT.

;* TBI WILL THEN DIG IN THE STACK AND FIND OUT IFF THIS SAME

;* VARIABLE WAS USED IN ANOTHER CURRENTLY ACTIVE 'FOR' LOOP.

;* IFF THAT IS THE CASE THEN THE OLD 'FOR' LOOP IS DEACTIVATED.

;* (PURGED FROM THE STACK..)

;*

;* 'NEXT VAR' SERVES AS THE LOGICAL (NOT NECESSARILLY PHYSICAL)

;* END OF THE 'FOR' LOOP.  THE CONTROL VARIABLE VAR. IS CHECKED

;* WITH THE 'LOPVAR'.  IFF THEY ARE NOT THE SAME, TBI DIGS IN

;* THE STACK TO FIND THE RIGHTt ONE AND PURGES ALL THOSE THAT

;* DID NOT MATCH.  EITHER WAY, TBI THEN ADDS THE 'STEP' TO

;* THAT VARIABLE AND CHECK THE RESULT WITH THE LIMIT.  IFF IT

;* IS WITHIN THE LIMIT, CONTROL LOOPS BACK TO THE COMMAND

;* FOLLOWING THE 'FOR'.  IFF OUTSIDE THE LIMIT, THE SAVE ARER

;* IS PURGED AND EXECUTION CONTINUES.

;*

FOR    CALL PUSHA     ;SAVE THE OLD SAVE AREA

       CALL SETVAL    ;SET THE CONTROL VAR.

       DCX  H         ;HL IS ITS ADDRESS

       SHLD LOPVAR    ;SAVE THAT

       LXI  H,TAB5-1  ;USE 'EXEC' TO LOOK

       JMP  EXEC      ;FOR THE WORD 'TO'

FR1    RST  3         ;EVALUATE THE LIMIT

       SHLD LOPLMT    ;SAVE THAT

       LXI  H,TAB6-1  ;USE 'EXEC' TO LOOK

       JMP  EXEC      ;FOR THE WORD 'STEP'

FR2    RST  3         ;FOUND IT, GET STEP

       JMP  FR4

FR3    LXI  H,1Q      ;NOT FOUND, SET TO 1

FR4    SHLD LOPINC    ;SAVE THAT TOO

FR5    LHLD CURRNT    ;SAVE CURRENT LINE #

       SHLD LOPLN

       XCHG           ;AND TEXT POINTER

       SHLD LOPPT

       LXI  B,12Q     ;DIG INTO STACK TO

       LHLD LOPVAR    ;FIND 'LOPVAR'

       XCHG

       MOV  H,B

       MOV  L,B       ;HL=0 NOW

       DAD  SP        ;HERE IS THE STACK

       DB   76Q

FR7    DAD  B         ;EACH LEVEL IS 10 DEEP

       MOV  A,M       ;GET THAT OLD 'LOPVAR'

       INX  H

       ORA  M

       JZ   FR8       ;0 SAYS NO MORE IN IT

       MOV  A,M

       DCX  H

       CMP  D         ;SAME AS THIS ONE?

       JNZ  FR7

       MOV  A,M       ;THE OTHER HALF?

       CMP  E

       JNZ  FR7

       XCHG           ;YES, FOUND ONE

       LXI  H,0Q

       DAD  SP        ;TRY TO MOVE SP

       MOV  B,H

       MOV  C,L

       LXI  H,12Q

       DAD  D

       CALL MVDOWN    ;AND PURGE 10 WORDS

       SPHL           ;IN THE STACK

FR8    LHLD LOPPT     ;JOB DONE, RESTORE DE

       XCHG

       RST  6         ;AND CONTINUE

;*

NEXT   RST  7         ;GET ADDRESS OF VAR.

       JC   QWHAT     ;NO VARIABLE, "WHAT?"

       SHLD VARNXT    ;YES, SAVE IT

NX0    PUSH D         ;SAVE TEXT POINTER

       XCHG

       LHLD LOPVAR    ;GET VAR. IN 'FOR'

       MOV  A,H

       ORA  L         ;0 SAYS NEVER HAD ONE

       JZ   AWHAT     ;SO WE ASK: "WHAT?"

       RST  4         ;ELSE WE CHECK THEM

       JZ   NX3       ;OK, THEY AGREE

       POP  D         ;NO, LET'S SEE

       CALL POPA      ;PURGE CURRENT LOOP

       LHLD VARNXT    ;AND POP ONE LEVEL

       JMP  NX0       ;GO CHECK AGAIN

NX3    MOV  E,M       ;COME HERE WHEN AGREED

       INX  H

       MOV  D,M       ;DE=VALUE OF VAR.

       LHLD LOPINC

       PUSH H

       DAD  D         ;ADD ONE STEP

       XCHG

       LHLD LOPVAR    ;PUT IT BACK

       MOV  M,E

       INX  H

       MOV  M,D

       LHLD LOPLMT    ;HL->LIMIT

       POP  PSW       ;OLD HL

       ORA  A

       JP   NX1       ;STEP > 0

       XCHG

NX1    CALL CKHLDE    ;COMPARE WITH LIMIT

       POP  D         ;RESTORE TEXT POINTER

       JC   NX2       ;OUTSIDE LIMIT

       LHLD LOPLN     ;WITHIN LIMIT, GO

       SHLD CURRNT    ;BACK TO THE SAVED

       LHLD LOPPT     ;'CURRNT' AND TEXT

       XCHG           ;POINTER

       RST  6

NX2    CALL POPA      ;PURGE THIS LOOP

       RST  6

;*

;**************************************************************

;*

;* *** REM *** IFF *** INPUT *** & LET (& DEFLT) ***

;*

;* 'REM' CAN BE FOLLOWED BY ANYTHING AND IS IGNORED BY TBI.

;* TBI TREATS IT LIKE AN 'IF' WITH A FALSE CONDITION.

;*

;* 'IF' IS FOLLOWED BY AN EXPR. AS A CONDITION AND ONE OR MORE

;* COMMANDS (INCLUDING OUTHER 'IF'S) SEPERATED BY SEMI-COLONS.

;* NOTE THAT THE WORD 'THEN' IS NOT USED.  TBI EVALUATES THE

;* EXPR. IFF IT IS NON-ZERO, EXECUTION CONTINUES.  IFF THE

;* EXPR. IS ZERO, THE COMMANDS THAT FOLLOWS ARE IGNORED AND

;* EXECUTION CONTINUES AT THE NEXT LINE.

;*

;* 'IPUT' COMMAND IS LIKE THE 'PRINT' COMMAND, AND IS FOLLOWED

;* BY A LIST OF ITEMS.  IFF THE ITEM IS A STRING IN SINGLE OR

;* DOUBLE QUOTES, OR IS A BACK-ARROW, IT HAS THE SAME EFFECT AS

;* IN 'PRINT'.  IFF AN ITEM IS A VARIABLE, THIS VARIABLE NAME IS

;* PRINTED OUT FOLLOWED BY A COLON.  THEN TBI WAITS FOR AN

;* EXPR. TO BE TYPED IN.  THE VARIABLE ISs THEN SET TO THE

;* VALUE OF THIS EXPR.  IFF THE VARIABLE IS PROCEDED BY A STRING

;* (AGAIN IN SINGLE OR DOUBLE QUOTES), THE STRING WILL BE

;* PRINTED FOLLOWED BY A COLON.  TBI THEN WAITS FOR INPUT EXPR.

;* AND SET THE VARIABLE TO THE VALUE OF THE EXPR.

;*

;* IFF THE INPUT EXPR. IS INVALID, TBI WILL PRINT "WHAT?",

;* "HOW?" OR "SORRY" AND REPRINT THE PROMPT AND REDO THE INPUT.

;* THE EXECUTION WILL NOT TERMINATE UNLESS YOU TYPE CONTROL-C.

;* THIS IS HANDLED IN 'INPERR'.

;*

;* 'LET' IS FOLLOWED BY A LIST OF ITEMS SEPERATED BY COMMAS.

;* EACH ITEM CONSISTS OF A VARIABLE, AN EQUAL SIGN, AND AN EXPR.

;* TBI EVALUATES THE EXPR. AND SET THE VARIBLE TO THAT VALUE.

;* TB WILL ALSO HANDLE 'LET' COMMAND WITHOUT THE WORD 'LET'.

;* THIS IS DONE BY 'DEFLT'.

;*

REM    LXI  H,0Q      ;*** REM ***

       DB   76Q

;*

IFF     RST  3         ;*** IFF ***

       MOV  A,H       ;IS THE EXPR.=0?

       ORA  L

       JNZ  RUNSML    ;NO, CONTINUE

       CALL FNDSKP    ;YES, SKIP REST OF LINE

       JNC  RUNTSL

       JMP  RSTART

;*

INPERR LHLD STKINP    ;*** INPERR ***

       SPHL           ;RESTORE OLD SP

       POP  H         ;AND OLD 'CURRNT'

       SHLD CURRNT

       POP  D         ;AND OLD TEXT POINTER

       POP  D         ;REDO INPUT

;*

INPUT  EQU  $         ;*** INPUT ***

IP1    PUSH D         ;SAVE IN CASE OF ERROR

       CALL QTSTG     ;IS NEXT ITEM A STRING?

       JMP  IP2       ;NO

       RST  7         ;YES. BUT FOLLOWED BY A

       JC   IP4       ;VARIABLE?   NO.

       JMP  IP3       ;YES.  INPUT VARIABLE

IP2    PUSH D         ;SAVE FOR 'PRTSTG'

       RST  7         ;MUST BE VARIABLE NOW

       JC   QWHAT     ;"WHAT?" IT IS NOT?

       LDAX D         ;GET READY FOR 'RTSTG'

       MOV  C,A

       SUB  A

       STAX D

       POP  D

       CALL PRTSTG    ;PRINT STRING AS PROMPT

       MOV  A,C       ;RESTORE TEXT

       DCX  D

       STAX D

IP3    PUSH D         ;SAVE IN CASE OF ERROR

       XCHG

       LHLD CURRNT    ;ALSO SAVE 'CURRNT'

       PUSH H

       LXI  H,IP1     ;A NEGATIVE NUMBER

       SHLD CURRNT    ;AS A FLAG

       LXI  H,0Q      ;SAVE SP TOO

       DAD  SP

       SHLD STKINP

       PUSH D         ;OLD HL

       MVI  A,72Q     ;PRINT THIS TOO

       CALL GETLN     ;AND GET A LINE

IP3A   LXI  D,BUFFER  ;POINTS TO BUFFER

       RST  3         ;EVALUATE INPUT

       NOP            ;CAN BE 'CALL ENDCHK'

       NOP

       NOP

       POP  D         ;OK, GET OLD HL

       XCHG

       MOV  M,E       ;SAVE VALUE IN VAR.

       INX  H

       MOV  M,D

       POP  H         ;GET OLD 'CURRNT'

       SHLD CURRNT

       POP  D         ;AND OLD TEXT POINTER

IP4    POP  PSW       ;PURGE JUNK IN STACK

       RST  1         ;IS NEXT CH. ','?

       DB   ','

       DB   3Q

       JMP  IP1       ;YES, MORE ITEMS.

IP5    RST  6

;*

DEFLT  LDAX D         ;*** DEFLT ***

       CPI  0DH       ;EMPTY LINE IS OK

       JZ   LT1       ;ELSE IT IS 'LET'

;*

LET    CALL SETVAL    ;*** LET ***

       RST  1         ;SET VALUE TO VAR.

       DB   ','

       DB   3Q

       JMP  LET       ;ITEM BY ITEM

LT1    RST  6         ;UNTIL FINISH

;*

;**************************************************************