Subversion Repositories t51

;*****************************************************************************
;*                                                                           *
;*                      MCS BASIC-52 (tm) Source Listing                     *
;*                             December 18, 1986                             *
;*        The original source code of V1.1 (BASIC.SRC and FP52.SRC) by       *
;*             Intel Corporation, Embedded Controller Operations             *
;*                              is public donain                             *
;*                                                                           *
;*---------------------------------------------------------------------------*
;*              Alterations made by D. Wulf , December 18, 1999              *
;*              Alterations made by D. Wallner , May 4, 2002                 *
;*                                                                           *
;*****************************************************************************
;
;  The BASIC.a51 source listing, when compiled without modification,
;  create the same object code that is found on the MCS BASIC-52
;  Version 1.1 microcontrollers but with a timing independent baud rate
;  recognition routine and a shorter ego message.
;
;  The following alterations are made to the original source code:
;
;  The original source code had 2 files BASIC.SRC and FP52.SRC those have 
;  been incorporated into this file for ease of assembly. 
;
;  All absolute and relativ jumps and calls without labels were providet
;  with labels.
; 
;  All machine code in the original source, codet in databytes is replaced
;  by the menomics.
;
;  One routine in the source was different to the ROM code and is replaced 
;  by the ROM code.                       
;
;  Daniel Wallner , May 4, 2002:
;  Part of ego message replaced with a different baud recognition routine.
;
;*****************************************************************************
;
T2CON   EQU     0C8H ; This three lines are necessary for MS-DOS freeware 
TL2     EQU     0CCH ; MCS-51 Family Cross Assembler  ASEM-51 V1.2 
TH2     EQU     0CDH ; from W.W. Heinz (e-mail: ww@andiunx.m.isar.de)
;
;*****************************************************************************
;
$EJECT
        ;**************************************************************
        ;
        ; TRAP VECTORS TO MONITOR
        ;
        ; RESET TAG (0AAH) ---------2001H
        ;
        ; TAG LOCATION (5AH) ------ 2002H
        ;
        ; EXTERNAL INTERRUPT 0 ---- 2040H
        ;
        ; COMMAND MODE ENTRY ------ 2048H
        ;
        ; SERIAL PORT ------------- 2050H
        ;
        ; MONITOR (BUBBLE) OUTPUT - 2058H
        ;
        ; MONITOR (BUBBLE) INPUT -- 2060H
        ;
        ; MONITOR (BUBBLE) CSTS --- 2068H
        ;
        ; GET USER JUMP VECTOR ---- 2070H
        ;
        ; GET USER LOOKUP VECTOR -- 2078H
        ;
        ; PRINT AT VECTOR --------- 2080H
        ;
        ; INTERRUPT PWM ----------- 2088H
        ;
        ; EXTERNAL RESET ---------- 2090H
        ;
        ; USER OUTPUT-------------- 4030H
        ;
        ; USER INPUT -------------- 4033H
        ;
        ; USER CSTS --------------- 4036H
        ;
        ; USER RESET -------------- 4039H
        ;
        ; USER DEFINED PRINT @ ---  403CH
        ;
        ;***************************************************************
        ;
$EJECT
        ;***************************************************************
        ;
        ; MCS - 51  -  8K BASIC VERSION 1.1
        ;
        ;***************************************************************
        ;
        AJMP    CRST            ;START THE PROGRAM
        ADDC    A,@R1
        ;
        ORG     3H
        ;
        ;***************************************************************
        ;
        ;EXTERNAL INTERRUPT 0
        ;
        ;***************************************************************
        ;
        JB      DRQ,STQ         ;SEE IF DMA IS SET
        PUSH    PSW             ;SAVE THE STATUS
        LJMP    4003H           ;JUMP TO USER IF NOT SET
        ;
        ORG     0BH
        ;
        ;***************************************************************
        ;
        ;TIMER 0 OVERFLOW INTERRUPT
        ;
        ;***************************************************************
        ;
        PUSH    PSW             ;SAVE THE STATUS
        JB      C_BIT,STJ       ;SEE IF USER WANTS INTERRUPT
        LJMP    400BH           ;EXIT IF USER WANTS INTERRUPTS
        ;
        ORG     13H
        ;
        ;***************************************************************
        ;
        ;EXTERNAL INTERRUPT 1
        ;
        ;***************************************************************
        ;
        JB      INTBIT,STK
        PUSH    PSW
        LJMP    4013H
        ;
$EJECT
        ;
        ORG     1BH
        ;
        ;***************************************************************
        ;
        ;TIMER 1 OVERFLOW INTERRUPT
        ;
        ;***************************************************************
        ;
        PUSH    PSW
        LJMP    CKS_I
        ;
STJ:    LJMP    I_DR            ;DO THE INTERRUPT
        ;
        ;***************************************************************
        ;
        ;SERIAL PORT INTERRUPT
        ;
        ;***************************************************************
        ;
        ORG     23H
        ;
        PUSH    PSW
        JB      SPINT,STU       ;SEE IF MONITOR EANTS INTERRUPT
        LJMP    4023H
        ;
        ORG     2BH
        ;
        ;**************************************************************
        ;
        ;TIMER 2 OVERFLOW INTERRUPT
        ;
        ;**************************************************************
        ;
        PUSH    PSW
        LJMP    402BH
        ;
$EJECT
        ;**************************************************************
        ;
        ;USER ENTRY
        ;
        ;**************************************************************
        ;
        ORG     30H
        ;
        LJMP    IBLK            ;LINK TO USER BLOCK
        ;
STQ:    JB      I_T0,STS        ;SEE IF MONITOR WANTS IT
        CLR     DACK
        JNB     P3.2,$          ;WAIT FOR DMA TO END
        SETB    DACK
        RETI
        ;
STS:    LJMP    2040H           ;GO TO THE MONITOR
        ;
STK:    SETB    INTPEN          ;TELL BASIC AN INTERRUPT WAS RECEIVED
        RETI
        ;
STU:    LJMP    2050H           ;SERIAL PORT INTERRUPT
        ;
$EJECT

;$INCLUDE(:F2:LOOK52.SRC)
; INCLUDED BELOW

        ;
        ;**************************************************************
        ;
        ; This is the equate table for 8052 basic.
        ;
        ;**************************************************************
        ;
        ; The register to direct equates for CJNE instructions.
        ;
R0B0    EQU     0
R1B0    EQU     1
R2B0    EQU     2
R3B0    EQU     3
R4B0    EQU     4
R5B0    EQU     5
R6B0    EQU     6
R7B0    EQU     7
        ;
        ; Register bank 1 contains the text pointer
        ; and the arg stack pointer.
        ;
TXAL    EQU     8               ;R0 BANK 1 = TEXT POINTER LOW
ASTKA   EQU     9               ;R1 BANK 1 = ARG STACK
TXAH    EQU     10              ;R2 BANK 1 = TEXT POINTER HIGH
        ;
        ; Now five temporary locations that are used by basic.
        ;
TEMP1   EQU     11
TEMP2   EQU     12
TEMP3   EQU     13
TEMP4   EQU     14
TEMP5   EQU     15
        ;
$EJECT
        ; Register bank 2 contains the read text pointer
        ; and the control stack pointer.
        ;
RTXAL   EQU     16              ;R0 BANK 2 = READ TEXT POINTER LOW
CSTKA   EQU     17              ;R1 BANK 2 = CONTROL STACK POINTER
RTXAH   EQU     18              ;R2 BANK 2 = READ TEXT POINTER HIGH
        ;
        ; Now some internal system equates.
        ;
BOFAH   EQU     19              ;START OF THE BASIC PROGRAM, HIGH BYTE
BOFAL   EQU     20              ;START OF THE BASIC PROGRAM, LOW BYTE
NULLCT  EQU     21              ;NULL COUNT
PHEAD   EQU     22              ;PRINT HEAD POSITION
FORMAT  EQU     23
        ;
        ; Register bank 3 is for the user and can be loaded
        ; by basic
        ;
        ;
        ;
        ; Now everything else is used by basic.
        ; First the bit locations, these use bytes 34, 35, 36, 37 and 38
        ;
$EJECT
OTS             BIT     16      ;34.0-ON TIME INSTRUCTION EXECUTED
INPROG          BIT     17      ;34.1-INTERRUPT IN PROCESS
INTBIT          BIT     18      ;34.2-INTERRUPT SET BIT
ON_ERR          BIT     19      ;34.3-ON ERROR EXECUTED
OTI             BIT     20      ;34.4-ON TIME INTERRUPT IN PROGRESS
LINEB           BIT     21      ;34.5-LINE CHANGE OCCURED
INTPEN          BIT     22      ;34.6-INTERRUPT PENDING BIT
CONB            BIT     23      ;34.7-CAN CONTINUE IF SET
GTRD            BIT     24      ;35.0-READ GET LOCATION
LPB             BIT     25      ;35.1-PRINT TO LINE PRINTER PORT
CKS_B           BIT     26      ;35.2-FOR PWM INTERRUPT
COB             BIT     27      ;35.3-CONSOLE OUT BIT
                                ;     0 = SERIAL PORT
                                ;     1 = LINE PRINTER
COUB            BIT     28      ;35.4-USER CONSOLE OUT BIT
                                ;     0 = SERIAL PORT
                                ;     1 = USER DRIVER
INBIT           BIT     29      ;35.5-INITIALIZATION BIT
CIUB            BIT     30      ;35.6-USER CONSOLE IN BIT
                                ;     0 = SERIAL PORT
                                ;     1 = USER ROUTINE
SPINT           BIT     31      ;35.7-SERIAL PORT INTERRUPT
STOPBIT         BIT     32      ;36.0-PROGRAM STOP ENCOUNTERED
U_IDL           BIT     33      ;36.1-USER IDLE BREAK
INP_B           BIT     34      ;36.2-SET DURING INPUT INSTRUCTION
;DCMPXZ         BIT     35      ;36.3-DCMPX ZERO FLAG
ARGF            BIT     36      ;36.4-ARG STACK HAS A VALUE
RETBIT          BIT     37      ;36.5-RET FROM INTERRUPT EXECUTED
I_T0            BIT     38      ;36.6-TRAP INTERRUPT ZERO TO MON
UPB             BIT     39      ;36.7-SET WHEN @ IS VALID
JKBIT           BIT     40      ;37.0-WB TRIGGER
ENDBIT          BIT     41      ;37.1-GET END OF PROGRAM
UBIT            BIT     42      ;37.2-FOR DIM STATEMENT
ISAV            BIT     43      ;37.3-SAVE INTERRUPT STATUS
BO              BIT     44      ;37.4-BUBBLE OUTPUT
XBIT            BIT     45      ;37.5-EXTERNAL PROGRAM PRESENT
C_BIT           BIT     46      ;37.6-SET WHEN CLOCK RUNNING
DIRF            BIT     47      ;37.7-DIRECT INPUT MODE
NO_C            BIT     48      ;38.0-NO CONTROL C
DRQ             BIT     49      ;38.1-DMA ENABLED
BI              BIT     50      ;38.2-BUBBLE INPUT
INTELB          BIT     51      ;38.3-INTELLIGENT PROM PROGRAMMING
C0ORX1          BIT     52      ;38.4-PRINT FROM ROM OR RAM
CNT_S           BIT     53      ;38.5-CONTROL S ENCOUNTERED
ZSURP           BIT     54      ;38.6-ZERO SUPRESS
HMODE           BIT     55      ;38.7-HEX MODE PRINT
LP              BIT     P1.7    ;SOFTWARE LINE PRINTER
DACK            BIT     P1.6    ;DMA ACK
PROMV           BIT     P1.5    ;TURN ON PROM VOLTAGE
PROMP           BIT     P1.4    ;PROM PULSE
ALED            BIT     P1.3    ;ALE DISABLE
T_BIT           BIT     P1.2    ;I/O TOGGLE BIT
        ;
$EJECT
        ;
        ; The next location is a bit addressable byte counter
        ;
BABC    EQU     39
        ;
        ; Now floating point and the other temps
        ;
        ; FP Uses to locations 03CH
        ;
        ; Now the stack designators.
        ;
SPSAV   EQU     3EH
S_LEN   EQU     3FH
T_HH    EQU     40H
T_LL    EQU     41H
INTXAH  EQU     42H
INTXAL  EQU     43H
MT1     EQU     45H
MT2     EQU     46H
MILLIV  EQU     47H             ;TIMER LOCATIONS
TVH     EQU     48H
TVL     EQU     49H
SAVE_T  EQU     4AH
SP_H    EQU     4BH             ;SERIAL PORT TIME OUT
SP_L    EQU     4CH
CMNDSP  EQU     4DH             ;SYSTEM STACK POINTER
RCAPH2  EQU     0CBH
RCAPL2  EQU     0CAH
IRAMTOP EQU     0FFH            ;TOP OF RAM
STACKTP EQU     0FEH            ;ARG AND CONTROL STACK TOPS
        ;
        ; The character equates
        ;
CR      EQU     0DH             ;CARRIAGE RETURN
LF      EQU     0AH             ;LINE FEED
BELL    EQU     07H             ;BELL CHARACTER
BS      EQU     08H             ;BACK SPACE
CNTRLC  EQU     03H             ;CONTROL C
CNTRLD  EQU     04H             ;CONTROL D
NULL    EQU     00H             ;NULL
        ;
$EJECT
        ;
        ; The internal system equates
        ;
LINLEN  EQU     73              ;THE LENGTH OF AN INPUT LINE
EOF     EQU     01              ;END OF FILE CHARACTER
ASTKAH  EQU     01              ;ASTKA IS IN PAGE 1 OF RAM
CSTKAH  EQU     00              ;CSTKA IS IN PAGE 0 OF RAM
FTYPE   EQU     01              ;CONTROL STACK "FOR"
GTYPE   EQU     02              ;CONTROL STACK "GOSUB"
DTYPE   EQU     03              ;DO-WHILE/UNTIL TYPE
ROMADR  EQU     8000H           ;LOCATION OF ROM
        ;
        ; The floating point equates
        ;
FPSIZ   EQU     6               ;NO. OF BYTES IN A FLOATING NUM
DIGIT   EQU     FPSIZ-2         ;THE MANTISSA OF A FLOATING NUM
STESIZ  EQU     FPSIZ+3         ;SIZE OF SYMBOL ADJUSTED TABLE ELEMENT
;FP_BASE EQU     1993H           ;BASE OF FLOATING POINT ROUTINES
PSTART  EQU     512             ;START OF A PROGRAM IN RAM
FSIZE   EQU     FPSIZ+FPSIZ+2+2+1
        ;
$EJECT
        ;**************************************************************
        ;
USENT:  ; User entry jump table
        ;
        ;**************************************************************
        ;
        DW      CMND1           ;(00, 00H)COMMAND MODE JUMP
        DW      IFIX            ;(01, 01H)CONVERT FP TO INT
        DW      PUSHAS          ;(02, 02H)PUSH VALUE ONTO ARG STACK
        DW      POPAS           ;(03, 03H)POP VALUE OFF ARG STACK
        DW      PG1             ;(04, 04H)PROGRAM A PROM
        DW      INLINE          ;(05, 05H)INPUT A LINE
        DW      UPRNT           ;(06, 06H)PRINT A LINR
        DW      CRLF            ;(07, 07H)OUTPUT A CRLF
        ;
        ;**************************************************************
        ;
        ; This is the operation jump table for arithmetics
        ;
        ;**************************************************************
        ;
OPTAB:  DW      ALPAR           ;(08, 08H)LEFT PAREN
        DW      AEXP            ;(09, 09H)EXPONENTAION
        DW      AMUL            ;(10, 0AH)FP MUL
        DW      AADD            ;(11, 0BH)FLOATING POINT ADD
        DW      ADIV            ;(12, 0CH)FLOATING POINT DIVIDE
        DW      ASUB            ;(13, 0DH)FLOATING POINT SUBTRACTION
        DW      AXRL            ;(14, 0EH)XOR
        DW      AANL            ;(15, 0FH)AND
        DW      AORL            ;(16, 10H)OR
        DW      ANEG            ;(17, 11H)NEGATE
        DW      AEQ             ;(18, 12H)EQUAL
        DW      AGE             ;(19, 13H)GREATER THAN OR EQUAL
        DW      ALE             ;(20, 14H)LESS THAN OR EQUAL
        DW      ANE             ;(21, 15H)NOT EQUAL
        DW      ALT             ;(22, 16H)LESS THAN
        DW      AGT             ;(23, 17H)GREATER THAN
        ;
$EJECT
        ;***************************************************************
        ;
        ; This is the jump table for unary operators
        ;
        ;***************************************************************
        ;
        DW      AABS            ;(24, 18H)ABSOLUTE VALUE
        DW      AINT            ;(25, 19H)INTEGER OPERATOR
        DW      ASGN            ;(26, 1AH)SIGN OPERATOR
        DW      ANOT            ;(27, 1BH)ONE'S COMPLEMENT
        DW      ACOS            ;(28, 1CH)COSINE
        DW      ATAN            ;(29, 1DH)TANGENT
        DW      ASIN            ;(30, 1EH)SINE
        DW      ASQR            ;(31, 1FH)SQUARE ROOT
        DW      ACBYTE          ;(32, 20H)READ CODE
        DW      AETOX           ;(33, 21H)E TO THE X
        DW      AATAN           ;(34, 22H)ARC TANGENT
        DW      ALN             ;(35, 23H)NATURAL LOG
        DW      ADBYTE          ;(36, 24H)READ DATA MEMORY
        DW      AXBYTE          ;(37, 25H)READ EXTERNAL MEMORY
        DW      PIPI            ;(38, 26H)PI
        DW      ARND            ;(39, 27H)RANDOM NUMBER
        DW      AGET            ;(40, 28H)GET INPUT CHARACTER
        DW      AFREE           ;(41, 29H)COMPUTE #BYTES FREE
        DW      ALEN            ;(42, 2AH) COMPUTE LEN OF PORGRAM
        DW      AXTAL           ;(43, 2BH) CRYSTAL
        DW      PMTOP           ;(44, 2CH)TOP OF MEMORY
        DW      ATIME           ;(45, 2DH) TIME
        DW      A_IE            ;(46, 2EH) IE
        DW      A_IP            ;(47, 2FH) IP
        DW      ATIM0           ;(48, 30H) TIMER 0
        DW      ATIM1           ;(49, 31H) TIMER 1
        DW      ATIM2           ;(50, 32H) TIMER 2
        DW      AT2CON          ;(51, 33H) T2CON
        DW      ATCON           ;(52, 34H) TCON
        DW      ATMOD           ;(53, 35H) ATMOD
        DW      ARCAP2          ;(54, 36H) RCAP2
        DW      AP1             ;(55, 37H) P1
        DW      APCON           ;(56, 38H) PCON
        DW      EXPRB           ;(57, 39H) EVALUATE AN EXPRESSION
        DW      AXTAL1          ;(58, 3AH) CALCULATE CRYSTAL
        DW      LINE            ;(59, 3BH) EDIT A LINE
        DW      PP              ;(60, 3CH) PROCESS A LINE
        DW      UPPL0           ;(61, 3DH) UNPROCESS A LINE
        DW      VAR             ;(62, 3EH) FIND A VARIABLE
        DW      GC              ;(63, 3FH) GET A CHARACTER
        DW      GCI             ;(64, 40H) GET CHARACTER AND INCREMENT
        DW      INCHAR          ;(65, 41H) INPUT A CHARACTER
        DW      CRUN            ;(66, 42H) RUN A PROGRAM
$EJECT
OPBOL:  DB      1               ;
        ;
        DB      15              ;LEFT PAREN
        DB      14              ;EXPONENTIAN **
        DB      10              ;MUL
        DB      8               ;ADD
        DB      10              ;DIVIDE
        DB      8               ;SUB
        DB      3               ;XOR
        DB      5               ;AND
        DB      4               ;OR
        DB      12              ;NEGATE
        DB      6               ;EQ
        DB      6               ;GT
        DB      6               ;LT
        DB      6               ;NE
        DB      6               ;LE
        DB      6               ;GE
        ;
UOPBOL: DB      15              ;AABS
        DB      15              ;AAINT
        DB      15              ;ASGN
        DB      15              ;ANOT
        DB      15              ;ACOS
        DB      15              ;ATAN
        DB      15              ;ASIN
        DB      15              ;ASQR
        DB      15              ;ACBYTE
        DB      15              ;E TO THE X
        DB      15              ;AATAN
        DB      15              ;NATURAL LOG
        DB      15              ;DBYTE
        DB      15              ;XBYTE
        ;
$EJECT
        ;***************************************************************
        ;
        ; The ASCII printed messages.
        ;
        ;***************************************************************
        ;
STP:    DB      'STOP"'
        ;
IAN:    DB      'TRY AGAIN"'
        ;
RDYS:   DB      'READY"'
        ;
INS:    DB      ' - IN LINE "'
        ;
        ;**************************************************************
        ;
        ; This is the command jump table
        ;
        ;**************************************************************
        ;
CMNDD:  DW      CRUN            ;RUN
        DW      CLIST           ;LIST
        DW      CNULL           ;NULL
        DW      CNEW            ;NEW
        DW      CCONT           ;CONTINUE
        DW      CPROG           ;PROGRAM A PROM
        DW      CXFER           ;TRANSFER FROM ROM TO RAM
        DW      CRAM            ;RAM MODE
        DW      CROM            ;ROM MODE
        DW      CIPROG          ;INTELLIGENT PROM PROGRAMMING
        ;
$EJECT
        ;***************************************************************
        ;
        ; This is the statement jump table.
        ;
        ;**************************************************************
        ;
STATD:  ;
        DW      SLET            ;LET            80H
        DW      SCLR            ;CLEAR          81H
        DW      SPUSH           ;PUSH VAR       82H
        DW      SGOTO           ;GO TO          83H
        DW      STONE           ;TONE           84H
        DW      SPH0            ;PRINT MODE 0   85H
        DW      SUI             ;USER INPUT     86H
        DW      SUO             ;USER OUTPUT    87H
        DW      SPOP            ;POP VAR        88H
        DW      SPRINT          ;PRINT          89H
        DW      SCALL           ;CALL           8AH
        DW      SDIMX           ;DIMENSION      8BH
        DW      STRING          ;STRING ALLO    8CH
        DW      SBAUD           ;SET BAUD       8DH
        DW      SCLOCK          ;CLOCK          8EH
        DW      SPH1            ;PRINT MODE 1   8FH
        ;
        ; No direct mode from here on
        ;
        DW      SSTOP           ;STOP           90H
        DW      SOT             ;ON TIME        91H
        DW      SONEXT          ;ON EXT INT     92H
        DW      SRETI           ;RET FROM INT   93H
        DW      S_DO            ;DO             94H
        DW      SRESTR          ;RESTOR         95H
        DW      WCR             ;REM            96H
        DW      SNEXT           ;NEXT           97H
        DW      SONERR          ;ON ERROR       98H
        DW      S_ON            ;ON             99H
        DW      SINPUT          ;INPUT          9AH
        DW      SREAD           ;READ           9BH
        DW      FINDCR          ;DATA           9CH
        DW      SRETRN          ;RETURN         9DH
        DW      SIF             ;IF             9EH
        DW      SGOSUB          ;GOSUB          9FH
        DW      SFOR            ;FOR            A0H
        DW      SWHILE          ;WHILE          A1H
        DW      SUNTIL          ;UNTIL          A2H
        DW      CMND1           ;END            A3H
        DW      I_DL            ;IDLE           A4H
        DW      ST_A            ;STORE AT       A5H
        DW      LD_A            ;LOAD AT        A6H
        DW      PGU             ;PGM            A7H
        DW      RROM            ;RUN A ROM      A9H
        ;
$EJECT
        ;**************************************************************
        ;
TOKTAB: ; This is the basic token table
        ;
        ;**************************************************************
        ;
        ; First the tokens for statements
        ;
        DB      80H             ;LET TOKEN
        DB      'LET'
        ;
        DB      81H             ;CLEAR TOKEN
        DB      'CLEAR'
        ;
        DB      82H             ;PUSH TOKEN
        DB      'PUSH'
        ;
T_GOTO  EQU     83H
        ;
        DB      83H             ;GO TO TOKEN
        DB      'GOTO'
        ;
        DB      84H             ;TOGGLE TOKEN
        DB      'PWM'
        ;
        DB      85H             ;PRINT HEX MODE 0
        DB      'PH0.'
        ;
        DB      86H             ;USER IN TOKEN
        DB      'UI'
        ;
        DB      87H             ;USER OUT TOKEN
        DB      'UO'
        ;
        DB      88H             ;POP TOKEN
        DB      'POP'
        ;
$EJECT
        DB      89H             ;PRINT TOKEN
        DB      'PRINT'
        DB      89H
        DB      'P.'            ;P. ALSO MEANS PRINT
        DB      89H             ;? ALSO
        DB      '?'
        ;
        DB      8AH             ;CALL TOKEN
        DB      'CALL'
        ;
        DB      8BH             ;DIMENSION TOKEN
        DB      'DIM'
        ;
        DB      8CH             ;STRING TOKEN
        DB      'STRING'
        ;
        DB      8DH             ;SET BAUD RATE
        DB      'BAUD'
        ;
        DB      8EH             ;CLOCK
        DB      'CLOCK'
        ;
        DB      8FH             ;PRINT HEX MODE 1
        DB      'PH1.'
        ;
T_STOP  EQU     90H             ;STOP TOKEN
        DB      T_STOP
        DB      'STOP'
        ;
T_DIR   EQU     T_STOP          ;NO DIRECT FROM HERE ON
        ;
        DB      T_STOP+1        ;ON TIMER INTERRUPT
        DB      'ONTIME'
        ;
        DB      T_STOP+2        ;ON EXTERNAL INTERRUPT
        DB      'ONEX1'
        ;
        DB      T_STOP+3        ;RETURN FROM INTERRUPT
        DB      'RETI'
        ;
        DB      T_STOP+4        ;DO TOKEN
        DB      'DO'
        ;
        DB      T_STOP+5        ;RESTORE TOKEN
        DB      'RESTORE'
        ;
$EJECT
T_REM   EQU     T_STOP+6        ;REMARK TOKEN
        DB      T_REM
        DB      'REM'
        ;
        DB      T_REM+1         ;NEXT TOKEN
        DB      'NEXT'
        ;
        DB      T_REM+2         ;ON ERROR TOKEN
        DB      'ONERR'
        ;
        DB      T_REM+3         ;ON TOKEN
        DB      'ON'
        ;
        DB      T_REM+4         ;INPUT
        DB      'INPUT'
        ;
        DB      T_REM+5         ;READ
        DB      'READ'
        ;
T_DATA  EQU     T_REM+6         ;DATA
        DB      T_DATA
        DB      'DATA'
        ;
        DB      T_DATA+1        ;RETURN
        DB      'RETURN'
        ;
        DB      T_DATA+2        ;IF
        DB      'IF'
        ;
T_GOSB  EQU     T_DATA+3        ;GOSUB
        DB      T_GOSB
        DB      'GOSUB'
        ;
        DB      T_GOSB+1        ;FOR
        DB      'FOR'
        ;
        DB      T_GOSB+2        ;WHILE
        DB      'WHILE'
        ;
        DB      T_GOSB+3        ;UNTIL
        DB      'UNTIL'
        ;
        DB      T_GOSB+4        ;END
        DB      'END'
        ;
$EJECT
T_LAST  EQU     T_GOSB+5        ;LAST INITIAL TOKEN
        ;
T_TAB   EQU     T_LAST          ;TAB TOKEN
        DB      T_TAB
        DB      'TAB'
        ;
T_THEN  EQU     T_LAST+1        ;THEN TOKEN
        DB      T_THEN
        DB      'THEN'
        ;
T_TO    EQU     T_LAST+2        ;TO TOKEN
        DB      T_TO
        DB      'TO'
        ;
T_STEP  EQU     T_LAST+3        ;STEP TOKEN
        DB      T_STEP
        DB      'STEP'
        ;
T_ELSE  EQU     T_LAST+4        ;ELSE TOKEN
        DB      T_ELSE
        DB      'ELSE'
        ;
T_SPC   EQU     T_LAST+5        ;SPACE TOKEN
        DB      T_SPC
        DB      'SPC'
        ;
T_CR    EQU     T_LAST+6
        DB      T_CR
        DB      'CR'
        ;
        DB      T_CR+1
        DB      'IDLE'
        ;
        DB      T_CR+2
        DB      'ST@'
        ;
        DB      T_CR+3
        DB      'LD@'
        ;
        DB      T_CR+4
        DB      'PGM'
        ;
        DB      T_CR+5
        DB      'RROM'
        ;
$EJECT
        ; Operator tokens
        ;
T_LPAR  EQU     0E0H            ;LEFT PAREN
        DB      T_LPAR
        DB      '('
        ;
        DB      T_LPAR+1        ;EXPONENTIAN
        DB      '**'
        ;
        DB      T_LPAR+2        ;FP MULTIPLY
        DB      '*'
        ;
T_ADD   EQU     T_LPAR+3
        DB      T_LPAR+3        ;ADD TOKEN
        DB      '+'
        ;
        DB      T_LPAR+4        ;DIVIDE TOKEN
        DB      '/'
        ;
T_SUB   EQU     T_LPAR+5        ;SUBTRACT TOKEN
        DB      T_SUB
        DB      '-'
        ;
        DB      T_LPAR+6        ;LOGICAL EXCLUSIVE OR
        DB      '.XOR.'
        ;
        DB      T_LPAR+7        ;LOGICAL AND
        DB      '.AND.'
        ;
        DB      T_LPAR+8        ;LOGICAL OR
        DB      '.OR.'
        ;
T_NEG   EQU     T_LPAR+9
        ;
T_EQU   EQU     T_LPAR+10       ;EQUAL
        DB      T_EQU
        DB      '='
        ;
        DB      T_LPAR+11       ;GREATER THAN OR EQUAL
        DB      '>='
        ;
        DB      T_LPAR+12       ;LESS THAN OR EQUAL
        DB      '<='
        ;
        DB      T_LPAR+13       ;NOT EQUAL
        DB      '<>'
        ;
        DB      T_LPAR+14       ;LESS THAN
        DB      '<'
        ;
        DB      T_LPAR+15       ;GREATER THAN
        DB      '>'
        ;
        ;
T_UOP   EQU     0B0H            ;UNARY OP BASE TOKEN
        ;
        DB      T_UOP           ;ABS TOKEN
        DB      'ABS'
        ;
        DB      T_UOP+1         ;INTEGER TOKEN
        DB      'INT'
        ;
        DB      T_UOP+2         ;SIGN TOKEN
        DB      'SGN'
        ;
        DB      T_UOP+3         ;GET TOKEN
        DB      'NOT'
        ;
        DB      T_UOP+4         ;COSINE TOKEN
        DB      'COS'
        ;
        DB      T_UOP+5         ;TANGENT TOKEN
        DB      'TAN'
        ;
        DB      T_UOP+6         ;SINE TOKEN
        DB      'SIN'
        ;
        DB      T_UOP+7         ;SQUARE ROOT TOKEN
        DB      'SQR'
        ;
        DB      T_UOP+8         ;CBYTE TOKEN
        DB      'CBY'
        ;
        DB      T_UOP+9         ;EXP (E TO THE X) TOKEN
        DB      'EXP'
        ;
        DB      T_UOP+10
        DB      'ATN'
        ;
        DB      T_UOP+11
        DB      'LOG'
        ;
        DB      T_UOP+12        ;DBYTE TOKEN
        DB      'DBY'
        ;
        DB      T_UOP+13        ;XBYTE TOKEN
        DB      'XBY'
        ;
T_ULAST EQU     T_UOP+14        ;LAST OPERATOR NEEDING PARENS
        ;
        DB      T_ULAST
        DB      'PI'
        ;
        DB      T_ULAST+1       ;RND TOKEN
        DB      'RND'
        ;
        DB      T_ULAST+2       ;GET TOKEN
        DB      'GET'
        ;
        DB      T_ULAST+3       ;FREE TOKEN
        DB      'FREE'
        ;
        DB      T_ULAST+4       ;LEN TOKEN
        DB      'LEN'
        ;
T_XTAL  EQU     T_ULAST+5       ;CRYSTAL TOKEN
        DB      T_XTAL
        DB      'XTAL'
        ;
T_MTOP  EQU     T_ULAST+6       ;MTOP
        DB      T_MTOP
        DB      'MTOP'
        ;
T_IE    EQU     T_ULAST+8       ;IE REGISTER
        DB      T_IE
        DB      'IE'
        ;
T_IP    EQU     T_ULAST+9       ;IP REGISTER
        DB      T_IP
        DB      'IP'
        ;
TMR0    EQU     T_ULAST+10      ;TIMER 0
        DB      TMR0
        DB      'TIMER0'
        ;
TMR1    EQU     T_ULAST+11      ;TIMER 1
        DB      TMR1
        DB      'TIMER1'
        ;
TMR2    EQU     T_ULAST+12      ;TIMER 2
        DB      TMR2
        DB      'TIMER2'
        ;
T_TIME  EQU     T_ULAST+7       ;TIME
        DB      T_TIME
        DB      'TIME'
        ;
TT2C    EQU     T_ULAST+13      ;T2CON
        DB      TT2C
        DB      'T2CON'
        ;
TTC     EQU     T_ULAST+14      ;TCON
        DB      TTC
        DB      'TCON'
        ;
TTM     EQU     T_ULAST+15      ;TMOD
        DB      TTM
        DB      'TMOD'
        ;
TRC2    EQU     T_ULAST+16      ;RCAP2
        DB      TRC2
        DB      'RCAP2'
        ;
T_P1    EQU     T_ULAST+17      ;P1
        DB      T_P1
        DB      'PORT1'
        ;
T_PC    EQU     T_ULAST+18      ;PCON
        DB      T_PC
        DB      'PCON'
        ;
T_ASC   EQU     T_ULAST+19      ;ASC TOKEN
        DB      T_ASC
        DB      'ASC('
        ;
T_USE   EQU     T_ULAST+20      ;USING TOKEN
        DB      T_USE
        DB      'USING('
        DB      T_USE
        DB      'U.('
        ;
T_CHR   EQU     T_ULAST+21      ;CHR TOKEN
        DB      T_CHR
        DB      'CHR('
        ;
$EJECT
T_CMND  EQU     0F0H            ;COMMAND BASE
        ;
        DB      0F0H            ;RUN TOKEN
        DB      'RUN'
        ;
        DB      0F1H            ;LIST TOKEN
        DB      'LIST'
        ;
        DB      0F2H            ;NULL TOKEN
        DB      'NULL'
        ;
        DB      0F3H            ;NEW TOKEN
        DB      'NEW'
        ;
        DB      0F4H            ;CONTINUE TOKEN
        DB      'CONT'
        ;
        DB      0F5H            ;PROGRAM TOKEN
        DB      'PROG'
        ;
        DB      0F6H            ;TRANSFER TOKEN
        DB      'XFER'
        ;
        DB      0F7H            ;RAM MODE
        DB      'RAM'
        ;
        DB      0F8H            ;ROM MODE
        DB      'ROM'
        ;
        DB      0F9H            ;INTELLIGENT PROM PROGRAMMING
        DB      'FPROG'
        ;
        DB      0FFH            ;END OF TABLE
        ;

; END OF INCLUDE LOOK52
;$INCLUDE(:F2:LOOK52.SRC)
        ;
EIG:    DB      'EXTRA IGNORED"'
        ;
EXA:    DB      'A-STACK"'
        ;
EXC:    DB      'C-STACK"'
        ;
$EJECT
;$INCLUDE(:F2:BAS52.RST)
; BEGINNING

        ;**************************************************************
        ;
CRST:   ; This performs system initialzation, it was moved here so the
        ; new power on reset functions could be tested in an 8751.
        ;
        ;**************************************************************
        ;
        ; First, initialize SFR's
        ;
        MOV     SCON,#5AH       ;INITIALIZE SFR'S
        MOV     TMOD,#10H
        MOV     TCON,#54H
        MOV     T2CON,#34H
;       DB      75H             ;MOV DIRECT, # OP CODE
;       DB      0C8H            ;T2CON LOCATION
;       DB      34H             ;CONFIGURATION BYTE
        ;
        MOV     DPTR,#2001H     ;READ CODE AT 2001H
        CLR     A
        MOVC    A,@A+DPTR
        CJNE    A,#0AAH,CRST1   ;IF IT IS AN AAH, DO USER RESET
        LCALL   2090H
        ;
CRST1:  MOV     R0,#IRAMTOP     ;PUT THE TOP OF RAM IN R0
        CLR     A               ;ZERO THE ACC
        ;
CRST2:  MOV     @R0,A           ;CLEAR INTERNAL MEMORY
        DJNZ    R0,CRST2        ;LOOP TIL DONE
        ;
        ; Now, test the external memory
        ;
        MOV     SPSAV,#CMNDSP   ;SET UP THE STACK
        MOV     SP,SPSAV
        ;
        MOV     BOFAH,#HIGH ROMADR
        MOV     BOFAL,#LOW ROMADR+17
        MOV     DPTR,#ROMADR    ;GET THE BYTE AT 8000H
        MOVX    A,@DPTR
        CLR     C
        SUBB    A,#31H          ;FOR BIAS
        MOV     MT1,A           ;SAVE IN DIRECT MATH LOC
        CLR     ACC.2           ;SAVE FOR RESET
        MOV     R7,A            ;SAVE IT IN R7
        INC     DPTR
        ACALL   L31DPI          ;SAVE BAUD RATE
        LCALL   RCL
        INC     DPTR            ;GET MEMTOP
        ACALL   L31DPI
        MOV     DPTR,#5FH       ;READ THE EXTERNAL BYTE
        MOVX    A,@DPTR
        MOV     DPTR,#0         ;ESTABLISH BASE FOR CLEAR
        CJNE    A,#0A5H,CRS
        MOV     A,MT1
        CLR     ACC.0           ;CLEAR BIT ONE
        XRL     A,#4H
        JZ      CR2
        ;
CRS:    CJNE    R7,#2,CRS1
        SJMP    CRS2
CRS1:   CJNE    R7,#3,CR0
CRS2:   ACALL   CL_1
        SJMP    CR1
        ;
CR0:    MOV     R3,DPH          ;SAVE THE DPTR
        MOV     R1,DPL
        INC     DPTR
        MOV     A,#5AH
        MOVX    @DPTR,A
        MOVX    A,@DPTR
        CJNE    A,#5AH,CR1
        CLR     A
        MOVX    @DPTR,A
        CJNE    R3,#0E0H,CR0
        ;
CR1:    CJNE    R3,#03H,CR11    ;NEED THIS MUCH RAM
CR11:   JC      CRST
        MOV     DPTR,#MEMTOP    ;SAVE MEMTOP
        ACALL   S31DP2          ;SAVE MEMTOP AND SEED RCELL
        ACALL   CNEW            ;CLEAR THE MEMORY AND SET UP POINTERS
        ;
CR2:    ACALL   RC1             ;SET UP STACKS IF NOT DONE
        ;
        LCALL   AXTAL0          ;DO THE CRYSTAL
        MOV     A,MT1           ;GET THE RESET BYTE
        CJNE    A,#5,CR20
        LCALL   4039H
CR20:   JNC     BG1             ;CHECK FOR 0,1,2,3, OR 4
        JNB     ACC.0,BG3       ;NO RUN IF WRONG TYPE
        MOV     DPTR,#ROMADR+16
        MOVX    A,@DPTR         ;READ THE BYTE
        CJNE    A,#55H,BG3
        LJMP    CRUN

        ; START OF BAUD RATE MODIFICATIONS BY DANIEL WALLNER

BG1:    CLR     A               ;DO BAUD RATE
        MOV     R3,A
        MOV     R1,A
        MOV     TL2,A
        CLR     T2CON.2
        JB      RXD,$           ;LOOP UNTIL A CHARACTER IS RECEIVED
        MOV     T2CON,#5
        CALL    TIB2
        JNB     RXD,$
        MOV     T2CON,#34H
        CALL    RCL             ;LOAD THE TIMER
        NOP
        NOP

        ; END OF BAUD RATE MODIFICATIONS BY DANIEL WALLNER


BG3:    MOV     DPTR,#S_N       ;GET THE MESSAGE
        ACALL   CRP             ;PRINT IT
        LJMP    CRAM

; END
;$INCLUDE(:F2:BAS52.RST)
        ;
$EJECT
        ;***************************************************************
        ;
        ; CIPROG AND CPROG - Program a prom
        ;
        ;***************************************************************
        ;
;$INCLUDE(:F2:BAS52.PGM)
;BEGINNING

PG8:    MOV     R7,#00H         ;PROGRAM ONE BYTE AT A TIME
        MOV     R6,#01H
        MOV     R2,#HIGH ROMADR-1
        MOV     R0,#LOW ROMADR-1;LOAD PROM ADDRESS
        ACALL   PG101
        INC     R6
        MOV     A,RCAPH2
;       DB      0E5H            ;MOV A DIRECT OP CODE
;       DB      0CBH            ;ADDRESS OF R2CAP HIGH
        ACALL   PG101
        MOV     A,RCAPL2
;       DB      0E5H            ;MOV A, DIRECT OP CODE
;       DB      0CAH            ;R2CAP LOW
        MOV     R6,#3
        MOV     R1,#LOW MEMTOP-1
        MOV     R3,#HIGH MEMTOP
        ACALL   PG101           ;SAVE MEMTOP
        SJMP    PGR
        ;
CIPROG: MOV     DPTR,#IPROGS    ;LOAD IPROG LOCATION
        SETB    INTELB
        SJMP    CPROG1          ;GO DO PROG
        ;
CPROG:  MOV     DPTR,#PROGS     ;LOAD PROG LOCATION
        CLR     INTELB
        ;
CPROG1: ACALL   LD_T            ;LOAD THE TIMER
        CLR     PROMV           ;TURN ON THE PROM VOLTAGE
        CALL    DELTST          ;SEE IF A CR
        JNZ     PG8             ;SAVE TIMER IF SO
        MOV     R4,#0FEH
        SETB    INBIT
        ACALL   ROMFD           ;GET THE ROM ADDRESS OF THE LAST LOCATION
        CALL    TEMPD           ;SAVE THE ADDRESS
        MOV     A,R4            ;GET COUNT
        CPL     A
        CALL    TWO_R2          ;PUT IT ON THE STACK
        CALL    FP_BASE7        ;OUTPUT IT
        ACALL   CCAL            ;GET THE PROGRAM
        ACALL   CRLF            ;DO CRLF
        MOV     R0,TEMP4        ;GET ADDRESS
        MOV     R2,TEMP5
        MOV     A,#55H          ;LOAD SIGNIFIER
        INC     R6              ;LOAD LEN + 1
        CJNE    R6,#00,CPROG2
        INC     R7
CPROG2: ACALL   PG102
        ;
$EJECT
PGR:    SETB    PROMV
        AJMP    C_K
        ;
PG1:    MOV     P2,R3           ;GET THE BYTE TO PROGRAM
        MOVX    A,@R1
PG101:  LCALL   INC3210         ;BUMP POINTERS
PG102:  MOV     R5,#1           ;SET UP INTELLIGENT COUMTER
        ;
PG2:    MOV     R4,A            ;SAVE THE BYTE IN R4
        ACALL   PG7             ;PROGRAM THE BYTE
        ACALL   PG9
        JB      INTELB,PG4      ;SEE IF INTELLIGENT PROGRAMMING
        ;
PG3:    XRL     A,R4
        JNZ     PG6             ;ERROR IF NOT THE SAME
        CALL    DEC76           ;BUMP THE COUNTERS
        JNZ     PG1             ;LOOP IF NOT DONE
        ANL     PSW,#11100111B  ;INSURE RB0
PG31:   RET
        ;
PG4:    XRL     A,R4            ;SEE IF PROGRAMMED
        JNZ     PG5             ;JUMP IF NOT
        MOV     A,R4            ;GET THE DATA BACK
        ACALL   PG7             ;PROGRAM THE LOCATION
PG41:   ACALL   ZRO             ;AGAIN
        ACALL   ZRO             ;AND AGAIN
        ACALL   ZRO             ;AND AGAIN
        DJNZ    R5,PG41         ;KEEP DOING IT
        ACALL   PG9             ;RESET PROG
        SJMP    PG3             ;FINISH THE LOOP
        ;
PG5:    INC     R5              ;BUMP THE COUNTER
        MOV     A,R4            ;GET THE BYTE
        CJNE    R5,#25,PG2      ;SEE IF TRIED 25 TIMES
        ;
PG6:    SETB    PROMV           ;TURN OFF PROM VOLTAGE
        MOV     PSW,#0          ;INSURE RB0
        JNB     DIRF,PG31       ;EXIT IF IN RUN MODE
        MOV     DPTR,#E16X      ;PROGRAMMING ERROR
        ;
ERRLK:  LJMP    ERROR           ;PROCESS THE ERROR
        ;
$EJECT
PG7:    MOV     P0,R0           ;SET UP THE PORTS
        MOV     P2,R2           ;LATCH LOW ORDER ADDRESS
        ACALL   PG11            ;DELAY FOR 8748/9
        CLR     ALED
        MOV     P0,A            ;PUT DATA ON THE PORT
        ;
ZRO:    NOP                     ;SETTLEING TIME + FP ZERO
        NOP
        NOP
        NOP
        NOP
        NOP
        ACALL   PG11            ;DELAY A WHILE
        CLR     PROMP           ;START PROGRAMMING
        ACALL   TIMER_LOAD      ;START THE TIMER
        JNB     TF1,$           ;WAIT FOR PART TO PROGRAM
        RET                     ;EXIT
        ;
PG9:    SETB    PROMP
        ACALL   PG11            ;DELAY FOR A WHILE
        JNB     P3.2,$          ;LOOP FOR EEPROMS
        MOV     P0,#0FFH
        CLR     P3.7            ;LOWER READ
        ACALL   PG11
        MOV     A,P0            ;READ THE PORT
        SETB    P3.7
        SETB    ALED
        RET
        ;
PG11:   MOV     TEMP5,#12       ;DELAY 30uS AT 12 MHZ
        DJNZ    TEMP5,$
        RET
        ;

;END
;$INCLUDE(:F2:BAS52.PGM)
$EJECT
        ;**************************************************************
        ;
PGU:    ;PROGRAM A PROM FOR THE USER
        ;
        ;**************************************************************
        ;
        CLR     PROMV           ;TURN ON THE VOLTAGE
        MOV     PSW,#00011000B  ;SELECT RB3
        ACALL   PG1             ;DO IT
        SETB    PROMV           ;TURN IT OFF
        RET
        ;
        ;
        ;*************************************************************
        ;
CCAL:   ; Set up for prom moves
        ; R3:R1 gets source
        ; R7:R6 gets # of bytes
        ;
        ;*************************************************************
        ;
        ACALL   GETEND          ;GET THE LAST LOCATION
        INC     DPTR            ;BUMP TO LOAD EOF
        MOV     R3,BOFAH
        MOV     R1,BOFAL        ;RESTORE START
        CLR     C               ;PREPARE FOR SUBB
        MOV     A,DPL           ;SUB DPTR - BOFA > R7:R6
        SUBB    A,R1
        MOV     R6,A
        MOV     A,DPH
        SUBB    A,R3
        MOV     R7,A
CCAL1:  RET
        ;
        ;
;$INCLUDE(:F2:BAS52.TL)
;BEGINNING

        ;**************************************************************
        ;
TIMER_LOAD:; Load the timer
        ;
        ;*************************************************************
        ;
        ACALL   CCAL1           ;DELAY FOUR CLOCKS
TIMER_LOAD1:
        CLR     TR1             ;STOP IT WHILE IT'S LOADED
        MOV     TH1,T_HH
        MOV     TL1,T_LL
        CLR     TF1             ;CLEAR THE OVERFLOW FLAG
        SETB    TR1             ;START IT NOW
        RET
        ;

;END
;$INCLUDE(:F2:BAS52.TL)
$EJECT
        ;***************************************************************
        ;
CROM:   ; The command action routine - ROM - Run out of rom
        ;
        ;***************************************************************
        ;
        CLR     CONB            ;CAN'T CONTINUE IF MODE CHANGE
        ACALL   RO1             ;DO IT
        ;
C_K:    LJMP    CL3             ;EXIT
        ;
;RO1:    CALL    INTGER          ;SEE IF INTGER PRESENT
;        MOV     R4,R0B0         ;SAVE THE NUMBER
;        JNC     $+4
;        MOV     R4,#01H         ;ONE IF NO INTEGER PRESENT
;        CALL   ROMFD           ;FIND THE PROGRAM
;       ACALL   ROMFD           ;FIND THE PROGRAM

RO1:    CALL    DELTST
        MOV     R4,#1
        JNC     RO11
        CALL    ONE
        MOV     R4,A
RO11:   ACALL   ROMFD
        CJNE    R4,#0,RFX       ;EXIT IF R4 <> 0
        INC     DPTR            ;BUMP PAST TAG
        MOV     BOFAH,DPH       ;SAVE THE ADDRESS
        MOV     BOFAL,DPL
        RET
        ;
ROMFD:  MOV     DPTR,#ROMADR+16 ;START OF USER PROGRAM
        ;
RF1:    MOVX    A,@DPTR         ;GET THE BYTE
        CJNE    A,#55H,RF3      ;SEE IF PROPER TAG
        DJNZ    R4,RF2          ;BUMP COUNTER
        ;
RFX:    RET                     ;DPTR HAS THE START ADDRESS
        ;
RF2:    INC     DPTR            ;BUMP PAST TAG
        ACALL   G5
        INC     DPTR            ;BUMP TO NEXT PROGRAM
        SJMP    RF1             ;DO IT AGAIN
        ;
RF3:    JBC     INBIT,RFX       ;EXIT IF SET
        ;
NOGO:   MOV     DPTR,#NOROM
        AJMP    ERRLK
        ;
$EJECT
        ;***************************************************************
        ;
L20DPI: ; load R2:R0 with the location the DPTR is pointing to
        ;
        ;***************************************************************
        ;
        MOVX    A,@DPTR
        MOV     R2,A
        INC     DPTR
        MOVX    A,@DPTR
        MOV     R0,A
        RET                     ;DON'T BUMP DPTR
        ;
        ;***************************************************************
        ;
X31DP:  ; swap R3:R1 with DPTR
        ;
        ;***************************************************************
        ;
        XCH     A,R3
        XCH     A,DPH
        XCH     A,R3
        XCH     A,R1
        XCH     A,DPL
        XCH     A,R1
        RET
        ;
        ;***************************************************************
        ;
LD_T:   ; Load the timer save location with the value the DPTR is
        ; pointing to.
        ;
        ;****************************************************************
        ;
        MOVX    A,@DPTR
        MOV     T_HH,A
        INC     DPTR
        MOVX    A,@DPTR
        MOV     T_LL,A
        RET
        ;
$EJECT
        ;
        ;***************************************************************
        ;
        ;GETLIN - FIND THE LOCATION OF THE LINE NUMBER IN R3:R1
        ;         IF ACC = 0 THE LINE WAS NOT FOUND I.E. R3:R1
        ;         WAS TOO BIG, ELSE ACC <> 0 AND THE DPTR POINTS
        ;         AT THE LINE THAT IS GREATER THAN OR EQUAL TO THE
        ;         VALUE IN R3:R1.
        ;
        ;***************************************************************
        ;
GETEND: SETB    ENDBIT          ;GET THE END OF THE PROGRAM
        ;
GETLIN: CALL    DP_B            ;GET BEGINNING ADDRESS
        ;
G1:     CALL    B_C
        JZ      G3              ;EXIT WITH A ZERO IN A IF AT END
        INC     DPTR            ;POINT AT THE LINE NUMBER
        JB      ENDBIT,G2       ;SEE IF WE WANT TO FIND THE END
        ACALL   DCMPX           ;SEE IF (DPTR) = R3:R1
        ACALL   DECDP           ;POINT AT LINE COUNT
        MOVX    A,@DPTR         ;PUT LINE LENGTH INTO ACC
        JB      UBIT,G3         ;EXIT IF EQUAL
        JC      G3              ;SEE IF LESS THAN OR ZERO
        ;
G2:     ACALL   ADDPTR          ;ADD IT TO DPTR
        SJMP    G1              ;LOOP
        ;
G3:     CLR     ENDBIT          ;RESET ENDBIT
        RET                     ;EXIT
        ;
G4:     MOV     DPTR,#PSTART    ;DO RAM
        ;
G5:     SETB    ENDBIT
        SJMP    G1              ;NOW DO TEST
        ;
$EJECT
        ;***************************************************************
        ;
        ; LDPTRI - Load the DATA POINTER with the value it is pointing
        ;          to - DPH = (DPTR) , DPL = (DPTR+1)
        ;
        ; acc gets wasted
        ;
        ;***************************************************************
        ;
LDPTRI: MOVX    A,@DPTR         ;GET THE HIGH BYTE
        PUSH    ACC             ;SAVE IT
        INC     DPTR            ;BUMP THE POINTER
        MOVX    A,@DPTR         ;GET THE LOW BYTE
        MOV     DPL,A           ;PUT IT IN DPL
        POP     DPH             ;GET THE HIGH BYTE
        RET                     ;GO BACK
        ;
        ;***************************************************************
        ;
        ;L31DPI - LOAD R3 WITH (DPTR) AND R1 WITH (DPTR+1)
        ;
        ;ACC GETS CLOBBERED
        ;
        ;***************************************************************
        ;
L31DPI: MOVX    A,@DPTR         ;GET THE HIGH BYTE
        MOV     R3,A            ;PUT IT IN THE REG
        INC     DPTR            ;BUMP THE POINTER
        MOVX    A,@DPTR         ;GET THE NEXT BYTE
        MOV     R1,A            ;SAVE IT
        RET
        ;
        ;***************************************************************
        ;
        ;DECDP - DECREMENT THE DATA POINTER - USED TO SAVE SPACE
        ;
        ;***************************************************************
        ;
DECDP2: ACALL   DECDP
        ;
DECDP:  XCH     A,DPL           ;GET DPL
        JNZ     DECDP1          ;BUMP IF ZERO
        DEC     DPH
DECDP1: DEC     A               ;DECREMENT IT
        XCH     A,DPL           ;GET A BACK
        RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
        ;DCMPX - DOUBLE COMPARE - COMPARE (DPTR) TO R3:R1
        ;R3:R1 - (DPTR) = SET CARRY FLAG
        ;
        ;IF R3:R1 > (DPTR) THEN C = 0
        ;IF R3:R1 < (DPTR) THEN C = 1
        ;IF R3:R1 = (DPTR) THEN C = 0
        ;
        ;***************************************************************
        ;
DCMPX:  CLR     UBIT            ;ASSUME NOT EQUAL
        MOVX    A,@DPTR         ;GET THE BYTE
        CJNE    A,R3B0,D1       ;IF A IS GREATER THAN R3 THEN NO CARRY
                                ;WHICH IS R3<@DPTR = NO CARRY AND
                                ;R3>@DPTR CARRY IS SET
        INC     DPTR            ;BUMP THE DATA POINTER
        MOVX    A,@DPTR         ;GET THE BYTE
        ACALL   DECDP           ;PUT DPTR BACK
        CJNE    A,R1B0,D1       ;DO THE COMPARE
        CPL     C               ;FLIP CARRY
        ;
        CPL     UBIT            ;SET IT
D1:     CPL     C               ;GET THE CARRY RIGHT
        RET                     ;EXIT
        ;
        ;***************************************************************
        ;
        ; ADDPTR - Add acc to the dptr
        ;
        ; acc gets wasted
        ;
        ;***************************************************************
        ;
ADDPTR: ADD     A,DPL           ;ADD THE ACC TO DPL
        MOV     DPL,A           ;PUT IT IN DPL
        JNC     ADDPTR1         ;JUMP IF NO CARRY
        INC     DPH             ;BUMP DPH
ADDPTR1:RET                     ;EXIT
        ;
$EJECT
        ;*************************************************************
        ;
LCLR:   ; Set up the storage allocation
        ;
        ;*************************************************************
        ;
        ACALL   ICLR            ;CLEAR THE INTERRUPTS
        ACALL   G4              ;PUT END ADDRESS INTO DPTR
        MOV     A,#6            ;ADJUST MATRIX SPACE
        ACALL   ADDPTR          ;ADD FOR PROPER BOUNDS
        ACALL   X31DP           ;PUT MATRIX BOUNDS IN R3:R1
        MOV     DPTR,#MT_ALL    ;SAVE R3:R1 IN MATRIX FREE SPACE
        ACALL   S31DP           ;DPTR POINTS TO MEMTOP
        ACALL   L31DPI          ;LOAD MEMTOP INTO R3:R1
        MOV     DPTR,#STR_AL    ;GET MEMORY ALLOCATED FOR STRINGS
        ACALL   LDPTRI
        CALL    DUBSUB          ;R3:R1 = MEMTOP - STRING ALLOCATION
        MOV     DPTR,#VARTOP    ;SAVE R3:R1 IN VARTOP
        ;
        ; FALL THRU TO S31DP2
        ;
        ;***************************************************************
        ;
        ;S31DP - STORE R3 INTO (DPTR) AND R1 INTO (DPTR+1)
        ;
        ;ACC GETS CLOBBERED
        ;
        ;***************************************************************
        ;
S31DP2: ACALL   S31DP           ;DO IT TWICE
        ;
S31DP:  MOV     A,R3            ;GET R3 INTO ACC
        MOVX    @DPTR,A         ;STORE IT
        INC     DPTR            ;BUMP DPTR
        MOV     A,R1            ;GET R1
        MOVX    @DPTR,A         ;STORE IT
        INC     DPTR            ;BUMP IT AGAIN TO SAVE PROGRAM SPACE
        RET                     ;GO BACK
        ;
        ;
        ;***************************************************************
        ;
STRING: ; Allocate memory for strings
        ;
        ;***************************************************************
        ;
        LCALL   TWO             ;R3:R1 = NUMBER, R2:R0 = LEN
        MOV     DPTR,#STR_AL    ;SAVE STRING ALLOCATION
        ACALL   S31DP
        INC     R6              ;BUMP
        MOV     S_LEN,R6        ;SAVE STRING LENGTH
        AJMP    RCLEAR          ;CLEAR AND SET IT UP
        ;
$EJECT
        ;***************************************************************
        ;
        ; F_VAR - Find  the variable in symbol table
        ;         R7:R6 contain the variable name
        ;         If not found create a zero entry and set the carry
        ;         R2:R0 has the address of variable on return
        ;
        ;***************************************************************
        ;
F_VAR:  MOV     DPTR,#VARTOP    ;PUT VARTOP IN DPTR
        ACALL   LDPTRI
        ACALL   DECDP2          ;ADJUST DPTR FOR LOOKUP
        ;
F_VAR0: MOVX    A,@DPTR         ;LOAD THE VARIABLE
        JZ      F_VAR2          ;TEST IF AT THE END OF THE TABLE
        INC     DPTR            ;BUMP FOR NEXT BYTE
        CJNE    A,R7B0,F_VAR1   ;SEE IF MATCH
        MOVX    A,@DPTR         ;LOAD THE NAME
        CJNE    A,R6B0,F_VAR1
        ;
        ; Found the variable now adjust and put in R2:R0
        ;
DLD:    MOV     A,DPL           ;R2:R0 = DPTR-2
        SUBB    A,#2
        MOV     R0,A
        MOV     A,DPH
        SUBB    A,#0            ;CARRY IS CLEARED
        MOV     R2,A
        RET
        ;
F_VAR1: MOV     A,DPL           ;SUBTRACT THE STACK SIZE+ADJUST
        CLR     C
        SUBB    A,#STESIZ
        MOV     DPL,A           ;RESTORE DPL
        JNC     F_VAR0
        DEC     DPH
        SJMP    F_VAR0          ;CONTINUE COMPARE
        ;
$EJECT
        ;
        ; Add the entry to the symbol table
        ;
F_VAR2: LCALL   R76S            ;SAVE R7 AND R6
        CLR     C
        ACALL   DLD             ;BUMP THE POINTER TO GET ENTRY ADDRESS
        ;
        ; Adjust pointer and save storage allocation
        ; and make sure we aren't wiping anything out
        ; First calculate new storage allocation
        ;
        MOV     A,R0
        SUBB    A,#STESIZ-3     ;NEED THIS MUCH RAM
        MOV     R1,A
        MOV     A,R2
        SUBB    A,#0
        MOV     R3,A
        ;
        ; Now save the new storage allocation
        ;
        MOV     DPTR,#ST_ALL
        CALL    S31DP           ;SAVE STORAGE ALLOCATION
        ;
        ; Now make sure we didn't blow it, by wiping out MT_ALL
        ;
        ACALL   DCMPX           ;COMPARE STORAGE ALLOCATION
        JC      CCLR3           ;ERROR IF CARRY
        SETB    C               ;DID NOT FIND ENTRY
        RET                     ;EXIT IF TEST IS OK
        ;
$EJECT
        ;***************************************************************
        ;
        ; Command action routine - NEW
        ;
        ;***************************************************************
        ;
CNEW:   MOV     DPTR,#PSTART    ;SAVE THE START OF PROGRAM
        MOV     A,#EOF          ;END OF FILE
        MOVX    @DPTR,A         ;PUT IT IN MEMORY
        ;
        ; falls thru
        ;
        ;*****************************************************************
        ;
        ; The statement action routine - CLEAR
        ;
        ;*****************************************************************
        ;
CNEW1:  CLR     LINEB           ;SET UP FOR RUN AND GOTO
        ;
RCLEAR: ACALL   LCLR            ;CLEAR THE INTERRUPTS, SET UP MATRICES
        MOV     DPTR,#MEMTOP    ;PUT MEMTOP IN R3:R1
        ACALL   L31DPI
        ACALL   G4              ;DPTR GETS END ADDRESS
        ACALL   CL_1            ;CLEAR THE MEMORY
        ;
RC1:    MOV     DPTR,#STACKTP   ;POINT AT CONTROL STACK TOP
        CLR     A               ;CONTROL UNDERFLOW
        ;
RC2:    MOVX    @DPTR,A         ;SAVE IN MEMORY
        MOV     CSTKA,#STACKTP
        MOV     ASTKA,#STACKTP
        CLR     CONB            ;CAN'T CONTINUE
        RET
        ;
$EJECT
        ;***************************************************************
        ;
        ; Loop until the memory is cleared
        ;
        ;***************************************************************
        ;
CL_1:   INC     DPTR            ;BUMP MEMORY POINTER
        CLR     A               ;CLEAR THE MEMORY
        MOVX    @DPTR,A         ;CLEAR THE RAM
        MOVX    A,@DPTR         ;READ IT
        JNZ     CCLR3           ;MAKE SURE IT IS CLEARED
        MOV     A,R3            ;GET POINTER FOR COMPARE
        CJNE    A,DPH,CL_1      ;SEE TO LOOP
        MOV     A,R1            ;NOW TEST LOW BYTE
        CJNE    A,DPL,CL_1
        ;
CL_2:   RET
        ;
CCLR3:  JMP     TB              ;ALLOCATED MEMORY DOESN'T EXSIST
        ;
        ;**************************************************************
        ;
SCLR:   ;Entry point for clear return
        ;
        ;**************************************************************
        ;
        CALL    DELTST          ;TEST FOR A CR
        JNC     RCLEAR
        CALL    GCI1            ;BUMP THE TEST POINTER
        CJNE    A,#'I',RC1      ;SEE IF I, ELSE RESET THE STACK
        ;
        ;**************************************************************
        ;
ICLR:   ; Clear interrupts and system garbage
        ;
        ;**************************************************************
        ;
        JNB     INTBIT,ICLR1    ;SEE IF BASIC HAS INTERRUPTS
        CLR     EX1             ;IF SO, CLEAR INTERRUPTS
ICLR1:  ANL     34,#00100000B   ;SET INTERRUPTS + CONTINUE
        RETI
        ;
$EJECT
        ;***************************************************************
        ;
        ;OUTPUT ROUTINES
        ;
        ;***************************************************************
        ;
CRLF2:  ACALL   CRLF            ;DO TWO CRLF'S
        ;
CRLF:   MOV     R5,#CR          ;LOAD THE CR
        ACALL   TEROT           ;CALL TERMINAL OUT
        MOV     R5,#LF          ;LOAD THE LF
        AJMP    TEROT           ;OUTPUT IT AND RETURN
        ;
        ;PRINT THE MESSAGE ADDRESSED IN ROM OR RAM BY THE DPTR
        ;ENDS WITH THE CHARACTER IN R4
        ;DPTR HAS THE ADDRESS OF THE TERMINATOR
        ;
CRP:    ACALL   CRLF            ;DO A CR THEN PRINT ROM
        ;
ROM_P:  CLR     A               ;CLEAR A FOR LOOKUP
        MOVC    A,@A+DPTR       ;GET THE CHARACTER
        CLR     ACC.7           ;CLEAR MS BIT
        CJNE    A,#'"',ROM_P1   ;EXIT IF TERMINATOR
        RET
ROM_P1: SETB    C0ORX1
        ;
PN1:    MOV     R5,A            ;OUTPUT THE CHARACTER
        ACALL   TEROT
        INC     DPTR            ;BUMP THE POINTER
        SJMP    PN0
        ;
UPRNT:  ACALL   X31DP
        ;
PRNTCR: MOV     R4,#CR          ;OUTPUT UNTIL A CR
        ;
PN0:    JBC     C0ORX1,ROM_P
        MOVX    A,@DPTR         ;GET THE RAM BYTE
        JZ      PN01
        CJNE    A,R4B0,PN02     ;SEE IF THE SAME AS TERMINATOR
PN01:   RET                     ;EXIT IF THE SAME
PN02:   CJNE    A,#CR,PN1       ;NEVER PRINT A CR IN THIS ROUTINE
        LJMP    E1XX            ;BAD SYNTAX
        ;
$EJECT
        ;***************************************************************
        ;
        ; INLINE - Input a line to IBUF, exit when a CR is received
        ;
        ;***************************************************************
        ;
INL2:   CJNE    A,#CNTRLD,INL2B ;SEE IF A CONTROL D
        ;
INL0:   ACALL   CRLF            ;DO A CR
        ;
INLINE: MOV     P2,#HIGH IBUF   ;IBUF IS IN THE ZERO PAGE
        MOV     R0,#LOW IBUF    ;POINT AT THE INPUT BUFFER
        ;
INL1:   ACALL   INCHAR          ;GET A CHARACTER
        MOV     R5,A            ;SAVE IN R5 FOR OUTPUT
        CJNE    A,#7FH,INL2     ;SEE IF A DELETE CHARACTER
        CJNE    R0,#LOW IBUF,INL6
INL11:  MOV     R5,#BELL        ;OUTPUT A BELL
        ;
INLX:   ACALL   TEROT           ;OUTPUT CHARACTER
        SJMP    INL1            ;DO IT AGAIN
        ;
INL2B:  MOVX    @R0,A           ;SAVE THE CHARACTER
        CJNE    A,#CR,INL2B1    ;IS IT A CR
        AJMP    CRLF            ;OUTPUT A CRLF AND EXIT
INL2B1: CJNE    A,#20H,INL2B2
INL2B2: JC      INLX            ;ONLY ECHO CONTROL CHARACTERS
        INC     R0              ;BUMP THE POINTER
        CJNE    R0,#IBUF+79,INLX
        DEC     R0              ;FORCE 79
        SJMP    INL11           ;OUTPUT A BELL
        ;
INL6:   DEC     R0              ;DEC THE RAM POINTER
        MOV     R5,#BS          ;OUTPUT A BACK SPACE
        ACALL   TEROT
        ACALL   STEROT          ;OUTPUT A SPACE
        MOV     R5,#BS          ;ANOTHER BACK SPACE
        SJMP    INLX            ;OUTPUT IT
        ;
PTIME:  DB      128-2           ; PROM PROGRAMMER TIMER
        DB      00H
        DB      00H
        DB      50H
        DB      67H
        DB      41H
        ;
$EJECT
;$INCLUDE(:F2:BAS52.OUT)
;BEGINNING
        ;***************************************************************
        ;
        ; TEROT - Output a character to the system console
        ;         update PHEAD position.
        ;
        ;***************************************************************
        ;
STEROT: MOV     R5,#' '         ;OUTPUT A SPACE
        ;
TEROT:  PUSH    ACC             ;SAVE THE ACCUMULATOR
        PUSH    DPH             ;SAVE THE DPTR
        PUSH    DPL
TEROT01:JNB     CNT_S,TEROT02   ;WAIT FOR A CONTROL Q
        ACALL   BCK             ;GET SERIAL STATUS
        SJMP    TEROT01
TEROT02:MOV     A,R5            ;PUT OUTPUT BYTE IN A
        JNB     BO,TEROT03      ;CHECK FOR MONITOR
        LCALL   2040H           ;DO THE MONITOR
        AJMP    TEROT1          ;CLEAN UP
TEROT03:JNB     COUB,TEROT04    ;SEE IF USER WANTS OUTPUT
        LCALL   4030H
        AJMP    TEROT1
TEROT04:JNB     UPB,T_1         ;NO AT IF NO XBIT
        JNB     LPB,T_1         ;AT PRINT
        LCALL   403CH           ;CALL AT LOCATION
        AJMP    TEROT1          ;FINISH OFF OUTPUT
        ;
T_1:    JNB     COB,TXX         ;SEE IF LIST SET
        MOV     DPTR,#SPV       ;LOAD BAUD RATE
        ACALL   LD_T
        CLR     LP              ;OUTPUT START BIT
        ACALL   TIMER_LOAD      ;LOAD AND START THE TIMER
        MOV     A,R5            ;GET THE OUTPUT BYTE
        SETB    C               ;SET CARRY FOR LAST OUTPUT
        MOV     R5,#9           ;LOAD TIMER COUNTDOWN
        ;
LTOUT1: RRC     A               ;ROTATE A
        JNB     TF1,$           ;WAIT TILL TIMER READY
        MOV     LP,C            ;OUTPUT THE BIT
        ACALL   TIMER_LOAD      ;DO THE NEXT BIT
        DJNZ    R5,LTOUT1       ;LOOP UNTIL DONE
        JNB     TF1,$           ;FIRST STOP BIT
        ACALL   TIMER_LOAD
        JNB     TF1,$           ;SECOND STOP BIT
        MOV     R5,A            ;RESTORE R5
        SJMP    TEROT1          ;BACK TO TEROT
        ;
$EJECT
TXX:    JNB     TI,$            ;WAIT FOR TRANSMIT READY
        CLR     TI
        MOV     SBUF,R5         ;SEND OUT THE CHARACTER
        ;
TEROT1: CJNE    R5,#CR,TEROT11  ;SEE IF A CR
        MOV     PHEAD,#00H      ;IF A CR, RESET PHEAD AND
        ;
TEROT11:CJNE    R5,#LF,NLC      ;SEE IF A LF
        MOV     A,NULLCT        ;GET THE NULL COUNT
        JZ      NLC             ;NO NULLS IF ZERO
        ;
TEROT2: MOV     R5,#NULL        ;PUT THE NULL IN THE OUTPUT REGISTER
        ACALL   TEROT           ;OUTPUT THE NULL
        DEC     A               ;DECREMENT NULL COUNT
        JNZ     TEROT2          ;LOOP UNTIL DONE
        ;
NLC:    CJNE    R5,#BS,NLC1     ;DEC PHEAD IF A BACKSPACE
        DEC     PHEAD
NLC1:   CJNE    R5,#20H,NLC2    ;IS IT A PRINTABLE CHARACTER?
NLC2:   JC      NLC3            ;DON'T INCREMENT PHEAD IF NOT PRINTABLE
        INC     PHEAD           ;BUMP PRINT HEAD
NLC3:   POP     DPL             ;RESTORE DPTR
        POP     DPH
        POP     ACC             ;RESTORE ACC
        RET                     ;EXIT
        ;

;END
;$INCLUDE(:F2:BAS52.OUT)
        ;
BCK:    ACALL   CSTS            ;CHECK STATUS
        JNC     CI_RET1         ;EXIT IF NO CHARACTER
        ;
$EJECT
        ;***************************************************************
        ;
        ;INPUTS A CHARACTER FROM THE SYSTEM CONSOLE.
        ;
        ;***************************************************************
        ;
INCHAR: JNB     BI,INCHAR1      ;CHECK FOR MONITOR (BUBBLE)
        LCALL   2060H
        SJMP    INCH1
INCHAR1:JNB     CIUB,INCHAR2    ;CHECK FOR USER
        LCALL   4033H
        SJMP    INCH1
INCHAR2:JNB     RI,$            ;WAIT FOR RECEIVER READY.
        MOV     A,SBUF
        CLR     RI              ;RESET READY
        CLR     ACC.7           ;NO BIT 7
        ;
INCH1:  CJNE    A,#13H,INCH11
        SETB    CNT_S
INCH11: CJNE    A,#11H,INCH12
        CLR     CNT_S
INCH12: CJNE    A,#CNTRLC,INCH13
        JNB     NO_C,C_EX       ;TRAP NO CONTROL C
        RET
        ;
INCH13: CLR     JKBIT
        CJNE    A,#17H,CI_RET   ;CONTROL W
        SETB    JKBIT
        ;
CI_RET: SETB    C               ;CARRY SET IF A CHARACTER
CI_RET1:RET                     ;EXIT
        ;
        ;*************************************************************
        ;
        ;RROM - The Statement Action Routine RROM
        ;
        ;*************************************************************
        ;
RROM:   SETB    INBIT           ;SO NO ERRORS
        ACALL   RO1             ;FIND THE LINE NUMBER
        JBC     INBIT,CRUN
        RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
CSTS:   ;       RETURNS CARRY = 1 IF THERE IS A CHARACTER WAITING FROM
        ;       THE SYSTEM CONSOLE. IF NO CHARACTER THE READY CHARACTER
        ;       WILL BE CLEARED
        ;
        ;***************************************************************
        ;
        JNB     BI,CSTS1        ;BUBBLE STATUS
        LJMP    2068H
CSTS1:  JNB     CIUB,CSTS2      ;SEE IF EXTERNAL CONSOLE
        LJMP    4036H
CSTS2:  MOV     C,RI
        RET
        ;
C_EX0:  MOV     DPTR,#WB        ;EGO MESSAGE
        ACALL   ROM_P
        ;
C_EX:   CLR     CNT_S           ;NO OUTPUT STOP
        LCALL   SPRINT1         ;ASSURE CONSOLE
        ACALL   CRLF
        JBC     JKBIT,C_EX0
        ;
        JNB     DIRF,SSTOP0
        AJMP    C_K             ;CLEAR COB AND EXIT
        ;
T_CMP:  MOV     A,TVH           ;COMPARE TIMER TO SP_H AND SP_L
        MOV     R1,TVL
        CJNE    A,TVH,T_CMP
        XCH     A,R1
        SUBB    A,SP_L
        MOV     A,R1
        SUBB    A,SP_H
        RET
        ;
        ;*************************************************************
        ;
BR0:    ; Trap the timer interrupt
        ;
        ;*************************************************************
        ;
        CALL    T_CMP           ;COMPARE TIMER
        JC      BCHR1           ;EXIT IF TEST FAILS
        SETB    OTI             ;DOING THE TIMER INTERRUPT
        CLR     OTS             ;CLEAR TIMER BIT
        MOV     C,INPROG        ;SAVE IN PROGRESS
        MOV     ISAV,C
        MOV     DPTR,#TIV
        SJMP    BR2
        ;
$EJECT
        ;***************************************************************
        ;
        ; The command action routine - RUN
        ;
        ;***************************************************************
        ;
CRUN:   LCALL   CNEW1           ;CLEAR THE STORAGE ARRAYS
        ACALL   SRESTR1         ;GET THE STARTING ADDRESS
        ACALL   B_C
        JZ      CMNDLK          ;IF NULL GO TO COMMAND MODE
        ;
        ACALL   T_DP
        ACALL   B_TXA           ;BUMP TO STARTING LINE
        ;
CILOOP: ACALL   SP0             ;DO A CR AND A LF
CILOOP1:CLR     DIRF            ;NOT IN DIRECT MODE
        ;
        ;INTERPERTER DRIVER
        ;
ILOOP:  MOV     SP,SPSAV        ;RESTORE THE STACK EACH TIME
        JB      DIRF,ILOOP1     ;NO INTERRUPTS IF IN DIRECT MODE
        MOV     INTXAH,TXAH     ;SAVE THE TEXT POINTER
        MOV     INTXAL,TXAL
ILOOP1: LCALL   BCK             ;GET CONSOLE STATUS
        JB      DIRF,I_L        ;DIRECT MODE
        ANL     C,/GTRD         ;SEE IF CHARACTER READY
        JNC     BCHR            ;NO CHARACTER = NO CARRY
        ;
        ; DO TRAP OPERATION
        ;
        MOV     DPTR,#GTB       ;SAVE TRAP CHARACTER
        MOVX    @DPTR,A
        SETB    GTRD            ;SAYS READ A BYTE
        ;
BCHR:   JB      OTI,I_L         ;EXIT IF TIMER INTERRUPT IN PROGRESS
        JB      OTS,BR0         ;TEST TIMER VALUE IF SET
BCHR1:  JNB     INTPEN,I_L      ;SEE IF INTERRUPT PENDING
        JB      INPROG,I_L      ;DON'T DO IT AGAIN IF IN PROGRESS
        MOV     DPTR,#INTLOC    ;POINT AT INTERRUPT LOCATION
        ;
BR2:    MOV     R4,#GTYPE       ;SETUP FOR A FORCED GOSUB
        ACALL   SGS1            ;PUT TXA ON STACK
        SETB    INPROG          ;INTERRUPT IN PROGRESS
        ;
ERL4:   CALL    L20DPI
        AJMP    D_L1            ;GET THE LINE NUMBER
        ;
I_L:    ACALL   ISTAT           ;LOOP
        ACALL   CLN_UP          ;FINISH IT OFF
        JNC     ILOOP           ;LOOP ON THE DRIVER
        JNB     DIRF,CMNDLK     ;CMND1 IF IN RUN MODE
        LJMP    CMNDR           ;DON'T PRINT READY
        ;
CMNDLK: JMP     CMND1           ;DONE
$EJECT
        ;**************************************************************
        ;
        ; The Statement Action Routine - STOP
        ;
        ;**************************************************************
        ;
SSTOP:  ACALL   CLN_UP          ;FINISH OFF THIS LINE
        MOV     INTXAH,TXAH     ;SAVE TEXT POINTER FOR CONT
        MOV     INTXAL,TXAL
        ;
SSTOP0: SETB    CONB            ;CONTINUE WILL WORK
        MOV     DPTR,#STP       ;PRINT THE STOP MESSAGE
        SETB    STOPBIT         ;SET FOR ERROR ROUTINE
        JMP     ERRS            ;JUMP TO ERROR ROUTINE
        ;
$EJECT
        ;**************************************************************
        ;
        ; ITRAP - Trap special function register operators
        ;
        ;**************************************************************
        ;
ITRAP:  CJNE    A,#TMR0,ITRAP1  ;TIMER 0
        MOV     TH0,R3
        MOV     TL0,R1
        RET
        ;
ITRAP1: CJNE    A,#TMR1,ITRAP2  ;TIMER 1
        MOV     TH1,R3
        MOV     TL1,R1
        RET
        ;
ITRAP2: CJNE    A,#TMR2,ITRAP3  ;TIMER 2
        MOV     TH2,R3
        MOV     TL2,R1
;       DB      8BH             ;MOV R3 DIRECT OP CODE
;       DB      0CDH            ;T2H LOCATION
;       DB      89H             ;MOV R1 DIRECT OP CODE
;       DB      0CCH            ;T2L LOCATION
        RET
        ;
ITRAP3: CJNE    A,#TRC2,RCL1    ;RCAP2 TOKEN
RCL:    MOV     RCAPH2,R3
        MOV     RCAPL2,R1
;       DB      8BH             ;MOV R3 DIRECT OP CODE
;       DB      0CBH            ;RCAP2H LOCATION
;       DB      89H             ;MOV R1 DIRECT OP CODE
;       DB      0CAH            ;RCAP2L LOCATION
        RET
        ;
RCL1:   ACALL   R3CK            ;MAKE SURE THAT R3 IS ZERO
        CJNE    A,#TT2C,RCL2
        MOV     T2CON,R1
;       DB      89H             ;MOV R1 DIRECT OP CODE
;       DB      0C8H            ;T2CON LOCATION
        RET
        ;
RCL2:   CJNE    A,#T_IE,RCL3    ;IE TOKEN
        MOV     IE,R1
        RET
        ;
RCL3:   CJNE    A,#T_IP,RCL4    ;IP TOKEN
        MOV     IP,R1
        RET
        ;
RCL4:   CJNE    A,#TTC,RCL5     ;TCON TOKEN
        MOV     TCON,R1
        RET
        ;
RCL5:   CJNE    A,#TTM,RCL6     ;TMOD TOKEN
        MOV     TMOD,R1
        RET
        ;
RCL6:   CJNE    A,#T_P1,T_T2    ;P1 TOKEN
        MOV     P1,R1
        RET
        ;
        ;***************************************************************
        ;
        ; T_TRAP - Trap special operators
        ;
        ;***************************************************************
        ;
T_T:    MOV     TEMP5,A         ;SAVE THE TOKEN
        ACALL   GCI1            ;BUMP POINTER
        ACALL   SLET2           ;EVALUATE AFTER =
        MOV     A,TEMP5         ;GET THE TOKEN BACK
        CJNE    A,#T_XTAL,T_T01
        LJMP    AXTAL1          ;SET UP CRYSTAL
        ;
T_T01:  ACALL   IFIXL           ;R3:R1 HAS THE TOS
        MOV     A,TEMP5         ;GET THE TOKEN AGAIN
        CJNE    A,#T_MTOP,T_T1  ;SEE IF MTOP TOKEN
        MOV     DPTR,#MEMTOP
        CALL    S31DP
        JMP     RCLEAR          ;CLEAR THE MEMORY
        ;
T_T1:   CJNE    A,#T_TIME,ITRAP ;SEE IF A TIME TOKEN
        MOV     C,EA            ;SAVE INTERRUPTS
        CLR     EA              ;NO TIMER 0 INTERRUPTS DURING LOAD
        MOV     TVH,R3          ;SAVE THE TIME
        MOV     TVL,R1
        MOV     EA,C            ;RESTORE INTERRUPTS
        RET                     ;EXIT
        ;
T_T2:   CJNE    A,#T_PC,INTERX  ;PCON TOKEN
        MOV     PCON,R1
;       DB      89H             ;MOV DIRECT, R1 OP CODE
;       DB      87H             ;ADDRESS OF PCON
        RET                     ;EXIT
        ;
T_TRAP: CJNE    A,#T_ASC,T_T    ;SEE IF ASC TOKEN
        ACALL   IGC             ;EAT IT AND GET THE NEXT CHARACTER
        CJNE    A,#'$',INTERX   ;ERROR IF NOT A STRING
        ACALL   CSY             ;CALCULATE ADDRESS
        ACALL   X3120
        CALL    TWO_EY
        ACALL   SPEOP1          ;EVALUATE AFTER EQUALS
        AJMP    ISTAX1          ;SAVE THE CHARACTER
        ;
$EJECT
        ;**************************************************************
        ;
        ;INTERPERT THE STATEMENT POINTED TO BY TXAL AND TXAH
        ;
        ;**************************************************************
        ;
ISTAT:  ACALL   GC              ;GET THR FIRST CHARACTER
        JNB     XBIT,IAT        ;TRAP TO EXTERNAL RUN PACKAGE
        CJNE    A,#20H,ISTAT1
ISTAT1: JNC     IAT
        LCALL   2070H           ;LET THE USER SET UP THE DPTR
        ACALL   GCI1
        ANL     A,#0FH          ;STRIP OFF BIAS
        SJMP    ISTA1
        ;
IAT:    CJNE    A,#T_XTAL,IAT1
IAT1:   JNC     T_TRAP
        JNB     ACC.7,SLET      ;IMPLIED LET IF BIT 7 NOT SET
        CJNE    A,#T_UOP+12,ISTAX       ;DBYTE TOKEN
        ACALL   SPEOP           ;EVALUATE SPECIAL OPERATOR
        ACALL   R3CK            ;CHECK LOCATION
        MOV     @R1,A           ;SAVE IT
        RET
        ;
ISTAX:  CJNE    A,#T_UOP+13,ISTAY       ;XBYTE TOKEN
        ACALL   SPEOP
        ;
ISTAX1: MOV     P2,R3
        MOVX    @R1,A
        RET
        ;
ISTAY:  CJNE    A,#T_CR+1,ISTAY1;TRAP NEW OPERATORS
ISTAY1: JC      I_S
        CJNE    A,#0B0H,ISTAY2  ;SEE IF TOO BIG
ISTAY2: JNC     INTERX
        ADD     A,#0F9H         ;BIAS FOR LOOKUP TABLE
        SJMP    ISTA0           ;DO THE OPERATION
        ;
I_S:    CJNE    A,#T_LAST,I_S1  ;MAKE SURE AN INITIAL RESERVED WORD
I_S1:   JC      INTERX1         ;ERROR IF NOT
        ;
INTERX: LJMP    E1XX            ;SYNTAX ERROR
        ;
INTERX1:JNB     DIRF,ISTA0      ;EXECUTE ALL STATEMENTS IF IN RUN MODE
        CJNE    A,#T_DIR,INTERX2;SEE IF ON TOKEN
INTERX2:JC      ISTA0           ;OK IF DIRECT
        CJNE    A,#T_GOSB+1,INTERX3;SEE IF FOR
        SJMP    ISTA0           ;FOR IS OK
INTERX3:CJNE    A,#T_REM+1,INTERX4      ;NEXT IS OK
        SJMP    ISTA0
INTERX4:CJNE    A,#T_STOP+6,INTERX      ;SO IS REM
        ;
$EJECT
ISTA0:  ACALL   GCI1            ;ADVANCE THE TEXT POINTER
        MOV     DPTR,#STATD     ;POINT DPTR TO LOOKUP TABLE
        CJNE    A,#T_GOTO-3,ISTA01;SEE IF LET TOKEN
        SJMP    ISTAT           ;WASTE LET TOKEN
ISTA01: ANL     A,#3FH          ;STRIP OFF THE GARBAGE
        ;
ISTA1:  RL      A               ;ROTATE FOR OFFSET
        ADD     A,DPL           ;BUMP
        MOV     DPL,A           ;SAVE IT
        CLR     A
        MOVC    A,@A+DPTR       ;GET HIGH BYTE
        PUSH    ACC             ;SAVE IT
        INC     DPTR
        CLR     A
        MOVC    A,@A+DPTR       ;GET LOW BYTE
        POP     DPH
        MOV     DPL,A
        ;
AC1:    CLR     A
        JMP     @A+DPTR         ;GO DO IT
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - LET
        ;
        ;***************************************************************
        ;
SLET:   ACALL   S_C             ;CHECK FOR POSSIBLE STRING
        JC      SLET0           ;NO STRING
        CLR     LINEB           ;USED STRINGS
        ;
        CALL    X31DP           ;PUT ADDRESS IN DPTR
        MOV     R7,#T_EQU       ;WASTE =
        ACALL   EATC
        ACALL   GC              ;GET THE NEXT CHARACTER
        CJNE    A,#'"',S_3      ;CHECK FOR A "
        MOV     R7,S_LEN        ;GET THE STRING LENGTH
        ;
S_0:    ACALL   GCI1            ;BUMP PAST "
        ACALL   DELTST          ;CHECK FOR DELIMITER
        JZ      INTERX          ;EXIT IF CARRIAGE RETURN
        MOVX    @DPTR,A         ;SAVE THE CHARACTER
        CJNE    A,#'"',S_1      ;SEE IF DONE
        ;
S_E:    MOV     A,#CR           ;PUT A CR IN A
        MOVX    @DPTR,A         ;SAVE CR
        AJMP    GCI1
        ;
S_3:    PUSH    DPH
        PUSH    DPL             ;SAVE DESTINATION
        ACALL   S_C             ;CALCULATE SOURCE
        JC      INTERX          ;ERROR IF CARRY
        POP     R0B0            ;GET DESTINATION BACK
        POP     R2B0
        ;
SSOOP:  MOV     R7,S_LEN        ;SET UP COUNTER
        ;
S_4:    CALL    TBYTE           ;TRANSFER THE BYTE
        CJNE    A,#CR,S_41      ;EXIT IF A CR
        RET
S_41:   DJNZ    R7,S_5          ;BUMP COUNTER
        MOV     A,#CR           ;SAVE A CR
        MOVX    @R0,A
        AJMP    EIGP            ;PRINT EXTRA IGNORED
        ;
$EJECT
        ;
S_5:    CALL    INC3210         ;BUMP POINTERS
        SJMP    S_4             ;LOOP
        ;
S_1:    DJNZ    R7,S_11         ;SEE IF DONE
        ACALL   S_E
        ACALL   EIGP            ;PRINT EXTRA IGNORED
        AJMP    FINDCR          ;GO FIND THE END
S_11:   INC     DPTR            ;BUMP THE STORE POINTER
        SJMP    S_0             ;CONTINUE TO LOOP
        ;
E3XX:   MOV     DPTR,#E3X       ;BAD ARG ERROR
        AJMP    EK
        ;
SLET0:  ACALL   SLET1
        AJMP    POPAS           ;COPY EXPRESSION TO VARIABLE
        ;
SLET1:  ACALL   VAR_ER          ;CHECK FOR A"VARIABLE"
        ;
SLET2:  PUSH    R2B0            ;SAVE THE VARIABLE ADDRESS
        PUSH    R0B0
        MOV     R7,#T_EQU       ;GET EQUAL TOKEN
        ACALL   WE
        POP     R1B0            ;POP VARIABLE TO R3:R1
        POP     R3B0
        RET                     ;EXIT
        ;
R3CK:   CJNE    R3,#00H,E3XX    ;CHECK TO SEE IF R3 IS ZERO
        RET
        ;
SPEOP:  ACALL   GCI1            ;BUMP TXA
        ACALL   P_E             ;EVALUATE PAREN
SPEOP1: ACALL   SLET2           ;EVALUATE AFTER =
        CALL    TWOL            ;R7:R6 GETS VALUE, R3:R1 GETS LOCATION
        MOV     A,R6            ;SAVE THE VALUE
        ;
        CJNE    R7,#00H,E3XX    ;R2 MUST BE = 0
        RET
        ;
$EJECT
        ;**************************************************************
        ;
        ; ST_CAL - Calculate string Address
        ;
        ;**************************************************************
        ;
IST_CAL:;
        ;
        ACALL   I_PI            ;BUMP TEXT, THEN EVALUATE
        ACALL   R3CK            ;ERROR IF R3 <> 0
        INC     R1              ;BUMP FOR OFFSET
        MOV     A,R1            ;ERROR IF R1 = 255
        JZ      E3XX
        MOV     DPTR,#VARTOP    ;GET TOP OF VARIABLE STORAGE
        MOV     B,S_LEN         ;MULTIPLY FOR LOCATION
        ACALL   VARD            ;CALCULATE THE LOCATION
        MOV     DPTR,#MEMTOP    ;SEE IF BLEW IT
        CALL    FUL1
        MOV     DPL,S_LEN       ;GET STRING LENGTH, DPH = 00H
        DEC     DPH             ;DPH = 0
        ;
DUBSUB: CLR     C
        MOV     A,R1
        SUBB    A,DPL
        MOV     R1,A
        MOV     A,R3
        SUBB    A,DPH
        MOV     R3,A
        ORL     A,R1
        RET
        ;
        ;***************************************************************
        ;
        ;VARD - Calculate the offset base
        ;
        ;***************************************************************
        ;
VARB:   MOV     B,#FPSIZ        ;SET UP FOR OPERATION
        ;
VARD:   CALL    LDPTRI          ;LOAD DPTR
        MOV     A,R1            ;MULTIPLY BASE
        MUL     AB
        ADD     A,DPL
        MOV     R1,A
        MOV     A,B
        ADDC    A,DPH
        MOV     R3,A
        RET
        ;
$EJECT
        ;*************************************************************
        ;
CSY:    ; Calculate a biased string address and put in R3:R1
        ;
        ;*************************************************************
        ;
        ACALL   IST_CAL         ;CALCULATE IT
        PUSH    R3B0            ;SAVE IT
        PUSH    R1B0
        MOV     R7,#','         ;WASTE THE COMMA
        ACALL   EATC
        ACALL   ONE             ;GET THE NEXT EXPRESSION
        MOV     A,R1            ;CHECK FOR BOUNDS
        CJNE    A,S_LEN,CSY1
CSY1:   JNC     E3XX            ;MUST HAVE A CARRY
        DEC     R1              ;BIAS THE POINTER
        POP     ACC             ;GET VALUE LOW
        ADD     A,R1            ;ADD IT TO BASE
        MOV     R1,A            ;SAVE IT
        POP     R3B0            ;GET HIGH ADDRESS
        JNC     CSY2            ;PROPAGATE THE CARRY
        INC     R3
CSY2:   AJMP    ERPAR           ;WASTE THE RIGHT PAREN
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine FOR
        ;
        ;***************************************************************
        ;
SFOR:   ACALL   SLET1           ;SET UP CONTROL VARIABLE
        PUSH    R3B0            ;SAVE THE CONTROL VARIABLE LOCATION
        PUSH    R1B0
        ACALL   POPAS           ;POP ARG STACK AND COPY CONTROL VAR
        MOV     R7,#T_TO        ;GET TO TOKEN
        ACALL   WE
        ACALL   GC              ;GET NEXT CHARACTER
        CJNE    A,#T_STEP,SF2
        ACALL   GCI1            ;EAT THE TOKEN
        ACALL   EXPRB           ;EVALUATE EXPRESSION
        SJMP    SF21            ;JUMP OVER
        ;
SF2:    LCALL   PUSH_ONE        ;PUT ONE ON THE STACK
        ;
SF21:   MOV     A,#-FSIZE       ;ALLOCATE FSIZE BYTES ON THE CONTROL STACK
        ACALL   PUSHCS          ;GET CS IN R0
        ACALL   CSC             ;CHECK CONTROL STACK
        MOV     R3,#CSTKAH      ;IN CONTROL STACK
        MOV     R1,R0B0         ;STACK ADDRESS
        ACALL   POPAS           ;PUT STEP ON STACK
        ACALL   POPAS           ;PUT LIMIT ON STACK
        ACALL   DP_T            ;DPTR GETS TEXT
        MOV     R0,R1B0         ;GET THE POINTER
        ACALL   T_X_S           ;SAVE THE TEXT
        POP     TXAL            ;GET CONTROL VARIABLE
        POP     TXAH
        MOV     R4,#FTYPE       ;AND THE TYPE
        ACALL   T_X_S           ;SAVE IT
        ;
SF3:    ACALL   T_DP            ;GET THE TEXT POINTER
        AJMP    ILOOP           ;CONTINUE TO PROCESS
        ;
$EJECT
        ;**************************************************************
        ;
        ; The statement action routines - PUSH and POP
        ;
        ;**************************************************************
        ;
SPUSH:  ACALL   EXPRB           ;PUT EXPRESSION ON STACK
        ACALL   C_TST           ;SEE IF MORE TO DO
        JNC     SPUSH           ;IF A COMMA PUSH ANOTHER
        RET
        ;
        ;
SPOP:   ACALL   VAR_ER          ;GET VARIABLE
        ACALL   XPOP            ;FLIP THE REGISTERS FOR POPAS
        ACALL   C_TST           ;SEE IF MORE TO DO
        JNC     SPOP
        ;
SPOP1:  RET
        ;
        ;***************************************************************
        ;
        ; The statement action routine - IF
        ;
        ;***************************************************************
        ;
SIF:    ACALL   RTST            ;EVALUATE THE EXPRESSION
        MOV     R1,A            ;SAVE THE RESULT
        ACALL   GC              ;GET THE CHARACTER AFTER EXPR
        CJNE    A,#T_THEN,SIF1  ;SEE IF THEN TOKEN
        ACALL   GCI1            ;WASTE THEN TOKEN
SIF1:   CJNE    R1,#0,T_F1      ;CHECK R_OP RESULT
        ;
E_FIND: MOV     R7,#T_ELSE      ;FIND ELSE TOKEN
        ACALL   FINDC
        JZ      SPOP1           ;EXIT IF A CR
        ACALL   GCI1            ;BUMP PAST TOKEN
        CJNE    A,#T_ELSE,E_FIND;WASTE IF NO ELSE
        ;
T_F1:   ACALL   INTGER          ;SEE IF NUMBER
        JNC     D_L1            ;EXECUTE LINE NUMBER
        AJMP    ISTAT           ;EXECUTE STATEMENT IN NOT
        ;
B_C:    MOVX    A,@DPTR
        DEC     A
        JB      ACC.7,FL11
        RET
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - GOTO
        ;
        ;***************************************************************
        ;
SGOTO:  ACALL   RLINE           ;R2:R0 AND DPTR GET INTGER
        ;
SGT1:   ACALL   T_DP            ;TEXT POINTER GETS DPTR
        ;
        JBC     RETBIT,SGT2     ;SEE IF RETI EXECUTED
        ;
        JNB     LINEB,SGT11     ;SEE IF A LINE WAS EDITED
        LCALL   CNEW1           ;CLEAR THE MEMORY IF SET
SGT11:  AJMP    CILOOP1         ;CLEAR DIRF AND LOOP
        ;
SGT2:   JBC     OTI,SGT21       ;SEE IF TIMER INTERRUPT
        ANL     34,#10111101B   ;CLEAR INTERRUPTS
        AJMP    ILOOP           ;EXECUTE
SGT21:  MOV     C,ISAV
        MOV     INPROG,C
        AJMP    ILOOP           ;RESTORE INTERRUPTS AND RET
        ;
        ;
        ;*************************************************************
        ;
RTST:   ; Test for ZERO
        ;
        ;*************************************************************
        ;
        ACALL   EXPRB           ;EVALUATE EXPRESSION
        CALL    INC_ASTKA       ;BUMP ARG STACK
        JZ      RTST1           ;EXIT WITH ZERO OR 0FFH
        MOV     A,#0FFH
RTST1:  RET
        ;
$EJECT
        ;
        ;**************************************************************
        ;
        ; GLN - get the line number in R2:R0, return in DPTR
        ;
        ;**************************************************************
        ;
GLN:    ACALL   DP_B            ;GET THE BEGINNING ADDRESS
        ;
FL1:    MOVX    A,@DPTR         ;GET THE LENGTH
        MOV     R7,A            ;SAVE THE LENGTH
        DJNZ    R7,FL3          ;SEE IF END OF FILE
        ;
FL11:   MOV     DPTR,#E10X      ;NO LINE NUMBER
        AJMP    EK              ;HANDLE THE ERROR
        ;
FL3:    JB      ACC.7,FL11      ;CHECK FOR BIT 7
        INC     DPTR            ;POINT AT HIGH BYTE
        MOVX    A,@DPTR         ;GET HIGH BYTE
        CJNE    A,R2B0,FL2      ;SEE IF MATCH
        INC     DPTR            ;BUMP TO LOW BYTE
        DEC     R7              ;ADJUST AGAIN
        MOVX    A,@DPTR         ;GET THE LOW BYTE
        CJNE    A,R0B0,FL2      ;SEE IF LOW BYTE MATCH
        INC     DPTR            ;POINT AT FIRST CHARACTER
        RET                     ;FOUND IT
        ;
FL2:    MOV     A,R7            ;GET THE LENGTH COUNTER
        CALL    ADDPTR          ;ADD A TO DATA POINTER
        SJMP    FL1             ;LOOP
        ;
        ;
        ;*************************************************************
        ;
        ;RLINE - Read in ASCII string, get line, and clean it up
        ;
        ;*************************************************************
        ;
RLINE:  ACALL   INTERR          ;GET THE INTEGER
        ;
RL1:    ACALL   GLN
        AJMP    CLN_UP
        ;
        ;
D_L1:   ACALL   GLN             ;GET THE LINE
        AJMP    SGT1            ;EXECUTE THE LINE
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routines WHILE and UNTIL
        ;
        ;***************************************************************
        ;
SWHILE: ACALL   RTST            ;EVALUATE RELATIONAL EXPRESSION
        CPL     A
        SJMP    S_WU
        ;
SUNTIL: ACALL   RTST            ;EVALUATE RELATIONAL EXPRESSION
        ;
S_WU:   MOV     R4,#DTYPE       ;DO EXPECTED
        MOV     R5,A            ;SAVE R_OP RESULT
        SJMP    SR0             ;GO PROCESS
        ;
        ;
        ;***************************************************************
        ;
CNULL:  ; The Command Action Routine - NULL
        ;
        ;***************************************************************
        ;
        ACALL   INTERR          ;GET AN INTEGER FOLLOWING NULL
        MOV     NULLCT,R0       ;SAVE THE NULLCOUNT
        AJMP    CMNDLK          ;JUMP TO COMMAND MODE
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - RETI
        ;
        ;***************************************************************
        ;
SRETI:  SETB    RETBIT          ;SAYS THAT RETI HAS BEEN EXECUTED
        ;
        ;***************************************************************
        ;
        ; The statement action routine - RETURN
        ;
        ;***************************************************************
        ;
SRETRN: MOV     R4,#GTYPE       ;MAKE SURE OF GOSUB
        MOV     R5,#55H         ;TYPE RETURN TYPE
        ;
SR0:    ACALL   CSETUP          ;SET UP CONTROL STACK
        MOVX    A,@R0           ;GET RETURN TEXT ADDRESS
        MOV     DPH,A
        INC     R0
        MOVX    A,@R0
        MOV     DPL,A
        INC     R0              ;POP CONTROL STACK
        MOVX    A,@DPTR         ;SEE IF GOSUB WAS THE LAST STATEMENT
        CJNE    A,#EOF,SR01
        AJMP    CMNDLK
SR01:   MOV     A,R5            ;GET TYPE
        JZ      SGT1            ;EXIT IF ZERO
        MOV     CSTKA,R0        ;POP THE STACK
        CPL     A               ;OPTION TEST, 00H, 55H, 0FFH, NOW 55H
        JNZ     SGT1            ;MUST BE GOSUB
        RET                     ;NORMAL FALL THRU EXIT FOR NO MATCH
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - GOSUB
        ;
        ;***************************************************************
        ;
SGOSUB: ACALL   RLINE           ;NEW TXA IN DPTR
        ;
SGS0:   MOV     R4,#GTYPE
        ACALL   SGS1            ;SET EVERYTHING UP
        AJMP    SF3             ;EXIT
        ;
SGS1:   MOV     A,#-3           ;ALLOCATE 3 BYTES ON CONTROL STACK
        ACALL   PUSHCS
        ;
T_X_S:  MOV     P2,#CSTKAH      ;SET UP PORT FOR CONTROL STACK
        MOV     A,TXAL          ;GET RETURN ADDRESS AND SAVE IT
        MOVX    @R0,A
        DEC     R0
        MOV     A,TXAH
        MOVX    @R0,A
        DEC     R0
        MOV     A,R4            ;GET TYPE
        MOVX    @R0,A           ;SAVE TYPE
        RET                     ;EXIT
        ;
        ;
CS1:    MOV     A,#3            ;POP 3 BYTES
        ACALL   PUSHCS
        ;
CSETUP: MOV     R0,CSTKA        ;GET CONTROL STACK
        MOV     P2,#CSTKAH
        MOVX    A,@R0           ;GET BYTE
        CJNE    A,R4B0,CSETUP1  ;SEE IF TYPE MATCH
        INC     R0
        RET
CSETUP1:JZ      E4XX            ;EXIT IF STACK UNDERFLOW
        CJNE    A,#FTYPE,CS1    ;SEE IF FOR TYPE
        ACALL   XXI3            ;WASTE THE FOR TYPE
        SJMP    CSETUP          ;LOOP
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - NEXT
        ;
        ;***************************************************************
        ;
SNEXT:  MOV     R4,#FTYPE       ;FOR TYPE
        ACALL   CSETUP          ;SETUP CONTROL STACK
        MOV     TEMP5,R0        ;SAVE CONTROL VARIABLE ADDRESS
        MOV     R1,#TEMP1       ;SAVE VAR + RETURN IN TEMP1-4
        ;
XXI:    MOVX    A,@R0           ;LOOP UNTIL DONE
        MOV     @R1,A
        INC     R1
        INC     R0
        CJNE    R1,#TEMP5,XXI
        ;
        ACALL   VAR             ;SEE IF THE USER HAS A VARIABLE
        JNC     XXI1
        MOV     R2,TEMP1
        MOV     R0,TEMP2
XXI1:   MOV     A,R2            ;SEE IF VAR'S AGREE
        CJNE    A,TEMP1,E4XX
        MOV     A,R0
        CJNE    A,TEMP2,E4XX
        ACALL   PUSHAS          ;PUT CONTROL VARIABLE ON STACK
        MOV     A,#FPSIZ+FPSIZ+2;COMPUTE ADDRESS TO STEP VALUE SIGN
        ADD     A,TEMP5         ;ADD IT TO BASE OF STACK
        MOV     R0,A            ;SAVE IN R0
        MOV     R2,#CSTKAH      ;SET UP TO PUSH STEP VALUE
        MOV     P2,R2           ;SET UP PORT
        MOVX    A,@R0           ;GET SIGN
        INC     R0              ;BACK TO EXPONENT
        PUSH    ACC             ;SAVE SIGN OF STEP
        ACALL   PUSHAS          ;PUT STEP VALUE ON STACK
        PUSH    R0B0            ;SAVE LIMIT VALUE LOCATION
        CALL    AADD            ;ADD STEP VALUE TO VARIABLE
        CALL    CSTAKA          ;COPY STACK
        MOV     R3,TEMP1        ;GET CONTROL VARIABLE
        MOV     R1,TEMP2
        ACALL   POPAS           ;SAVE THE RESULT
        MOV     R2,#CSTKAH      ;RESTORE LIMIT LOCATION
        POP     R0B0
        ACALL   PUSHAS          ;PUT LIMIT ON STACK
        CALL    FP_BASE2        ;DO THE COMPARE
        POP     ACC             ;GET LIMIT SIGN BACK
        JZ      XXI2            ;IF SIGN NEGATIVE, TEST "BACKWARDS"
        CPL     C
XXI2:   ORL     C,F0            ;SEE IF EQUAL
        JC      N4              ;STILL SMALLER THAN LIMIT?
XXI3:   MOV     A,#FSIZE        ;REMOVE CONTROL STACK ENTRY
        ;
        ; Fall thru to PUSHCS
        ;
$EJECT
        ;***************************************************************
        ;
        ; PUSHCS - push frame onto control stack
        ;          acc has - number of bytes, also test for overflow
        ;
        ;***************************************************************
        ;
PUSHCS: ADD     A,CSTKA         ;BUMP CONTROL STACK
        CJNE    A,#CONVT+17,PUSHCS1 ;SEE IF OVERFLOWED
PUSHCS1:JC      E4XX            ;EXIT IF STACK OVERFLOW
        XCH     A,CSTKA         ;STORE NEW CONTROL STACK VALUE, GET OLD
        DEC     A               ;BUMP OLD VALUE
        MOV     R0,A            ;PUT OLD-1 IN R0
        ;
PUSHCS2:RET                     ;EXIT
        ;
CSC:    ACALL   CLN_UP          ;FINISH OFF THE LINE
        JNC     PUSHCS2         ;EXIT IF NO TERMINATOR
        ;
E4XX:   MOV     DPTR,#EXC       ;CONTROL STACK ERROR
        AJMP    EK              ;STACK ERROR
        ;
N4:     MOV     TXAH,TEMP3      ;GET TEXT POINTER
        MOV     TXAL,TEMP4
        AJMP    ILOOP           ;EXIT
        ;
        ;***************************************************************
        ;
        ; The statement action routine - RESTORE
        ;
        ;***************************************************************
        ;
SRESTR: ACALL   X_TR            ;SWAP POINTERS
SRESTR1:ACALL   DP_B            ;GET THE STARTING ADDRESS
        ACALL   T_DP            ;PUT STARTING ADDRESS IN TEXT POINTER
        ACALL   B_TXA           ;BUMP TXA
        ;
        ; Fall thru
        ;
X_TR:   ;swap txa and rtxa
        ;
        XCH     A,TXAH
        XCH     A,RTXAH
        XCH     A,TXAH
        XCH     A,TXAL
        XCH     A,RTXAL
        XCH     A,TXAL
        RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - READ
        ;
        ;***************************************************************
        ;
SREAD:  ACALL   X_TR            ;SWAP POINTERS
        ;
SRD0:   ACALL   C_TST           ;CHECK FOR COMMA
        JC      SRD4            ;SEE WHAT IT IS
        ;
SRD:    ACALL   EXPRB           ;EVALUATE THE EXPRESSION
        ACALL   GC              ;GET THE CHARACTER AFTER EXPRESSION
        CJNE    A,#',',SRD1     ;SEE IF MORE DATA
        SJMP    SRD2            ;BYBASS CLEAN UP IF A COMMA
        ;
SRD1:   ACALL   CLN_UP          ;FINISH OFF THE LINE, IF AT END
        ;
SRD2:   ACALL   X_TR            ;RESTORE POINTERS
        ACALL   VAR_ER          ;GET VARIABLE ADDRESS
        ACALL   XPOP            ;FLIP THE REGISTERS FOR POPAS
        ACALL   C_TST           ;SEE IF A COMMA
        JNC     SREAD           ;READ AGAIN IF A COMMA
SRD21:  RET                     ;EXIT IF NOT
        ;
SRD4:   CJNE    A,#T_DATA,SRD5  ;SEE IF DATA
        ACALL   GCI1            ;BUMP POINTER
        SJMP    SRD
        ;
SRD5:   CJNE    A,#EOF,SRD6     ;SEE IF YOU BLEW IT
SRD51:  ACALL   X_TR            ;GET THE TEXT POINTER BACK
        MOV     DPTR,#E14X      ;READ ERROR
        ;
EK:     LJMP    ERROR
        ;
SRD6:   ACALL   FINDCR          ;WASTE THIS LINE
        ACALL   CLN_UP          ;CLEAN IT UP
        JC      SRD51           ;ERROR IF AT END
        SJMP    SRD0
        ;
NUMC:   ACALL   GC              ;GET A CHARACTER
        CJNE    A,#'#',NUMC1    ;SEE IF A #
        SETB    COB             ;VALID LINE PRINT
        AJMP    IGC             ;BUMP THE TEXT POINTER
        ;
NUMC1:  CJNE    A,#'@',SRD21    ;EXIT IF NO GOOD
        SETB    LPB
        AJMP    IGC
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - PRINT
        ;
        ;***************************************************************
        ;
SPH0:   SETB    ZSURP           ;NO ZEROS
        ;
SPH1:   SETB    HMODE           ;HEX MODE
        ;
SPRINT: ACALL   NUMC            ;TEST FOR A LINE PRINT
        ACALL   SPRINT2         ;PROCEED
SPRINT1:ANL     35,#11110101B   ;CLEAR COB AND LPB
        ANL     38,#00111111B   ;NO HEX MODE
        ;
        RET
        ;
SPRINT2:ACALL   DELTST          ;CHECK FOR A DELIMITER
        JC      SP1
        ;
SP0:    JMP     CRLF            ;EXIT WITH A CR IF SO
        ;
SP2:    ACALL   C_TST           ;CHECK FOR A COMMA
        JC      SP0             ;EXIT IF NO COMMA
        ;
SP1:    ACALL   CPS             ;SEE IF A STRING TO PRINT
        JNC     SP2             ;IF A STRING, CHECK FOR A COMMA
        ;
SP4:    CJNE    A,#T_TAB,SP6
        ACALL   I_PI            ;ALWAYS CLEARS CARRY
        SUBB    A,PHEAD         ;TAKE DELTA BETWEEN TAB AND PHEAD
        JC      SP2             ;EXIT IF PHEAD > TAB
        SJMP    SP7             ;OUTPUT SPACES
        ;
SP6:    CJNE    A,#T_SPC,SM
        ACALL   I_PI            ;SET UP PAREN VALUE
        ;
SP7:    JZ      SP2
        LCALL   STEROT          ;OUTPUT A SPACE
        DEC     A               ;DECREMENT COUNTER
        SJMP    SP7             ;LOOP
        ;
$EJECT
SM:     CJNE    A,#T_CHR,SP8
        ACALL   IGC
        CJNE    A,#'$',SM01
        ACALL   CNX             ;PUT THE CHARACTER ON THE STACK
        ACALL   IFIXL           ;PUT THE CHARACTER IN R1
        SJMP    SM02
SM01:   ACALL   ONE             ;EVALUATE THE EXPRESSION, PUT IN R3:R1
        ACALL   ERPAR
SM02:   MOV     R5,R1B0         ;BYTE TO OUTPUT
        SJMP    SQ
        ;
SP8:    CJNE    A,#T_CR,SX
        ACALL   GCI1            ;EAT THE TOKEN
        MOV     R5,#CR
        ;
SQ:     CALL    TEROT
        SJMP    SP2             ;OUTPUT A CR AND DO IT AGAIN
        ;
SX:     CJNE    A,#T_USE,SP9    ;USING TOKEN
        ACALL   IGC             ;GE THE CHARACTER AFTER THE USING TOKEN
        CJNE    A,#'F',U4       ;SEE IF FLOATING
        MOV     FORMAT,#0F0H    ;SET FLOATING
        ACALL   IGC             ;BUMP THE POINTER AND GET THE CHARACTER
        ACALL   GCI1            ;BUMP IT AGAIN
        ANL     A,#0FH          ;STRIP OFF ASCII BIAS
        JZ      U3              ;EXIT IF ZERO
        CJNE    A,#3,SX1        ;SEE IF AT LEAST A THREE
SX1:    JNC     U3              ;FORCE A THREE IF NOT A THREE
        MOV     A,#3
        ;
U3:     ORL     FORMAT,A        ;PUT DIGIT IN FORMAT
        SJMP    U8              ;CLEAN UP END
        ;
U4:     CJNE    A,#'0',U5
        MOV     FORMAT,#0       ;FREE FORMAT
        ACALL   GCI1            ;BUMP THE POINTER
        SJMP    U8
        ;
U5:     CJNE    A,#'#',U8       ;SEE IF INTGER FORMAT
        ACALL   U6
        MOV     FORMAT,R7       ;SAVE THE FORMAT
        CJNE    A,#'.',U8A      ;SEE IF TERMINATOR WAS RADIX
        ACALL   IGC             ;BUMP PAST .
        ACALL   U6              ;LOOP AGAIN
        MOV     A,R7            ;GET COUNT
        ADD     A,FORMAT        ;SEE IF TOO BIG
        ADD     A,#0F7H
        JNC     U5A
        ;
$EJECT
SE0:    AJMP    INTERX          ;ERROR, BAD SYNTAX
        ;
U5A:    MOV     A,R7            ;GET THE COUNT BACK
        SWAP    A               ;ADJUST
        ORL     FORMAT,A        ;GET THE COUNT
        ;
U8A:    MOV     A,FORMAT
        ;
U8B:    SWAP    A               ;GET THE FORMAT RIGHT
        MOV     FORMAT,A
        ;
U8:     ACALL   ERPAR
        AJMP    SP2             ;DONE
        ;
U6:     MOV     R7,#0           ;SET COUNTER
        ;
U7:     CJNE    A,#'#',SP9A     ;EXIT IF NOT A #
        INC     R7              ;BUMP COUNTER
        ACALL   IGC             ;GET THE NEXT CHARACTER
        SJMP    U7              ;LOOP
        ;
SP9:    ACALL   DELTST1         ;CHECK FOR DELIMITER
        JNC     SP9A            ;EXIT IF A DELIMITER
        ;
        CJNE    A,#T_ELSE,SS
        ;
SP9A:   RET                     ;EXIT IF ELSE TOKEN
        ;
        ;**************************************************************
        ;
        ; P_E - Evaluate an expression in parens ( )
        ;
        ;**************************************************************
        ;
P_E:    MOV     R7,#T_LPAR
        ACALL   WE
        ;
ERPAR:  MOV     R7,#')'         ;EAT A RIGHT PAREN
        ;
EATC:   ACALL   GCI             ;GET THE CHARACTER
        CJNE    A,R7B0,SE0      ;ERROR IF NOT THE SAME
        RET
        ;
$EJECT
        ;***************************************************************
        ;
S_ON:   ; ON Statement
        ;
        ;***************************************************************
        ;
        ACALL   ONE             ;GET THE EXPRESSION
        ACALL   GCI             ;GET THE NEXT CHARACTER
        CJNE    A,#T_GOTO,C0
        ACALL   C1              ;EAT THE COMMAS
        AJMP    SF3             ;DO GOTO
        ;
C0:     CJNE    A,#T_GOSB,SE0
        ACALL   C1
        AJMP    SGS0            ;DO GOSUB
        ;
C1:     CJNE    R1,#0,C2
        ACALL   INTERR          ;GET THE LINE NUMBER
        ACALL   FINDCR
        AJMP    RL1             ;FINISH UP THIS LINE
        ;
C2:     MOV     R7,#','
        ACALL   FINDC
        CJNE    A,#',',SE0      ;ERROR IF NOT A COMMA
        DEC     R1
        ACALL   GCI1            ;BUMP PAST COMMA
        SJMP    C1
        ;
$EJECT
        ;
SS:     ACALL   S_C             ;SEE IF A STRING
        JC      SA              ;NO STRING IF CARRY IS SET
        LCALL   UPRNT           ;PUT POINTER IN DPTR
        AJMP    SP2             ;SEE IF MORE
        ;
SA:     ACALL   EXPRB           ;MUST BE AN EXPRESSION
        MOV     A,#72
        CJNE    A,PHEAD,SA1     ;CHECK PHEAD POSITION
SA1:    JNC     SA2
        ACALL   SP0             ;FORCE A CRLF
SA2:    JNB     HMODE,S13       ;HEX MODE?
        CALL    FCMP            ;SEE IF TOS IS < 0FFFH
        JC      S13             ;EXIT IF GREATER
        CALL    AABS            ;GET THE SIGN
        JNZ     OOPS            ;WASTE IF NEGATIVE
        ACALL   IFIXL
        CALL    FP_BASE11       ;PRINT HEXMODE
        AJMP    SP2
OOPS:   CALL    ANEG            ;MAKE IT NEGATIVE
        ;
S13:    CALL    FP_BASE7        ;DO FP OUTPUT
        MOV     A,#1            ;OUTPUT A SPACE
        AJMP    SP7
        ;
$EJECT
        ;***************************************************************
        ;
        ; ANU -  Get variable name from text - set carry if not found
        ;        if succeeds returns variable in R7:R6
        ;        R6 = 0 if no digit in name
        ;
        ;***************************************************************
        ;
ANU:    ACALL   IGC             ;INCREMENT AND GET CHARACTER
        LCALL   DIGIT_CHECK     ;CHECK FOR DIGIT
        JC      AL2             ;EXIT IF VALID DIGIT
        CJNE    A,#'_',AL       ;SEE IF A _
        RET
        ;
AL:     CJNE    A,#'A',AL1      ;IS IT AN ASCII A?
AL1:    JC      AL3             ;EXIT IF CARRY IS SET
        CJNE    A,#'Z'+1,AL2    ;IS IT LESS THAN AN ASCII Z
AL2:    CPL     C               ;FLIP CARRY
AL3:    RET
        ;
SD01:   JNB     F0,VAR2
        ;
SD0:    MOV     DPTR,#E6X
        AJMP    EK
        ;
SDIMX:  SETB    F0              ;SAYS DOING A DIMENSION
        SJMP    VAR1
        ;
VAR:    CLR     F0              ;SAYS DOING A VARIABLE
        ;
VAR1:   ACALL   GC              ;GET THE CHARACTER
        ACALL   AL              ;CHECK FOR ALPHA
        JNC     VAR11           ;ERROR IF IN DIM
        JB      F0,SD0
        RET
VAR11:  MOV     R7,A            ;SAVE ALPHA CHARACTER
        CLR     A               ;ZERO IN CASE OF FAILURE
        MOV     R5,A            ;SAVE IT
        ;
VY:     MOV     R6,A
        ACALL   ANU             ;CHECK FOR ALPHA OR NUMBER
        JC      VX              ;EXIT IF NO ALPHA OR NUM
        ;
        XCH     A,R7
        ADD     A,R5            ;NUMBER OF CHARACTERS IN ALPHABET
        XCH     A,R7            ;PUT IT BACK
        MOV     R5,#26          ;FOR THE SECOND TIME AROUND
        SJMP    VY
        ;
VX:     CLR     LINEB           ;TELL EDITOR A VARIABLE IS DECLARED
        CJNE    A,#T_LPAR,V4    ;SEE IF A LEFT PAREN
        ;
        ORL     R6B0,#80H       ;SET BIT 7 TO SIGINIFY MATRIX
        CALL    F_VAR           ;FIND THE VARIABLE
        PUSH    R2B0            ;SAVE THE LOCATION
        PUSH    R0B0
        JNC     SD01            ;DEFAULT IF NOT IN TABLE
        JB      F0,SDI          ;NO DEFAULT FOR DIMENSION
        MOV     R1,#10
        MOV     R3,#0
        ACALL   D_CHK
        ;
VAR2:   ACALL   PAREN_INT       ;EVALUATE INTEGER IN PARENS
        CJNE    R3,#0,SD0       ;ERROR IF R3<>0
        POP     DPL             ;GET VAR FOR LOOKUP
        POP     DPH
        MOVX    A,@DPTR         ;GET DIMENSION
        DEC     A               ;BUMP OFFSET
        SUBB    A,R1            ;A MUST BE > R1
        JC      SD0
        LCALL   DECDP2          ;BUMP POINTER TWICE
        ACALL   VARB            ;CALCULATE THE BASE
        ;
X3120:  XCH     A,R1            ;SWAP R2:R0, R3:R1
        XCH     A,R0
        XCH     A,R1
        XCH     A,R3
        XCH     A,R2
        XCH     A,R3
        RET
        ;
V4:     JB      F0,SD0          ;ERROR IF NO LPAR FOR DIM
        LCALL   F_VAR           ;GET SCALAR VARIABLE
        CLR     C
        RET
        ;
$EJECT
        ;
SDI:    ACALL   PAREN_INT       ;EVALUATE PAREN EXPRESSION
        CJNE    R3,#0,SD0       ;ERROR IF NOT ZERO
        POP     R0B0            ;SET UP R2:R0
        POP     R2B0
        ACALL   D_CHK           ;DO DIM
        ACALL   C_TST           ;CHECK FOR COMMA
        JNC     SDIMX           ;LOOP IF COMMA
        RET                     ;RETURN IF NO COMMA
        ;
D_CHK:  INC     R1              ;BUMP FOR TABLE LOOKUP
        MOV     A,R1
        JZ      SD0             ;ERROR IF 0FFFFH
        MOV     R4,A            ;SAVE FOR LATER
        MOV     DPTR,#MT_ALL    ;GET MATRIX ALLOCATION
        ACALL   VARB            ;DO THE CALCULATION
        MOV     R7,DPH          ;SAVE MATRIX ALLOCATION
        MOV     R6,DPL
        MOV     DPTR,#ST_ALL    ;SEE IF TOO MUCH MEMORY TAKEN
        CALL    FUL1            ;ST_ALL SHOULD BE > R3:R1
        MOV     DPTR,#MT_ALL    ;SAVE THE NEW MATRIX POINTER
        CALL    S31DP
        MOV     DPL,R0          ;GET VARIABLE ADDRESS
        MOV     DPH,R2
        MOV     A,R4            ;DIMENSION SIZE
        MOVX    @DPTR,A         ;SAVE IT
        CALL    DECDP2          ;SAVE TARGET ADDRESS
        ;
R76S:   MOV     A,R7
        MOVX    @DPTR,A
        INC     DPTR
        MOV     A,R6            ;ELEMENT SIZE
        MOVX    @DPTR,A
        RET                     ;R2:R0 STILL HAS SYMBOL TABLE ADDRESS
        ;
$EJECT
        ;***************************************************************
        ;
        ; The statement action routine - INPUT
        ;
        ;***************************************************************
        ;
SINPUT: ACALL   CPS             ;PRINT STRING IF THERE
        ;
        ACALL   C_TST           ;CHECK FOR A COMMA
        JNC     IN2A            ;NO CRLF
        ACALL   SP0             ;DO A CRLF
        ;
IN2:    MOV     R5,#'?'         ;OUTPUT A ?
        CALL    TEROT
        ;
IN2A:   SETB    INP_B           ;DOING INPUT
        CALL    INLINE          ;INPUT THE LINE
        CLR     INP_B
        MOV     TEMP5,#HIGH IBUF
        MOV     TEMP4,#LOW IBUF
        ;
IN3:    ACALL   S_C             ;SEE IF A STRING
        JC      IN3A            ;IF CARRY IS SET, NO STRING
        ACALL   X3120           ;FLIP THE ADDRESSES
        MOV     R3,TEMP5
        MOV     R1,TEMP4
        ACALL   SSOOP
        ACALL   C_TST           ;SEE IF MORE TO DO
        JNC     IN2
        RET
        ;
IN3A:   CALL    DTEMP           ;GET THE USER LOCATION
        CALL    GET_NUM         ;GET THE USER SUPPLIED NUMBER
        JNZ     IN5             ;ERROR IF NOT ZERO
        CALL    TEMPD           ;SAVE THE DATA POINTER
        ACALL   VAR_ER          ;GET THE VARIABLE
        ACALL   XPOP            ;SAVE THE VARIABLE
        CALL    DTEMP           ;GET DPTR BACK FROM VAR_ER
        ACALL   C_TST           ;SEE IF MORE TO DO
        JC      IN6             ;EXIT IF NO COMMA
        MOVX    A,@DPTR         ;GET INPUT TERMINATOR
        CJNE    A,#',',IN5      ;IF NOT A COMMA DO A CR AND TRY AGAIN
        INC     DPTR            ;BUMP PAST COMMA AND READ NEXT VALUE
        CALL    TEMPD
        SJMP    IN3
        ;
$EJECT
        ;
IN5:    MOV     DPTR,#IAN       ;PRINT INPUT A NUMBER
        CALL    CRP             ;DO A CR, THEN, PRINT FROM ROM
        LJMP    CC1             ;TRY IT AGAIN
        ;
IN6:    MOVX    A,@DPTR
        CJNE    A,#CR,EIGP
        RET
        ;
EIGP:   MOV     DPTR,#EIG
        CALL    CRP             ;PRINT THE MESSAGE AND EXIT
        AJMP    SP0             ;EXIT WITH A CRLF
        ;
        ;***************************************************************
        ;
SOT:    ; On timer interrupt
        ;
        ;***************************************************************
        ;
        ACALL   TWO             ;GET THE NUMBERS
        MOV     SP_H,R3
        MOV     SP_L,R1
        MOV     DPTR,#TIV       ;SAVE THE NUMBER
        SETB    OTS
        AJMP    R76S            ;EXIT
        ;
        ;
        ;***************************************************************
        ;
SCALL:  ; Call a user rountine
        ;
        ;***************************************************************
        ;
        ACALL   INTERR          ;CONVERT INTEGER
        CJNE    R2,#0,S_C_1     ;SEE IF TRAP
        MOV     A,R0
        JB      ACC.7,S_C_1
        ADD     A,R0
        MOV     DPTR,#4100H
        MOV     DPL,A
        ;
S_C_1:  ACALL   AC1             ;JUMP TO USER PROGRAM
        ANL     PSW,#11100111B  ;BACK TO BANK 0
        RET                     ;EXIT
        ;
$EJECT
        ;**************************************************************
        ;
THREE:  ; Save value for timer function
        ;
        ;**************************************************************
        ;
        ACALL   ONE             ;GET THE FIRST INTEGER
        CALL    CBIAS           ;BIAS FOR TIMER LOAD
        MOV     T_HH,R3
        MOV     T_LL,R1
        MOV     R7,#','         ;WASTE A COMMA
        ACALL   EATC            ;FALL THRU TO TWO
        ;
        ;**************************************************************
        ;
TWO:    ; Get two values seperated by a comma off the stack
        ;
        ;**************************************************************
        ;
        ACALL   EXPRB
        MOV     R7,#','         ;WASTE THE COMMA
        ACALL   WE
        JMP     TWOL            ;EXIT
        ;
        ;*************************************************************
        ;
ONE:    ; Evaluate an expression and get an integer
        ;
        ;*************************************************************
        ;
        ACALL   EXPRB           ;EVALUATE EXPERSSION
        ;
IFIXL:  CALL    IFIX            ;INTEGERS IN R3:R1
        MOV     A,R1
        RET
        ;
        ;
        ;*************************************************************
        ;
I_PI:   ; Increment text pointer then get an integer
        ;
        ;*************************************************************
        ;
        ACALL   GCI1            ;BUMP TEXT, THEN GET INTEGER
        ;
PAREN_INT:; Get an integer in parens ( )
        ;
        ACALL   P_E
        SJMP    IFIXL
        ;
$EJECT
        ;
DP_B:   MOV     DPH,BOFAH
        MOV     DPL,BOFAL
        RET
        ;
DP_T:   MOV     DPH,TXAH
        MOV     DPL,TXAL
        RET
        ;
CPS:    ACALL   GC              ;GET THE CHARACTER
        CJNE    A,#'"',NOPASS   ;EXIT IF NO STRING
        ACALL   DP_T            ;GET TEXT POINTER
        INC     DPTR            ;BUMP PAST "
        MOV     R4,#'"'
        CALL    PN0             ;DO THE PRINT
        INC     DPTR            ;GO PAST QUOTE
        CLR     C               ;PASSED TEST
        ;
T_DP:   MOV     TXAH,DPH        ;TEXT POINTER GETS DPTR
        MOV     TXAL,DPL
        RET
        ;
        ;*************************************************************
        ;
S_C:    ; Check for a string
        ;
        ;*************************************************************
        ;
        ACALL   GC              ;GET THE CHARACTER
        CJNE    A,#'$',NOPASS   ;SET CARRY IF NOT A STRING
        AJMP    IST_CAL         ;CLEAR CARRY, CALCULATE OFFSET
        ;
        ;
        ;
        ;**************************************************************
        ;
C_TST:  ACALL   GC              ;GET A CHARACTER
        CJNE    A,#',',NOPASS   ;SEE IF A COMMA
        ;
$EJECT
        ;***************************************************************
        ;
        ;GC AND GCI - GET A CHARACTER FROM TEXT (NO BLANKS)
        ;             PUT CHARACTER IN THE ACC
        ;
        ;***************************************************************
        ;
IGC:    ACALL   GCI1            ;BUMP POINTER, THEN GET CHARACTER
        ;
GC:     SETB    RS0             ;USE BANK 1
        MOV     P2,R2           ;SET UP PORT 2
        MOVX    A,@R0           ;GET EXTERNAL BYTE
        CLR     RS0             ;BACK TO BANK 0
        RET                     ;EXIT
        ;
GCI:    ACALL   GC
        ;
        ; This routine bumps txa by one and always clears the carry
        ;
GCI1:   SETB    RS0             ;BANK 1
        INC     R0              ;BUMP TXA
        CJNE    R0,#0,GCI11
        INC     R2
GCI11:  CLR     RS0
        RET                     ;EXIT
        ;
$EJECT
        ;**************************************************************
        ;
        ; Check delimiters
        ;
        ;**************************************************************
        ;
DELTST: ACALL   GC              ;GET A CHARACTER
DELTST1:CJNE    A,#CR,DT1       ;SEE IF A CR
        CLR     A
        RET
        ;
DT1:    CJNE    A,#':',NOPASS   ;SET CARRY IF NO MATCH
        ;
L_RET:  RET
        ;
        ;
        ;***************************************************************
        ;
        ; FINDC - Find the character in R7, update TXA
        ;
        ;***************************************************************
        ;
FINDCR: MOV     R7,#CR          ;KILL A STATEMENT LINE
        ;
FINDC:  ACALL   DELTST
        JNC     L_RET
        ;
        CJNE    A,R7B0,FNDCL2   ;MATCH?
        RET
        ;
FNDCL2: ACALL   GCI1
        SJMP    FINDC           ;LOOP
        ;
FNDCL3: ACALL   GCI1
        ;
WCR:    ACALL   DELTST          ;WASTE UNTIL A "REAL" CR
        JNZ     FNDCL3
        RET
        ;
$EJECT
        ;***************************************************************
        ;
        ; VAR_ER - Check for a variable, exit if error
        ;
        ;***************************************************************
        ;
VAR_ER: ACALL   VAR
        SJMP    INTERR1
        ;
        ;
        ;***************************************************************
        ;
        ; S_D0 - The Statement Action Routine DO
        ;
        ;***************************************************************
        ;
S_DO:   ACALL   CSC             ;FINISH UP THE LINE
        MOV     R4,#DTYPE       ;TYPE FOR STACK
        ACALL   SGS1            ;SAVE ON STACK
        AJMP    ILOOP           ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
        ; CLN_UP - Clean up the end of a statement, see if at end of
        ;          file, eat character and line count after CR
        ;
        ;***************************************************************
        ;
C_2:    CJNE    A,#':',C_1      ;SEE IF A TERMINATOR
        AJMP    GCI1            ;BUMP POINTER AND EXIT, IF SO
        ;
C_1:    CJNE    A,#T_ELSE,EP5
        ACALL   WCR             ;WASTE UNTIL A CR
        ;
CLN_UP: ACALL   GC              ;GET THE CHARACTER
        CJNE    A,#CR,C_2       ;SEE IF A CR
        ACALL   IGC             ;GET THE NEXT CHARACTER
        CJNE    A,#EOF,B_TXA    ;SEE IF TERMINATOR
        ;
NOPASS: SETB    C
        RET
        ;
B_TXA:  XCH     A,TXAL          ;BUMP TXA BY THREE
        ADD     A,#3
        XCH     A,TXAL
        JBC     CY,B_TXA1
        RET
B_TXA1: INC     TXAH
        RET
        ;
$EJECT
        ;***************************************************************
        ;
        ;         Get an INTEGER from the text
        ;         sets CARRY if not found
        ;         returns the INTGER value in DPTR and R2:R0
        ;         returns the terminator in ACC
        ;
        ;***************************************************************
        ;
INTERR: ACALL   INTGER          ;GET THE INTEGER
INTERR1:JC      EP5             ;ERROR IF NOT FOUND
        RET                     ;EXIT IF FOUND
        ;
INTGER: ACALL   DP_T
        CALL    FP_BASE9        ;CONVERT THE INTEGER
        ACALL   T_DP
        MOV     DPH,R2          ;PUT THE RETURNED VALUE IN THE DPTR
        MOV     DPL,R0
        ;
ITRET:  RET                     ;EXIT
        ;
        ;
WE:     ACALL   EATC            ;WASTE THE CHARACTER
        ;
        ; Fall thru to evaluate the expression
        ;
$EJECT
        ;***************************************************************
        ;
        ; EXPRB - Evaluate an expression
        ;
        ;***************************************************************
        ;
EXPRB:  MOV     R2,#LOW OPBOL   ;BASE PRECEDENCE
        ;
EP1:    PUSH    R2B0            ;SAVE OPERATOR PRECEDENCE
        CLR     ARGF            ;RESET STACK DESIGNATOR
        ;
EP2:    MOV     A,SP            ;GET THE STACK POINTER
        ADD     A,#12           ;NEED AT LEAST 12 BYTES
        JNC     EP21
        LJMP    E1XX2
EP21:   MOV     A,ASTKA         ;GET THE ARG STACK
        SUBB    A,#LOW TM_TOP+12;NEED 12 BYTES ALSO
        JNC     EP22
        LJMP    E4YY
EP22:   JB      ARGF,EP4        ;MUST BE AN OPERATOR, IF SET
        ACALL   VAR             ;IS THE VALUE A VARIABLE?
        JNC     EP3             ;PUT VARIABLE ON STACK
        ;
        ACALL   CONST           ;IS THE VALUE A NUMERIC CONSTANT?
        JNC     EP4             ;IF SO, CONTINUE, IF NOT, SEE WHAT
        CALL    GC              ;GET THE CHARACTER
        CJNE    A,#T_LPAR,EP4   ;SEE IF A LEFT PAREN
        MOV     A,#(LOW OPBOL+1)
        SJMP    XLPAR           ;PROCESS THE LEFT PAREN
        ;
EP3:    ACALL   PUSHAS          ;SAVE VAR ON STACK
        ;
EP4:    ACALL   GC              ;GET THE OPERATOR
        ;
        CJNE    A,#T_LPAR,EP41  ;IS IT AN OPERATOR
EP41:   JNC     XOP             ;PROCESS OPERATOR
        CJNE    A,#T_UOP,EP42   ;IS IT A UNARY OPERATOR
EP42:   JNC     XBILT           ;PROCESS UNARY (BUILT IN) OPERATOR
        POP     R2B0            ;GET BACK PREVIOUS OPERATOR PRECEDENCE
        JB      ARGF,ITRET      ;OK IF ARG FLAG IS SET
        ;
EP5:    CLR     C               ;NO RECOVERY
        LJMP    E1XX1
        ;
        ; Process the operator
        ;
XOP:    ANL     A,#1FH          ;STRIP OFF THE TOKE BITS
        JB      ARGF,XOP1       ;IF ARG FLAG IS SET, PROCESS
        CJNE    A,#T_SUB-T_LPAR,XOP3
        MOV     A,#T_NEG-T_LPAR
        ;
$EJECT
XOP1:   ADD     A,#LOW OPBOL+1  ;BIAS THE TABLE
        MOV     R2,A
        MOV     DPTR,#00H
        MOVC    A,@A+DPTR       ;GET THE CURRENT PRECEDENCE
        MOV     R4,A
        POP     ACC             ;GET THE PREVIOUS PRECEDENCE
        MOV     R5,A            ;SAVE THE PREVIOUS PRECEDENCE
        MOVC    A,@A+DPTR       ;GET IT
        CJNE    A,R4B0,XOP11    ;SEE WHICH HAS HIGHER PRECEDENCE
        CJNE    A,#12,ITRET     ;SEE IF ANEG
        SETB    C
XOP11:  JNC     ITRET           ;PROCESS NON-INCREASING PRECEDENCE
        ;
        ; Save increasing precedence
        ;
        PUSH    R5B0            ;SAVE OLD PRECEDENCE ADDRESS
        PUSH    R2B0            ;SAVE NEW PRECEDENCE ADDRESS
        ACALL   GCI1            ;EAT THE OPERATOR
        ACALL   EP1             ;EVALUATE REMAINING EXPRESSION
XOP12:  POP     ACC
        ;
        ; R2 has the action address, now setup and perform operation
        ;
XOP2:   MOV     DPTR,#OPTAB
        ADD     A,#LOW (NOT OPBOL)
        CALL    ISTA1           ;SET UP TO RETURN TO EP2
        AJMP    EP2             ;JUMP TO EVALUATE EXPRESSION
        ;
        ; Built-in operator processing
        ;
XBILT:  ACALL   GCI1            ;EAT THE TOKEN
        ADD     A,#LOW (50H+LOW UOPBOL)
        JB      ARGF,EP5        ;XBILT MUST COME AFTER AN OPERATOR
        CJNE    A,#STP,XBILT1
XBILT1: JNC     XOP2
        ;
XLPAR:  PUSH    ACC             ;PUT ADDRESS ON THE STACK
        ACALL   P_E
        SJMP    XOP12           ;PERFORM OPERATION
        ;
XOP3:   CJNE    A,#T_ADD-T_LPAR,EP5
        ACALL   GCI1
        AJMP    EP2             ;WASTE + SIGN
        ;
$EJECT
XPOP:   ACALL   X3120           ;FLIP ARGS THEN POP
        ;
        ;***************************************************************
        ;
        ; POPAS - Pop arg stack and copy variable to R3:R1
        ;
        ;***************************************************************
        ;
POPAS:  LCALL   INC_ASTKA
        JMP     VARCOP          ;COPY THE VARIABLE
        ;
AXTAL:  MOV     R2,#HIGH CXTAL
        MOV     R0,#LOW CXTAL
        ;
        ; fall thru
        ;
        ;***************************************************************
        ;
PUSHAS: ; Push the Value addressed by R2:R0 onto the arg stack
        ;
        ;***************************************************************
        ;
        CALL    DEC_ASTKA
        SETB    ARGF            ;SAYS THAT SOMTHING IS ON THE STACK
        LJMP    VARCOP
        ;
        ;
        ;***************************************************************
        ;
ST_A:   ; Store at expression
        ;
        ;***************************************************************
        ;
        ACALL   ONE             ;GET THE EXPRESSION
        SJMP    POPAS           ;SAVE IT
        ;
        ;
        ;***************************************************************
        ;
LD_A:   ; Load at expression
        ;
        ;***************************************************************
        ;
        ACALL   ONE             ;GET THE EXPRESSION
        ACALL   X3120           ;FLIP ARGS
        SJMP    PUSHAS
        ;
$EJECT
        ;***************************************************************
        ;
CONST:  ; Get a constant fron the text
        ;
        ;***************************************************************
        ;
        CALL    GC              ;FIRST SEE IF LITERAL
        CJNE    A,#T_ASC,C0C    ;SEE IF ASCII TOKEN
        CALL    IGC             ;GET THE CHARACTER AFTER TOKEN
        CJNE    A,#'$',CN0      ;SEE IF A STRING
        ;
CNX:    CALL    CSY             ;CALCULATE IT
        JMP     AXBYTE1         ;SAVE IT ON THE STACK
        ;
CN0:    CALL    TWO_R2          ;PUT IT ON THE STACK
        CALL    GCI1            ;BUMP THE POINTER
        JMP     ERPAR           ;WASTE THE RIGHT PAREN
        ;
        ;
C0C:    CALL    DP_T            ;GET THE TEXT POINTER
        CALL    GET_NUM         ;GET THE NUMBER
        CJNE    A,#0FFH,C1C     ;SEE IF NO NUMBER
        SETB    C
C2C:    RET
        ;
C1C:    JNZ     FPTST
        CLR     C
        SETB    ARGF
        ;
C3C:    JMP     T_DP
        ;
FPTST:  ANL     A,#00001011B    ;CHECK FOR ERROR
        JZ      C2C             ;EXIT IF ZERO
        ;
        ; Handle the error condition
        ;
        MOV     DPTR,#E2X       ;DIVIDE BY ZERO
        JNB     ACC.0,FPTST1    ;UNDERFLOW
        MOV     DPTR,#E7X
FPTST1: JNB     ACC.1,FPTS      ;OVERFLOW
        MOV     DPTR,#E11X
        ;
FPTS:   JMP     ERROR
        ;
$EJECT
        ;***************************************************************
        ;
        ; The Command action routine - LIST
        ;
        ;***************************************************************
        ;
CLIST:  CALL    NUMC            ;SEE IF TO LINE PORT
        ACALL   FSTK            ;PUT 0FFFFH ON THE STACK
        CALL    INTGER          ;SEE IF USER SUPPLIES LN
        CLR     A               ;LN = 0 TO START
        MOV     R3,A
        MOV     R1,A
        JC      CL1             ;START FROM ZERO
        ;
        CALL    TEMPD           ;SAVE THE START ADDTESS
        CALL    GCI             ;GET THE CHARACTER AFTER LIST
        CJNE    A,#T_SUB,CLIST1 ;CHECK FOR TERMINATION ADDRESS '-'
        ACALL   INC_ASTKA       ;WASTE 0FFFFH
        LCALL   INTERR          ;GET TERMINATION ADDRESS
        ACALL   TWO_EY          ;PUT TERMINATION ON THE ARG STACK
CLIST1: MOV     R3,TEMP5        ;GET THE START ADDTESS
        MOV     R1,TEMP4
        ;
CL1:    CALL    GETLIN          ;GET THE LINE NO IN R3:R1
        JZ      CL3             ;RET IF AT END
        ;
CL2:    ACALL   C3C             ;SAVE THE ADDRESS
        INC     DPTR            ;POINT TO LINE NUMBER
        ACALL   PMTOP1          ;PUT LINE NUMBER ON THE STACK
        ACALL   CMPLK           ;COMPARE LN TO END ADDRESS
        JC      CL3             ;EXIT IF GREATER
        CALL    BCK             ;CHECK FOR A CONTROL C
        ACALL   DEC_ASTKA       ;SAVE THE COMPARE ADDRESS
        CALL    DP_T            ;RESTORE ADDRESS
        ACALL   UPPL            ;UN-PROCESS THE LINE
        ACALL   C3C             ;SAVE THE CR ADDRESS
        ACALL   CL6             ;PRINT IT
        INC     DPTR            ;BUMP POINTER TO NEXT LINE
        MOVX    A,@DPTR         ;GET LIN LENGTH
        DJNZ    ACC,CL2         ;LOOP
        ACALL   INC_ASTKA       ;WASTE THE COMPARE BYTE
        ;
CL3:    AJMP    CMND1           ;BACK TO COMMAND PROCESSOR
        ;
CL6:    MOV     DPTR,#IBUF      ;PRINT IBUF
        CALL    PRNTCR          ;PRINT IT
        CALL    DP_T
        ;
CL7:    JMP     CRLF
        ;
UPPL0:  LCALL   X31DP
$EJECT
        ;***************************************************************
        ;
        ;UPPL - UN PREPROCESS A LINE ADDRESSED BY DPTR INTO IBUF
        ;       RETURN SOURCE ADDRESS OF CR IN DPTR ON RETURN
        ;
        ;***************************************************************
        ;
UPPL:   MOV     R3,#HIGH IBUF   ;POINT R3 AT HIGH IBUF
        MOV     R1,#LOW IBUF    ;POINT R1 AT IBUF
        INC     DPTR            ;SKIP OVER LINE LENGTH
        ACALL   C3C             ;SAVE THE DPTR (DP_T)
        CALL    L20DPI          ;PUT LINE NUMBER IN R2:R0
        CALL    FP_BASE8        ;CONVERT R2:R0 TO INTEGER
        CALL    DP_T
        INC     DPTR            ;BUMP DPTR PAST THE LINE NUMBER
        ;
UPP0:   CJNE    R1,#LOW IBUF+6,UPP01
UPP01:  JC      UPP91           ;PUT SPACES IN TEXT
        INC     DPTR            ;BUMP PAST LN HIGH
        MOVX    A,@DPTR         ;GET USER TEXT
        MOV     R6,A            ;SAVE A IN R6 FOR TOKE COMPARE
        JB      ACC.7,UPP1      ;IF TOKEN, PROCESS
        CJNE    A,#20H,UPP02    ;TRAP THE USER TOKENS
UPP02:  JNC     UPP03
        CJNE    A,#CR,UPP1      ;DO IT IF NOT A CR
UPP03:  CJNE    A,#'"',UPP9     ;SEE IF STRING
        ACALL   UPP7            ;SAVE IT
UPP04:  ACALL   UPP8            ;GET THE NEXT CHARACTER AND SAVE IT
        CJNE    A,#'"',UPP04    ;LOOP ON QUOTES
        SJMP    UPP0
        ;
UPP9:   CJNE    A,#':',UPP1A    ;PUT A SPACE IN DELIMITER
        ACALL   UPP7A
        MOV     A,R6
        ACALL   UPP7
UPP91:  ACALL   UPP7A
        SJMP    UPP0
        ;
UPP1A:  ACALL   UPP81           ;SAVE THE CHARACTER, UPDATE POINTER
        SJMP    UPP0            ;EXIT IF A CR, ELSE LOOP
        ;
UPP1:   ACALL   C3C             ;SAVE THE TEXT POINTER
        MOV     C,XBIT
        MOV     F0,C            ;SAVE XBIT IN F0
UPP11:  MOV     DPTR,#TOKTAB    ;POINT AT TOKEN TABLE
        JNB     F0,UPP2
        LCALL   2078H           ;SET UP DPTR FOR LOOKUP
        ;
UPP2:   CLR     A               ;ZERO A FOR LOOKUP
        MOVC    A,@A+DPTR       ;GET TOKEN
        INC     DPTR            ;ADVANCE THE TOKEN POINTER
        CJNE    A,#0FFH,UP_2    ;SEE IF DONE
        JBC     F0,UPP11        ;NOW DO NORMAL TABLE
        AJMP    CMND1           ;EXIT IF NOT FOUND
        ;
UP_2:   CJNE    A,R6B0,UPP2     ;LOOP UNTIL THE SAME
        ;
UP_3:   CJNE    A,#T_UOP,UP_4
UP_4:   JNC     UPP3
        ACALL   UPP7A           ;PRINT THE SPACE IF OK
        ;
UPP3:   CLR     A               ;DO LOOKUP
        MOVC    A,@A+DPTR
        JB      ACC.7,UPP4      ;EXIT IF DONE, ELSE SAVE
        JZ      UPP4            ;DONE IF ZERO
        ACALL   UPP7            ;SAVE THE CHARACTER
        INC     DPTR
        SJMP    UPP3            ;LOOP
        ;
UPP4:   CALL    DP_T            ;GET IT BACK
        MOV     A,R6            ;SEE IF A REM TOKEN
        XRL     A,#T_REM
        JNZ     UPP42
UPP41:  ACALL   UPP8
        SJMP    UPP41
UPP42:  JNC     UPP0            ;START OVER AGAIN IF NO TOKEN
        ACALL   UPP7A           ;PRINT THE SPACE IF OK
        SJMP    UPP0            ;DONE
        ;
UPP7A:  MOV     A,#' '          ;OUTPUT A SPACE
        ;
UPP7:   AJMP    PPL91           ;SAVE A
        ;
UPP8:   INC     DPTR
        MOVX    A,@DPTR
UPP81:  CJNE    A,#CR,UPP7
        AJMP    PPL71
        ;
$EJECT
        ;**************************************************************
        ;
        ; This table contains all of the floating point constants
        ;
        ; The constants in ROM are stored "backwards" from the way
        ; basic normally treats floating point numbers. Instead of
        ; loading from the exponent and decrementing the pointer,
        ; ROM constants pointers load from the most significant
        ; digits and increment the pointers. This is done to 1) make
        ; arg stack loading faster and 2) compensate for the fact that
        ; no decrement data pointer instruction exsist.
        ;
        ; The numbers are stored as follows:
        ;
        ; BYTE X+5    = MOST SIGNIFICANT DIGITS IN BCD
        ; BYTE X+4    = NEXT MOST SIGNIFICANT DIGITS IN BCD
        ; BYTE X+3    = NEXT LEAST SIGNIFICANT DIGITS IN BCD
        ; BYTE X+2    = LEAST SIGNIFICANT DIGITS IN BCD
        ; BYTE X+1    = SIGN OF THE ABOVE MANTISSA 0 = +, 1 = -
        ; BYTE X      = EXPONENT IN TWO'S COMPLEMENT BINARY
        ;               ZERO EXPONENT = THE NUMBER ZERO
        ;
        ;**************************************************************
        ;
ATTAB:  DB      128-2           ; ARCTAN LOOKUP
        DB      00H
        DB      57H
        DB      22H
        DB      66H
        DB      28H
        ;
        DB      128-1
        DB      01H
        DB      37H
        DB      57H
        DB      16H
        DB      16H
        ;
        DB      128-1
        DB      00H
        DB      14H
        DB      96H
        DB      90H
        DB      42H
        ;
        DB      128-1
        DB      01H
        DB      40H
        DB      96H
        DB      28H
        DB      75H
        ;
        DB      128
        DB      00H
        DB      64H
        DB      62H
        DB      65H
        DB      10H
        ;
        DB      128
        DB      01H
        DB      99H
        DB      88H
        DB      20H
        DB      14H
        ;
        DB      128
        DB      00H
        DB      51H
        DB      35H
        DB      99H
        DB      19H
        ;
        DB      128
        DB      01H
        DB      45H
        DB      31H
        DB      33H
        DB      33H
        ;
        DB      129
        DB      00H
        DB      00H
        DB      00H
        DB      00H
        DB      10H
        ;
        DB      0FFH            ;END OF TABLE
        ;
NTWO:   DB      129
        DB      0
        DB      0
        DB      0
        DB      0
        DB      20H
        ;
TTIME:  DB      128-4           ; CLOCK CALCULATION
        DB      00H
        DB      00H
        DB      00H
        DB      04H
        DB      13H
        ;
$EJECT
        ;***************************************************************
        ;
        ; COSINE - Add pi/2 to stack, then fall thru to SIN
        ;
        ;***************************************************************
        ;
ACOS:   ACALL   POTWO           ;PUT PI/2 ON THE STACK
        ACALL   AADD            ;TOS = TOS+PI/2
        ;
        ;***************************************************************
        ;
        ; SINE - use taylor series to calculate sin function
        ;
        ;***************************************************************
        ;
ASIN:   ACALL   PIPI            ;PUT PI ON THE STACK
        ACALL   RV              ;REDUCE THE VALUE
        MOV     A,MT2           ;CALCULATE THE SIGN
        ANL     A,#01H          ;SAVE LSB
        XRL     MT1,A           ;SAVE SIGN IN MT1
        ACALL   CSTAKA          ;NOW CONVERT TO ONE QUADRANT
        ACALL   POTWO
        ACALL   CMPLK           ;DO COMPARE
        JC      ASIN1
        ACALL   PIPI
        ACALL   ASUB
ASIN1:  ACALL   AABS
        MOV     DPTR,#SINTAB    ;SET UP LOOKUP TABLE
        ACALL   POLYC           ;CALCULATE THE POLY
        ACALL   STRIP
        AJMP    SIN0
        ;
        ; Put PI/2 on the stack
        ;
POTWO:  ACALL   PIPI            ;PUT PI ON THE STACK, NOW DIVIDE
        ;
DBTWO:  MOV     DPTR,#NTWO
        ACALL   PUSHC
        ;MOV    A,#2            ;BY TWO
        ;ACALL  TWO_R2
        AJMP    ADIV
        ;
$EJECT
        ;*************************************************************
        ;
POLYC:  ; Expand a power series to calculate a polynomial
        ;
        ;*************************************************************
        ;
        ACALL   CSTAKA2         ;COPY THE STACK
        ACALL   AMUL            ;SQUARE THE STACK
        ACALL   POP_T1          ;SAVE X*X
        ACALL   PUSHC           ;PUT CONSTANT ON STACK
        ;
POLY1:  ACALL   PUSH_T1         ;PUT COMPUTED VALUE ON STACK
        ACALL   AMUL            ;MULTIPLY CONSTANT AND COMPUTED VALUE
        ACALL   PUSHC           ;PUT NEXT CONSTANT ON STACK
        ACALL   AADD            ;ADD IT TO THE OLD VALUE
        CLR     A               ;CHECK TO SEE IF DONE
        MOVC    A,@A+DPTR
        CJNE    A,#0FFH,POLY1   ;LOOP UNTIL DONE
        ;
AMUL:   LCALL   FP_BASE3
        AJMP    FPTST
        ;
        ;*************************************************************
        ;
RV:     ; Reduce a value for Trig and A**X functions
        ;
        ; value = (value/x - INT(value/x)) * x
        ;
        ;*************************************************************
        ;
        ACALL   C2_T2           ;COPY TOS TO T2
        ACALL   ADIV            ;TOS = TOS/TEMP2
        ACALL   AABS            ;MAKE THE TOS A POSITIVE NUMBER
        MOV     MT1,A           ;SAVE THE SIGN
        ACALL   CSTAKA2         ;COPY THE STACK TWICE
        ACALL   IFIX            ;PUT THE NUMBER IN R3:R1
        PUSH    R3B0            ;SAVE R3
        MOV     MT2,R1          ;SAVE THE LS BYTE IN MT2
        ACALL   AINT            ;MAKE THE TOS AN INTEGER
        ACALL   ASUB            ;TOS = TOS/T2 - INT(TOS/T2)
        ACALL   P_T2            ;TOS = T2
        ACALL   AMUL            ;TOS = T2*(TOS/T2 - INT(TOS/T2)
        POP     R3B0            ;RESTORE R3
        RET                     ;EXIT
        ;
$EJECT
        ;**************************************************************
        ;
        ; TAN
        ;
        ;**************************************************************
        ;
ATAN:   ACALL   CSTAKA          ;DUPLACATE STACK
        ACALL   ASIN            ;TOS = SIN(X)
        ACALL   SWAP_ASTKA      ;TOS = X
        ACALL   ACOS            ;TOS = COS(X)
        AJMP    ADIV            ;TOS = SIN(X)/COS(X)
        ;
STRIP:  ACALL   SETREG          ;SETUP R0
        MOV     R3,#1           ;LOOP COUNT
        AJMP    AI11            ;WASTE THE LSB
        ;
        ;************************************************************
        ;
        ; ARC TAN
        ;
        ;************************************************************
        ;
AATAN:  ACALL   AABS
        MOV     MT1,A           ;SAVE THE SIGN
        ACALL   SETREG          ;GET THE EXPONENT
        ADD     A,#7FH          ;BIAS THE EXPONENT
        MOV     UBIT,C          ;SAVE CARRY STATUS
        JNC     AATAN1          ;SEE IF > 1
        ACALL   RECIP           ;IF > 1, TAKE RECIP
AATAN1: MOV     DPTR,#ATTAB     ;SET UP TO CALCULATE THE POLY
        ACALL   POLYC           ;CALCULATE THE POLY
        JNB     UBIT,SIN0       ;JUMP IF NOT SET
        ACALL   ANEG            ;MAKE X POLY NEGATIVE
        ACALL   POTWO           ;SUBTRACT PI/2
        ACALL   AADD
        ;
SIN0:   MOV     A,MT1           ;GET THE SIGN
        JZ      SRT
        AJMP    ANEG
        ;
$EJECT
        ;*************************************************************
        ;
        ; FCOMP - COMPARE 0FFFFH TO TOS
        ;
        ;*************************************************************
        ;
FCMP:   ACALL   CSTAKA          ;COPY THE STACK
        ACALL   FSTK            ;MAKE THE TOS = 0FFFFH
        ACALL   SWAP_ASTKA      ;NOW COMPARE IS 0FFFFH - X
        ;
CMPLK:  JMP     FP_BASE2        ;DO THE COMPARE
        ;
        ;*************************************************************
        ;
DEC_ASTKA:      ;Push ARG STACK and check for underflow
        ;
        ;*************************************************************
        ;
        MOV     A,#-FPSIZ
        ADD     A,ASTKA
        CJNE    A,#LOW TM_TOP+6,DEC_ASTKA1
DEC_ASTKA1:
        JC      E4YY
        MOV     ASTKA,A
        MOV     R1,A
        MOV     R3,#ASTKAH
        ;
SRT:    RET
        ;
E4YY:   MOV     DPTR,#EXA
        AJMP    FPTS            ;ARG STACK ERROR
        ;
        ;
AXTAL3: ACALL   PUSHC           ;PUSH CONSTANT, THEN MULTIPLY
        ACALL   AMUL
        ;
        ; Fall thru to IFIX
        ;
$EJECT
        ;***************************************************************
        ;
IFIX:   ; Convert a floating point number to an integer, put in R3:R1
        ;
        ;***************************************************************
        ;
        CLR     A               ;RESET THE START
        MOV     R3,A
        MOV     R1,A
        MOV     R0,ASTKA        ;GET THE ARG STACK
        MOV     P2,#ASTKAH
        MOVX    A,@R0           ;READ EXPONENT
        CLR     C
        SUBB    A,#81H          ;BASE EXPONENT
        MOV     R4,A            ;SAVE IT
        DEC     R0              ;POINT AT SIGN
        MOVX    A,@R0           ;GET THE SIGN
        JNZ     SQ_ERR          ;ERROR IF NEGATIVE
        JC      INC_ASTKA       ;EXIT IF EXPONENT IS < 81H
        INC     R4              ;ADJUST LOOP COUNTER
        MOV     A,R0            ;BUMP THE POINTER REGISTER
        SUBB    A,#FPSIZ-1
        MOV     R0,A
        ;
I2:     INC     R0              ;POINT AT DIGIT
        MOVX    A,@R0           ;GET DIGIT
        SWAP    A               ;FLIP
        CALL    FP_BASE10       ;ACCUMULATE
        JC      SQ_ERR
        DJNZ    R4,I21
        SJMP    INC_ASTKA
I21:    MOVX    A,@R0           ;GET DIGIT
        CALL    FP_BASE10
        JC      SQ_ERR
        DJNZ    R4,I2
        ;
$EJECT
        ;************************************************************
        ;
INC_ASTKA:      ; Pop the ARG STACK and check for overflow
        ;
        ;************************************************************
        ;
        MOV     A,#FPSIZ        ;NUMBER TO POP
        SJMP    SETREG1
        ;
SETREG: CLR     A               ;DON'T POP ANYTHING
SETREG1:MOV     R0,ASTKA
        MOV     R2,#ASTKAH
        MOV     P2,R2
        ADD     A,R0
        JC      E4YY
        MOV     ASTKA,A
        MOVX    A,@R0
A_D:    RET
        ;
        ;************************************************************
        ;
        ; EBIAS - Bias a number for E to the X calculations
        ;
        ;************************************************************
        ;
EBIAS:  ACALL   PUSH_ONE
        ACALL   RV
        CJNE    R3,#00H,SQ_ERR  ;ERROR IF R3 <> 0
        ACALL   C2_T2           ;TEMP 2 GETS FRACTIONS
        ACALL   INC_ASTKA
        ACALL   POP_T1
        ACALL   PUSH_ONE
        ;
AELP:   MOV     A,MT2
        JNZ     AEL1
        ;
        MOV     A,MT1
        JZ      A_D
        MOV     DPTR,#FPT2-1
        MOVX    @DPTR,A         ;MAKE THE FRACTIONS NEGATIVE
        ;
RECIP:  ACALL   PUSH_ONE
        ACALL   SWAP_ASTKA
        AJMP    ADIV
        ;
AEL1:   DEC     MT2
        ACALL   PUSH_T1
        ACALL   AMUL
        SJMP    AELP
        ;
SQ_ERR: LJMP    E3XX            ;LINK TO BAD ARG
        ;
$EJECT
        ;************************************************************
        ;
        ; SQUARE ROOT
        ;
        ;************************************************************
        ;
ASQR:   ACALL   AABS            ;GET THE SIGN
        JNZ     SQ_ERR          ;ERROR IF NEGATIVE
        ACALL   C2_T2           ;COPY VARIABLE TO T2
        ACALL   POP_T1          ;SAVE IT IN T1
        MOV     R0,#LOW FPT1
        MOVX    A,@R0           ;GET EXPONENT
        JZ      SQR41           ;EXIT IF ZERO
        ADD     A,#128          ;BIAS THE EXPONENT
        JNC     SQR1            ;SEE IF < 80H
        RR      A
        ANL     A,#127
        SJMP    SQR2
        ;
SQR1:   CPL     A               ;FLIP BITS
        INC     A
        RR      A
        ANL     A,#127          ;STRIP MSB
        CPL     A
        INC     A
        ;
SQR2:   ADD     A,#128          ;BIAS EXPONENT
        MOVX    @R0,A           ;SAVE IT
        ;
        ; NEWGUESS = ( X/OLDGUESS + OLDGUESS) / 2
        ;
SQR4:   ACALL   P_T2            ;TOS = X
        ACALL   PUSH_T1         ;PUT NUMBER ON STACK
        ACALL   ADIV            ;TOS = X/GUESS
        ACALL   PUSH_T1         ;PUT ON AGAIN
        ACALL   AADD            ;TOS = X/GUESS + GUESS
        ACALL   DBTWO           ;TOS = ( X/GUESS + GUESS ) / 2
        ACALL   TEMP_COMP       ;SEE IF DONE
        JNB     F0,SQR4
        ;
SQR41:  AJMP    PUSH_T1         ;PUT THE ANSWER ON THE STACK
        ;
$EJECT
        ;*************************************************************
        ;
        ; NATURAL LOG
        ;
        ;*************************************************************
        ;
ALN:    ACALL   AABS            ;MAKE SURE THAT NUM IS POSITIVE
        JNZ     SQ_ERR          ;ERROR IF NOT
        MOV     MT2,A           ;CLEAR FOR LOOP
        INC     R0              ;POINT AT EXPONENT
        MOVX    A,@R0           ;READ THE EXPONENT
        JZ      SQ_ERR          ;ERROR IF EXPONENT IS ZERO
        CJNE    A,#81H,ALN1     ;SEE IF NUM >= 1
ALN1:   MOV     UBIT,C          ;SAVE CARRY STATUS
        JC      ALNL            ;TAKE RECIP IF >= 1
        ACALL   RECIP
        ;
        ; Loop to reduce
        ;
ALNL:   ACALL   CSTAKA          ;COPY THE STACK FOR COMPARE
        ACALL   PUSH_ONE        ;COMPARE NUM TO ONE
        ACALL   CMPLK
        JNC     ALNO            ;EXIT IF DONE
        ACALL   SETREG          ;GET THE EXPONENT
        ADD     A,#85H          ;SEE HOW BIG IT IS
        JNC     ALN11           ;BUMP BY EXP(11) IF TOO SMALL
        ACALL   PLNEXP          ;PUT EXP(1) ON STACK
        MOV     A,#1            ;BUMP COUNT
        ;
ALNE:   ADD     A,MT2
        JC      SQ_ERR
        MOV     MT2,A
        ACALL   AMUL            ;BIAS THE NUMBER
        SJMP    ALNL
        ;
ALN11:  MOV     DPTR,#EXP11     ;PUT EXP(11) ON STACK
        ACALL   PUSHC
        MOV     A,#11
        SJMP    ALNE
        ;
$EJECT
ALNO:   ACALL   C2_T2           ;PUT NUM IN TEMP 2
        ACALL   PUSH_ONE        ;TOS = 1
        ACALL   ASUB            ;TOS = X - 1
        ACALL   P_T2            ;TOS = X
        ACALL   PUSH_ONE        ;TOS = 1
        ACALL   AADD            ;TOS = X + 1
        ACALL   ADIV            ;TOS = (X-1)/(X+1)
        MOV     DPTR,#LNTAB     ;LOG TABLE
        ACALL   POLYC
        INC     DPTR            ;POINT AT LN(10)
        ACALL   PUSHC
        ACALL   AMUL
        MOV     A,MT2           ;GET THE COUNT
        ACALL   TWO_R2          ;PUT IT ON THE STACK
        ACALL   ASUB            ;INT - POLY
        ACALL   STRIP
        JNB     UBIT,AABS
        ;
LN_D:   RET
        ;
        ;*************************************************************
        ;
TEMP_COMP:      ; Compare FPTEMP1 to TOS, FPTEMP1 gets TOS
        ;
        ;*************************************************************
        ;
        ACALL   PUSH_T1         ;SAVE THE TEMP
        ACALL   SWAP_ASTKA      ;TRADE WITH THE NEXT NUMBER
        ACALL   CSTAKA          ;COPY THE STACK
        ACALL   POP_T1          ;SAVE THE NEW NUMBER
        JMP     FP_BASE2        ;DO THE COMPARE
        ;
$EJECT
AETOX:  ACALL   PLNEXP          ;EXP(1) ON TOS
        ACALL   SWAP_ASTKA      ;X ON TOS
        ;
AEXP:   ;EXPONENTIATION
        ;
        ACALL   EBIAS           ;T1=BASE,T2=FRACTIONS,TOS=INT MULTIPLIED
        MOV     DPTR,#FPT2      ;POINT AT FRACTIONS
        MOVX    A,@DPTR         ;READ THE EXP OF THE FRACTIONS
        JZ      LN_D            ;EXIT IF ZERO
        ACALL   P_T2            ;TOS = FRACTIONS
        ACALL   PUSH_T1         ;TOS = BASE
        ACALL   SETREG          ;SEE IF BASE IS ZERO
        JZ      AEXP1
        ACALL   ALN             ;TOS = LN(BASE)
AEXP1:  ACALL   AMUL            ;TOS = FRACTIONS * LN(BASE)
        ACALL   PLNEXP          ;TOS = EXP(1)
        ACALL   SWAP_ASTKA      ;TOS = FRACTIONS * LN(BASE)
        ACALL   EBIAS           ;T2 = FRACTIONS, TOS = INT MULTIPLIED
        MOV     MT2,#00H        ;NOW CALCULATE E**X
        ACALL   PUSH_ONE
        ACALL   CSTAKA
        ACALL   POP_T1          ;T1 = 1
        ;
AEXL:   ACALL   P_T2            ;TOS = FRACTIONS
        ACALL   AMUL            ;TOS = FRACTIONS * ACCUMLATION
        INC     MT2             ;DO THE DEMONIATOR
        MOV     A,MT2
        ACALL   TWO_R2
        ACALL   ADIV
        ACALL   CSTAKA          ;SAVE THE ITERATION
        ACALL   PUSH_T1         ;NOW ACCUMLATE
        ACALL   AADD            ;ADD ACCUMLATION
        ACALL   TEMP_COMP
        JNB     F0,AEXL         ;LOOP UNTIL DONE
        ;
        ACALL   INC_ASTKA
        ACALL   PUSH_T1
        ACALL   AMUL            ;LAST INT MULTIPLIED
        ;
MU1:    AJMP    AMUL            ;FIRST INT MULTIPLIED
        ;
$EJECT
        ;***************************************************************
        ;
        ; integer operator - INT
        ;
        ;***************************************************************
        ;
AINT:   ACALL   SETREG          ;SET UP THE REGISTERS, CLEAR CARRY
        SUBB    A,#129          ;SUBTRACT EXPONENT BIAS
        JNC     AI1             ;JUMP IF ACC > 81H
        ;
        ; Force the number to be a zero
        ;
        ACALL   INC_ASTKA       ;BUMP THE STACK
        ;
P_Z:    MOV     DPTR,#ZRO       ;PUT ZERO ON THE STACK
        AJMP    PUSHC
        ;
AI1:    SUBB    A,#7
        JNC     AI3
        CPL     A
        INC     A
        MOV     R3,A
AI11:   DEC     R0              ;POINT AT SIGN
        ;
AI2:    DEC     R0              ;NOW AT LSB'S
        MOVX    A,@R0           ;READ BYTE
        ANL     A,#0F0H         ;STRIP NIBBLE
        MOVX    @R0,A           ;WRITE BYTE
        DJNZ    R3,AI21
        RET
AI21:   CLR     A
        MOVX    @R0,A           ;CLEAR THE LOCATION
        DJNZ    R3,AI2
        ;
AI3:    RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
AABS:   ; Absolute value - Make sign of number positive
        ;                  return sign in ACC
        ;
        ;***************************************************************
        ;
        ACALL   ANEG            ;CHECK TO SEE IF + OR -
        JNZ     ALPAR           ;EXIT IF NON ZERO, BECAUSE THE NUM IS
        MOVX    @R0,A           ;MAKE A POSITIVE SIGN
        RET
        ;
        ;***************************************************************
        ;
ASGN:   ; Returns the sign of the number 1 = +, -1 = -
        ;
        ;***************************************************************
        ;
        ACALL   INC_ASTKA       ;POP STACK, GET EXPONENT
        JZ      P_Z             ;EXIT IF ZERO
        DEC     R0              ;BUMP TO SIGN
        MOVX    A,@R0           ;GET THE SIGN
        MOV     R7,A            ;SAVE THE SIGN
        ACALL   PUSH_ONE        ;PUT A ONE ON THE STACK
        MOV     A,R7            ;GET THE SIGN
        JZ      ALPAR           ;EXIT IF ZERO
        ;
        ; Fall thru to ANEG
        ;
        ;***************************************************************
        ;
ANEG:   ; Flip the sign of the number on the tos
        ;
        ;***************************************************************
        ;
        ACALL   SETREG
        DEC     R0              ;POINT AT THE SIGN OF THE NUMBER
        JZ      ALPAR           ;EXIT IF ZERO
        MOVX    A,@R0
        XRL     A,#01H          ;FLIP THE SIGN
        MOVX    @R0,A
        XRL     A,#01H          ;RESTORE THE SIGN
        ;
ALPAR:  RET
        ;
$EJECT
        ;***************************************************************
        ;
ACBYTE: ; Read the ROM
        ;
        ;***************************************************************
        ;
        ACALL   IFIX            ;GET EXPRESSION
        CALL    X31DP           ;PUT R3:R1 INTO THE DP
        CLR     A
        MOVC    A,@A+DPTR
        AJMP    TWO_R2
        ;
        ;***************************************************************
        ;
ADBYTE: ; Read internal memory
        ;
        ;***************************************************************
        ;
        ACALL   IFIX            ;GET THE EXPRESSION
        CALL    R3CK            ;MAKE SURE R3 = 0
        MOV     A,@R1
        AJMP    TWO_R2
        ;
        ;***************************************************************
        ;
AXBYTE: ; Read external memory
        ;
        ;***************************************************************
        ;
        ACALL   IFIX            ;GET THE EXPRESSION
AXBYTE1:MOV     P2,R3
        MOVX    A,@R1
        AJMP    TWO_R2
        ;
$EJECT
        ;***************************************************************
        ;
        ; The relational operators - EQUAL                        (=)
        ;                            GREATER THAN                 (>)
        ;                            LESS THAN                    (<)
        ;                            GREATER THAN OR EQUAL        (>=)
        ;                            LESS THAN OR EQUAL           (<=)
        ;                            NOT EQUAL                    (<>)
        ;
        ;***************************************************************
        ;
AGT:    ACALL   CMPLK
        ORL     C,F0            ;SEE IF EITHER IS A ONE
AGT1:   JC      P_Z
        ;
FSTK:   MOV     DPTR,#FS
        AJMP    PUSHC
        ;
FS:     DB      85H
        DB      00H
        DB      00H
        DB      50H
        DB      53H
        DB      65H
        ;
ALT:    ACALL   CMPLK
ALT1:   CPL     C
        SJMP    AGT1
        ;
AEQ:    ACALL   CMPLK
AEQ1:   MOV     C,F0
        SJMP    ALT1
        ;
ANE:    ACALL   CMPLK
        CPL     F0
        SJMP    AEQ1
        ;
AGE:    ACALL   CMPLK
        SJMP    AGT1
        ;
ALE:    ACALL   CMPLK
        ORL     C,F0
        SJMP    ALT1
        ;
$EJECT
        ;***************************************************************
        ;
ARND:   ; Generate a random number
        ;
        ;***************************************************************
        ;
        MOV     DPTR,#RCELL     ;GET THE BINARY SEED
        CALL    L31DPI
        MOV     A,R1
        CLR     C
        RRC     A
        MOV     R0,A
        MOV     A,#6
        RRC     A
        ADD     A,R1
        XCH     A,R0
        ADDC    A,R3
        MOV     R2,A
        DEC     DPL             ;SAVE THE NEW SEED
        ACALL   S20DP
        ACALL   TWO_EY
        ACALL   FSTK
        ;
ADIV:   LCALL   FP_BASE4
        AJMP    FPTST
        ;
$EJECT
        ;***************************************************************
        ;
SONERR: ; ON ERROR Statement
        ;
        ;***************************************************************
        ;
        LCALL   INTERR          ;GET THE LINE NUMBER
        SETB    ON_ERR
        MOV     DPTR,#ERRNUM    ;POINT AT THR ERROR LOCATION
        SJMP    S20DP
        ;
        ;
        ;**************************************************************
        ;
SONEXT: ; ON EXT1 Statement
        ;
        ;**************************************************************
        ;
        LCALL   INTERR
        SETB    INTBIT
        ORL     IE,#10000100B   ;ENABLE INTERRUPTS
        MOV     DPTR,#INTLOC
        ;
S20DP:  MOV     A,R2            ;SAVE R2:R0 @DPTR
        MOVX    @DPTR,A
        INC     DPTR
        MOV     A,R0
        MOVX    @DPTR,A
        RET
        ;
$EJECT
        ;***************************************************************
        ;
        ; CASTAK - Copy and push another top of arg stack
        ;
        ;***************************************************************
        ;
CSTAKA2:ACALL   CSTAKA          ;COPY STACK TWICE
        ;
CSTAKA: ACALL   SETREG          ;SET UP R2:R0
        SJMP    PUSH_T12
        ;
PLNEXP: MOV     DPTR,#EXP1
        ;
        ;***************************************************************
        ;
        ; PUSHC - Push constant on to the arg stack
        ;
        ;***************************************************************
        ;
PUSHC:  ACALL   DEC_ASTKA
        MOV     P2,R3
        MOV     R3,#FPSIZ       ;LOOP COUNTER
        ;
PCL:    CLR     A               ;SET UP A
        MOVC    A,@A+DPTR       ;LOAD IT
        MOVX    @R1,A           ;SAVE IT
        INC     DPTR            ;BUMP POINTERS
        DEC     R1
        DJNZ    R3,PCL          ;LOOP
        ;
        SETB    ARGF
        RET                     ;EXIT
        ;
PUSH_ONE:;
        ;
        MOV     DPTR,#FPONE
        AJMP    PUSHC
        ;
$EJECT
        ;
POP_T1:
        ;
        MOV     R3,#HIGH FPT1
        MOV     R1,#LOW FPT1
        JMP     POPAS
        ;
PUSH_T1:
        ;
        MOV     R0,#LOW FPT1
PUSH_T11:
        MOV     R2,#HIGH FPT1
PUSH_T12:
        LJMP    PUSHAS
        ;
P_T2:   MOV     R0,#LOW FPT2
        SJMP    PUSH_T11                ;JUMP TO PUSHAS
        ;
        ;****************************************************************
        ;
SWAP_ASTKA:     ; SWAP TOS<>TOS-1
        ;
        ;****************************************************************
        ;
        ACALL   SETREG          ;SET UP R2:R0 AND P2
        MOV     A,#FPSIZ        ;PUT TOS+1 IN R1
        MOV     R2,A
        ADD     A,R0
        MOV     R1,A
        ;
S_L:    MOVX    A,@R0
        MOV     R3,A
        MOVX    A,@R1
        MOVX    @R0,A
        MOV     A,R3
        MOVX    @R1,A
        DEC     R1
        DEC     R0
        DJNZ    R2,S_L
        RET
        ;
$EJECT
        ;
C2_T2:  ACALL   SETREG          ;SET UP R2:R0
        MOV     R3,#HIGH FPT2
        MOV     R1,#LOW FPT2    ;TEMP VALUE
        ;
        ; Fall thru
        ;
        ;***************************************************************
        ;
        ; VARCOP - Copy a variable from R2:R0 to R3:R1
        ;
        ;***************************************************************
        ;
VARCOP: MOV     R4,#FPSIZ       ;LOAD THE LOOP COUNTER
        ;
V_C:    MOV     P2,R2           ;SET UP THE PORTS
        MOVX    A,@R0           ;READ THE VALUE
        MOV     P2,R3           ;PORT TIME AGAIN
        MOVX    @R1,A           ;SAVE IT
        ACALL   DEC3210         ;BUMP POINTERS
        DJNZ    R4,V_C          ;LOOP
        RET                     ;EXIT
        ;
PIPI:   MOV     DPTR,#PIE
        AJMP    PUSHC
        ;
$EJECT
        ;***************************************************************
        ;
        ; The logical operators ANL, ORL, XRL, NOT
        ;
        ;***************************************************************
        ;
AANL:   ACALL   TWOL            ;GET THE EXPRESSIONS
        MOV     A,R3            ;DO THE AND
        ANL     A,R7
        MOV     R2,A
        MOV     A,R1
        ANL     A,R6
        SJMP    TWO_EX
        ;
AORL:   ACALL   TWOL            ;SAME THING FOR OR
        MOV     A,R3
        ORL     A,R7
        MOV     R2,A
        MOV     A,R1
        ORL     A,R6
        SJMP    TWO_EX
        ;
ANOT:   ACALL   FSTK            ;PUT 0FFFFH ON THE STACK
        ;
AXRL:   ACALL   TWOL
        MOV     A,R3
        XRL     A,R7
        MOV     R2,A
        MOV     A,R1
        XRL     A,R6
        SJMP    TWO_EX
        ;
TWOL:   ACALL   IFIX
        MOV     R7,R3B0
        MOV     R6,R1B0
        AJMP    IFIX
        ;
$EJECT
        ;*************************************************************
        ;
AGET:   ; READ THE BREAK BYTE AND PUT IT ON THE ARG STACK
        ;
        ;*************************************************************
        ;
        MOV     DPTR,#GTB       ;GET THE BREAK BYTE
        MOVX    A,@DPTR
        JBC     GTRD,TWO_R2
        CLR     A
        ;
TWO_R2: MOV     R2,#00H         ;ACC GOES TO STACK
        ;
        ;
TWO_EX: MOV     R0,A            ;R2:ACC GOES TO STACK
        ;
        ;
TWO_EY: SETB    ARGF            ;R2:R0 GETS PUT ON THE STACK
        JMP     FP_BASE12       ;DO IT
        ;
$EJECT
        ;*************************************************************
        ;
        ; Put directs onto the stack
        ;
        ;**************************************************************
        ;
A_IE:   MOV     A,IE            ;IE
        SJMP    TWO_R2
        ;
A_IP:   MOV     A,IP            ;IP
        SJMP    TWO_R2
        ;
ATIM0:  MOV     R2,TH0          ;TIMER 0
        MOV     R0,TL0
        SJMP    TWO_EY
        ;
ATIM1:  MOV     R2,TH1          ;TIMER 1
        MOV     R0,TL1
        SJMP    TWO_EY
        ;
ATIM2:  MOV     R2,TH2
        MOV     R0,TL2
;       DB      0AAH            ;MOV R2 DIRECT OP CODE
;       DB      0CDH            ;T2 HIGH
;       DB      0A8H            ;MOV R0 DIRECT OP CODE
;       DB      0CCH            ;T2 LOW
        SJMP    TWO_EY          ;TIMER 2
        ;
AT2CON: MOV     A,T2CON
;       DB      0E5H            ;MOV A,DIRECT OPCODE
;       DB      0C8H            ;T2CON LOCATION
        SJMP    TWO_R2
        ;
ATCON:  MOV     A,TCON          ;TCON
        SJMP    TWO_R2
        ;
ATMOD:  MOV     A,TMOD          ;TMOD
        SJMP    TWO_R2
        ;
ARCAP2: MOV     R2,RCAPH2
        MOV     R0,RCAPL2
;       DB      0AAH            ;MOV R2, DIRECT OP CODE
;       DB      0CBH            ;RCAP2H LOCATION
;       DB      0A8H            ;MOV R0, DIRECT OP CODE
;       DB      0CAH            ;R2CAPL LOCATION
        SJMP    TWO_EY
        ;
AP1:    MOV     A,P1            ;GET P1
        SJMP    TWO_R2          ;PUT IT ON THE STACK
        ;
APCON:  MOV     A,PCON
;       DB      0E5H            ;MOV A, DIRECT OP CODE
;       DB      87H             ;ADDRESS OF PCON
        SJMP    TWO_R2          ;PUT PCON ON THE STACK
        ;
$EJECT
        ;***************************************************************
        ;
        ;THIS IS THE LINE EDITOR
        ;
        ;TAKE THE PROCESSED LINE IN IBUF AND INSERT IT INTO THE
        ;BASIC TEXT FILE.
        ;
        ;***************************************************************
        ;
LINE0:  LJMP    NOGO            ;CAN'T EDIT A ROM
        ;
LINE:   MOV     A,BOFAH
        CJNE    A,#HIGH PSTART,LINE0
        CALL    G4              ;GET END ADDRESS FOR EDITING
        MOV     R4,DPL
        MOV     R5,DPH
        MOV     R3,TEMP5        ;GET HIGH ORDER IBLN
        MOV     R1,TEMP4        ;LOW ORDER IBLN
        ;
        CALL    GETLIN          ;FIND THE LINE
        JNZ     INSR            ;INSERT IF NOT ZERO, ELSE APPEND
        ;
        ;APPEND THE LINE AT THE END
        ;
        MOV     A,TEMP3         ;PUT IBCNT IN THE ACC
        CJNE    A,#4H,LINE1     ;SEE IF NO ENTRY
        RET                     ;RET IF NO ENTRY
        ;
LINE1:  ACALL   FULL            ;SEE IF ENOUGH SPACE LEFT
        MOV     R2,R5B0         ;PUT END ADDRESS A INTO TRANSFER
        MOV     R0,R4B0         ;REGISTERS
        ACALL   IMOV            ;DO THE BLOCK MOVE
        ;
UE:     MOV     A,#EOF          ;SAVE EOF CHARACTER
        AJMP    TBR
        ;
        ;INSERT A LINE INTO THE FILE
        ;
INSR:   MOV     R7,A            ;SAVE IT IN R7
        CALL    TEMPD           ;SAVE INSERATION ADDRESS
        MOV     A,TEMP3         ;PUT THE COUNT LENGTH IN THE ACC
        JC      LTX             ;JUMP IF NEW LINE # NOT = OLD LINE #
        CJNE    A,#04H,INSR1    ;SEE IF NULL
        CLR     A
        ;
INSR1:  SUBB    A,R7            ;SUBTRACT LINE COUNT FROM ACC
        JZ      LIN1            ;LINE LENGTHS EQUAL
        JC      GTX             ;SMALLER LINE
        ;
$EJECT
        ;
        ;EXPAND FOR A NEW LINE OR A LARGER LINE
        ;
LTX:    MOV     R7,A            ;SAVE A IN R7
        MOV     A,TEMP3         ;GET THE COUNT IN THE ACC
        CJNE    A,#04H,LTX1     ;DO NO INSERTATION IF NULL LINE
        RET                     ;EXIT IF IT IS
        ;
LTX1:   MOV     A,R7            ;GET THE COUNT BACK - DELTA IN A
        ACALL   FULL            ;SEE IF ENOUGH MEMORY NEW EOFA IN R3:R1
        CALL    DTEMP           ;GET INSERATION ADDRESS
        ACALL   NMOV            ;R7:R6 GETS (EOFA)-DPTR
        CALL    X3120
        MOV     R1,R4B0         ;EOFA LOW
        MOV     R3,R5B0         ;EOFA HIGH
        INC     R6              ;INCREMENT BYTE COUNT
        CJNE    R6,#00,LTX2     ;NEED TO BUMP HIGH BYTE?
        INC     R7
        ;
LTX2:   ACALL   RMOV            ;GO DO THE INSERTION
        SJMP    LIN1            ;INSERT THE CURRENT LINE
        ;
GTX:    CPL     A               ;FLIP ACC
        INC     A               ;TWOS COMPLEMENT
        CALL    ADDPTR          ;DO THE ADDITION
        ACALL   NMOV            ;R7:R6 GETS (EOFA)-DPTR
        MOV     R1,DPL          ;SET UP THE REGISTERS
        MOV     R3,DPH
        MOV     R2,TEMP5        ;PUT INSERTATION ADDRESS IN THE RIGHT REG
        MOV     R0,TEMP4
        JZ      GTX1            ;IF ACC WAS ZERO FROM NMOV, JUMP
        ACALL   LMOV            ;IF NO ZERO DO A LMOV
        ;
GTX1:   ACALL   UE              ;SAVE NEW END ADDRESS
        ;
LIN1:   MOV     R2,TEMP5        ;GET THE INSERTATION ADDRESS
        MOV     R0,TEMP4
        MOV     A,TEMP3         ;PUT THE COUNT LENGTH IN ACC
        CJNE    A,#04H,IMOV     ;SEE IF NULL
        RET                     ;EXIT IF NULL
$EJECT
        ;***************************************************************
        ;
        ;INSERT A LINE AT ADDRESS R2:R0
        ;
        ;***************************************************************
        ;
IMOV:   CLR     A               ;TO SET UP
        MOV     R1,#LOW IBCNT   ;INITIALIZE THE REGISTERS
        MOV     R3,A
        MOV     R6,TEMP3        ;PUT THE BYTE COUNT IN R6 FOR LMOV
        MOV     R7,A            ;PUT A 0 IN R7 FOR LMOV
        ;
        ;***************************************************************
        ;
        ;COPY A BLOCK FROM THE BEGINNING
        ;
        ;R2:R0 IS THE DESTINATION ADDRESS
        ;R3:R1 IS THE SOURCE ADDRESS
        ;R7:R6 IS THE COUNT REGISTER
        ;
        ;***************************************************************
        ;
LMOV:   ACALL   TBYTE           ;TRANSFER THE BYTE
        ACALL   INC3210         ;BUMP THE POINTER
        ACALL   DEC76           ;BUMP R7:R6
        JNZ     LMOV            ;LOOP
        RET                     ;GO BACK TO CALLING ROUTINE
        ;
INC3210:INC     R0
        CJNE    R0,#00H,INC3211
        INC     R2
        ;
INC3211:INC     R1
        CJNE    R1,#00H,INC3212
        INC     R3
INC3212:RET
        ;
$EJECT
        ;***************************************************************
        ;
        ;COPY A BLOCK STARTING AT THE END
        ;
        ;R2:R0 IS THE DESTINATION ADDRESS
        ;R3:R1 IS THE SOURCE ADDRESS
        ;R6:R7 IS THE COUNT REGISTER
        ;
        ;***************************************************************
        ;
RMOV:   ACALL   TBYTE           ;TRANSFER THE BYTE
        ACALL   DEC3210         ;DEC THE LOCATIONS
        ACALL   DEC76           ;BUMP THE COUNTER
        JNZ     RMOV            ;LOOP
        ;
DEC_R:  NOP                     ;CREATE EQUAL TIMING
        RET                     ;EXIT
        ;
DEC3210:DEC     R0              ;BUMP THE POINTER
        CJNE    R0,#0FFH,DEC3212;SEE IF OVERFLOWED
DEC3211:DEC     R2              ;BUMP THE HIGH BYTE
DEC3212:DEC     R1              ;BUMP THE POINTER
        CJNE    R1,#0FFH,DEC_R  ;SEE IF OVERFLOWED
        DEC     R3              ;CHANGE THE HIGH BYTE
        RET                     ;EXIT
        ;
        ;***************************************************************
        ;
        ;TBYTE - TRANSFER A BYTE
        ;
        ;***************************************************************
        ;
TBYTE:  MOV     P2,R3           ;OUTPUT SOURCE REGISTER TO PORT
        MOVX    A,@R1           ;PUT BYTE IN ACC
        ;
TBR:    MOV     P2,R2           ;OUTPUT DESTINATION TO PORT
        MOVX    @R0,A           ;SAVE THE BYTE
        RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
        ;NMOV - R7:R6 = END ADDRESS - DPTR
        ;
        ;ACC GETS CLOBBERED
        ;
        ;***************************************************************
        ;
NMOV:   MOV     A,R4            ;THE LOW BYTE OF EOFA
        CLR     C               ;CLEAR THE CARRY FOR SUBB
        SUBB    A,DPL           ;SUBTRACT DATA POINTER LOW
        MOV     R6,A            ;PUT RESULT IN R6
        MOV     A,R5            ;HIGH BYTE OF EOFA
        SUBB    A,DPH           ;SUBTRACT DATA POINTER HIGH
        MOV     R7,A            ;PUT RESULT IN R7
        ORL     A,R6            ;SEE IF ZERO
NMOV1:  RET                     ;EXIT
        ;
        ;***************************************************************
        ;
        ;CHECK FOR A FILE OVERFLOW
        ;LEAVES THE NEW END ADDRESS IN R3:R1
        ;A HAS THE INCREASE IN SIZE
        ;
        ;***************************************************************
        ;
FULL:   ADD     A,R4            ;ADD A TO END ADDRESS
        MOV     R1,A            ;SAVE IT
        CLR     A
        ADDC    A,R5            ;ADD THE CARRY
        MOV     R3,A
        MOV     DPTR,#VARTOP    ;POINT AT VARTOP
        ;
FUL1:   CALL    DCMPX           ;COMPARE THE TWO
        JC      NMOV1           ;OUT OF ROOM
        ;
TB:     MOV     DPTR,#E5X       ;OUT OF MEMORY
        AJMP    FPTS
        ;
$EJECT
        ;***************************************************************
        ;
        ; PP - Preprocesses the line in IBUF back into IBUF
        ;      sets F0 if no line number
        ;      leaves the correct length of processed line in IBCNT
        ;      puts the line number in IBLN
        ;      wastes the text address TXAL and TXAH
        ;
        ;***************************************************************
        ;
PP:     ACALL   T_BUF           ;TXA GETS IBUF
        CALL    INTGER          ;SEE IF A NUMBER PRESENT
        CALL    TEMPD           ;SAVE THE INTEGER IN TEMP5:TEMP4
        MOV     F0,C            ;SAVE INTEGER IF PRESENT
        MOV     DPTR,#IBLN      ;SAVE THE LINE NUMBER, EVEN IF NONE
        ACALL   S20DP
        MOV     R0,TXAL         ;TEXT POINTER
        MOV     R1,#LOW IBUF    ;STORE POINTER
        ;
        ; Now process the line back into IBUF
        ;
PPL:    CLR     ARGF            ;FIRST PASS DESIGNATOR
        MOV     DPTR,#TOKTAB    ;POINT DPTR AT LOOK UP TABLE
        ;
PPL1:   MOV     R5B0,R0         ;SAVE THE READ POINTER
        CLR     A               ;ZERO A FOR LOOKUP
        MOVC    A,@A+DPTR       ;GET THE TOKEN
        MOV     R7,A            ;SAVE TOKEN IN CASE OF MATCH
        ;
PPL2:   MOVX    A,@R0           ;GET THE USER CHARACTER
        MOV     R3,A            ;SAVE FOR REM
        CJNE    A,#'a',PPL21
PPL21:  JC      PPX             ;CONVERT LOWER TO UPPER CASE
        CJNE    A,#('z'+1),PPL22
PPL22:  JNC     PPX
        CLR     ACC.5
        ;
PPX:    MOV     R2,A
        MOVX    @R0,A           ;SAVE UPPER CASE
        INC     DPTR            ;BUMP THE LOOKUP POINTER
        CLR     A
        MOVC    A,@A+DPTR
        CJNE    A,R2B0,PPL3     ;LEAVE IF NOT THE SAME
        INC     R0              ;BUMP THE USER POINTER
        SJMP    PPL2            ;CONTINUE TO LOOP
        ;
PPL3:   JB      ACC.7,PPL6      ;JUMP IF FOUND MATCH
        JZ      PPL6            ;USER MATCH
        ;
        ;
        ; Scan to the next TOKTAB entry
        ;
PPL4:   INC     DPTR            ;ADVANCE THE POINTER
        CLR     A               ;ZERO A FOR LOOKUP
        MOVC    A,@A+DPTR       ;LOAD A WITH TABLE
        JB      ACC.7,PPL41     ;KEEP SCANNING IF NOT A RESERVED WORD
        JNZ     PPL4
        INC     DPTR
        ;
        ; See if at the end of TOKTAB
        ;
PPL41:  MOV     R0,R5B0         ;RESTORE THE POINTER
        CJNE    A,#0FFH,PPL1    ;SEE IF END OF TABLE
        ;
        ; Character not in TOKTAB, so see what it is
        ;
        CJNE    R2,#' ',PPLX    ;SEE IF A SPACE
        INC     R0              ;BUMP USER POINTER
        SJMP    PPL             ;TRY AGAIN
        ;
PPLX:   JNB     XBIT,PPLY       ;EXTERNAL TRAP
        JB      ARGF,PPLY
        SETB    ARGF            ;SAYS THAT THE USER HAS TABLE
        LCALL   2078H           ;SET UP POINTER
        AJMP    PPL1
        ;
PPLY:   ACALL   PPL7            ;SAVE CHARACTER, EXIT IF A CR
        CJNE    A,#'"',PPL      ;SEE IF QUOTED STRING, START AGAIN IF NOT
        ;
        ; Just copy a quoted string
        ;
PPLY1:  ACALL   PPL7            ;SAVE THE CHARACTER, TEST FOR CR
        CJNE    A,#'"',PPLY1    ;IS THERE AN ENDQUOTE, IF NOT LOOP
        SJMP    PPL             ;DO IT AGAIN IF ENDQUOTE
        ;
PPL6:   MOV     A,R7            ;GET THE TOKEN
        ACALL   PPL91           ;SAVE THE TOKEN
        CJNE    A,#T_REM,PPL    ;SEE IF A REM TOKEN
        MOV     A,R3
        ACALL   PPL71           ;WASTE THE REM STATEMENT
PPL61:  ACALL   PPL7            ;LOOP UNTIL A CR
        SJMP    PPL61
        ;
PPL7:   MOVX    A,@R0           ;GET THE CHARACTER
PPL71:  CJNE    A,#CR,PPL9      ;FINISH IF A CR
        POP     R0B0            ;WASTE THE CALLING STACK
        POP     R0B0
        MOVX    @R1,A           ;SAVE CR IN MEMORY
        INC     R1              ;SAVE A TERMINATOR
        MOV     A,#EOF
        MOVX    @R1,A
        MOV     A,R1            ;SUBTRACT FOR LENGTH
        SUBB    A,#4
        MOV     TEMP3,A         ;SAVE LENGTH
        MOV     R1,#LOW IBCNT   ;POINT AT BUFFER COUNT
        ;
PPL9:   INC     R0
PPL91:  MOVX    @R1,A           ;SAVE THE CHARACTER
        INC     R1              ;BUMP THE POINTERS
        RET                     ;EXIT TO CALLING ROUTINE
        ;
        ;
        ;***************************************************************
        ;
        ;DEC76 - DECREMENT THE REGISTER PAIR R7:R6
        ;
        ;ACC = ZERO IF R7:R6 = ZERO ; ELSE ACC DOES NOT
        ;
        ;***************************************************************
        ;
DEC76:  DEC     R6              ;BUMP R6
        CJNE    R6,#0FFH,DEC77  ;SEE IF RAPPED AROUND
        DEC     R7
DEC77:  MOV     A,R7            ;SEE IF ZERO
        ORL     A,R6
        RET                     ;EXIT
        ;
        ;***************************************************************
        ;
        ; MTOP - Get or Put the top of assigned memory
        ;
        ;***************************************************************
        ;
PMTOP:  MOV     DPTR,#MEMTOP
PMTOP1: CALL    L20DPI
        AJMP    TWO_EY          ;PUT R2:R0 ON THE STACK
        ;
$EJECT
        ;*************************************************************
        ;
        ; AXTAL - Crystal value calculations
        ;
        ;*************************************************************
        ;
AXTAL0: MOV     DPTR,#XTALV     ;CRYSTAL VALUE
        ACALL   PUSHC
        ;
AXTAL1: ACALL   CSTAKA2         ;COPY CRYSTAL VALUE TWICE
        ACALL   CSTAKA
        MOV     DPTR,#PTIME     ;PROM TIMER
        ACALL   AXTAL2
        MOV     DPTR,#PROGS
        ACALL   S31L
        MOV     DPTR,#IPTIME    ;IPROM TIMER
        ACALL   AXTAL2
        MOV     DPTR,#IPROGS
        ACALL   S31L
        MOV     DPTR,#TTIME     ;CLOCK CALCULATION
        ACALL   AXTAL3
        MOV     A,R1
        CPL     A
        INC     A
        MOV     SAVE_T,A
        MOV     R3,#HIGH CXTAL
        MOV     R1,#LOW CXTAL
        JMP     POPAS
        ;
AXTAL2: ACALL   AXTAL3
        ;
CBIAS:  ;Bias the crystal calculations
        ;
        MOV     A,R1            ;GET THE LOW COUNT
        CPL     A               ;FLIP IT FOR TIMER LOAD
        ADD     A,#15           ;BIAS FOR CALL AND LOAD TIMES
        MOV     R1,A            ;RESTORE IT
        MOV     A,R3            ;GET THE HIGH COUNT
        CPL     A               ;FLIP IT
        ADDC    A,#00H          ;ADD THE CARRY
        MOV     R3,A            ;RESTORE IT
        RET
        ;
$EJECT
;$INCLUDE(:F2:BAS52.PWM)
;BEGINNING
        ;**************************************************************
        ;
STONE:  ; Toggle the I/O port
        ;
        ;**************************************************************
        ;
        CALL    THREE           ;GET THE NUMBERS
        ACALL   CBIAS           ;BIAS R3:R1 FOR COUNT LOOP
        ;
STONE1: CLR     T_BIT           ;TOGGLE THE BIT
        CLR     TR1             ;STOP THE TIMER
        MOV     TH1,R3          ;LOAD THE TIMER
        MOV     TL1,R1
        CLR     TF1             ;CLEAR THE OVERFLOW FLAG
        SETB    TR1             ;TURN IT ON
        ACALL   DEC76
        JNB     TF1,$           ;WAIT
        ACALL   ALPAR
        SETB    T_BIT           ;BACK TO A ONE
        CALL    TIMER_LOAD1     ;LOAD THE HIGH VALUE
        JNB     TF1,$           ;WAIT
        JNZ     STONE1          ;LOOP
        RET
        ;

;END
;$INCLUDE(:F2:BAS52.PWM)
$EJECT
        ;LNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLN
        ;
LNTAB:  ; Natural log lookup table
        ;
        ;LNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLNLN
        ;
        DB      80H
        DB      00H
        DB      71H
        DB      37H
        DB      13H
        DB      19H
        ;
        DB      7FH
        DB      00H
        DB      76H
        DB      64H
        DB      37H
        DB      94H
        ;
        DB      80H
        DB      00H
        DB      07H
        DB      22H
        DB      75H
        DB      17H
        ;
        DB      80H
        DB      00H
        DB      52H
        DB      35H
        DB      93H
        DB      28H
        ;
        DB      80H
        DB      00H
        DB      71H
        DB      91H
        DB      85H
        DB      86H
        ;
        DB      0FFH
        ;
        DB      81H
        DB      00H
        DB      51H
        DB      58H
        DB      02H
        DB      23H
        ;
$EJECT
        ;SINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSIN
        ;
SINTAB: ; Sin lookup table
        ;
        ;SINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSINSIN
        ;
        DB      128-9
        DB      00H
        DB      44H
        DB      90H
        DB      05H
        DB      16H
        ;
        DB      128-7
        DB      01H
        DB      08H
        DB      21H
        DB      05H
        DB      25H
        ;
        DB      128-5
        DB      00H
        DB      19H
        DB      73H
        DB      55H
        DB      27H
        ;
$EJECT
        ;
        DB      128-3
        DB      01H
        DB      70H
        DB      12H
        DB      84H
        DB      19H
        ;
        DB      128-2
        DB      00H
        DB      33H
        DB      33H
        DB      33H
        DB      83H
        ;
        DB      128
        DB      01H
        DB      67H
        DB      66H
        DB      66H
        DB      16H
        ;
FPONE:  DB      128+1
        DB      00H
        DB      00H
        DB      00H
        DB      00H
        DB      10H
        ;
        DB      0FFH            ;END OF TABLE
        ;
$EJECT
        ;
SBAUD:  CALL    AXTAL           ;PUT CRYSTAL ON THE STACK
        CALL    EXPRB           ;PUT THE NUMBER AFTER BAUD ON STACK
        MOV     A,#12
        ACALL   TWO_R2          ;TOS = 12
        ACALL   AMUL            ;TOS = 12*BAUD
        ACALL   ADIV            ;TOS = XTAL/(12*BAUD)
        ACALL   IFIX
        ACALL   CBIAS
        MOV     DPTR,#SPV
        ;
S31L:   JMP     S31DP
        ;
AFREE:  CALL    PMTOP           ;PUT MTOP ON STACK
        CALL    G4              ;GET END ADDRESS
        MOV     R0,DPL
        MOV     R2,DPH
        ACALL   TWO_EY
        ;
ASUB:   LCALL   FP_BASE1        ;DO FP SUB
        AJMP    FPTST
        ;
ALEN:   CALL    CCAL            ;CALCULATE THE LEN OF THE SELECTED PROGRAM
        MOV     R2,R7B0         ;SAVE THE HIGH BYTE
        MOV     A,R6            ;SAVE THE LOW BYTE
        AJMP    TWO_EX          ;PUT IT ON THE STACK
        ;
ATIME:  MOV     C,EA            ;SAVE INTERRUTS
        CLR     EA
        PUSH    MILLIV          ;SAVE MILLI VALUE
        MOV     R2,TVH          ;GET THE TIMER
        MOV     A,TVL
        MOV     EA,C            ;SAVE INTERRUPTS
        ACALL   TWO_EX          ;PUT TIMER ON THE STACK
        POP     ACC             ;GET MILLI
        ACALL   TWO_R2          ;PUT MILLI ON STACK
        MOV     A,#200
        ACALL   TWO_R2          ;DIVIDE MILLI BY 200
        ACALL   ADIV
        ;
AADD:   LCALL   FP_BASE         ;DO FP ADDITION
        AJMP    FPTST           ;CHECK FOR ERRORS
        ;
$EJECT
        ;**************************************************************
        ;
        ; Here are some error messages that were moved
        ;
        ;**************************************************************
        ;
        ;
E1X:    DB      'BAD SYNTAX"'
E2X:    DB      128+10
        DB      'DIVIDE BY ZERO"'
        ;
E6X:    DB      'ARRAY SIZE"'
        ;
$EJECT
        ;**************************************************************
        ;
T_BUF:  ; TXA gets IBUF
        ;
        ;**************************************************************
        ;
        MOV     TXAH,#HIGH IBUF
        MOV     TXAL,#LOW IBUF
        RET
        ;
        ;
        ;***************************************************************
        ;
CXFER:  ; Transfer a program from rom to ram
        ;
        ;***************************************************************
        ;
        CALL    CCAL            ;GET EVERYTHING SET UP
        MOV     R2,#HIGH PSTART
        MOV     R0,#LOW PSTART
        ACALL   LMOV            ;DO THE TRANSFER
        CALL    RCLEAR          ;CLEAR THE MEMORY
        ;
        ; Fall thru to CRAM
        ;
        ;***************************************************************
        ;
CRAM:   ; The command action routine - RAM - Run out of ram
        ;
        ;***************************************************************
        ;
        CLR     CONB            ;CAN'T CONTINUE IF MODE CHANGE
        MOV     BOFAH,#HIGH PSTART
        MOV     BOFAL,#LOW PSTART
        ;
        ; Fall thru to Command Processor
        ;
$EJECT
        ;***************************************************************
        ;
CMND1:  ; The entry point for the command processor
        ;
        ;***************************************************************
        ;
        LCALL   SPRINT1         ;WASTE AT AND HEX
        CLR     XBIT            ;TO RESET IF NEEDED
        CLR     A
        MOV     DPTR,#2002H     ;CHECK FOR EXTERNAL TRAP PACKAGE
        MOVC    A,@A+DPTR
        CJNE    A,#5AH,CMND11
        LCALL   2048H           ;IF PRESENT JUMP TO LOCATION 200BH
CMND11: MOV     DPTR,#RDYS      ;PRINT THE READY MESSAGE
        CALL    CRP             ;DO A CR, THEN, PRINT FROM THE ROM
        ;
CMNDR:  SETB    DIRF            ;SET THE DIRECT INPUT BIT
        MOV     SP,SPSAV        ;LOAD THE STACK
        ACALL   CL7             ;DO A CRLF
        ;
CMNX:   CLR     GTRD            ;CLEAR BREAK
        MOV     DPTR,#5EH       ;DO RUN TRAP
        MOVX    A,@DPTR
        XRL     A,#52
        JNZ     CMNX1
        LJMP    CRUN
CMNX1:  MOV     R5,#'>'         ;OUTPUT A PROMPT
        LCALL   TEROT
        CALL    INLINE          ;INPUT A LINE INTO IBUF
        CALL    PP              ;PRE-PROCESS THE LINE
        JB      F0,CMND3        ;NO LINE NUMBER
        CALL    LINE            ;PROCESS THE LINE
        LCALL   LCLR
        JB      LINEB,CMNX      ;DON'T CLEAR MEMORY IF NO NEED
        SETB    LINEB
        LCALL   RCLEAR          ;CLEAR THE MEMORY
        SJMP    CMNX            ;LOOP BACK
        ;
CMND3:  CALL    T_BUF           ;SET UP THE TEXT POINTER
        CALL    DELTST          ;GET THE CHARACTER
        JZ      CMNDR           ;IF CR, EXIT
        MOV     DPTR,#CMNDD     ;POINT AT THE COMMAND LOOKUP
        CJNE    A,#T_CMND,CMND31;PROCESS STATEMENT IF NOT A COMMAND
CMND31: JC      CMND5
        CALL    GCI1            ;BUMP TXA
        ANL     A,#0FH          ;STRIP MSB'S FOR LOOKUP
        LCALL   ISTA1           ;PROCESS COMMAND
        SJMP    CMNDR
        ;
CMND5:  LJMP    ILOOP           ;CHECK FOR A POSSIBLE BREAK
        ;
        ;
        ;
        ;CONSTANTS
        ;
XTALV:  DB      128+8           ; DEFAULT CRYSTAL VALUE
        DB      00H
        DB      00H
        DB      92H
        DB      05H
        DB      11H
        ;
EXP11:  DB      85H
        DB      00H
        DB      42H
        DB      41H
        DB      87H
        DB      59H
        ;
EXP1:   DB      128+1           ; EXP(1)
        DB      00H
        DB      18H
        DB      28H
        DB      18H
        DB      27H
        ;
IPTIME: DB      128-4           ;FPROG TIMING
        DB      00H
        DB      00H
        DB      00H
        DB      75H
        DB      83H
        ;
PIE:    DB      128+1           ;PI
        DB      00H
        DB      26H
        DB      59H
        DB      41H
        DB      31H             ; 3.1415926
        ;
$EJECT
        ;***************************************************************
        ;
        ; The error messages, some have been moved
        ;
        ;***************************************************************
        ;
E7X:    DB      128+30
        DB      'ARITH. UNDERFLOW"'
        ;
E5X:    DB      'MEMORY ALLOCATION"'
        ;
E3X:    DB      128+40
        DB      'BAD ARGUMENT"'
        ;
EXI:    DB      'I-STACK"'
        ;
$EJECT
        ;***************************************************************
        ;
        ; The command action routine - CONTINUE
        ;
        ;***************************************************************
        ;
CCONT:  MOV     DPTR,#E15X
        JNB     CONB,ERROR      ;ERROR IF CONTINUE IS NOT SET
        ;
CC1:    ;used for input statement entry
        ;
        MOV     TXAH,INTXAH     ;RESTORE TXA
        MOV     TXAL,INTXAL
        JMP     CILOOP          ;EXECUTE
        ;
DTEMP:  MOV     DPH,TEMP5       ;RESTORE DPTR
        MOV     DPL,TEMP4
        RET
        ;
TEMPD:  MOV     TEMP5,DPH
        MOV     TEMP4,DPL
        RET
        ;
$EJECT
        ;**************************************************************
        ;
I_DL:   ; IDLE
        ;
        ;**************************************************************
        ;
        JB      DIRF,E1XX       ;SYNTAX ERROR IN DIRECT INPUT
        CLR     DACK            ;ACK IDLE
        ;
U_ID1:  ORL     PCON,#01H
;       DB      01000011B       ;ORL DIRECT OP CODE
;       DB      87H             ;PCON ADDRESS
;       DB      01H             ;SET IDLE BIT
        JB      INTPEN,I_RET    ;EXIT IF EXTERNAL INTERRUPT
        JBC     U_IDL,I_RET     ;EXIT IF USER WANTS TO
        JNB     OTS,U_ID1       ;LOOP IF TIMER NOT ENABLED
        LCALL   T_CMP           ;CHECK THE TIMER
        JC      U_ID1           ;LOOP IF TIME NOT BIG ENOUGH
        ;
I_RET:  SETB    DACK            ;RESTORE EXECUTION
        RET                     ;EXIT IF IT IS
        ;
        ;
        ;
ER0:    INC     DPTR            ;BUMP TO TEXT
        JB      DIRF,ERROR0     ;CAN'T GET OUT OF DIRECT MODE
        JNB     ON_ERR,ERROR0   ;IF ON ERROR ISN'T SET, GO BACK
        MOV     DPTR,#ERRLOC    ;SAVE THE ERROR CODE
        CALL    RC2             ;SAVE ERROR AND SET UP THE STACKS
        INC     DPTR            ;POINT AT ERRNUM
        JMP     ERL4            ;LOAD ERR NUM AND EXIT
        ;
$EJECT
        ;
        ; Syntax error
        ;
E1XX:   MOV     C,DIRF          ;SEE IF IN DIRECT MODE
E1XX1:  MOV     DPTR,#E1X       ;ERROR MESSAGE
        SJMP    ERROR1          ;TRAP ON SET DIRF
        ;
E1XX2:  MOV     DPTR,#EXI       ;STACK ERROR
        ;
        ; Falls through
        ;
        ;***************************************************************
        ;
        ;ERROR PROCESSOR - PRINT OUT THE ERROR TYPE, CHECK TO SEE IF IN
        ;                  RUN OR COMMAND MODE, FIND AND PRINT OUT THE
        ;                  LINE NUMBER IF IN RUN MODE
        ;
        ;***************************************************************
        ;
ERROR:  CLR     C               ;RESET STACK
ERROR1: MOV     SP,SPSAV        ;RESET THE STACK
        LCALL   SPRINT1         ;CLEAR LINE AND AT MODE
        CLR     A               ;SET UP TO GET ERROR CODE
        MOVC    A,@A+DPTR
        JBC     ACC.7,ER0       ;PROCESS ERROR
        ;
ERROR0: ACALL   TEMPD           ;SAVE THE DATA POINTER
        JC      ERROR01         ;NO RESET IF CARRY IS SET
        LCALL   RC1             ;RESET THE STACKS
ERROR01:CALL    CRLF2           ;DO TWO CARRIAGE RET - LINE FEED
        MOV     DPTR,#ERS       ;OUTPUT ERROR MESSAGE
        CALL    ROM_P
        CALL    DTEMP           ;GET THE ERROR MESSAGE BACK
        ;
ERRS:   CALL    ROM_P           ;PRINT ERROR TYPE
        JNB     DIRF,ER1        ;DO NOT PRINT IN LINE IF DIRF=1
        ;
SERR1:  CLR     STOPBIT         ;PRINT STOP THEN EXIT, FOR LIST
        JMP     CMND1
        ;
ER1:    MOV     DPTR,#INS       ;OUTPUT IN LINE
        CALL    ROM_P
        ;
        ;NOW, FIND THE LINE NUMBER
        ;
        ;
$EJECT
        ;
        ;
        CALL    DP_B            ;GET THE FIRST ADDRESS OF THE PROGRAM
        CLR     A               ;FOR INITIALIZATION
        ;
ER2:    ACALL   TEMPD           ;SAVE THE DPTR
        CALL    ADDPTR          ;ADD ACC TO DPTR
        ACALL   ER4             ;R3:R1 = TXA-DPTR
        JC      ER3             ;EXIT IF DPTR>TXA
        JZ      ER3             ;EXIT IF DPTR=TXA
        MOVX    A,@DPTR         ;GET LENGTH
        CJNE    A,#EOF,ER2      ;SEE IF AT THE END
        ;
ER3:    ACALL   DTEMP           ;PUT THE LINE IN THE DPTR
        ACALL   ER4             ;R3:R1 = TXA - BEGINNING OF LINE
        MOV     A,R1            ;GET LENGTH
        ADD     A,#10           ;ADD 10 TO LENGTH, DPTR STILL HAS ADR
        MOV     MT1,A           ;SAVE THE COUNT
        INC     DPTR            ;POINT AT LINE NUMBER HIGH BYTE
        CALL    PMTOP1          ;LOAD R2:R0, PUT IT ON THE STACK
        ACALL   FP_BASE7        ;OUTPUT IT
        JB      STOPBIT,SERR1   ;EXIT IF STOP BIT SET
        CALL    CRLF2           ;DO SOME CRLF'S
        CALL    DTEMP
        CALL    UPPL            ;UNPROCESS THE LINE
        CALL    CL6             ;PRINT IT
ER31:   MOV     R5,#'-'         ;OUTPUT DASHES, THEN AN X
        ACALL   T_L             ;PRINT AN X IF ERROR CHARACTER FOUND
        DJNZ    MT1,ER31        ;LOOP UNTIL DONE
        MOV     R5,#'X'
        ACALL   T_L
        AJMP    SERR1
        ;
ER4:    MOV     R3,TXAH         ;GET TEXT POINTER AND PERFORM SUBTRACTION
        MOV     R1,TXAL
        JMP     DUBSUB
        ;
$EJECT
        ;**************************************************************
        ;
        ; Interrupt driven timer
        ;
        ;**************************************************************
        ;
I_DR:   MOV     TH0,SAVE_T      ;LOAD THE TIMER
        XCH     A,MILLIV        ;SAVE A, GET MILLI COUNTER
        INC     A               ;BUMP COUNTER
        CJNE    A,#200,TR       ;CHECK OUT TIMER VALUE
        CLR     A               ;FORCE ACC TO BE ZERO
        INC     TVL             ;INCREMENT LOW TIMER
        CJNE    A,TVL,TR        ;CHECK LOW VALUE
        INC     TVH             ;BUMP TIMER HIGH
        ;
TR:     XCH     A,MILLIV
        POP     PSW
        RETI
        ;
$EJECT
;$INCLUDE(:F2:BAS52.CLK)
;BEGINNING
        ;**************************************************************
        ;
        ; The statement action routine - CLOCK
        ;
        ;**************************************************************
        ;
SCLOCK: ACALL   OTST            ;GET CHARACTER AFTER CLOCK TOKEN
        CLR     ET0
        CLR     C_BIT
        JNC     SC_R            ;EXIT IF A ZERO
        ANL     TMOD,#0F0H      ;SET UP THE MODE
        SETB    C_BIT           ;USER INTERRUPTS
        ORL     IE,#82H         ;ENABLE ET0 AND EA
        SETB    TR0             ;TURN ON THE TIMER
        ;
SC_R:   RET
        ;

;END
;$INCLUDE(:F2:BAS52.CLK)
        ;***************************************************************
        ;
SUI:    ; Statement USER IN action routine
        ;
        ;***************************************************************
        ;
        ACALL   OTST
        MOV     CIUB,C          ;SET OR CLEAR CIUB
        RET
        ;
        ;***************************************************************
        ;
SUO:    ; Statement USER OUT action routine
        ;
        ;***************************************************************
        ;
        ACALL   OTST
        MOV     COUB,C
        RET
        ;
OTST:   ; Check for a one
        ;
        LCALL   GCI             ;GET THE CHARACTER, CLEARS CARRY
        SUBB    A,#'1'          ;SEE IF A ONE
        CPL     C               ;SETS CARRY IF ONE, CLEARS IT IF ZERO
OTST1:  RET
        ;
$EJECT
        ;**************************************************************
        ;
        ; IBLK - EXECUTE USER SUPPLIED TOKEN
        ;
        ;**************************************************************
        ;
IBLK:   JB      PSW.4,OTST1     ;EXIT IF REGISTER BANK <> 0
        JB      PSW.3,OTST1
        JBC     ACC.7,IBLK1     ;SEE IF BIT SEVEN IS SET
        MOV     DPTR,#USENT     ;USER ENTRY LOCATION
        LJMP    ISTA1
        ;
IBLK1:  JB      ACC.0,FP_BASE6  ;FLOATING POINT INPUT
        JZ      T_L             ;DO OUTPUT ON 80H
        MOV     DPTR,#FP_BASE-2
        JMP     @A+DPTR
        ;
        ;
        ;**************************************************************
        ;
        ; GET_NUM - GET A NUMBER, EITHER HEX OR FLOAT
        ;
        ;**************************************************************
        ;
GET_NUM:ACALL   FP_BASE5        ;SCAN FOR HEX
        JNC     FP_BASE6        ;DO FP INPUT
        ;
        ACALL   FP_BASE9        ;ASCII STRING TO R2:R0
        JNZ     H_RET
        PUSH    DPH             ;SAVE THE DATA_POINTER
        PUSH    DPL
        ACALL   FP_BASE12       ;PUT R2:R0 ON THE STACK
        POP     DPL             ;RESTORE THE DATA_POINTER
        POP     DPH
        CLR     A               ;NO ERRORS
        RET                     ;EXIT
        ;
$EJECT

        ; START OF BAUD RATE MODIFICATIONS BY DANIEL WALLNER
TIB1:MOV        ACC,TL2
        JB      ACC.3,TIB1
        CALL    DEC3211
TIB2:   MOV     ACC,TL2
        JNB     ACC.3,TIB2
        JNB     RXD,TIB1                ;16x12 CLOCKS, LOOP UNTIL DONE
        JB      RXD,$           ;WAIT FOR STOP CHARACTER TO END
        RET

        ;**************************************************************
        ;
        ; WB - THE EGO MESSAGE
        ;
        ;**************************************************************
        ;
WB:
;       DB      'W'+80H,'R'+80H
;       DB      'I'+80H,'T'+80H,'T','E'+80H,'N'+80H
;       DB      ' ','B'+80H,'Y'+80H,' '
;       DB      'J'+80H,'O'+80H,'H'+80H,'N'+80H,' '+80H
;       DB      'K','A'+80H,'T'+80H,'A'+80H,'U'+80H
;       DB      'S','K'+80H,'Y'+80H

        ; END OF BAUD RATE MODIFICATIONS BY DANIEL WALLNER

        DB      ', I','N'+80H,'T'+80H,'E'+80H,'L'+80H
        DB      ' '+80H,'C'+80H,'O'+80H,'R'+80H,'P'+80H
        DB      '. 1','9'+80H,'85'
H_RET:  RET
        ;
$EJECT
        ORG     1990H
        ;
OUTPUT:
T_L:    LJMP    TEROT
        ;
        ORG     1F78H
        ;
CKS_I:  JB      CKS_B,CS_I
        LJMP    401BH
        ;
CS_I:   LJMP    2088H
        ;
E14X:   DB      'NO DATA"'
        ;
E11X:   DB      128+20
        DB      'ARITH. OVERFLOW"'
        ;
E16X:   DB      'PROGRAMMING"'
        ;
E15X:   DB      'CAN'
        DB      27H
        DB      'T CONTINUE"'
        ;
E10X:   DB      'INVALID LINE NUMBER"'
        ;
NOROM:  DB      'PROM MODE"'
        ;
S_N:    DB      '*MCS-51(tm) BASIC V1.1*"'
        ;
        ORG     1FF8H
        ;
ERS:    DB      'ERROR: "'
        ;
$EJECT


;************************************************************
;
; This is a complete BCD floating point package for the 8051 micro-
; controller. It provides 8 digits of accuracy with exponents that
; range from +127 to -127. The mantissa is in packed BCD, while the
; exponent is expressed in pseudo-twos complement. A ZERO exponent
; is used to express the number ZERO. An exponent value of 80H or
; greater than means the exponent is positive, i.e. 80H = E 0,
; 81H = E+1, 82H = E+2 and so on. If the exponent is 7FH or less,
; the exponent is negative, 7FH = E-1, 7EH = E-2, and so on.
; ALL NUMBERS ARE ASSUMED TO BE NORMALIZED and all results are
; normalized after calculation. A normalized mantissa is >=.10 and
; <=.99999999.
;
; The numbers in memory assumed to be stored as follows:
;
; EXPONENT OF ARGUMENT 2   =   VALUE OF ARG_STACK+FP_NUMBER_SIZE
; SIGN OF ARGUMENT 2       =   VALUE OF ARG_STACK+FP_NUMBER_SIZE-1
; DIGIT 78 OF ARGUMENT 2   =   VALUE OF ARG_STACK+FP_NUMBER_SIZE-2
; DIGIT 56 OF ARGUMENT 2   =   VALUE OF ARG_STACK+FP_NUMBER_SIZE-3
; DIGIT 34 OF ARGUMENT 2   =   VALUE OF ARG_STACK+FP_NUMBER_SIZE-4
; DIGIT 12 OF ARGUMENT 2   =   VALUE OF ARG_STACK+FP_NUMBER_SIZE-5
;
; EXPONENT OF ARGUMENT 1   =   VALUE OF ARG_STACK
; SIGN OF ARGUMENT 1       =   VALUE OF ARG_STACK-1
; DIGIT 78 OF ARGUMENT 1   =   VALUE OF ARG_STACK-2
; DIGIT 56 OF ARGUMENT 1   =   VALUE OF ARG_STACK-3
; DIGIT 34 OF ARGUMENT 1   =   VALUE OF ARG_STACK-4
; DIGIT 12 OF ARGUMENT 1   =   VALUE OF ARG_STACK-5
;
; The operations are performed thusly:
;
; ARG_STACK+FP_NUMBER_SIZE = ARG_STACK+FP_NUMBER_SIZE # ARG_STACK
;
; Which is ARGUMENT 2 = ARGUMENT 2 # ARGUMENT 1
;
; Where # can be ADD, SUBTRACT, MULTIPLY OR DIVIDE.
;
; Note that the stack gets popped after an operation.
;
; The FP_COMP instruction POPS the ARG_STACK TWICE and returns status.
;
;**********************************************************************
;
$EJECT
;**********************************************************************
;
; STATUS ON RETURN - After performing an operation (+, -, *, /)
;                    the accumulator contains the following status
;
; ACCUMULATOR - BIT 0 - FLOATING POINT UNDERFLOW OCCURED
;
;             - BIT 1 - FLOATING POINT OVERFLOW OCCURED
;
;             - BIT 2 - RESULT WAS ZER0
;
;             - BIT 3 - DIVIDE BY ZERO ATTEMPTED
;
;             - BIT 4 - NOT USED, 0 RETURNED
;
;             - BIT 5 - NOT USED, 0 RETURNED
;
;             - BIT 6 - NOT USED, 0 RETURNED
;
;             - BIT 7 - NOT USED, 0 RETURNED
;
; NOTE: When underflow occures, a ZERO result is returned.
;       When overflow or divide by zero occures, a result of
;       .99999999 E+127 is returned and it is up to the user
;       to handle these conditions as needed in the program.
;
; NOTE: The Compare instruction returns F0 = 0 if ARG 1 = ARG 2
;       and returns a CARRY FLAG = 1 if ARG 1 is > ARG 2
;
;***********************************************************************
;
$EJECT
;***********************************************************************
;
; The following values MUST be provided by the user
;
;***********************************************************************
;
ARG_STACK       EQU     9       ;ARGUMENT STACK POINTER
ARG_STACK_PAGE  EQU     1
;OUTPUT          EQU     1990H   ;CALL LOCATION TO OUTPUT A CHARACTER
CONVERT         EQU     58H     ;LOCATION TO CONVERT NUMBERS
INTGRC          BIT     25      ;BIT SET IF INTGER ERROR
;
;***********************************************************************
;
; The following equates are used internally
;
;***********************************************************************
;
FP_NUMBER_SIZE  EQU     6
UNDERFLOW       EQU     0
OVERFLOW        EQU     1
ZERO            EQU     2
ZERO_DIVIDE     EQU     3
;
;***********************************************************************
$EJECT
        ;**************************************************************
        ;
        ; The following internal locations are used by the math pack
        ; ordering is important and the FP_DIGITS must be bit
        ; addressable
        ;
        ;***************************************************************
        ;
FP_STATUS       EQU     28H             ;NOT USED
FP_TEMP         EQU     FP_STATUS+1     ;NOT USED
FP_CARRY        EQU     FP_STATUS+2     ;USED FOR BITS
ADD_IN          BIT     35              ;DCMPXZ IN BASIC BACKAGE
XSIGN           BIT     FP_CARRY.0
FOUND_RADIX     BIT     FP_CARRY.1
FIRST_RADIX     BIT     FP_CARRY.2
DONE_LOAD       BIT     FP_CARRY.3
FP_DIG12        EQU     FP_CARRY+1
FP_DIG34        EQU     FP_CARRY+2
FP_DIG56        EQU     FP_CARRY+3
FP_DIG78        EQU     FP_CARRY+4
FP_SIGN         EQU     FP_CARRY+5
MSIGN           BIT     FP_SIGN.0
FP_EXP          EQU     FP_CARRY+6
FP_NIB1         EQU     FP_DIG12
FP_NIB2         EQU     FP_NIB1+1
FP_NIB3         EQU     FP_NIB1+2
FP_NIB4         EQU     FP_NIB1+3
FP_NIB5         EQU     FP_NIB1+4
FP_NIB6         EQU     FP_NIB1+5
FP_NIB7         EQU     FP_NIB1+6
FP_NIB8         EQU     FP_NIB1+7
FP_ACCX         EQU     FP_NIB1+8
FP_ACCC         EQU     FP_NIB1+9
FP_ACC1         EQU     FP_NIB1+10
FP_ACC2         EQU     FP_NIB1+11
FP_ACC3         EQU     FP_NIB1+12
FP_ACC4         EQU     FP_NIB1+13
FP_ACC5         EQU     FP_NIB1+14
FP_ACC6         EQU     FP_NIB1+15
FP_ACC7         EQU     FP_NIB1+16
FP_ACC8         EQU     FP_NIB1+17
FP_ACCS         EQU     FP_NIB1+18
        ;
$EJECT
        ORG     1993H
        ;
        ;**************************************************************
        ;
        ; The floating point entry points and jump table
        ;
        ;**************************************************************
        ;
FP_BASE:        AJMP    FLOATING_ADD
FP_BASE1:       AJMP    FLOATING_SUB
FP_BASE2:       AJMP    FLOATING_COMP
FP_BASE3:       AJMP    FLOATING_MUL
FP_BASE4:       AJMP    FLOATING_DIV
FP_BASE5:       AJMP    HEXSCAN
FP_BASE6:       AJMP    FLOATING_POINT_INPUT
FP_BASE7:       AJMP    FLOATING_POINT_OUTPUT
FP_BASE8:       AJMP    CONVERT_BINARY_TO_ASCII_STRING
FP_BASE9:       AJMP    CONVERT_ASCII_STRING_TO_BINARY
FP_BASE10:      AJMP    MULNUM10
FP_BASE11:      AJMP    HEXOUT
FP_BASE12:      AJMP    PUSHR2R0
        ;
$EJECT
        ;
FLOATING_SUB:
        ;
        MOV     P2,#ARG_STACK_PAGE
        MOV     R0,ARG_STACK
        DEC     R0              ;POINT TO SIGN
        MOVX    A,@R0           ;READ SIGN
        CPL     ACC.0
        MOVX    @R0,A
        ;
        ;AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        ;
FLOATING_ADD:
        ;
        ;AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        ;
        ;
        ACALL   MDES1           ;R7=TOS EXP, R6=TOS-1 EXP, R4=TOS SIGN
                                ;R3=TOS-1 SIGN, OPERATION IS R1 # R0
        ;
        MOV     A,R7            ;GET TOS EXPONENT 
        JZ      POP_AND_EXIT    ;IF TOS=0 THEN POP AND EXIT
        CJNE    R6,#0,LOAD1     ;CLEAR CARRY EXIT IF ZERO
        ;
        ;**************************************************************
        ;
SWAP_AND_EXIT:  ; Swap external args and return
        ;
        ;**************************************************************
        ;
        ACALL   LOAD_POINTERS
        MOV     R7,#FP_NUMBER_SIZE
        ;
SE1:    MOVX    A,@R0           ;SWAP THE ARGUMENTS
        MOVX    @R1,A
        DEC     R0
        DEC     R1
        DJNZ    R7,SE1
        ;
POP_AND_EXIT:
        ;
        MOV     A,ARG_STACK     ;POP THE STACK
        ADD     A,#FP_NUMBER_SIZE
        MOV     ARG_STACK,A
        CLR     A
        RET
        ;
        ;
LOAD1:  SUBB    A,R6            ;A = ARG 1 EXP - ARG 2 EXP
        MOV     FP_EXP,R7       ;SAVE EXPONENT AND SIGN
        MOV     FP_SIGN,R4
        JNC     LOAD2           ;ARG1 EXPONENT IS LARGER OR SAME
        MOV     FP_EXP,R6
        MOV     FP_SIGN,R3
        CPL     A
        INC     A               ;COMPENSATE FOR EXP DELTA
        XCH     A,R0            ;FORCE R0 TO POINT AT THE LARGEST
        XCH     A,R1            ;EXPONENT
        XCH     A,R0
        ;
LOAD2:  MOV     R7,A            ;SAVE THE EXPONENT DELTA IN R7
        CLR     ADD_IN
        CJNE    R5,#0,LOAD21
        SETB    ADD_IN
        ;
$EJECT
        ; Load the R1 mantissa
        ;
LOAD21: ACALL   LOADR1_MANTISSA ;LOAD THE SMALLEST NUMBER
        ;
        ; Now align the number to the delta exponent
        ; R4 points to the string of the last digits lost
        ;
        CJNE    R7,#DIGIT+DIGIT+3,LOAD22
LOAD22: JC      LOAD23
        MOV     R7,#DIGIT+DIGIT+2
        ;
LOAD23: MOV     FP_CARRY,#00    ;CLEAR THE CARRY
        ACALL   RIGHT           ;SHIFT THE NUMBER
        ;
        ; Set up for addition and subtraction
        ;
        MOV     R7,#DIGIT       ;LOOP COUNT
        MOV     R1,#FP_DIG78
        MOV     A,#9EH
        CLR     C
        SUBB    A,R4
        DA      A
        XCH     A,R4
        JNZ     LOAD24
        MOV     R4,A
LOAD24: CJNE    A,#50H,LOAD25   ;TEST FOR SUBTRACTION
LOAD25: JNB     ADD_IN,SUBLP    ;DO SUBTRACTION IF NO ADD_IN
        CPL     C               ;FLIP CARRY FOR ADDITION
        ACALL   ADDLP           ;DO ADDITION
        ;
        JNC     ADD_R
        INC     FP_CARRY
        MOV     R7,#1
        ACALL   RIGHT
        ACALL   INC_FP_EXP      ;SHIFT AND BUMP EXPONENT
        ;
ADD_R:  AJMP    STORE_ALIGN_TEST_AND_EXIT
        ;
ADDLP:  MOVX    A,@R0
        ADDC    A,@R1
        DA      A
        MOV     @R1,A
        DEC     R0
        DEC     R1
        DJNZ    R7,ADDLP        ;LOOP UNTIL DONE
        RET
        ;
$EJECT
        ;
SUBLP:  MOVX    A,@R0           ;NOW DO SUBTRACTION
        MOV     R6,A
        CLR     A
        ADDC    A,#99H
        SUBB    A,@R1
        ADD     A,R6
        DA      A
        MOV     @R1,A
        DEC     R0
        DEC     R1
        DJNZ    R7,SUBLP
        JC      FSUB6
        ;
$EJECT
        ;
        ; Need to complement the result and sign because the floating
        ; point accumulator mantissa was larger than the external
        ; memory and their signs were equal.
        ;
        CPL     FP_SIGN.0
        MOV     R1,#FP_DIG78
        MOV     R7,#DIGIT       ;LOOP COUNT
        ;
FSUB5:  MOV     A,#9AH
        SUBB    A,@R1
        ADD     A,#0
        DA      A
        MOV     @R1,A
        DEC     R1
        CPL     C
        DJNZ    R7,FSUB5        ;LOOP
        ;
        ; Now see how many zeros their are
        ;
FSUB6:  MOV     R0,#FP_DIG12
        MOV     R7,#0
        ;
FSUB7:  MOV     A,@R0
        JNZ     FSUB8
        INC     R7
        INC     R7
        INC     R0
        CJNE    R0,#FP_SIGN,FSUB7
        AJMP    ZERO_AND_EXIT
        ;
FSUB8:  CJNE    A,#10H,FSUB81
FSUB81: JNC     FSUB9
        INC     R7
        ;
        ; Now R7 has the number of leading zeros in the FP ACC
        ;
FSUB9:  MOV     A,FP_EXP        ;GET THE OLD EXPONENT
        CLR     C
        SUBB    A,R7            ;SUBTRACT FROM THE NUMBER OF ZEROS
        JZ      FSUB10
        JC      FSUB10
        ;
        MOV     FP_EXP,A        ;SAVE THE NEW EXPONENT
        ;
        ACALL   LEFT1           ;SHIFT THE FP ACC
        MOV     FP_CARRY,#0
        AJMP    STORE_ALIGN_TEST_AND_EXIT
        ;
FSUB10: AJMP    UNDERFLOW_AND_EXIT
        ;
$EJECT
        ;***************************************************************
        ;
FLOATING_COMP:  ; Compare two floating point numbers
                ; used for relational operations and is faster
                ; than subtraction. ON RETURN, The carry is set
                ; if ARG1 is > ARG2, else carry is not set
                ; if ARG1 = ARG2, F0 gets set
        ;
        ;***************************************************************
        ;
        ACALL   MDES1           ;SET UP THE REGISTERS
        MOV     A,ARG_STACK
        ADD     A,#FP_NUMBER_SIZE+FP_NUMBER_SIZE
        MOV     ARG_STACK,A     ;POP THE STACK TWICE, CLEAR THE CARRY
        MOV     A,R6            ;CHECK OUT EXPONENTS
        CLR     F0
        SUBB    A,R7
        JZ      EXPONENTS_EQUAL
        JC      ARG1_EXP_IS_LARGER
        ;
        ; Now the ARG2 EXPONENT is > ARG1 EXPONENT
        ;
SIGNS_DIFFERENT:
        ;
        MOV     A,R3            ;SEE IF SIGN OF ARG2 IS POSITIVE
        SJMP    ARG1_EXP_IS_LARGER1
        ;
ARG1_EXP_IS_LARGER:
        ;
        MOV     A,R4            ;GET THE SIGN OF ARG1 EXPONENT
ARG1_EXP_IS_LARGER1:
        JZ      ARG1_EXP_IS_LARGER2
        CPL     C
ARG1_EXP_IS_LARGER2:
        RET
        ;
EXPONENTS_EQUAL:
        ;
        ; First, test the sign, then the mantissa
        ;
        CJNE    R5,#0,SIGNS_DIFFERENT
        ;
BOTH_PLUS:
        ;
        MOV     R7,#DIGIT       ;POINT AT MS DIGIT
        DEC     R0
        DEC     R0
        DEC     R0
        DEC     R1
        DEC     R1
        DEC     R1
        ;
        ; Now do the compare
        ;
CLOOP:  MOVX    A,@R0
        MOV     R6,A
        MOVX    A,@R1
        SUBB    A,R6
        JNZ     ARG1_EXP_IS_LARGER
        INC     R0
        INC     R1
        DJNZ    R7,CLOOP
        ;
        ; If here, the numbers are the same, the carry is cleared
        ;
        SETB    F0
        RET                     ;EXIT WITH EQUAL
        ;
$EJECT
;MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
;
FLOATING_MUL:   ; Floating point multiply
;
;MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
;
        ACALL   MUL_DIV_EXP_AND_SIGN
        ;
        ; check for zero exponents
        ;
        CJNE    R6,#00,FMUL1    ;ARG 2 EXP ZERO?
FMUL0:  AJMP    ZERO_AND_EXIT
        ;
        ; calculate the exponent
        ;
FMUL1:  MOV     FP_SIGN,R5      ;SAVE THE SIGN, IN CASE OF FAILURE
        ;
        MOV     A,R7
        JZ      FMUL0
        ADD     A,R6            ;ADD THE EXPONENTS
        JB      ACC.7,FMUL_OVER
        JBC     CY,FMUL2        ;SEE IF CARRY IS SET
        ;
        AJMP    UNDERFLOW_AND_EXIT
        ;
FMUL_OVER:
        ;
        JNC     FMUL2           ;OK IF SET
        ;
FOV:    AJMP    OVERFLOW_AND_EXIT
        ;
FMUL2:  SUBB    A,#129          ;SUBTRACT THE EXPONENT BIAS
        MOV     R6,A            ;SAVE IT FOR LATER
        ;
        ; Unpack and load R0
        ;
        ACALL   UNPACK_R0
        ;
        ; Now set up for loop multiply
        ;
        MOV     R3,#DIGIT
        MOV     R4,R1B0
        ;
$EJECT
        ;
        ; Now, do the multiply and accumulate the product
        ;
FMUL3:  MOV     R1B0,R4
        MOVX    A,@R1
        MOV     R2,A
        ACALL   MUL_NIBBLE
        ;
        MOV     A,R2
        SWAP    A
        ACALL   MUL_NIBBLE
        DEC     R4
        DJNZ    R3,FMUL3
        ;
        ; Now, pack and restore the sign
        ;
        MOV     FP_EXP,R6
        MOV     FP_SIGN,R5
        AJMP    PACK            ;FINISH IT OFF
        ;
$EJECT
        ;DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
        ;
FLOATING_DIV:
        ;
        ;DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
        ;
        ACALL   MDES1
        ;
        ; Check the exponents
        ;
        MOV     FP_SIGN,R5      ;SAVE THE SIGN
        CJNE    R7,#0,DIV0      ;CLEARS THE CARRY
        ACALL   OVERFLOW_AND_EXIT
        CLR     A
        SETB    ACC.ZERO_DIVIDE
        RET
        ;
DIV0:   MOV     A,R6            ;GET EXPONENT
        JZ      FMUL0           ;EXIT IF ZERO
        SUBB    A,R7            ;DELTA EXPONENT
        JB      ACC.7,D_UNDER
        JNC     DIV3
        AJMP    UNDERFLOW_AND_EXIT
        ;
D_UNDER:JNC     FOV
        ;
DIV3:   ADD     A,#129          ;CORRECTLY BIAS THE EXPONENT
        MOV     FP_EXP,A        ;SAVE THE EXPONENT
        ACALL   LOADR1_MANTISSA ;LOAD THE DIVIDED
        ;
        MOV     R2,#FP_ACCC     ;SAVE LOCATION
        MOV     R3,R0B0         ;SAVE POINTER IN R3
        MOV     FP_CARRY,#0     ;ZERO CARRY BYTE
        ;
DIV4:   MOV     R5,#0FFH        ;LOOP COUNT
        SETB    C
        ;
DIV5:   MOV     R0B0,R3         ;RESTORE THE EXTERNAL POINTER
        MOV     R1,#FP_DIG78    ;SET UP INTERNAL POINTER
        MOV     R7,#DIGIT       ;LOOP COUNT
        JNC     DIV7            ;EXIT IF NO CARRY
        ;
DIV6:   MOVX    A,@R0           ;DO ACCUMLATION
        MOV     R6,A
        CLR     A
        ADDC    A,#99H
        SUBB    A,R6
        ADD     A,@R1
        DA      A
        MOV     @R1,A
        DEC     R0
        DEC     R1
        DJNZ    R7,DIV6         ;LOOP
        ;
        INC     R5              ;SUBTRACT COUNTER
        JC      DIV5            ;KEEP LOOPING IF CARRY
        MOV     A,@R1           ;GET CARRY
        SUBB    A,#1            ;CARRY IS CLEARED
        MOV     @R1,A           ;SAVE CARRY DIGIT
        CPL     C
        SJMP    DIV5            ;LOOP
        ;
        ; Restore the result if carry was found
        ;
DIV7:   ACALL   ADDLP           ;ADD NUMBER BACK
        MOV     @R1,#0          ;CLEAR CARRY
        MOV     R0B0,R2         ;GET SAVE COUNTER
        MOV     @R0,5           ;SAVE COUNT BYTE
        ;
        INC     R2              ;ADJUST SAVE COUNTER
        MOV     R7,#1           ;BUMP DIVIDEND
        ACALL   LEFT
        CJNE    R2,#FP_ACC8+2,DIV4
        ;
        DJNZ    FP_EXP,DIV8
        AJMP    UNDERFLOW_AND_EXIT
        ;
DIV8:   MOV     FP_CARRY,#0
        ;
$EJECT
        ;***************************************************************
        ;
PACK:   ; Pack the mantissa
        ;
        ;***************************************************************
        ;
        ; First, set up the pointers
        ;
        MOV     R0,#FP_ACCC
        MOV     A,@R0           ;GET FP_ACCC
        MOV     R6,A            ;SAVE FOR ZERO COUNT
        JZ      PACK0           ;JUMP OVER IF ZERO
        ACALL   INC_FP_EXP      ;BUMP THE EXPONENT
        DEC     R0
        ;
PACK0:  INC     R0              ;POINT AT FP_ACC1
        ;
PACK1:  MOV     A,#8            ;ADJUST NIBBLE POINTER
        MOV     R1,A
        ADD     A,R0
        MOV     R0,A
        CJNE    @R0,#5,PACK11   ;SEE IF ADJUSTING NEEDED
PACK11: JC      PACK31
        ;
PACK2:  SETB    C
        CLR     A
        DEC     R0
        ADDC    A,@R0
        DA      A
        XCHD    A,@R0           ;SAVE THE VALUE
        JNB     ACC.4,PACK3
        DJNZ    R1,PACK2
        ;
        DEC     R0
        MOV     @R0,#1
        ACALL   INC_FP_EXP
        SJMP    PACK4
        ;
PACK3:  DEC     R1
PACK31: MOV     A,R1
        CLR     C
        XCH     A,R0
        SUBB    A,R0
        MOV     R0,A
        ;
PACK4:  MOV     R1,#FP_DIG12
        ;
        ; Now, pack
        ;
PLOOP:  MOV     A,@R0
        SWAP    A               ;FLIP THE DIGITS
        INC     R0
        XCHD    A,@R0
        ORL     6,A             ;ACCUMULATE THE OR'ED DIGITS
        MOV     @R1,A
        INC     R0
        INC     R1
        CJNE    R1,#FP_SIGN,PLOOP
        MOV     A,R6
        JNZ     STORE_ALIGN_TEST_AND_EXIT
        MOV     FP_EXP,#0       ;ZERO EXPONENT
        ;
        ;**************************************************************
        ;
STORE_ALIGN_TEST_AND_EXIT:      ;Save the number align carry and exit
        ;
        ;**************************************************************
        ;
        ACALL   LOAD_POINTERS
        MOV     ARG_STACK,R1    ;SET UP THE NEW STACK
        MOV     R0,#FP_EXP
        ;
        ; Now load the numbers
        ;
STORE2: MOV     A,@R0
        MOVX    @R1,A           ;SAVE THE NUMBER
        DEC     R0
        DEC     R1
        CJNE    R0,#FP_CARRY,STORE2
        ;
        CLR     A               ;NO ERRORS
        ;
PRET:   RET                     ;EXIT
        ;
$EJECT
INC_FP_EXP:
        ;
        INC     FP_EXP
        MOV     A,FP_EXP
        JNZ     PRET            ;EXIT IF NOT ZERO
        POP     ACC             ;WASTE THE CALLING STACK
        POP     ACC
        AJMP    OVERFLOW_AND_EXIT
        ;
;***********************************************************************
;
UNPACK_R0:      ; Unpack BCD digits and load into nibble locations
;
;***********************************************************************
        ;
        PUSH    R1B0
        MOV     R1,#FP_NIB8
        ;
ULOOP:  MOVX    A,@R0
        ANL     A,#0FH
        MOV     @R1,A           ;SAVE THE NIBBLE
        MOVX    A,@R0
        SWAP    A
        ANL     A,#0FH
        DEC     R1
        MOV     @R1,A           ;SAVE THE NIBBLE AGAIN
        DEC     R0
        DEC     R1
        CJNE    R1,#FP_NIB1-1,ULOOP
        ;
        POP     R1B0
        ;
LOAD7:  RET
        ;
$EJECT
        ;**************************************************************
        ;
OVERFLOW_AND_EXIT:      ;LOAD 99999999 E+127,  SET OV BIT, AND EXIT
        ;
        ;**************************************************************
        ;
        MOV     R0,#FP_DIG78
        MOV     A,#99H
        ;
OVE1:   MOV     @R0,A
        DEC     R0
        CJNE    R0,#FP_CARRY,OVE1
        ;
        MOV     FP_EXP,#0FFH
        ACALL   STORE_ALIGN_TEST_AND_EXIT
        ;
        SETB    ACC.OVERFLOW
        RET
        ;
$EJECT
        ;**************************************************************
        ;
UNDERFLOW_AND_EXIT:     ;LOAD 0, SET UF BIT, AND EXIT
        ;
        ;**************************************************************
        ;
        ACALL   ZERO_AND_EXIT
        CLR     A
        SETB    ACC.UNDERFLOW
        RET
        ;
        ;**************************************************************
        ;
ZERO_AND_EXIT:          ;LOAD 0, SET ZERO BIT, AND EXIT
        ;
        ;**************************************************************
        ;
        ACALL   FP_CLEAR
        ACALL   STORE_ALIGN_TEST_AND_EXIT
        SETB    ACC.ZERO
        RET                     ;EXIT
        ;
        ;**************************************************************
        ;
FP_CLEAR:
        ;
        ; Clear internal storage
        ;
        ;**************************************************************
        ;
        CLR     A
        MOV     R0,#FP_ACC8+1
        ;
FPC1:   MOV     @R0,A
        DEC     R0
        CJNE    R0,#FP_TEMP,FPC1
        RET
        ;
$EJECT
        ;**************************************************************
        ;
RIGHT:  ; Shift ACCUMULATOR RIGHT the number of nibbles in R7
        ; Save the shifted values in R4 if SAVE_ROUND is set
        ;
        ;**************************************************************
        ;
        MOV     R4,#0           ;IN CASE OF NO SHIFT
        ;
RIGHT1: CLR     C
RIGHT2: MOV     A,R7            ;GET THE DIGITS TO SHIFT
        JZ      RIGHTL1         ;EXIT IF ZERO
        SUBB    A,#2            ;TWO TO DO?
        JNC     RIGHT5          ;SHIFT TWO NIBBLES
        ;
        ; Swap one nibble then exit
        ;
RIGHT3: PUSH    R0B0            ;SAVE POINTER REGISTER
        PUSH    R1B0
        ;
        MOV     R1,#FP_DIG78    ;LOAD THE POINTERS
        MOV     R0,#FP_DIG56
        MOV     A,R4            ;GET THE OVERFLOW REGISTER
        XCHD    A,@R1           ;GET DIGIT 8
        SWAP    A               ;FLIP FOR LOAD
        MOV     R4,A
        ;
RIGHTL: MOV     A,@R1           ;GET THE LOW ORDER BYTE
        XCHD    A,@R0           ;SWAP NIBBLES
        SWAP    A               ;FLIP FOR STORE
        MOV     @R1,A           ;SAVE THE DIGITS
        DEC     R0              ;BUMP THE POINTERS
        DEC     R1
        CJNE    R1,#FP_DIG12-1,RIGHTL   ;LOOP
        ;
        MOV     A,@R1           ;ACC = CH8
        SWAP    A               ;ACC = 8CH
        ANL     A,#0FH          ;ACC = 0CH
        MOV     @R1,A           ;CARRY DONE
        POP     R1B0            ;EXIT
        POP     R0B0            ;RESTORE REGISTER
RIGHTL1:RET
        ;
RIGHT5: MOV     R7,A            ;SAVE THE NEW SHIFT NUMBER
        CLR     A
        XCH     A,FP_CARRY      ;SWAP THE NIBBLES
        XCH     A,FP_DIG12
        XCH     A,FP_DIG34
        XCH     A,FP_DIG56
        XCH     A,FP_DIG78
        MOV     R4,A            ;SAVE THE LAST DIGIT SHIFTED
        SJMP    RIGHT2
        ;
$EJECT
        ;***************************************************************
        ;
LEFT:   ; Shift ACCUMULATOR LEFT the number of nibbles in R7
        ;
        ;***************************************************************
        ;
        MOV     R4,#00H         ;CLEAR FOR SOME ENTRYS
        ;
LEFT1:  CLR     C
LEFT2:  MOV     A,R7            ;GET SHIFT VALUE
        JZ      LEFTL1          ;EXIT IF ZERO
        SUBB    A,#2            ;SEE HOW MANY BYTES TO SHIFT
        JNC     LEFT5
        ;
LEFT3:  PUSH    R0B0            ;SAVE POINTER
        PUSH    R1B0
        MOV     R0,#FP_CARRY
        MOV     R1,#FP_DIG12
        ;
        MOV     A,@R0           ;ACC=CHCL
        SWAP    A               ;ACC = CLCH
        MOV     @R0,A           ;ACC = CLCH, @R0 = CLCH
        ;
LEFTL:  MOV     A,@R1           ;DIG 12
        SWAP    A               ;DIG 21
        XCHD    A,@R0
        MOV     @R1,A           ;SAVE IT
        INC     R0              ;BUMP POINTERS
        INC     R1
        CJNE    R0,#FP_DIG78,LEFTL
        ;
        MOV     A,R4
        SWAP    A
        XCHD    A,@R0
        ANL     A,#0F0H
        MOV     R4,A
        ;
        POP     R1B0
        POP     R0B0            ;RESTORE
LEFTL1: RET                     ;DONE
        ;
LEFT5:  MOV     R7,A            ;RESTORE COUNT
        CLR     A
        XCH     A,R4            ;GET THE RESTORATION BYTE
        XCH     A,FP_DIG78      ;DO THE SWAP
        XCH     A,FP_DIG56
        XCH     A,FP_DIG34
        XCH     A,FP_DIG12
        XCH     A,FP_CARRY
        SJMP    LEFT2
        ;
$EJECT
MUL_NIBBLE:
        ;
        ; Multiply the nibble in R7 by the FP_NIB locations
        ; accumulate the product in FP_ACC
        ;
        ; Set up the pointers for multiplication
        ;
        ANL     A,#0FH          ;STRIP OFF MS NIBBLE
        MOV     R7,A
        MOV     R0,#FP_ACC8
        MOV     R1,#FP_NIB8
        CLR     A
        MOV     FP_ACCX,A
        ;
MNLOOP: DEC     R0              ;BUMP POINTER TO PROPAGATE CARRY
        ADD     A,@R0           ;ATTEMPT TO FORCE CARRY
        DA      A               ;BCD ADJUST
        JNB     ACC.4,MNL0      ;DON'T ADJUST IF NO NEED
        DEC     R0              ;PROPAGATE CARRY TO THE NEXT DIGIT
        INC     @R0             ;DO THE ADJUSTING
        INC     R0              ;RESTORE R0
        ;
MNL0:   XCHD    A,@R0           ;RESTORE INITIAL NUMBER
        MOV     B,R7            ;GET THE NUBBLE TO MULTIPLY
        MOV     A,@R1           ;GET THE OTHER NIBBLE
        MUL     AB              ;DO THE MULTIPLY
        MOV     B,#10           ;NOW BCD ADJUST
        DIV     AB
        XCH     A,B             ;GET THE REMAINDER
        ADD     A,@R0           ;PROPAGATE THE PARTIAL PRODUCTS
        DA      A               ;BCD ADJUST
        JNB     ACC.4,MNL1      ;PROPAGATE PARTIAL PRODUCT CARRY
        INC     B
        ;
MNL1:   INC     R0
        XCHD    A,@R0           ;SAVE THE NEW PRODUCT
        DEC     R0
        MOV     A,B             ;GET BACK THE QUOTIENT
        DEC     R1
        CJNE    R1,#FP_NIB1-1,MNLOOP
        ;
        ADD     A,FP_ACCX       ;GET THE OVERFLOW
        DA      A               ;ADJUST
        MOV     @R0,A           ;SAVE IT
        RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
LOAD_POINTERS:  ; Load the ARG_STACK into R0 and bump R1
        ;
        ;***************************************************************
        ;
        MOV     P2,#ARG_STACK_PAGE
        MOV     R0,ARG_STACK
        MOV     A,#FP_NUMBER_SIZE
        ADD     A,R0
        MOV     R1,A
        RET
        ;
        ;***************************************************************
        ;
MUL_DIV_EXP_AND_SIGN:
        ;
        ; Load the sign into R7, R6. R5 gets the sign for
        ; multiply and divide.
        ;
        ;***************************************************************
        ;
        ACALL   FP_CLEAR        ;CLEAR INTERNAL MEMORY
        ;
MDES1:  ACALL   LOAD_POINTERS   ;LOAD REGISTERS
        MOVX    A,@R0           ;ARG 1 EXP
        MOV     R7,A            ;SAVED IN R7
        MOVX    A,@R1           ;ARG 2 EXP
        MOV     R6,A            ;SAVED IN R6
        DEC     R0              ;BUMP POINTERS TO SIGN
        DEC     R1
        MOVX    A,@R0           ;GET THE SIGN
        MOV     R4,A            ;SIGN OF ARG1
        MOVX    A,@R1           ;GET SIGN OF NEXT ARG
        MOV     R3,A            ;SIGN OF ARG2
        XRL     A,R4            ;ACC GETS THE NEW SIGN
        MOV     R5,A            ;R5 GETS THE NEW SIGN
        ;
        ; Bump the pointers to point at the LS digit
        ;
        DEC     R0
        DEC     R1
        ;
        RET
        ;
$EJECT
        ;***************************************************************
        ;
LOADR1_MANTISSA:
        ;
        ; Load the mantissa of R0 into FP_Digits
        ;
        ;***************************************************************
        ;
        PUSH    R0B0            ;SAVE REGISTER 1
        MOV     R0,#FP_DIG78    ;SET UP THE POINTER
        ;
LOADR1: MOVX    A,@R1
        MOV     @R0,A
        DEC     R1
        DEC     R0
        CJNE    R0,#FP_CARRY,LOADR1
        ;
        POP     R0B0
        RET
        ;
$EJECT
        ;***************************************************************
        ;
HEXSCAN:        ; Scan a string to determine if it is a hex number
                ; set carry if hex, else carry = 0
        ;
        ;***************************************************************
        ;
        ACALL   GET_DPTR_CHARACTER
        PUSH    DPH
        PUSH    DPL             ;SAVE THE POINTER
        ;
HEXSC1: MOVX    A,@DPTR         ;GET THE CHARACTER
        ACALL   DIGIT_CHECK     ;SEE IF A DIGIT
        JC      HS1             ;CONTINUE IF A DIGIT
        ACALL   HEX_CHECK       ;SEE IF HEX
        JC      HS1
        ;
        CLR     ACC.5           ;NO LOWER CASE
        CJNE    A,#'H',HEXDON
        SETB    C
        SJMP    HEXDO1          ;NUMBER IS VALID HEX, MAYBE
        ;
HEXDON: CLR     C
        ;
HEXDO1: POP     DPL             ;RESTORE POINTER
        POP     DPH
        RET
        ;
HS1:    INC     DPTR            ;BUMP TO NEXT CHARACTER
        SJMP    HEXSC1          ;LOOP
        ;
HEX_CHECK:      ;CHECK FOR A VALID ASCII HEX, SET CARRY IF FOUND
        ;
        CLR     ACC.5           ;WASTE LOWER CASE
        CJNE    A,#'F'+1,HEX_CHECK1     ;SEE IF F OR LESS
HEX_CHECK1:
        JC      HC1
        RET
        ;
HC1:    CJNE    A,#'A',HC11     ;SEE IF A OR GREATER
HC11:   CPL     C
        RET
        ;
$EJECT
        ;
PUSHR2R0:
        ; 
        MOV     R3,#HIGH CONVERT;CONVERSION LOCATION
        MOV     R1,#LOW CONVERT
        ACALL   CONVERT_BINARY_TO_ASCII_STRING
        MOV     A,#0DH          ;A CR TO TERMINATE
        MOVX    @R1,A           ;SAVE THE CR
        MOV     DPTR,#CONVERT
        ;
        ; Falls thru to FLOATING INPUT
        ;
$EJECT
        ;***************************************************************
        ;
FLOATING_POINT_INPUT:   ; Input a floating point number pointed to by
                        ; the DPTR
        ;
        ;***************************************************************
        ;
        ACALL   FP_CLEAR        ;CLEAR EVERYTHING
        ACALL   GET_DPTR_CHARACTER
        ACALL   PLUS_MINUS_TEST
        MOV     MSIGN,C         ;SAVE THE MANTISSA SIGN
        ;
        ; Now, set up for input loop
        ;
        MOV     R0,#FP_ACCC
        MOV     R6,#7FH         ;BASE EXPONENT
        SETB    F0              ;SET INITIAL FLAG
        ;
INLOOP: ACALL   GET_DIGIT_CHECK
        JNC     GTEST           ;IF NOT A CHARACTER, WHAT IS IT?
        ANL     A,#0FH          ;STRIP ASCII
        ACALL   STDIG           ;STORE THE DIGITS
        ;
INLPIK: INC     DPTR            ;BUMP POINTER FOR LOOP
        SJMP    INLOOP          ;LOOP FOR INPUT
        ;
GTEST:  CJNE    A,#'.',GT1      ;SEE IF A RADIX
        JB      FOUND_RADIX,INERR
        SETB    FOUND_RADIX
        CJNE    R0,#FP_ACCC,INLPIK
        SETB    FIRST_RADIX     ;SET IF FIRST RADIX
        SJMP    INLPIK          ;GET ADDITIONAL DIGITS
        ;
GT1:    JB      F0,INERR        ;ERROR IF NOT CLEARED
        CJNE    A,#'e',GT11     ;CHECK FOR LOWER CASE
        SJMP    GT12
GT11:   CJNE    A,#'E',FINISH_UP
GT12:   ACALL   INC_AND_GET_DPTR_CHARACTER
        ACALL   PLUS_MINUS_TEST
        MOV     XSIGN,C         ;SAVE SIGN STATUS
        ACALL   GET_DIGIT_CHECK
        JNC     INERR
        ;
        ANL     A,#0FH          ;STRIP ASCII BIAS OFF THE CHARACTER
        MOV     R5,A            ;SAVE THE CHARACTER IN R5
        ;
GT2:    INC     DPTR
        ACALL   GET_DIGIT_CHECK
        JNC     FINISH1
        ANL     A,#0FH          ;STRIP OFF BIAS
        XCH     A,R5            ;GET THE LAST DIGIT
        MOV     B,#10           ;MULTIPLY BY TEN
        MUL     AB
        ADD     A,R5            ;ADD TO ORIGINAL VALUE
        MOV     R5,A            ;SAVE IN R5
        JNC     GT2             ;LOOP IF NO CARRY
        MOV     R5,#0FFH        ;FORCE AN ERROR
        ;
FINISH1:MOV     A,R5            ;GET THE SIGN
        JNB     XSIGN,POSNUM    ;SEE IF EXPONENT IS POS OR NEG
        CLR     C
        SUBB    A,R6
        CPL     A
        INC     A
        JC      FINISH2
        MOV     A,#01H
        RET
        ;
POSNUM: ADD     A,R6            ;ADD TO EXPONENT
        JNC     FINISH2
        ;
POSNM1: MOV     A,#02H
        RET
        ;
FINISH2:XCH     A,R6            ;SAVE THE EXPONENT
        ;
FINISH_UP:
        ;
        MOV     FP_EXP,R6       ;SAVE EXPONENT
        CJNE    R0,#FP_ACCC,FINISH_UP1
        ACALL   FP_CLEAR        ;CLEAR THE MEMORY IF 0
FINISH_UP1:
        MOV     A,ARG_STACK     ;GET THE ARG STACK
        CLR     C
        SUBB    A,#FP_NUMBER_SIZE+FP_NUMBER_SIZE
        MOV     ARG_STACK,A     ;ADJUST FOR STORE
        AJMP    PACK
        ;
STDIG:  CLR     F0              ;CLEAR INITIAL DESIGNATOR
        JNZ     STDIG1          ;CONTINUE IF NOT ZERO
        CJNE    R0,#FP_ACCC,STDIG1
        JNB     FIRST_RADIX,RET_X
        ;
DECX:   DJNZ    R6,RET_X
        ;
INERR:  MOV     A,#0FFH
        ;
RET_X:  RET
        ;
STDIG1: JB      DONE_LOAD,FRTEST
        CLR     FIRST_RADIX
        ;
FRTEST: JB      FIRST_RADIX,DECX
        ;
FDTEST: JB      FOUND_RADIX,FDT1
        INC     R6
        ;
FDT1:   JB      DONE_LOAD,RET_X
        CJNE    R0,#FP_ACC8+1,FDT2
        SETB    DONE_LOAD
        ;
FDT2:   MOV     @R0,A           ;SAVE THE STRIPPED ACCUMULATOR
        INC     R0              ;BUMP THE POINTER
        RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
        ; I/O utilities
        ;
        ;***************************************************************
        ;
INC_AND_GET_DPTR_CHARACTER:
        ;
        INC     DPTR
        ;
GET_DPTR_CHARACTER:
        ;
        MOVX    A,@DPTR         ;GET THE CHARACTER
        CJNE    A,#' ',PMT1     ;SEE IF A SPACE
        ;
        ; Kill spaces
        ;
        SJMP    INC_AND_GET_DPTR_CHARACTER
        ;
PLUS_MINUS_TEST:
        ;
        CJNE    A,#0E3H,PMT11   ;SEE IF A PLUS, PLUS TOKEN FROM BASIC
        SJMP    PMT3
PMT11:  CJNE    A,#'+',PMT12
        SJMP    PMT3
PMT12:  CJNE    A,#0E5H,PMT13   ;SEE IF MINUS, MINUS TOKEN FROM BASIC
        SJMP    PMT2
PMT13:  CJNE    A,#'-',PMT1
        ;
PMT2:   SETB    C
        ;
PMT3:   INC     DPTR
        ;
PMT1:   RET
        ;
$EJECT
        ;***************************************************************
        ;
FLOATING_POINT_OUTPUT:  ; Output the number, format is in location 23
        ;
        ; IF FORMAT = 00 - FREE FLOATING
        ;           = FX - EXPONENTIAL (X IS THE NUMBER OF SIG DIGITS)
        ;           = NX - N = NUM BEFORE RADIX, X = NUM AFTER RADIX
        ;                  N + X = 8 MAX
        ;
        ;***************************************************************
        ;
        ACALL   MDES1           ;GET THE NUMBER TO OUTPUT, R0 IS POINTER
        ACALL   POP_AND_EXIT    ;OUTPUT POPS THE STACK
        MOV     A,R7
        MOV     R6,A            ;PUT THE EXPONENT IN R6
        ACALL   UNPACK_R0       ;UNPACK THE NUMBER
        MOV     R0,#FP_NIB1     ;POINT AT THE NUMBER
        MOV     A,FORMAT        ;GET THE FORMAT
        MOV     R3,A            ;SAVE IN CASE OF EXP FORMAT
        JZ      FREE            ;FREE FLOATING?
        CJNE    A,#0F0H,FPO1    ;SEE IF EXPONENTIAL
FPO1:   JNC     EXPOUT
        ;
        ; If here, must be integer USING format
        ;
        MOV     A,R6            ;GET THE EXPONENT
        JNZ     FPO2
        MOV     R6,#80H
FPO2:   MOV     A,R3            ;GET THE FORMAT
        SWAP    A               ;SPLIT INTEGER AND FRACTION
        ANL     A,#0FH
        MOV     R2,A            ;SAVE INTEGER
        ACALL   NUM_LT          ;GET THE NUMBER OF INTEGERS
        XCH     A,R2            ;FLIP FOR SUBB
        CLR     C
        SUBB    A,R2
        MOV     R7,A
        JNC     FPO3
        MOV     R5,#'?'         ;OUTPUT A QUESTION MARK
        ACALL   SOUT1           ;NUMBER IS TOO LARGE FOR FORMAT
        AJMP    FREE
FPO3:   CJNE    R2,#00,USING0   ;SEE IF ZERO
        DEC     R7
        ACALL   SS7
        ACALL   ZOUT            ;OUTPUT A ZERO
        SJMP    USING1
        ;
USING0: ACALL   SS7             ;OUTPUT SPACES, IF NEED TO
        MOV     A,R2            ;OUTPUT DIGITS
        MOV     R7,A
        ACALL   OUTR0
        ;
USING1: MOV     A,R3
        ANL     A,#0FH          ;GET THE NUMBER RIGHT OF DP
        MOV     R2,A            ;SAVE IT
        JZ      PMT1            ;EXIT IF ZERO
        ACALL   ROUT            ;OUTPUT DP
        ACALL   NUM_RT
        CJNE    A,2,USINGX      ;COMPARE A TO R2
        ;
USINGY: MOV     A,R2
        AJMP    Z7R7
        ;
USINGX: JNC     USINGY
        ;
USING2: XCH     A,R2
        CLR     C
        SUBB    A,R2
        XCH     A,R2
        ACALL   Z7R7            ;OUTPUT ZEROS IF NEED TO
        MOV     A,R2
        MOV     R7,A
        AJMP    OUTR0
        ;
        ; First, force exponential output, if need to
        ;
FREE:   MOV     A,R6            ;GET THE EXPONENT
        JNZ     FREE1           ;IF ZERO, PRINT IT
        ACALL   SOUT
        AJMP    ZOUT
        ;
FREE1:  MOV     R3,#0F0H        ;IN CASE EXP NEEDED
        MOV     A,#80H-DIGIT-DIGIT-1
        ADD     A,R6
        JC      EXPOUT
        SUBB    A,#0F7H
        JC      EXPOUT
        ;
        ; Now, just print the number
        ;
        ACALL   SINOUT          ;PRINT THE SIGN OF THE NUMBER
        ACALL   NUM_LT          ;GET THE NUMBER LEFT OF DP
        CJNE    A,#8,FREE4
        AJMP    OUTR0
        ;
FREE4:  ACALL   OUTR0
        ACALL   ZTEST           ;TEST FOR TRAILING ZEROS
        JZ      U_RET           ;DONE IF ALL TRAILING ZEROS
        ACALL   ROUT            ;OUTPUT RADIX
        ;
FREE2:  MOV     R7,#1           ;OUTPUT ONE DIGIT
        ACALL   OUTR0
        JNZ     U_RET
        ACALL   ZTEST
        JZ      U_RET
        SJMP    FREE2           ;LOOP
        ;
EXPOUT: ACALL   SINOUT          ;PRINT THE SIGN
        MOV     R7,#1           ;OUTPUT ONE CHARACTER
        ACALL   OUTR0
        ACALL   ROUT            ;OUTPUT RADIX
        MOV     A,R3            ;GET FORMAT
        ANL     A,#0FH          ;STRIP INDICATOR
        JZ      EXPOTX
        ;
        MOV     R7,A            ;OUTPUT THE NUMBER OF DIGITS
        DEC     R7              ;ADJUST BECAUSE ONE CHAR ALREADY OUT
        ACALL   OUTR0
        SJMP    EXPOT4
        ;
EXPOTX: ACALL   FREE2           ;OUTPUT UNTIL TRAILING ZEROS
        ;
EXPOT4: ACALL   SOUT            ;OUTPUT A SPACE
        MOV     R5,#'E'
        ACALL   SOUT1           ;OUTPUT AN E
        MOV     A,R6            ;GET THE EXPONENT
        JZ      XOUT0           ;EXIT IF ZERO
        DEC     A               ;ADJUST FOR THE DIGIT ALREADY OUTPUT
        CJNE    A,#80H,XOUT2    ;SEE WHAT IT IS
        ;
XOUT0:  ACALL   SOUT
        CLR     A
        SJMP    XOUT4
        ;
XOUT2:  JC      XOUT3           ;NEGATIVE EXPONENT
        MOV     R5,#'+'         ;OUTPUT A PLUS SIGN
        ACALL   SOUT1
        SJMP    XOUT4
        ;
XOUT3:  ACALL   MOUT
        CPL     A               ;FLIP BITS
        INC     A               ;BUMP
        ;
XOUT4:  CLR     ACC.7
        MOV     R0,A
        MOV     R2,#0
        MOV     R1,#LOW CONVERT ;CONVERSION LOCATION
        MOV     R3,#HIGH CONVERT
        ACALL   CONVERT_BINARY_TO_ASCII_STRING
        MOV     R0,#LOW CONVERT ;NOW, OUTPUT EXPONENT
        ;
EXPOT5: MOVX    A,@R0           ;GET THE CHARACTER
        MOV     R5,A            ;OUTPUT IT
        ACALL   SOUT1
        INC     R0              ;BUMP THE POINTER
        MOV     A,R0            ;GET THE POINTER
        CJNE    A,R1B0,EXPOT5   ;LOOP
        ;
U_RET:  RET                     ;EXIT
        ;
OUTR0:  ; Output the characters pointed to by R0, also bias ascii
        ;
        MOV     A,R7            ;GET THE COUNTER
        JZ      OUTR            ;EXIT IF DONE
        MOV     A,@R0           ;GET THE NUMBER
        ORL     A,#30H          ;ASCII BIAS
        INC     R0              ;BUMP POINTER AND COUNTER
        DEC     R7
        MOV     R5,A            ;PUT CHARACTER IN OUTPUT REGISTER
        ACALL   SOUT1           ;OUTPUT THE CHARACTER
        CLR     A               ;JUST FOR TEST
        CJNE    R0,#FP_NIB8+1,OUTR0
        MOV     A,#55H          ;KNOW WHERE EXIT OCCURED
        ;
OUTR:   RET
        ;
ZTEST:  MOV     R1,R0B0         ;GET POINTER REGISTER
        ;
ZT0:    MOV     A,@R1           ;GET THE VALUE
        JNZ     ZT1
        INC     R1              ;BUMP POINTER
        CJNE    R1,#FP_NIB8+1,ZT0
        ;
ZT1:    RET
        ;
NUM_LT: MOV     A,R6            ;GET EXPONENT
        CLR     C               ;GET READY FOR SUBB
        SUBB    A,#80H          ;SUB EXPONENT BIAS
        JNC     NL1             ;OK IF NO CARRY
        CLR     A               ;NO DIGITS LEFT
        ;
NL1:    MOV     R7,A            ;SAVE THE COUNT
        RET
        ;
NUM_RT: CLR     C               ;SUBB AGAIN
        MOV     A,#80H          ;EXPONENT BIAS
        SUBB    A,R6            ;GET THE BIASED EXPONENT
        JNC     NR1
        CLR     A
        ;
NR1:    RET                     ;EXIT
        ;
SPACE7: MOV     A,R7            ;GET THE NUMBER OF SPACES
        JZ      NR1             ;EXIT IF ZERO
        ACALL   SOUT            ;OUTPUT A SPACE
        DEC     R7              ;BUMP COUNTER
        SJMP    SPACE7          ;LOOP
        ;
Z7R7:   MOV     R7,A
        ;
ZERO7:  MOV     A,R7            ;GET COUNTER
        JZ      NR1             ;EXIT IF ZERO
        ACALL   ZOUT            ;OUTPUT A ZERO
        DEC     R7              ;BUMP COUNTER
        SJMP    ZERO7           ;LOOP
        ;
SS7:    ACALL   SPACE7
        ;
SINOUT: MOV     A,R4            ;GET THE SIGN
        JZ      SOUT            ;OUTPUT A SPACE IF ZERO
        ;
MOUT:   MOV     R5,#'-'
        SJMP    SOUT1           ;OUTPUT A MINUS IF NOT
        ;
ROUT:   MOV     R5,#'.'         ;OUTPUT A RADIX
        SJMP    SOUT1
        ;
ZOUT:   MOV     R5,#'0'         ;OUTPUT A ZERO
        SJMP    SOUT1
        ;
SOUT:   MOV     R5,#' '         ;OUTPUT A SPACE
        ;
SOUT1:  AJMP    OUTPUT
        ;
$EJECT
        ;***************************************************************
        ;
CONVERT_ASCII_STRING_TO_BINARY:
        ;
        ;DPTR POINTS TO ASCII STRING
        ;PUT THE BINARY NUMBER IN R2:R0, ERROR IF >64K
        ;
        ;***************************************************************
        ;
CASB:   ACALL   HEXSCAN         ;SEE IF HEX NUMBER
        MOV     ADD_IN,C        ;IF ADD_IN IS SET, THE NUMBER IS HEX
        ACALL   GET_DIGIT_CHECK
        CPL     C               ;FLIP FOR EXIT
        JC      RCASB
        MOV     R3,#00H         ;ZERO R3:R1 FOR LOOP
        MOV     R1,#00H
        SJMP    CASB5
        ;
CASB2:  INC     DPTR
        MOV     R0B0,R1         ;SAVE THE PRESENT CONVERTED VALUE
        MOV     R2B0,R3         ;IN R2:R0
        ACALL   GET_DIGIT_CHECK
        JC      CASB5
        JNB     ADD_IN,RCASB    ;CONVERSION COMPLETE
        ACALL   HEX_CHECK       ;SEE IF HEX NUMBER
        JC      CASB4           ;PROCEED IF GOOD
        INC     DPTR            ;BUMP PAST H
        SJMP    RCASB
        ;
CASB4:  ADD     A,#9            ;ADJUST HEX ASCII BIAS
        ;
CASB5:  MOV     B,#10
        JNB     ADD_IN,CASB6
        MOV     B,#16           ;HEX MODE
        ;
CASB6:  ACALL   MULNUM          ;ACCUMULATE THE DIGITS
        JNC     CASB2           ;LOOP IF NO CARRY
        ;
RCASB:  CLR     A               ;RESET ACC
        MOV     ACC.OVERFLOW,C  ;IF OVERFLOW, SAY SO
        RET                     ;EXIT
        ;
$EJECT
        ;
MULNUM10:MOV    B,#10
        ;
        ;***************************************************************
        ;
MULNUM: ; Take the next digit in the acc (masked to 0FH)
        ; accumulate in R3:R1
        ;
        ;***************************************************************
        ;
        PUSH    ACC             ;SAVE ACC
        PUSH    B               ;SAVE MULTIPLIER
        MOV     A,R1            ;PUT LOW ORDER BITS IN ACC
        MUL     AB              ;DO THE MULTIPLY
        MOV     R1,A            ;PUT THE RESULT BACK
        MOV     A,R3            ;GET THE HIGH ORDER BYTE
        MOV     R3,B            ;SAVE THE OVERFLOW
        POP     B               ;GET THE MULTIPLIER
        MUL     AB              ;DO IT
        MOV     C,OV            ;SAVE OVERFLOW IN F0
        MOV     F0,C
        ADD     A,R3            ;ADD OVERFLOW TO HIGH RESULT
        MOV     R3,A            ;PUT IT BACK
        POP     ACC             ;GET THE ORIGINAL ACC BACK
        ORL     C,F0            ;OR CARRY AND OVERFLOW
        JC      MULX            ;NO GOOD IF THE CARRY IS SET
        ;
MUL11:  ANL     A,#0FH          ;MASK OFF HIGH ORDER BITS
        ADD     A,R1            ;NOW ADD THE ACC
        MOV     R1,A            ;PUT IT BACK
        CLR     A               ;PROPAGATE THE CARRY
        ADDC    A,R3
        MOV     R3,A            ;PUT IT BACK
        ;
MULX:   RET                     ;EXIT WITH OR WITHOUT CARRY
        ;
        ;***************************************************************
        ;
CONVERT_BINARY_TO_ASCII_STRING:
        ;
        ;R3:R1 contains the address of the string
        ;R2:R0 contains the value to convert
        ;DPTR, R7, R6, and ACC gets clobbered
        ;
        ;***************************************************************
        ;
        CLR     A               ;NO LEADING ZEROS
        MOV     DPTR,#10000     ;SUBTRACT 10000
        ACALL   RSUB            ;DO THE SUBTRACTION
        MOV     DPTR,#1000      ;NOW 1000
        ACALL   RSUB
        MOV     DPTR,#100       ;NOW 100
        ACALL   RSUB
        MOV     DPTR,#10        ;NOW 10
        ACALL   RSUB
        MOV     DPTR,#1         ;NOW 1
        ACALL   RSUB
        JZ      RSUB2           ;JUMP OVER RET
        ;
RSUB_R: RET
        ;
RSUB:   MOV     R6,#-1          ;SET UP THE COUNTER
        ;
RSUB1:  INC     R6              ;BUMP THE COUNTER
        XCH     A,R2            ;DO A FAST COMPARE
        CJNE    A,DPH,RSUB11
RSUB11: XCH     A,R2
        JC      FAST_DONE
        XCH     A,R0            ;GET LOW BYTE
        SUBB    A,DPL           ;SUBTRACT, CARRY IS CLEARED
        XCH     A,R0            ;PUT IT BACK
        XCH     A,R2            ;GET THE HIGH BYTE
        SUBB    A,DPH           ;ADD THE HIGH BYTE
        XCH     A,R2            ;PUT IT BACK
        JNC     RSUB1           ;LOOP UNTIL CARRY
        ;
        XCH     A,R0
        ADD     A,DPL           ;RESTORE R2:R0
        XCH     A,R0
        XCH     A,R2
        ADDC    A,DPH
        XCH     A,R2
        ;
FAST_DONE:
        ;
        ORL     A,R6            ;OR THE COUNT VALUE
        JZ      RSUB_R          ;RETURN IF ZERO
        ;
RSUB2:  MOV     A,#'0'          ;GET THE ASCII BIAS
        ADD     A,R6            ;ADD THE COUNT
        ;
RSUB4:  MOV     P2,R3           ;SET UP P2
        MOVX    @R1,A           ;PLACE THE VALUE IN MEMORY
        INC     R1
        CJNE    R1,#00H,RSUB3   ;SEE IF RAPPED AROUND
        INC     R3              ;BUMP HIGH BYTE
        ;
RSUB3:  RET                     ;EXIT
        ;
$EJECT
        ;***************************************************************
        ;
HEXOUT: ; Output the hex number in R3:R1, supress leading zeros, if set
        ;
        ;***************************************************************
        ;
        ACALL   SOUT            ;OUTPUT A SPACE
        MOV     C,ZSURP         ;GET ZERO SUPPRESSION BIT
        MOV     ADD_IN,C
        MOV     A,R3            ;GET HIGH NIBBLE AND PRINT IT
        ACALL   HOUTHI
        MOV     A,R3
        ACALL   HOUTLO
        ;
HEX2X:  CLR     ADD_IN          ;DON'T SUPPRESS ZEROS
        MOV     A,R1            ;GET LOW NIBBLE AND PRINT IT
        ACALL   HOUTHI
        MOV     A,R1
        ACALL   HOUTLO
        MOV     R5,#'H'         ;OUTPUT H TO INDICATE HEX MODE
        ;
SOUT_1: AJMP    SOUT1
        ;
HOUT1:  CLR     ADD_IN          ;PRINTED SOMETHING, SO CLEAR ADD_IN
        ADD     A,#90H          ;CONVERT TO ASCII
        DA      A
        ADDC    A,#40H
        DA      A               ;GOT IT HERE
        MOV     R5,A            ;OUTPUT THE BYTE
        SJMP    SOUT_1
        ;
HOUTHI: SWAP    A               ;SWAP TO OUTPUT HIGH NIBBLE
        ;
HOUTLO: ANL     A,#0FH          ;STRIP
        JNZ     HOUT1           ;PRINT IF NOT ZERO
        JNB     ADD_IN,HOUT1    ;OUTPUT A ZERO IF NOT SUPRESSED
        RET
        ;
$EJECT
        ORG     1FEBH           ;FOR LINK COMPATABILITY
        ;
        ;
GET_DIGIT_CHECK:        ; Get a character, then check for digit
        ;
        ACALL   GET_DPTR_CHARACTER
        ;
DIGIT_CHECK:    ;CHECK FOR A VALID ASCII DIGIT, SET CARRY IF FOUND
        ;
        CJNE    A,#'9'+1,DC10   ;SEE IF ASCII 9 OR LESS
DC10:   JC      DC1
        RET
        ;
DC1:    CJNE    A,#'0',DC11     ;SEE IF ASCII 0 OR GREATER
DC11:   CPL     C
        RET
        ;
        ;***************************************************************
        ;
        XSEG    ;External Ram
        ;
        ;***************************************************************
        ;
        DS      4
IBCNT:  DS      1               ;LENGTH OF A LINE
IBLN:   DS      2               ;THE LINE NUMBER
IBUF:   DS      LINLEN          ;THE INPUT BUFFER
CONVT:  DS      15              ;CONVERSION LOCATION FOR FPIN
        ;
        ORG     100H
        ;
GTB:    DS      1               ;GET LOCATION
ERRLOC: DS      1               ;ERROR TYPE
ERRNUM: DS      2               ;WHERE TO GO ON AN ERROR
VARTOP: DS      2               ;TOP OF VARIABLE STORAGE
ST_ALL: DS      2               ;STORAGE ALLOCATION
MT_ALL: DS      2               ;MATRIX ALLOCATION
MEMTOP: DS      2               ;TOP OF MEMORY
RCELL:  DS      2               ;RANDOM NUMBER CELL
        DS      FPSIZ-1
CXTAL:  DS      1               ;CRYSTAL
        DS      FPSIZ-1
FPT1:   DS      1               ;FLOATINP POINT TEMP 1
        DS      FPSIZ-1
FPT2:   DS      1               ;FLOATING POINT TEMP 2
INTLOC: DS      2               ;LOCATION TO GO TO ON INTERRUPT
STR_AL: DS      2               ;STRING ALLOCATION
SPV:    DS      2               ;SERIAL PORT BAUD RATE
TIV:    DS      2               ;TIMER INTERRUPT NUM AND LOC
PROGS:  DS      2               ;PROGRAM A PROM TIME OUT
IPROGS: DS      2               ;INTELLIGENT PROM PROGRAMMER TIMEOUT
TM_TOP: DS      1

        END