*
*    SET MEMORY
*       (HL) ADDR OF MEMORY  (DE) SIZE OF PATCH  (B) VALUE
*
SETM MOV A,D
 ORA E
 RZ
 MOV M,B
 DCX D
 INX H
 JMP SETM
*
*     COPY BYTES FROM (HL) TO (DE) FOR (BC) BYTES
*        (BC) MUST BE NONZERO ON ENTRY
*
COPY MVI B,0
COPYX MOV A,M
 STAX D
 INX H
 INX D
 DCX B
 MOV A,B
 ORA C
 JNZ COPYX
 RET .  NOTE:  Z IS SET
*
*     COMPARE HL TO DE
*       HL-DE
*
HDCMP MOV A,H
 CMP D
 RNZ
 MOV A,L
 CMP E
 RET
*
*     COMPARE DE AGAINST VALUE ADDRESSED BY HL
*     CLOBBERS A ONLY
*
DCMP INX H
DCMP1 MOV A,D
 CMP M
 DCX H
 RNZ
 MOV A,E
 CMP M
 RET
*
*     INDIRECT LOAD HL THRU HL
*
LHLI PUSH PSW
 MOV A,M
 INX H
 MOV H,M
 MOV L,A
 POP PSW
 RET
*
*     CLEAR DE BYTES OF MEMORY STARTING AT ADDR HL
*
CLRM MVI B,0
 JMP SETM
*
*   RETURN Z SET IFF THE NEXT ITEM IS A STRING ITEM
*
STEST LHLD TXA
 PUSH H  SAVE TXA
 MOV A,M
 CPI FNRW
 JNZ STST2  NOT A FUNCTION
 INX H  SKIP FNRW FOR STRING TEST
 SHLD TXA
STST2 CALL ALPH1  NEEDS TXA IN HL
 JC STST1  NOT AN ALPHA CHR
 CALL DIG  DIGIT?  (RETURNS TXA IN HL)
 JC STST1  IF NO DIGIT
 MOV A,M  NEXT CHR AFTER DIGIT
STST1 POP H  GET BACK TXA
 SHLD TXA  RESTORE IT
 CPI '"'
 RZ
 CPI '$'
 RZ
 CPI CHRRW
 RZ
 CPI STRRW
 RZ
 CPI ERRRW
 RET
*
*     ROUTINES FOR FORMAT SPECIFICATION
*     DEFAULT COPIED FROM CURRENT
*
DFC LHLD COPT
 SHLD DOPT
 LHLD CWIDTH
 SHLD DWIDTH
 RET
*
*     COPY CURRENT FORMAT FROM DEFAULT
*
CFD LHLD DOPT
 SHLD COPT
 LHLD DWIDTH
 SHLD CWIDTH
 RET
*
*     SET CURRENT FORMAT TO FREE FORMAT
*
CFF LXI H,'#'*256+0  SET OPTIONS FOR FREE FORMAT
 SHLD COPT
 RET
*
*     DIMENSION STRING
*     CALLED AFTER STLK HAS CREATED A SYM.TAB. ENTRY
*     DE HAS NUMBER OF BYTES IN STRING
*
DIMST LXI H,4  SPACE FOR LOGICAL LENGTH AND MAX LENGTH
 DAD D  ADD IN STRING SIZE
 PUSH D
 CALL ASTAB
 POP D
*
*     FALL THROUGH TO DSTOR TO SET MAX LENGTH FIELD AND RETURN
*     THIS ROUTINE STORES THE CONTENTS OF DE AT ADDRESS IN HL, A
*     NO REGISTERS OTHER THAN HL MODIFIED
*
DSTOR MOV M,E
 INX H
 MOV M,D
 INX H
 RET
*
*     LOAD DE FROM ADDRESS IN HL, AND INC HL BY 2
*
DLOAD MOV E,M
 INX H
 MOV D,M
 INX H
 RET
*
*     CREATE DIM TABLE FOR DEFAULT MATRIX OF ONE DIMENSION
*
DIMM0 LXI H,4
 CALL ASTAB
 PUSH H  SAVE SYM.TAB. PTR TO MAX LENGTH
 INX H
 INX H
 LXI D,10  ENTRY IN DIMENSION TABLE (DEFAULT SIZE OF 10)
 CALL DSTOR
 POP H
*
*     FALL THROUGH TO DIMM
*     CALLED AFTER STLK AND DIMENSION TABLE SET UP
*     THE END OF DIMENSION TABLE MARKER AND REST OF MATRIX SYM.T
*     NUMBER OF ELEMENT IN DE, SYM.TAB. PTR TO MAX IN HL
*
DIMM  PUSH H
 LXI B,FPSIZ
 CALL IMUL
 XCHG
 POP H
 CALL DSTOR
 XCHG
 INX H  ADD ROOM FOR END OF DIMENSION TABLE MARKER
 INX H
 JMP ASTAB  THE MARKER IS A ZERO
*
*   THIS SUBROUTINE EXCHANGES TOP OF STACK AND TXA, CLOBBERING
*     NOTHING BUT SINK
*
FTXA SHLD SINK  USE SINK-SINK+3 FOR TEMPS
 POP H  RETURN LINK
 SHLD SINK+2
 LHLD TXA
 XTHL
 SHLD TXA
 LHLD SINK+2  RETURN LINK
 PUSH H
 LHLD SINK  ORIGINAL HL
 RET
*
*     JUNK ON END OF STATEMENT, TESTS IF NEXT CHAR IS EOS
*     DOES NOT CLOBBER DE
*     EATS CHARACTER AND LINE COUNT AFTER CR
*     LEAVES NEW TXA IN HL
*     SETS CARRY IF END OF FILE
*
JOE LHLD TXA
 MOV A,M
 INX H
 SHLD TXA
 CPI EOSRW
 RZ
 CPI CR
 JZ JOE0
 LXI H,IFTERM
 XRA M  SEE IF IT MATCHES EXPECTED IF TERMINATOR
 JNZ BSERR
 CALL REM  SCAN TO NEXT CR
 JMP JOE
*
JOE0 MVI A,CR
 STA IFTERM  THIS SAYS--ELSE IS NOT LEGAL AS A TERM
*
 MOV A,M  GET NEXT CHR
 STC .  IN CASE OF EOF
 DCR A
 RZ .  IF SO LEAVE TXA POINTING TO EOF
 INX H
 INX H
 INX H  SKIP OVER COUNT AND LINE NUMBER
*
JOE1 SHLD TXA
 ORA A  CLEAR THE CARRY
 RET
*
*
NAME1 CALL ALPHA
 RC
 CALL NAME2
 CALL VAR0
 RNZ
 JMP TYERR
*
*     GET NAME FROM TEXT
*     SETS CARRY IF NAME NOT FOUND
*     IF SUCCEEDS RETURNS NAME IN BC
*
NAME CALL ALPHA
 RC .  NO NAME
NAME2 MOV B,A
 MVI C,0FH  BECAUSE 0 IS DIGIT '0'
 CALL DIG1  HL STILL HAS TXA
 CMC .  CLEAR CARRY BEFORE RETURN
 RNC .  NO 2ND CHAR
 ANI 0FH  CLEARS CARRY  0='0'
 MOV C,A  2ND CHAR TO C
 RET
*
*  LOOK FOR EITHER NUMERIC OR STRING NAME:C=1 NUMERIC C=0 STRING
*
ANAME CALL NAME
 JC BSERR
* FALL THROUGH TO SNAME
*
*     BC RETURNED WITH NAME
*     LOOKS FOR STRING NAME AT TXA
*     BC CONTAINS NAME ON ENTRY
*     SETS CARRY IF NOT A STRING NAME
*
SNAME MVI A,'$'
 CALL SCANC
 RC .  NOT STRING
 MOV A,C
 ORI STYPE
 MOV C,A
 XRA A  STRING
 RET
*
*     GET FUNCTION NAME (FN RW TOKEN ALREADY EATEN)
*     RETURN NAME IN BC, WITH C COPIED TO ACC
*
FNAME CALL ANAME
 MOV A,C
 ANI 70H  IGNORE OTHER BITS
 CPI STYPE
 MOV A,C
 JZ FNA0
*
 ANI 8FH  PRESERVE OTHER BITS
 ORI NFTYPE  NUMERIC FINCTION TYPE
 JMP FNA1
*
FNA0 ANI 8FH  PRESERVE OTHER BITS
 ORI SFTYPE  STRING FUNCTION TYPE
*
FNA1 MOV C,A
 RET
*
*     SEARCH FOR STATEMENT OF TYPE IN B OR C
*     ACC HAS TYPE OF CURRENT STATEMENT
*     RETURN TYPE FOUND IN ACC
*     SET CARRY IF NOT FOUND BEFORE END OF PROGRAM
*
LSTAT PUSH B
 CALL NEXTS
 CALL JOE
 MOV A,M
 POP B
 INX H
 SHLD TXA
*
 RC .  END OF FILE FOUND
 CMP B
 RZ
 CMP C
 JNZ LSTAT
 RET
*
*     SKIP OVER FUNCTION DEFINITION
*     ON RETURN TXA POINTS TO LAST STATEMENT OF DEFINTION
*
FEND LHLD TXA  SEE IF ONE LINER
FEND2 MOV A,M
 CPI EQRW
 RZ
 CPI CR
 JZ FEND1
 INX H
 SHLD TXA
 JMP FEND2
*
* MULTILINER CASE
FEND1 LXI B,DEFRW*256+FNERW
 CALL LSTAT
 LXI B,'FD'
 JC EOFERR
 CPI DEFRW
 JZ FDERR
 RET
*
*      GOBBLES NEXT TEXT CHARACTER IF ALPHABETIC
*      SETS CARRY IF NOT
*      NEXT CHAR IN ACC ON FAILURE
*
ALPHA LHLD TXA
ALPH1 MOV A,M
 CPI 'A'
 RC
 CPI 'Z'+1
 CMC
 JNC DIGT1
 RET
*
*     GOBBLES NEXT TEXT CHAR IF DIGIT
*     SETS CARRY IF NOT
*     NEXT CHAR IN ACC ON FAILURE
*
DIG  LHLD TXA
DIG1 MOV A,M
 CPI '0'
 RC
 CPI '9'+1
 CMC
 RC
*
DIGT1 INX H
 SHLD TXA
 RET
*
*     COPYS FPSIZ BYTES AT ADDR HL TO ADDR DE
*
VCPY1 LXI H,FPONE  ENTRY POINT FOR FPONE
*
VCOPY MVI C,FPSIZ
*
VCOP1 MOV A,M
 STAX D
 DCX H
 DCX D
 DCR C
 JNZ VCOP1
 RET
*
*    LOAD PTR TO TO FP VALUE ON STACK TO BC AND HL
*    PUTS FPSIZ IN DE
*
TOPFP LHLD TSTKA
 LXI B,FPSIZ
 DAD B
 MOV D,H
 MOV E,L
 RET
*
*
*     PUSH VALUE ADDRESSED BY HL ONTO ARG STACK
*     SETS ARGF, CLEARS CARRY
*
PSHAS PUSH H
 LXI D,-FPSIZ
 CALL PSHCS
 POP D
 XCHG
 XRA A
 INR A
 STA ARGF
 JMP VCOPY
*
*
*     POP ARG STACK
*     HL CONTAINS ADDRESS TO PUT POPPED VALUE AT
*
POPFP LXI H,FPSINK  THIS ENTRY POINT POPS TOP FP TO FPSINK
*
POPAS XCHG
POPA1 LHLD TSTKA
 LXI B,FPSIZ
 DAD B
 SHLD TSTKA  INCREMENT STACK POINTER
 JMP VCOPY
*
*     PUSH FRAME ONTO CONTROL STACK
*     TAKES MINUS AMOUNT TO SUB FROM TSTKA IN DE
*     DOES OVERFLOW TEST AND RETURNS OLD TSTKA
*
PSHCS LHLD TSTKA
 PUSH H
 DAD D
 CALL STOV
 SHLD TSTKA
 POP H
 RET
*
*     EXHANGE TXA AND RTXA
*     CLOBERS NOTHING
*
XTXA PUSH H
 LHLD TXA
 PUSH H
 LHLD RTXA
 SHLD TXA
 POP H
 SHLD RTXA
 POP H
 RET
*
*     ALLOCATE HL BYTES OF SYMBOL TABLE SPACE
*     AND ZERO IT OUT
*     RETURNS BEGINNING OF AREA ALLOCATED IN HL
*
ASTAB XCHG
ASTA1 LHLD STA
 PUSH H
 DAD D
 CALL STOV
 SHLD STA
 POP H
 PUSH H
 CALL CLRM  CLEAR MEMORY
 POP H
 RET
*
*     STORAGE OVERFLOW TEST
*     TEST THAT VALUE IN HL IS BETWEEN TSTKA AND STA
*     DOES NOT CLOBBER HL, DE, BE
*
STOV PUSH D
 XCHG
 LXI H,STA+1
 CALL DCMP1
 JC SOERR
 LXI H,TSTKA+1
 CALL DCMP1
 XCHG
 POP D
 RC
 JMP SOERR
*
*     INCREMENTS TXA IF NEXT CHAR IS EQUAL TO B
*     ELSE SYNTAX ERROR
*     DOESN'T CLOBBER BC, DE
*
EATL0 CALL GCI  SPRECIAL ENTRY POINT FOR EATLP
*
EATLP MVI B,LPARRW
 JMP EATC
*
EATRP MVI B,')'  ENTRY POINT FOR EATING A RIGHT PAREN
*
EATC LHLD TXA
 MOV A,M
 INX H
 SHLD TXA
 CMP B
 RZ
 JMP BSERR
*
*     GET NEXT TEXT CHAR FROM PROGRAM INTO ACC
*
GC LHLD TXA
 MOV A,M
 RET
*
*     GET NEXT TEXT CHAR AND INCREMENT TXA
*     DOES NOT CLOBBER DE, BC
*     RETURN CHAR IN ACC
*
GCI LHLD TXA
 MOV A,M
 INX H
 SHLD TXA
 RET
*
*     SCAN FOR COMMA
*
SCOMA MVI A,','
*
*     SCAN NEXT CHAR
*     IF IT EQUALS A THEN GOBBLE IT AND RETURN IT IN A WITH
*     CARRY CLEAR (I.E. C BIT OPERATES IN REVERSE OF Z BIT)
*     ELSE SET CARRY AND DON'T GOBBLE IT
*     CLOBBERS HL
*
SCANC LHLD TXA
 CMP M
 STC .  SET CARRY
 RNZ
 INX H
 SHLD TXA
 CMC .  CLEAR CARRY
 RET
*
*     FIND TEXT LINE WITH LEAST LINE NUMBER GREATER OR EQUAL TO
*     RETURNS TEXT ADDRESS OF COUNT BYTE IN HL
*     ALSO COMPUTES "NEW LINE NUMBER" FOR REN COMMAND
*
FINDLN LHLD BEG
 SHLD NLN  INITIAL "NEW LINE NUMBER"
 MVI B,0
 LHLD BOFA
*
FIND1 MOV C,M
 MOV A,C
 CPI EOF
 STC
 RZ
 INX H
 CALL DCMP
 DCX H
 RZ
 CMC
 RNC
 PUSH H  SAVE TEXT PTR
 PUSH D
 LHLD DEL
 XCHG
 LHLD NLN
 DAD D
 JC OBERR
 SHLD NLN
 POP D
 POP H
 DAD B
 JMP FIND1
*
*    FIND LINE    MUST BE EXACT MATCH
*
FNEQLN LHLD BOFA  START AT BIGINING OF FILE
 MVI B,0
FNEQ1 MOV C,M  BC:=LENGTH OF THIS LINE
 MOV A,C
 DCR A  TEST FOR EOF FLAG (01H)
 JZ LNERR
 INX H  PASS LENGTH BYTE
 CALL DCMP  DE-(HL)
 DCX H  POINT AT LENGTH BYTE
 RZ .  Z=1 & C#1, FOUND, RETURN
 DAD B
 JMP FNEQ1
*
*     GET LINE NUMBER ARGUMENTS
*       FORMAT:
*          COMMAND [FIRST][,][LAST]
*     DEFAULTS:
*          FIRST  BOFA
*          LAST   EOFA
*          IF ONLY FIRST IS GIVEN, LAST = FIRST + ONE LINE
*
GLARG LHLD BOFA
 SHLD FIRST  FIRST DEFAULT
 LHLD EOFA
 SHLD LAST  LAST DEFAULT
*
 CALL GC
 CPI CR
 RZ .  TAKE BOTH DEFAULTS
*
 CPI ','
 JZ GLA0  TAKE DEFAULT FOR FIRST
*
 CALL INTGER  FIRST IS APPARENTLY PRESENT
 JC LNERR
 XCHG
 CALL FINDLN  MUST BE EXACT MATCH
 JC LNERR
 SHLD FIRST
 MOV A,M  IF NO COMMA, LAST = FIRST + ONE LINE
 CALL ADR  POINT TO NEXT LINE
 SHLD LAST
*
 CALL GC
 CPI CR
 RZ .
*
 CPI ','
 JNZ BSERR
 LHLD EOFA  IF COMMA PRESENT, RESET LAST DEFAULT TO EOFA
 SHLD LAST
GLA0 CALL GCI  PASS THE COMMA
*
 MOV A,M  GET THE NEXT CHR
 CPI CR
 RZ
*
 CALL INTGER  LAST IS APPARENTLY PRESENT
 JC LNERR
 XCHG
 CALL FINDLN
 JC LNERR
 MOV A,M  POINT TO LINE'S END
 CALL ADR
 SHLD LAST
*
 XCHG .  TEST PARAMETERS
 LHLD FIRST
 CALL HDCMP
 JNC BSERR  LAST MUST BE > FRIST !!
*
 CALL GC
 CPI CR
 JNZ BSERR
 RET
*
*     PRINT MESSAGE
*      HL POINTS TO MESSAGE
*     PRNTCR PRINTS UP TO A CR
*     PRNT PRINTS TO A QUOTE
*     PRN1 PRINTS UP TO WHAT'S IN C
*
PRNTCR MVI C,CR  UP TO A CR
 JMP PRN1
*
PRNT MVI C,'"'  UP TO A QOUTE
*
PRN1 MOV A,M
 MOV B,A  NEXT CHARACTER TO OUTPUT
 CMP C  TERMINATOR?
 RZ .  YES ALL DONE
*
 CPI CR  THIS ROUTINE CAN'T PRINT A CR
 JZ BSERR
*
 CALL CHOUT  THIS WILL EXPAND CTRL-CHARACTERS
 INX H
 JMP PRN1  MORE?
*
*
*     COMPARE TWO STRINGS
*       BC     HAS LHS SIZE
*       DE     HAS RHS SIZE
*       LHSBA  HAS LHS BASE ADDRESS
*       RHSBA  HAS RHS BASE ADDRESS
*
SCOMP LHLD RHSBA  PLACE RHSBA ON STACK
 PUSH H
 LHLD LHSBA  GET LHS ADDR
*
SCUM9 MOV A,B  TEST FOR END OF LHS
 ORA C
 JZ SCUM0
*
 MOV A,D  TEST FOR END OF RHS
 ORA E
 JZ SCUM1
*
 XTHL .  HL:=LHSBA
 MOV A,M
 DCX H
 XTHL .  HL:=RHSBA
 CMP M
 DCX H
*
 DCX D
 DCX B  UPDATE COUNTS
 JZ SCUM9  NEXT!
 POP H  FLAGS ARE SET
 RET .  ALL DONE
*
*
SCUM0 POP H  LHS HAS ENDED
 MOV A,D  TEST RHS
 ORA E
 RZ .  THEY ARE EQUAL  Z=1, C=0
 RET .  LHS < RHS  Z=0, C=0
*
*
SCUM1 POP H  END OF RHS BUT NOT LHS
 XRA A
 INR A
 STC .  Z=0, C=1  LHS > RHS
 RET
*
*
*
*     FLAGS
*
ARGF DS 1  "LAST WAS ARGUEMENT" FLAG
UNDEF DS 1  FLAG FOR ERROR RECOVERY
IFTERM DS 1  IF STATEMENT TERMINATOR (EOS OR ELSE)
DIRF DS 1  DIRECT FLAG (KEYBOARD MODE STATEMENTS)
CONTF DS 1  CAN/CAN'T CONTINUE FLAG
LETFG DS 1  THE PRE-PROCESSOR'S 'LET' FLAG
FLNFG DS 1  THE UN-PREPROCESSOR'S FIRST LN FLAG
LPHED DS 1  INDENTATION COUNT FOR UN-PREPROCESSOR
FORFG DS 1  THE "FOR" SEEN FLAG
CTLFG DB 0  THE CTRL-CHARACTER EXPANTION FLAG AND CHARACTER
LEDFG DB 0  THE LEAD-CHARACTER-SEEN FLAG
INSFG DB 0  THE INSERT FLAG
*
*     TEXT POINTERS INTO THE BASIC PROGRAM
*
TXA DS 2
RTXA DS 2
INSA DS 2  INSERT ADDRESS FOR EDITOR
FIRST DS 2  HOLDS ADDR OF FIRST LINE TO BE AFFECTED
LAST DS 2  HOLD ADDR OF END OF LAST LINE TO BE AFFECTED
LHSBA DS 2  LEFT  HAND STRING BASE ADDRESS
RHSBA DS 2  RIGHT HAND STRING BASE ADDRESS
*
*     VARIABLES FOR RENUMBER
*
BEG DS 2
DEL DS 2
NLN DS 2
*
*