         PAGE  *****  C O N T R O L  *****
;        "BASIC" SYSCALL SUBROUTINE INTERFACE
;
XOPSYSCALL1ARG EQU                     ; *
         TSX    
         BSR   SYSCALLCHOOSESCBLK
         CLR   SCBLK:WRLEN,X           ; ZERO THE WRITE BUFFER LENGTH
         CLR   SCBLK:WRLEN+1,X
SYSCALL1OR2ARG EQU                     ; *
         CLR   SCBLK:RDLEN,X           ; NO REPLY BUFFER, MAKE ITS LENGTH ZERO
         CLR   SCBLK:RDLEN+1,X
         lhld  #0
         shld  SYSCALLSTRHEADPTR
SYSCALLDOIT    EQU                     ; *
         lhld  TEMPX                   ; NOW CLEAN OFF THE STACK
         TXS    
         lhld  SYSCALLBLOCKPTR
         CLR   SCBLK:RPLEN,X           ; ZERO THE REPLY LENGTH IN CASE 
         CLR   SCBLK:RPLEN+1,X         ; SDOS DOESN'T SET IT
         LDA   SCBLK:PARAMS,X          ; SAVE CHANNEL # GIVEN IN OPCODE STRING
         STA   TBYTE
         LDA   CHANEL                  ; IS CHANNEL SELECTED <>0?
         jrz   SYSCALLDOIT0
         STA   SCBLK:PARAMS,X
SYSCALLDOIT0   call                    ; SYSCALL$
         jrc   SYSCALLDOIT1            ; B/ ERROR OCCURRED
         lhld  #0                      ; NO ERROR, PICK UP APPROPRIATE ERROR CODE
SYSCALLDOIT1   EQU                     ; *
         shld  TEMPX                   ; SAVE THE ERROR CODE TEMPORARILY
         lhld  SYSCALLBLOCKPTR         ; SET REPLY BUFFER LENGTH
         LDD   SCBLK:RPLEN,X
         lhld  SYSCALLSTRHEADPTR       ; WAS REPLY BUFFER A STRING OR SUBSTRING ?
         jrz   SYSCALLDOIT2            ; B/ WAS SUBSTRING, CAN'T SET "LEN"
         STD   CURLEN,X                ; SET LEN(READBUFFER$) TO REPLY LENGTH
SYSCALLDOIT2   EQU                     ; *
         lhld  SYSCALLBLOCKPTR         ; RESTORE CHANNEL # BYTE TO ORIGINAL VALUE
         LDA   TBYTE
         STA   SCBLK:PARAMS,X
         LDD   TEMPX                   ; ...
         BNED  SYSCALLDOIT4
         JMP   PL1PC1                  ; ALL IS OK!
SYSCALLDOIT4   EQU                     ; *
         JMP   IOERROR                 ; TO THE "BASIC" ERROR HANDLER ENTRY POINT
         PAGE    
SYSCALLCHOOSESCBLK                     ; EQU *
         call  SYSCALLGETSTRING        ; DETERMINE SIZE AND LOCATION OF SYSCALL OPCODE
         CMPD  #SCBLK:DATA             ; IS USER STRING LARGE ENOUGH ?
         BCC   SYSCALLCHOOSE1          ; B/ YEP, USE IT DIRECTLY
         LDD   ,X                      ; NO, GRAB CRITICAL 4 BYTES OF SYSCALL
         lhld  2,X
         STD   SYSCALLBLOCK            ; AND SAVE IN WORKING TEMP
         shld  SYSCALLBLOCK+2
         lhld  #SYSCALLBLOCK           ; REMEMBER WHERE WORKING STRING IS GOING TO BE
SYSCALLCHOOSE1 EQU                     ; * REMEMBER SYSCALL BLOCK ADDRESS
         shld  SYSCALLBLOCKPTR
         ret

SSB13J   JMP   SSB13

XOPSYSCALL4ARG EQU                     ; *
         call  RNDTOS                  ; B/ NOT AN INT --> SUBSCRIPT OUT OF RANGE!
         DW    SSB13                   ; GET READ-BACK BUFFER MAX LENGTH
         STD   TWORD
         TSX                           ; SET UP RDBUF POINTER
         BSR   SYSCALLGETRDBUF         ; GET READ BUFFER ADDRESS AND SIZE
         CMPD  TWORD                   ; CHECK GIVEN LENGTH AGAINST MAX
         jrc   SSB13J                  ; B/ GIVEN > STRLENGTH!
         LDD   TWORD                   ; OK, GIVEN VALUE IS LEGAL SO USE IT!
         jr    SYSCALL3ARGA            ; GO FINISH THE SYSCALL
         PAGE    
XOPSYSCALL3ARG EQU                     ; *
         TSX    
         BSR   SYSCALLGETRDBUF         ; GET READ BUFFER ADDRESS AND SIZE
SYSCALL3ARGA   EQU                     ; * (A,B) = READ BUFFER MAX LENGTH
         STD   SYSCALLRDLEN
         BSR   SYSCALLGETNEXTSTRING    ; = WRBUF DESCRIPTOR
         BSR   SYSCALLGETWRBUF1        ; AND SAVE THE PARAMETERS
         lhld  TEMPX
         LEAX  RSESIZ,X
         BSR   SYSCALLCHOOSESCBLK      ; DECIDE WHERE SCBLK IS GOING TO BE
         BSR   SYSCALLSETUPRDBUF       ; STUFF IN RDBUF PARAMS
         BSR   SYSCALLSETUPWRBUF       ; STUFF IN WRBUF PARAMS
         JMP   SYSCALLDOIT             ; YOU GUESS!!
         PAGE    
SYSCALLGETRDBUF                        ; EQU *
         shld  TEMPX                   ; DETERMINE SIZE AND LOCATION OF RDBUF
         LDD   4,X                     ; GET SIZE OF RDBUF STRING
         lhld  2,X                     ; AND ITS LOCATION
         CLR   SYSCALLSTRHEADPTR       ; ASSUME REFERENCE TO SUBSTRING
         CLR   SYSCALLSTRHEADPTR+1
         CMPD  #$FFFF                  ; REFERENCE TO "WHOLE STRING" ?
         jrnz  SYSCALLGETRDBUF1        ; B/ NO
         shld  SYSCALLSTRHEADPTR       ; YES, SAVE POINTER TO HEAD OF STRING
         LDD   MAXLEN,X                ; USE STRING DIMENSION AS MAX READ SIZE
SYSCALLGETRDBUF1                       ; EQU *
         LEAX  STRING,X
         shld  SYSCALLRDBUF            ; SAVPOINTER TO REPLY BUFFER AREA
         ret

SYSCALLSETUPRDBUF                      ; EQU * (X)=SYSCALLBLKPTR
         LDD   SYSCALLRDBUF
         STD   SCBLK:RDBUF,X
         LDD   SYSCALLRDLEN
         STD   SCBLK:RDLEN,X
         ret
         PAGE    
SYSCALLGETNEXTSTRING                   ; EQU *
         lhld  TEMPX
         LEAX  RSESIZ,X
SYSCALLGETSTRING                       ; EQU * (X) POINTS TO STRING DESCRIPTOR
         shld  TEMPX                   ; SO WE CAN FIND NEXT ARG IN LIST LATER
         LDD   R1SDC1,X                ; GET STRING SIZE
         lhld  R1SDA,X                 ; GET STRING ADDRESS
         CMPD  #$FFFF                  ; THE "WHOLE STRING" ?
         jrnz  SYSCALLGETSTRING1       ; B/ NO
         LDD   CURLEN,X                ; YES, USE CURRENT LENGTH OF STRING
SYSCALLGETSTRING1                      ; EQU *
         LEAX  STRING,X                ; COMPUTE POINTER TO 1ST DATA BYTE OF STRING
         ret

SYSCALLGETWRBUF                        ; EQU *
         BSR   SYSCALLGETSTRING
SYSCALLGETWRBUF1                       ; EQU *
         STD   SYSCALLWRLEN
         shld  SYSCALLWRBUF
         ret
         PAGE    
XOPSYSCALL2ARG EQU                     ; *
         TSX    
         BSR   SYSCALLGETWRBUF
         lhld  TEMPX
         LEAX  RSESIZ,X
         call  SYSCALLCHOOSESCBLK
         BSR   SYSCALLSETUPWRBUF
         JMP   SYSCALL1OR2ARG

SYSCALLSETUPWRBUF                      ; EQU *
         LDD   SYSCALLWRBUF            ; (X) CONTAINS SYSCALLBLKPTR
         STD   SCBLK:WRBUF,X           ; STUFF WRBUF PARAMS INTO CHOSEN SCBLK
         LDD   SYSCALLWRLEN
         STD   SCBLK:WRLEN,X
         ret
         PAGE    
SYSCALLONUSERCHAN                     ; PERFORM SYSCALL USING USER CHANNEL
         LDA   CHANEL
SYSCALLONCHANNELA                      ; STA SCBLK+SCBLK:PARAMS
;        JMP   ISYSCALL
;        I(NTERNAL) SYSCALL
;
;        SUPRESS EOF ERRORS ON CHANNELS 0-31
;        ONLY RETURNS ON ERROR IF CALLING ROUTINE HAS BCS OR BCC
;        AFTER THE JSR (OR BSR).  OTHERWISE TRAPS ERROR TO IOERROR
;
;
ISYSCALL EQU   *
;
;        FIRST, CLEAR EOF FLAG
;
         CLRA    
         CLR   EOFHITFLAG              ; ASSUME 'NO EOF HIT'
         LDB   SCBLK+SCBLK:PARAMS      ; CHANNEL #=>0
         BITB  #$E0                    ; B<32?
         jrnz  EXECISYSCALL            ; B/ NO, SO CAN'T DO A THING
         BSR   EOFBGEN                 ; MAKE ME AN EOF BIT AND X-REG
         COMA                          ; MAKE A MASK
         ANDA  ,X                      ; RESET 'EOF HIT' BIT
         STA   ,X

EXECISYSCALL   lhld                    ; #SCBLK NOW DO SYSCALL
         call  SYSCALL$
         jrc   RATS                    ; B/ GOT AN ERROR
         ret                           ; ALL DONE!

         PAGE    
RATS     CPX   #ERR:EOFHIT             ; GET AN EOF ERROR?
         jrz   TRAPEOF                 ; B/ YES, TRAP IT

;        CHECK FOR BCS OR BCC AFTER JSR

CHECKBCS shld  TEMPX
         LDA   [0,S]
         ANDA  #$FE
         CMPA  #$24                    ; IS IT?
         jrz   PASSBACKERROR
SYSCALLERRORED LDD                     ; TEMPX NO, SO GIVE ERROR TO BASIC PROGRAM
         JMP   IOERROR

PASSBACKERROR  lhld                    ; TEMPX
         SEC    
         ret

         PAGE    
TRAPEOF  LDA   SCBLK+SCBLK:PARAMS      ; IS IT WITHIN THE PROPER RANGE?
         BITA  #$E0                    ; 0..31
         jrnz  CHECKBCS
         INC   EOFHITFLAG
         BSR   EOFBGEN
         ORAB  ,X
         STB   ,X
         CLC                           ; WHAT ERROR?  DID YOU SEE AN ERROR?  I DIDN'T!
         ret

;        GENERATE X-REG AND MASK FOR CHANNEL IN EOF-TABLE
EOFBGEN  LDB   SCBLK+SCBLK:PARAMS
         ANDB  #7
         CLRA    
         SEC    

EOFBGEN2 ROLA                          ; GENERATE MASK FOR BIT NUMBER (B)
         DECB    
         BPL   EOFBGEN2

         LDB   SCBLK+SCBLK:PARAMS
         LSRB    
         LSRB    
         LSRB    
         IF    M6800!M6801
         ADDB  #EOFTABLE&$FF
         STB   TEMPX+1
         CLR   TEMPX                   ; ASSERT: EOFTABLE+7<=$FF
         lhld  TEMPX
         ELSE  (M6809)
         lhld  #EOFTABLE
         LEAX  B,X
         FIN    
         TFR   A,B
         ret
         PAGE    
;
;        BRANCH IF FLAG FALSE
;
XOPBF    LDA   FLAG
         jrnz  BT1
XOPJMP   EQU   *
BF0      ; UNCONDITIONALLY DO THE BRANC; H
         IF    M6800!M6801
         lhld  [BPC]                   ; GET TARGET ADDRESS
         ELSE  (M6809)
         lhld  ILADD,X                 ; A SMIDGEN FASTER THAN THE '00 COULD DO IT
         FIN    
         JMP   NTRPTX
;
;        BRANCH IF FLAG TRUE
;
XOPBT    LDA   FLAG
         jrnz  BF0
BT1      ; UNCONDITIONALLY **DON'T** DO;  THE BRANCH
         IF    M6800!M6801
         JMP   NTRPT3
         ELSE  (M6809)
         JMP   NTRPT3X
         FIN    
;
;        INVERT THE FLAG
;
XOPINV   COM   FLAG                    ; MAPS 0 TO $FF, $FF TO 0
         IF    M6800!M6801
         JMP   NTRPT1
         ELSE  (M6809)
         JMP   NTRPTX
         FIN    
         PAGE    
;        ON TOS GOTO
;        OPCODE, POINTER TO NEXT INSTRUCTION, ADDR1, ADDR2, ...
;
XOPON    call  RNDTOS
         DW    ONGOTO1                 ; B/ FAILED TO ROUND
         BSR   GOTOS
         jr    ONGOTO3                 ; ALL IS OK
ONGOTO1  lhld  [BPC]                   ; FALL THRU "ON" STMT
         jr    ONGOTO4
ONGOTO3  lhld  [TWORD]
ONGOTO4  JMP   NTRPTX
;
;        ON GOSUB
;
XOPONG   call  RNDTOS
         DW    ONGOTO1                 ; B/ FAILED TO ROUND!
         BSR   GOTOS
         jr    OPONG3
         jr    ONGOTO1
OPONG3   LDD   [BPC]                   ; GET RETURN ADDRESS
         lhld  [TWORD]                 ; GET WHERE TO GO
         jr    GOSUB1
         PAGE    
;        ON GOTO/GOSUB SUBROUTINE TO DETERMINE TARGET LINE NUMBER (ADDRESS)
;        (D) = ROUNDED VALUE OF "ON" EXPRESSION
;        NON-SKIP EXIT IF OK
;        SKIP EXIT IF INDEX OUT OF RANGE
;
GOTOS    SUBD  #1                      ; CONVERT TO ZERO ORIGIN
         ASLD    
         jrc   GOTOS2                  ; B/ # WAS TOO BIG OR WAS ZERO!
         ADDD  BPC
         jrc   GOTOS2
         ADDD  #ILADD+2                ; DISPLACEMENT TO 1ST TARGET ADDRESS
         jrc   GOTOS2
         CMPD  [BPC]                   ; POINTER TO TARGET BEYOND END OF TARGET ADDRESS LIST ?
         BCC   GOTOS2                  ; B/ YES, FALL THROUGH
GOTOS1   STD   TWORD
         ret

GOTOS2   PULX                          ; INDEX OUT OF RANGE, TAKE SKIP EXIT
         JMP   2,X
         PAGE    
;        GOSUB
;        OPGSB,ADDRESSOFSUBROUTINE
;
XOPGSB   ; "GOSUB" OPCODE
         IF    M6800!M6801
         lhld  BPC                     ; ASSERT: (S) = ERRORRECOVERYSTACK at this point
         FIN    
         LDD   BPC                     ; COMPUTE RETURN ADDRESS
         ADDD  #ILADD+2
         lhld  ILADD,X
;
;        GOSUB1                        -- DO THE GOSUB COMMON WORK
;              (X) = GOSUB TARGET PC
;              (D) = RETURN TARGET PC
;
GOSUB1   ; PUSH BPC, LINEADDR ONTO GOSU; B STACK
         PSHD                          ; SAVE "BASIC" RETURN ADDRESS
         LDD   LINEADDR                ; LINE # DERIVABLE FROM STACKED LINE ADDRESS!
         PSHD                          ; SAVE LAST ENCOUNTERED OPLINE ADDRESS
         sspd  ERRORRECOVERYSTACK      ; NEW STACK VALUE FOR ERROR TRAP RECOVERY
         JMP   NTRPTX
         PAGE    
;        GOSUB POP
;        TOS HAS # TO POP
;        IF POP TOO MANY, CROAK
;        IF TOS IS ZERO, EMPTY THE ENTIRE STACK
;
XOPGPOP  call  RNDTOS
         DW    RTRN1                   ; CAN'T FIX, YOU DIE!
         STD   LOOPX
         BEQD  OPGPOP0                 ; REAM THE STACK
OPGPOP2
         IF    M6800!M6801
         TSX                           ; POP A GOSUB STACK ENTRY
         DEX                           ; IS STACK FRAME EMPTY ?
         CPX   STACKFRAMEBASE          ; ...?
         ELSE  (M6809)
         CMPS  STACKFRAMEBASE          ; IS STACK FRAME EMPTY?
         FIN    
         jrz   RTRN1                   ; B/ YES, ERROR THE USER
         LEAS  4,S                     ; NO, GET RID OF A GOSUB STACK ENTRY NOTE: GOSUB POP DOES NOT WORK FOR SUB/FUN RETURN ADDRESSES!
         sspd  ERRORRECOVERYSTACK      ; UPDATE THE STACK ERROR RECOVERY POINT
         lhld  LOOPX
         DEX    
         shld  LOOPX
         jrnz  OPGPOP2                 ; B/ NEED TO POP ANOTHER....
         jr    OPGPOP3                 ; ALL DONE

OPGPOP0  lspd  STACKFRAMEBASE          ; "GOSUB POP 0"
         sspd  ERRORRECOVERYSTACK      ; UPDATE STACK ERROR RECOVERY PART
OPGPOP3  JMP   NTRPT2
         PAGE    
;        RETURN
;        POP BPC FROM GOSUB STACK & JUMP
;
XOPRET
         IF    M6800!M6801
         TSX                           ; ANY RETURN ADDRESSES STILL IN THIS STACK FRAME ?
         DEX    
         CPX   STACKFRAMEBASE          ; ...?
         ELSE  (M6809)
         CMPS  STACKFRAMEBASE          ; ANY RETURN ADDRESSES LEFT IN THIS STACK FRAME?
         FIN    
         jrz   RTRN1                   ; B/ NO, CAN'T DO A RETURN HERE!
         PULD                          ; RESTORE LAST LINE OPCODE ENCOUNTERED ADDRESS
         STD   LINEADDR                ; RESTORE LINE ADDRESS AT TIME OF GOSUB
         PULX                          ; RESTORE BPC AT TIME OF GOSUB
         sspd  ERRORRECOVERYSTACK      ; AND UPDATE RECOVERY TIME STACK VALUE
         JMP   NTRPTX

RTRN1    call  RTPERR
         db    :GSBUND
*       CALL USER SUBROUTINE
;        (OPCALL)(SUBROUTINE ADDR)(ARG COUNT)
;              NOTE: # ARGS LIMITED TO 255/6 = 42!
;
XOPCALL  BSR   CALLIT
;        CAME BACK! (SUB/FUNS COMPILED BY BASIC DON'T COME BACK HERE)
         jrc   XOPCALLERRED            ; B/ ERROR IN SUBROUTINE
         lspd  ERRORRECOVERYSTACK      ; MUST HAVE BEEN USER SUBROUTINE CALL
XOPCALL1 LDB   #3                      ; = DISTANCE TO BUMP BPC
         JMP   NTRADB                  ; GO DO NEXT INSTRUCTION
;
;        OPFNCALL -- CALL USER FUNCTION
;        (OPFNCALL) (FUNCTION ADDR) (ARGUMENT COUNT)
;
XOPFNCALL      BSR                     ; CALLIT GET THE FUNCTION ADDRESS, DUMMY!
         jrc   XOPCALLERRED            ; B/ ERROR IN FUNCTION
         lhld  #OPPOLYARG              ; CALL THE FUNCTION
         call  FSTORE                  ; SAVE THE RETURNED VALUE
         lhld  BPC                     ; NOW POP ARG LIST FROM STACK
         LDB   2,X
         ASLB                          ; ARG COUNT * 2
         IF    M6800!M6801             ; ADD #ARGS*6 TO STACK
         TBA    
         ASLA                          ; ... * 4
         ABA                           ; ... * 6
         sspd  TEMPX
         ADDA  TEMPX+1
         BCC   XOPFNCALL1
         INC   TEMPX
XOPFNCALL1     EQU                     ; *
         STA   TEMPX+1
         lspd  TEMPX
         ELSE  (M6809)
         ADDB  2,X                     ; ARG COUNT * 3
         ASLB                          ; * 6
         LEAS  B,S                     ; ASSERT: ARG COUNT < 128/3
         FIN    
         lhld  #OPPOLYARG              ; GET THE RETURNED VALUE BACK
         call  FLOAD
         jr    XOPCALL1
         PAGE    
CALLIT   ; SUBROUTINE FOR XOPCALL, XOPF; NCALL
         IF    M6800!M6801
         lhld  BPC
         FIN    
         LDD   ILADD,X                 ; GET SUBROUTINE ADDRESS
         PSHD                          ; PUSH ONTO STACK
         LDA   ILADD+2,X               ; GRAB ARGUMENT COUNT
         IF    M6800!M6801
         TSX                           ; GET POINTER TO PARAMETER LIST
         LEAX  4,X
         ELSE  (M6809)
         LEAX  4,S
         FIN    
         ret                           ; GO TO SUBROUTINE

XOPCALLERRED   ; USER FUNCTION/SUBROUTI; NE ERRORED!
         lspd  ERRORRECOVERYSTACK      ; SWITCH TO SAFE STACK POINTER
         shld  ERCODE                  ; SAVE THE ERROR CODE
         JMP   ERROR                   ; AND GO PROCESS THE ERROR!
         PAGE    
;        PARAMETERIZED SUBROUTINE/FUNCTION ENTRY POINT
;
;        CALL  $106                    WITH (A) = # ARGUMENTS PASSED BY CALLER
;        DB    version
;        DW    forwardreflabelchain
;        DW    pointer to first byte of last parameter variable storage
;                                      Argument variables are allocated contiguously
;        DW    baseofscalarvariables
;        DW    address of 1st byte above the data space
;        DB    #arguments given by SUBROUTINE/FUNCTION definition
;              ...basic opcodes...
;
;
;        1) CHECK ARG COUNT AND COMPLAIN IF INCORRECT
;        2) COPY ARGS OFF STACK INTO PARAMETER VARIABLES
;        3) PUSH RETURN ADDRESS (BPC) ONTO STACK ALONG WITH:
;              SCALAR VARIABLE TABLE BASE
;              LAST ENCOUNTERED LINE NUMBER/LABEL OPCODE ADDRESS
;              CURRENT VALUE OF ERROR TRAP ADDRESS
;              OLD STACKFRAMEBASE, ERRORRECOVERYSTACK
;        4) GO DO AN XOPSETLABEL
;
;        NOTE: ON A RETURN STATEMENT, CONTROL IS NOT PASSED BACK TO XOPCALL!
;        THIS IS BECAUSE XOPCALL WILL ATTEMPT TO CLEAN OFF THE STACK,
;        AND THIS WILL HAVE ALREADY BEEN DONE.
;
??       IF    OPLINE=$BD
         ?can't tell JSR from OPLINE?
         ENDIF

ARGCOUNTERROR ; report (fatal) Argument Count error
         LXI   H,0                     ; KILL OFF THE ERROR TRAP ADDRESS
         SHLD  ERTRAP                  ; SO THE ERROR IS FATAL
         CALL  RTPERR
         DB    ERR@ARGCNTERR

???VERSIONERRJ JMP VERSIONERROR        ; report "Wrong Version RTP" error
         PAGE    
SUBFUNENTRY ; enter Compiled BASIC Subroutine/Function
         pop   h                       ; = RETURN ADDRESS FROM CALL
         mov   c,a                     ; save argument count
         mov   a,m                     ; fetch RTP@VERSIONNUMBER
         cpi   #version                ; CHECK VERSION NUMBER
         jnz   VERSIONERRJ             ; B/ WRONG VERSION NUMBER
         SHLD  BPCSAV                  ; REMEMBER ROUGHLY WHERE BPC IS (CALL SITE)
         lxi   d,RTP@ARGCOUNT          ; find argument count
         dad   h
         mov   a,m                     ; and fetch it
         CMP   C                       ; IS ARG COUNT CORRECT ?
         jnz   ARGCOUNTERROR           ; B/ NO, GO YELL AND SCREAM AND DIE...
         inx   h                       ; now points to popcode start
         shld  BPC                     ; save location of 1st byte of popcode
         lxi   d,RTP@LASTPARAMADDR-RTP@FUNSUBOPCODE ; fetch pointer to params
         dad   d
         mov   b,m                     ; make HL point to last parameter variable
         inx   h
         mov   h,m
         mov   l,b
         pop   d                       ; POP $106 ENTRY POINT JSR RETURN ADDRESS OFF POP RETURN ADDRESS PUSHED BY OPCALL
         ana   a                       ; ANY ARGS LEFT TO COPY FROM STACK ?
         jz    SUBFUN2                 ; B/ NOPE
SUBFUNL ; PARAMETER FILL LOOP
         pop   d                       ; COPY ARGUMENT VALUE INTO A PARAMETER VARIABLE
         mov   m,e
         inx   h
         mov   m,d
         inx   h
         pop   d
         mov   m,e
         inx   h
         mov   m,d
         inx   h
         pop   d
         mov   m,e
         inx   h
         mov   m,d
;        inx   h
         lxi   d,-RSESIZ*2-1           ; find next parameter variable
         dad   d
         dcr   a
         jnz   SUBFUNL                 ; B/ MORE TO FILL!
         PAGE    
;
SUBFUN2 ; NOW PUSH OLD CONTEXT
         mvi   c,(ContextEnd-ContextStart)/2 ; how many bytes to save
         lxi   h,ContextEnd            ; do it the compact way...
SUBFUN2L ; SINCE WE DON'T DO IT OFTEN
         DCX   H
         mov   e,m
         dcx   h
         mov   d,m
         push  d                       ; push pair of context bytes
         dcr   c                       ; ??z80 improvement ??
         jnz   subfun2l
         lxi   h,SUBROUTINENESTING     ; ANOTHER CONTEXT BLOCK HAS BEEN PUSHED!
         inr   m
         lxi   h,0                     ; ANOTHER CONTEXT BLOCK PUSHED
         shld  ERTRAP                  ; NEW ENVIRONMENT:
                                       ; --> NEW ERROR TRAP MUST BE SET!
         dad   sp                      ; get base of stack frame
         shld  STACKFRAMEBASE          ; MARK BASE OF STACK FRAME
         shld  ERRORRECOVERYSTACK      ; MARK GOSUB LIST AS EMPTY
         lhld  BPCSAV                  ; ROUGHLY WHERE SUBROUTINE ENTRY IS
         call  INITCOMMON              ; GO DO COMMON INIT STUFF
         lhld  BPCSAV
         dcx   h
         dcx   h
         dcx   h                       ; = EXACTLY WHERE SUBROUTINE ENTRY IS
         shld  LINEADDR
         lhld  BPC                     ; ***PREVENT <ESC> ON FUNCTION ENTRY***
         lda   BreakLine+VINT1
         xra   h
         jnz   subfun3                 ; b/ breakpoint not required
         lda   BreakLine+VINT2
         xra   l
         jz    XOPLINE6J               ; B/ BREAKPOINT REQUIRED (ALLOW ESCAPE)
         LDA   LINEFLAGS               ; BREAKPOINT NOT DESIRED, TRACE OR SINGLE STEP!
         ana   a                       ; Trace or Single Step enabled ?
         jz    NTRPT1                  ; NORMAL CASE, GO DO NEXT OPCODE
;        jnz   XOPLINE6J               ; B/ TRACE OR SINGLE STEP DESIRED
XOPLINE6J JMP  XOPLINE6                ; GO PROCESS CURRENT LINEFLAGS
         PAGE    
;        FUNRETURN -- RETURN FROM A FUNCTION
;
XOPFUNRET ; Return from a Compile BASIC function (DEF)
         lxi   h,OPPOLYARG
         call  FSTORE
;
;        SUBRETURN -- RETURN FROM A SUBROUTINE
;
XOPSUBRET ; return from a Compiled BASIC SUBROUTINE
         lhld  BPC                     ; GRAB OPCODE BYTE, SAVE IN (B)
         dcx   h
         mov   b,m
         lspd  STACKFRAMEBASE          ; BYE BYE GOSUBS FOR THIS INCARNATION
         mvi   c,(ContextEnd-ContextStart)/2 ; how many bytes to save
         lxi   h,CONTEXTSTART          ; RESTORE CONTEXT FROM STACK
OPSUBRETL ; pop context byte pair
         pop   d                       ; see SUBFUN2L loop
         mov   m,d                     ; this does the opposite
         inx   h
         mov   m,e
         inx   h
         dcr   c                       ; ??Z80 improvement ??
         jnz   opsubretl
         lxi   h,SUBROUTINENESTING     ; ANOTHER CONTEXT BLOCK HAS BEEN POPPED
         dcr   m
         mov   a,b                     ; returning from a parameterized subroutine ?
         cpi   OPSUBRET
         jz    OPSUBRET1               ; B/ YES, GO CLEAN UP
         lxi   h,OPPOLYARG             ; NO, MUST BE RETURNING FROM PARAMETERIZED FUNCTION
         call  FLOAD                   ; MOVE RESULT VALUE BACK ONTO VALUE STACK
OPSUBRET1 JMP  XOPCALL1                ; ALL DONE, CONTINUE EXECUTION IN CALLING ENVIRONMENT
         PAGE    
;
;        ENTER ASSEMBLY LANGUAGE
;        JUMPS TO ADDRESS OF OPCODE + 1
;        OPASM
;
XOPASM   ; ENTER ASSEMBLY LANGUAGE OPCO; DE
         lhld  BPC
         pchl    
;
;        FORWARD REFERENCE LABEL
;        THE VALUE OF THE LABEL IS IN A VARIABLE
;        SO THAT IT CAN BE TREATED THE SAME AS A SCALAR
;
;        OPLFREFL
;        DW    SCALAR ADDRESS
;        DW    POINTER TO NEXT OPLFREL OPCODE
;
XOPLFREFL ; FORWARD REFERENCE LABEL OPCODE
;        Since RESOLVEFREF has already resolved Forward References,
;        we need do nothing but advance BPC past this opcode.
         lhld  BPC
         dcx   h                       ; MAKE POINTER TO OPCODE BYTE
         shld  LINEADDR                ; GOTO ELN NEEDS THIS
         lxi   d,5                     ; BUMP BPC SO NTRPT1 IS CORRECT EXIT
         dad   d
         shld  BPC
         jmp   XOPLFREFL1
;
;        SINGLE BYTE SET LABEL OPCODE
;
;        OPSETLABEL
;
XOPSETLABEL ; SET LABEL POINT
         lhld  BPC
         dcx   h                       ; MAKE IT POINT TO LABEL OPCODE
         shld  LINEADDR                ; GOTO ELN NEEDS THIS
         jr    XOPLFREFL1
         PAGE    
;
;        PRLINEADDR -- PRINT LINE NUMBER/ADDRESS OF OPCODE @HL
;              STORES LINE NUMBER/ADDRESS IN OPPOLYARG
;
PRLINEADDR ; Print Line Number/Address of Opcode at HL
         xra   a
         sta   OPPOLYARG               ; MAKE "OPPOLYARG" INTO AN INTEGER
         mov   a,m                     ; GET OPCODE SELECTED
         cpi   OPLINE                  ; A LINE NUMBER OPCODE ?
         jnz   PRLINEADDR1             ; B/ NO
         inx   h                       ; yes, grab the line number
         mov   a,m
         inx   h
         mov   h,m
         mov   l,a
         shld  OPPOLYARG+VINT1
         call  XBCODE                  ; NOW DISPLAY THE NUMBER
         DB    OPLOAD
         DW    OPPOLYARG
         DB    OPPV
         DB    OPPCR
         DB    OPASM
         ret    

PRLINEADDR1 ; Print Line Address in HL
         shld   OPPOLYARG+VINT1         ; NOT A LINE NUMBER OPCODE, PRINT THE ADDRESS
         call   XBCODE
         DB    OPLOAD
         DW    OPPOLYARG
         DB    HIGH OPHEX,LOW OPHEX
         DB    OPPS
         DB    OPPCR
         DB    OPASM
         ret    
         PAGE    
;        SET LINE NUMBER
;        PICK UP 2 BYTES & PUT IN THE LINE # REG
;        CHECK LINE FLAG
;        OPLINE,16BITLINENUMBER
;
XOPLINE  ; SET LINE NUMBER OPCODE
         lhld  BPC
         dcx   h                       ; SET LINEADDR = ADDRESS OF LINE # OPCODE
         shld  LINEADDR
         inx   h                       ; BUMP BPC SO NTRPT1 IS CORRECT EXIT
         inx   h
         inx   h
         shld  BPC
         dcx   h                       ; fetch line number to HL
         mov   a,m
         dcx   h
         mov   h,m
         mov   l,a
XOPLFREFL1 ; HL contains Line Number/Line address
;        **** HELP HELP! WHAT IF LINE # = LINE ADDRESS OF DIFFERENT LINE? ****
         lda   BreakLine+VINT1         ; hit line number breakpoint ?
         cmp   l
         jnz   xopline9                ; b/ no
         lda   BreakLine+VINT2
         cmp   h
         jz    XOPLINE6                ; b/ yes
         LDA   LINEFLAGS               ; REQUEST FOR TRACE/SINGLE STEP ?
         ana   a
         jz    XOPLINE0                ; B/ NO, SEE IF NEW REQUEST ARRIVED
XOPLINE6 ; MUST BE TRACE OR SINGLE STEP --> PRINT LINE NUMBER
         call  XBSUBR
         DB    OPZCHN                  ;  TO PRINT ON CHANNEL 0
         DB    OPLSC
         DB    5,'Line '
         DB    OPPS
         DB    OPASM
         lhld  LINEADDR
         call  PRLINEADDR
         lhld  BPCSAV                  ; RESTORE USER'S BASIC PC
         shld  BPC
         lhld  OPPOLYARG+VINT1
         lda   BreakLine+VINT1
         cmp   l
         jnz   xopline6a
         lda   BreakLine+VINT2
         cmp   h
         jz    XOPLINE7
xopline6a ; not at breakpoint
         LDA   LINEFLAGS               ; BREAKPOINT OR SINGLE STEP ?
         ana   SSTEPBIT                ; ...?
         jz    XOPLINE0                ; B/ NEITHER, CONTINUE EXECUTION
XOPLINE7 call  GETLINEFLAGS            ; WAIT FOR RESPONSE TO BREAK/SS
         ana   a
         jz    XOPLINE7                ; No response yet, wait some more
         call  PROCESSLINEFLAGS1       ; GO PROCESS LINE FLAGS JUST COLLECTED
         JMP   NTRPT1
         PAGE    
GETLINEFLAGS   ; SUBROUTINE TO GET LINE FLAGS
         call  SETSCOP                 ; SETUP TO DO A GETLINEFLAGS CALL
         db    SYSCALL:STATUS,14
         db    0,SC:GETLINEFLAGS
         call  SETSCRDBUF
         DW    TBYTE,1
         call  EXECISYSCALL            ; DO THE CALL
         jc    GETLINEFLAGS1           ; B/ CALL ERRORED, USE HINT AS RESULT
         LDA   TBYTE                   ; GET LINE FLAGS...
         mov   c,a
GETLINEFLAGS2 ; zap the hint and exit with line flags in (A)
         xra   a                       ; AND ZAP THE HINT
         sta   $F0
         mov   a,c
         RET    

GETLINEFLAGS1 ; SC:GETLINEFLAGS failed
         LDA   $F0                     ; USE HINT AS LINEFLAGS
         mov   c,a
         lxi   d,ERR:ILLDEVICEOP       ; INVALID CALL (NOT VT DRIVER?)
         dad   d                       ; Simply not implemented ?
         mov   a,h
         ora   l
         jz    GETLINEFLAGS2           ; B/ yes, we don't have VT DRIVER
         shld  ERCODE                  ; OOOH...SOMETHING IS VERY WRONG!
         JMP   ERRORLDS
         PAGE    
XOPLINE0 LDA   $F0                     ; DON'T HAVE TO DISPLAY LINE NUMBER, QUICKLY GET LINE FLAGS
         ana   a                       ; any hint about line flags present ?
         jz    XOPLINE4                ; B/ NOTHING TO DO, TAKE FAST EXIT
         lhld  LINEADDR                ; DID WE GET CAUGHT AT THE ERROR TRAP POINT?
         lda   ERTRAP
         cmp   l
         jnz   xopline0a
         lda   ERTRAP+1
         cmp   h
         jz    XOPLINE4                ; B/ YES, IGNORE
xopline0a ; not at error trap point, process the line flags
         CALL  PROCESSLINEFLAGS
XOPLINE4 JMP   NTRPT1                  ; ASSERT: BPC POINTS TO NEXT OP TO EXECUTE
;
;        PROCESSLINEFLAGS -- PROCESS LINE FLAGS
;        MUST NOT BE CALLED IN MIDDLE OF I/O STATEMENT TO NON-ZERO CHANNEL #
;
PROCESSLINEFLAGS                       ; EQU *
         BSR   GETLINEFLAGS            ; GET FLAGS TO PROCESS
PROCESSLINEFLAGS1 ; COME HERE WITH (A) ; = LINE FLAGS TO PROCESS
         LDB   LINEFLAGS               ; GET CURRENT STATE OF DEBUG INFO
         BITA  #GOBIT                  ; DID HE SAY "GO" ?
         jrz   XOPLINE8                ; B/ NO
         ANDB  #\SSTEPBIT              ; YES, DUMP THE SINGLE STEP BIT
XOPLINE8 BITA  #TRACEBIT
         jrz   XOPLINE1
         EORB  #TRACEBIT               ; LOOK! THERE'S SOMETHING TO DO!
XOPLINE1 BITA  #SSTEPBIT
         jrz   XOPLINE2
         ORAB  #SSTEPBIT
XOPLINE2 STB   LINEFLAGS
         BITA  #ABORTBIT
         jrnz  XOPABORT
         BITA  #BREAKBIT
         jrz   PROCESSLINEFLAGSRTS
         PAGE    
GETBREAKPOINT  call                    ; XBSUBR
         OPZCHN
         OPLSC
         db    17,ASCII:CR,ASCII:BEL
         db    'Break on Line? '
         OPPS    
         OPASM
         lhld  BPCSAV                  ; RESTORE BPC IN CASE OF CONVERSION ERROR, BELOW
         shld  BPC
         call  SETSCOP                 ; ISSUE SYSCALL:READA TO GET BREAKPOINT LINE NUMBER
         db    SYSCALL:READA,READA:SCLE; N
         db    0,1                     ; DO READ FROM CONSOLE IN LINE MODE
         call  SETSCRDBUF              ; PUT REPLY IN "OUTBUF" (A NICE TEMP)
         DW    OUTBUF,OUTBUFSIZE
         call  ISYSCALL                ; ISSUE THE READ
;** WHAT HAPPENS HERE IF AN I/O ERROR OCCURS ???
         lhld  #OUTBUF                 ; CONVERT THE INPUT TO A LINE NUMBER
         LDD   #OUTBUFSIZE
         call  CONVERT
         jr    GETBREAKPOINT1          ; B/ CONVERTED OK
         jr    GETBREAKPOINT           ; B/ FAILED TO CONVERT PROPERLY

GETBREAKPOINT1 call                    ; XBSUBR STORE THE CONVERTED VALUE
         OPSTORE,#BREAKLINE
         OPASM
         IF    0
;        THIS LITTLE STUNT ALLOWS OVERLAYED BASIC DEBUGGER TO GET CONTROL ON BKPT
         LDA   BREAKLINE
         BPL   --                      ; ONE OF IRA'S UNFINISHED SYMPHONIES ???
         --- CHAIN TO BASIC DEBUGGER --; -
         FIN   0
         lhld  BPCSAV
         shld  BPC
         LDA   BREAKLINE               ; IS BREAKPOINT AN INTEGER?
         jrnz  GETBREAKPOINT           ; B/ NO, ASK AGAIN!
PROCESSLINEFLAGSRTS                    ; RTS
         PAGE    
XOPABORT BSR   RTPERR
         db    :ABORT

XOPSTP   BSR   RTPERR
         db    :STOP

XOPERRCAUSE    ; CAUSE SPECIFIED ERROR ; CODE
         call  RNDTOS
         DW    FIXTOSERR
         jr    IOERROR

         PAGE  *****  E R R O R   S T U;  F F  *****
;        OPGOELN -- GOTO LINE NUMBER IN WHICH LAST ERROR OCCURRED
;
XOPGOELN EQU   *
         lhld  ERADDR                  ; IS ERROR ADDRESS SET ?
         CLR   ERADDR                  ; CLEAR "ERROR OCCURRED" FLAG
         CLR   ERADDR+1
         shld  TEMPX                   ; DID ERROR REALLY OCCUR ?
         jrnz  IOERRSTX                ; B/ ERROR DID OCCUR, CONTINUE EXECUTION
         BSR   RTPERR                  ; ELN WENT TO UNDEFINED LINE NUMBER!?
         db    :UDFLIN
;
;        ERROR STUFF
;
RTPERR   LDB   [,S]                    ; FETCH INLINE ERROR CODE
         CLRA    
IOERROR  STD   ERCODE                  ; SAVE ERROR CODE
ERRORLDS lspd  ERRORRECOVERYSTACK      ; GET US A CLEAN STACK TO WORK WITH...
         lhld  LINEADDR                ; SAVE POINTER TO LINE ORIGINATING THE ERROR
         shld  ORIGINALSINADDR
ERROR    lhld  USING                   ; WIPE OUT AN ACTIVE USING STRING
         shld  USINGMAX
         lhld  LINEADDR                ; SAVE ADDRESS OF LINE OPCODE IN WHICH ERROR OCCURRED
         shld  ERADDR                  ; FOR GOTOELN
         CPX   ERTRAP                  ; IS THE ERROR RECOVERY STUCK IN A LOOP?
         jrz   ERRPRINT                ; B/ YES, ABORT HIM
         lhld  ERCODE                  ; IS THIS A "STOP" STATEMENT ?
         jrz   ERRPRINT                ; B/ YES, NO ERROR RECOVERY POSSIBLE
         lhld  ERTRAP                  ; IS ERROR TRAPPING ENABLED?
         jrz   XOPERRST                ; B/ NO, ABORT HIM
IOERRSTX JMP   NTRPTX
;
;        OPTRP, STICK ADDRESS IN ERTRAP REG
;        OPTRP,POINTERTOERRORTRAPROUTINE
;
XOPTRP   ; SET ON ERROR TRAP TO INLINE ; ADDRESS
         IF    M6800!M6801
         lhld  BPC
         FIN    
         lhld  ILADD,X
         shld  ERTRAP
         JMP   NTRPT3
         PAGE    
;        OPERR, Prints Line number/address,
;        sets SDOS Error code, Prints it and exits
;        NOTE: COULD CHAIN TO SPECIAL PGM THAT CONVERTED HEX ADDRESS...
;        FOR LINE NUMBER BACK INTO ORIGINAL LABEL NAME BY LOOKING IT UP...
;        IN THE SYMBOL TABLE PRODUCED BY THE ASSEMBLER
;
;
XOPERRST TST   SUBROUTINENESTING       ; IN MAIN PROGRAM ?
         jrz   ERRPRINT                ; B/ YES, GO PRINT THE ERROR
         lspd  STACKFRAMEBASE          ; NO, POP A CONTEXT BLOCK
         lhld  #CONTEXTSTART+2         ; ( LEAVE ERCODE ALONE! )
         LEAS  2,S
XOPERRSTL      PULA    
         STA   ,X+
         CPX   #CONTEXTEND
         jrnz  XOPERRSTL
         DEC   SUBROUTINENESTING       ; = # PUSHED CONTEXT BLOCKS
         lspd  ERRORRECOVERYSTACK      ; POP CONTEXT TO GET TO CALLER'S CONTEXT
         jr    ERROR                   ; GO CHECK FOR ERROR RECOVERY

ERRPRINT call  XBSUBR
         OPZCHN                        ;  PRINT ON CONSOLE, PLEEZ...
         OPLSC                         ; LOAD CON STRING DES
         db    5
         db    'Line '
         OPPS                          ; PRINT THE STRING
         OPASM
         lhld  ORIGINALSINADDR         ; GET ADDRESS OF ORIGINAL SIN
         call  PRLINEADDR              ; PRINT THE LINE NUMBER/ADDRESS
         call  SETSCOP                 ; SET ERROR INTO SDOS SO DO FILES SEE THEM
         db    SYSCALL:ERROREXIT
         db    SETERROR:SCLEN
         DW    CHANGED

         lhld  ERCODE
         shld  SCBLK+SCBLK:PARAMS
         call  EXECISYSCALL            ; ASSERT: EOF CONDITION CANNOT OCCUR
         jrc   *                       ; GOOD GRIEF! SDOS DIDN'T KNOW WHAT TO DO!
         PAGE    
;
;        EXIT ROUTINE
;
XOPEXIT  call  SETSCOP
         db    SYSCALL:EXIT
         db    EXIT:SCLEN
         DW    IGNORED

         call  ISYSCALL
;        jr    *                       CAN'T GET HERE NORMALLY
        PAGE  *****  P E E K - P O K E;  *****
;        PEEK AT ADDRESS SPECIFIED BY TOS INTEGER
;
XOPEEK   LDA   R1TYPE,S
         jrnz  PEEK1
         IF    M6800!M6801
         lhld  R1ADD,X
         ELSE  (M6809)
         lhld  R1ADD,S
         FIN    
         LDB   BYTE,X
         JMP   LOADB1
;
;        POKE ADDRESS AT TOS-1, BYTE AT TOS
;        NO POKING AT THE INTERPRETER, PLEEZE
;
XOPOKE   call  MAKEBOTHLOGICAL         ; AFTER ALL, ISN'T THAT THE LOGICAL THING TO DO?
         LDD   #BASICRTPEND$
         SUBD  R2ADDH,S
         BCC   POKE4
         IF    M6800!M6801
         LDA   R1INT1,X
         jrnz  POKE5
         LDA   R1INT2,X
         lhld  R2ADD,X
         ELSE  (M6809)
         LDA   R1INT1,S
         jrnz  POKE5
         LDA   R1INT2,S
         lhld  R2ADD,S
         FIN    
         STA   BYTE,X
         JMP   PL2PC1

POKE4    call  RTPERR
         db    :POKRTP                 ; OUCH! THAT HURT!
POKE5    call  RTPERR
         db    :POKVAL
PEEK1    call  RTPERR
         db    :POKADD
         PAGE  *****  F O R - N E X T  ; *****
;        XOPFOR -- SETS UP A FOR/NEXT LOOP
;        ON THE VALUE STACK IS:
;        TOS   STEP
;        TOS-1 LIMIT
;        TOS-2 INITIAL VALUE FOR LOOP VARIABLE
;        (OPFOR)(OPNEXT ADDR+3)(INDEXVAR ADDR)(STEP/LIMIT VALUE ADDR)
;
XOPFOR
         IF    M6800!M6801
         lhld  BPC
         FIN    
         DEX                           ; MAKE BPC POINT TO FOR OPCODE
         shld  BPC
         ; ARE STEP, LIMIT, AND INITIAL;  VALUES ALL INTEGER ?
         LDA   R1TYPE,S                ; ...?
         IF    M6800!M6801
         ORAA  R2TYPE,X
         ORAA  R3TYPE,X
         ELSE  (M6809)
         ORAA  R2TYPE,S
         ORAA  R3TYPE,S
         FIN    
         jrz   FORINT                  ; B/ YES, THIS IS THE EASY CASE!
         call  MAKEBOTHFLOAT           ; NO, FORCE STEP AND LIMIT TO BE FLOATING
         BSR   STORESTEPANDLIMIT       ; AND SAVE THEM
         call  FORCEFLOAT              ; FORCE INITIAL VALUE TO BE FLOAT
         JMP   NEXTFS                  ; GO SAVE IT AND CHECK AGAINST LIMIT

FORINT   EQU   *                       ; STEP, LIMIT AND INITIAL VALUE ARE ALL INTEGER!
         BSR   STORESTEPANDLIMIT       ; SAVE STEP AND LIMIT VALUES
         lhld  BPC                     ; STORE INITIAL VALUE
         lhld  ILADD+3,X               ; GET LOOP INDEX ADDRESS
         call  FSTORE                  ; IT DOESN'T HURT TO BE A LITTLE SLOW HERE, WE ONLY DO THIS ONCE!
         lhld  BPC                     ; GET SET TO CHECK INITIAL VALUE AGAINST LOOP LIMIT
         lhld  ILADD+5,X
         LDD   #0                      ; CHEAT: FAKE STEP VALUE OF ZERO FOR BACK DOOR ENTRY
         jr    NEXTICHECK              ; GO CHECK LOOP LIMIT
         PAGE    
;        STORESTEPANDLIMIT -- COPIES TOS INTO STEP, TOS-1 INTO LIMIT
;
STORESTEPANDLIMIT                      ; EQU *
         IF    M6800!M6801
         PULD                          ; HIDE THE RETURN ADDRESS
         STD   RTPRET
         ELSE  (M6809)
         PULS  Y
         FIN    
         LDB   #RSESIZ*2               ; = # BYTES TO PULL OFF THE STACK
         lhld  BPC                     ; GET STEP/LIMIT STORAGE ADDRESS
         lhld  ILADD+5,X               ; POINTER TO PLACE FOR STEP
STORESTEPANDLIMITL                     ; EQU *
         PULA    
         STA   ,X+
         DECB    
         jrnz  STORESTEPANDLIMITL      ; YOU FIGURE IT OUT
         IF    M6800!M6801
         JMP   [RTPRET]
         ELSE  (M6809)
         JMP   ,Y
         FIN    
;
;        OPEXITLOOP -- PASS CONTROL TO STMT PAST "NEXT"
;        (OPEXITLOOP) (OPFORADDR )  [ I.E., POINTER TO "OPFOR" FOR MATCHING INDEX VAR)
;
XOPEXITLOOP    EQU                     ; *
         IF    M6800!M6801
         lhld  BPC                     ; FIND THE "FOR" OPCODE
         FIN    
         lhld  ILADD,X
         jr    NEXT1A                  ; THEN FIND THE "NEXT" THAT MATCHES AND EXIT THE LOOP
         PAGE    
;        OPNXT -- DO END OF LOOP PROCESSING FOR "FOR/NEXT" LOOP
;        (OPNXT)(OPFOR ADDR FOR MATCHING INDEX VAR)
;
;        NOTE: INTEGER PATH HAS BEEN OPTIMIZED TO DEATH!
;
XOPNEXT  EQU   *
         IF    M6800!M6801
         lhld  BPC                     ; FIND "OPFOR" OPCODE
         FIN    
         lhld  ILADD,X
         shld  BPC                     ; AND REMEMBER WHERE IT IS
         lhld  ILADD+5,X               ; GRAB POINTER TO STEP VALUE
         LDA   FSTYPE,X                ; IS STEP AN INTEGER ?
         ORAA  FLTYPE,X                ; (ARE BOTH STEP AND LIMIT INTEGERS ?)
         jrnz  NEXTF                   ; B/ NO, FLOATING OPERATIONS ARE REQUIRED
         LDD   FISTEP1,X               ; MOVE INTEGER STEP TO (A,B)
;        NOTE: IF USER FLOATED THE INDEX VAR, HE'LL BE SORRY!
NEXTICHECK     lhld                    ; FILIM1,X GRAB LOOP LIMIT
         shld  TEMPX                   ; SAVE IT A MOMENT
         lhld  BPC                     ; NOW ADD LOOP INDEX VALUE...
         lhld  ILADD+3,X               ; TO STEP VALUE
         TST   VTYPE,X                 ; CHECK FOR EXTREMELY UNUSUAL CASE
         jrnz  NEXTIF                  ; B/ USER FLOATED INDEX VARIABLE, SOMEHOW!
         ADDD  VINT1,X                 ; (A,B):= NEXT INDEX VARIABLE VALUE
         jrc   NEXTIOV                 ; B/ NEW INDEX VALUE > 65535, RATS!
         STD   VINT1,X                 ; SAVE UPDATED LOOP INDEX VALUE
         SEC                           ; CHECK: LOOP INDEX VALUE <= LIMIT ?
         SBCB  TEMPX+1                 ; ...?
         SBCA  TEMPX                   ; ...?
         BCC   NEXTEXIT                ; B/ NOPE, TIME TO LEAVE THE LOOP!
NEXTITERATION  EQU                     ; *
         LDB   #7                      ; DO NEXT ITERATION OF LOOP, 7 IS LENGTH OF "OPFOR" OPCODE
         JMP   NTRADB                  ; START EXECUTION FOLLOWING OPFOR OPCODE AGAIN
         PAGE    
NEXTIOV  PSHD                          ; RATS, LOOP INDEX > 65535: CONVERT TO 4 BYTE INTEGER
         LDD   #1                      ; EQUIVALENT OF CORRECT SUM
         PSHD                          ; ("1" = CARRY WE LOST)
         call  FLOAT                   ; FLOAT THE RESULT
         lhld  BPC                     ; SAVE IT BACK IN THE INDEX VARIABLE
         lhld  ILADD+3,X
         call  FSTORE                  ; ASSERT: LOOP INDEX > LOOP LIMIT
NEXTEXIT EQU   *
         lhld  BPC                     ; NOW FALL OUT OF THE LOOP...
NEXT1A   lhld  ILADD+1,X               ; AND START EXECUTION BEYOND "NEXT" OPCODE
         JMP   NTRPTX
;
NEXT1    lhld  BPC                     ; LOOP INDEX < LIMIT
         lhld  ILADD+5,X               ; NOW CHECK SIGN OF STEP
         LDA   FSTYPE,X
         BPL   NEXTITERATION           ; B/ SIGN >= 0, DO NEXT ITERATION
         jr    NEXTEXIT                ; STEP IS < 0, LOOP IS COMPLETE!
         PAGE    
NEXTIF   EQU   *                       ; INDEX VARIABLE IS FLOATING, BUT STEP AND LIMIT AREN'T!!
         lhld  BPC                     ; PUSH LIMIT AND STEP
         lhld  ILADD+5,X               ; WE'LL DO THE SLOW WAY SINCE THIS HAPPENS ONCE IN A BLUE MOON
         LDB   #RSESIZ*2               ; # BYTES TO PUSH
NEXTIFL  LDA   RSESIZ*2-1,X
         DEX    
         PSHA    
         DECB    
         jrnz  NEXTIFL                 ; YOU FIGURE IT OUT
         call  MAKEBOTHFLOAT           ; FLOAT STEP AND LIMIT
         call  STORESTEPANDLIMIT       ; SAVE THEM AWAY
         lhld  BPC
         lhld  ILADD+5,X
NEXTF    EQU   *                       ; STEP/LIMIT ARE FLOAT, WE ASSUME INDEX VAR IS, TOO!
         call  FLOAD                   ; GRAB STEP VALUE
         lhld  BPC                     ; GET INDEX VARIABLE
         lhld  ILADD+3,X
         call  FLOAD
         call  FORCEFLOAT              ; JUST IN CASE!
NEXTF1   lhld  #FLOATOVFLOW            ; IN CASE WE GET OVERFLOW,...
         shld  FPTRAP                  ; WE WANT TO BE PREPARED!
         call  FADD                    ; ADD STEP TO INDEX VARIABLE VALUE
NEXTFS   lhld  BPC                     ; AND STORE UPDATED INDEX VAR VALUE
         lhld  ILADD+3,X
         call  FSTORE
         lhld  BPC
         lhld  ILADD+3,X
         call  FLOAD                   ; NOW CHECK: IS INDEX VAR VALUE PAST LIMIT ?
         lhld  BPC
         lhld  ILADD+5,X
         LDD   FLIM5,X                 ; PUSH LIMIT...
         PSHD    
         LDD   FLIM3,X
         PSHD    
         LDD   FLTYPE,X
         PSHD    
         call  FCMP                    ; I REPEAT, IS INDEX VAR PAST LIMIT ?
         BLT   NEXT1                   ; B LOOP INDEX < LIMIT
         jrz   NEXTITERATION           ; B/ LOOP INDEX = LIMIT EXACTLY (UNUSUAL!!)
         lhld  BPC                     ; LOOP INDEX > LIMIT, NOW CHECK SIGN OF STEP
         lhld  ILADD+5,X
         LDA   FSTYPE,X
         BPL   NEXTEXIT                ; B/ STEP >=0, LOOP IS COMPLETE
         JMP   NEXTITERATION           ; B/ STEP < 0, DO NEXT ITERATION
         PAGE  *****  I N P U T  *****
;        XINLINE -- OPCODE TO READ IN AN ASCII LINE AT BEGINNING OF "INPUT" STATEMENT
;        READ CHARS INTO CATBUF ON CURRENT CHANNEL
;        UNTIL CR OR CATMAX (INCLUSIVE)
;        PUT CR IN BUFFER IF READ
;        SET INPTR TO 1ST BYTE OF INPUT LINE
;        CATPTR TO LAST BYTE OF INPUT LINE, +1
;
XOPINL   ; INPUT LINE OF TEXT FOR PROCE; SSING BY REST OF INPUT STATEMENT
         LDA   CHANEL                  ; CHANNEL 0 ?
         jrnz  OPINL1                  ; B/ NO, DON'T REQUEST BREAK
         call  PROCESSLINEFLAGS        ; COLLECT TRACE AND SINGLE STEP BITS
;                                       BREAK REQUEST, ABORT IF ESCAPE
OPINL1   EQU   *
         lhld  BPC
         shld  ILERR                   ; SAVE RECOVERY POINT (+1) IN CASE OF ERROR IN INPUT
         LEAX  2,X                     ; ADVANCE BPC PAST "INLINE" INSTRUCTION
         shld  BPC

         call  SETSCOP
         db    SYSCALL:READA
         db    READA:SCLEN
         db    CHANGED,1               ; **** READ IT IN "LINE MODE"

         lhld  CATBUF
         shld  INPTR                   ; NOTE: INPTR POINTS DIRECTLY TO 1ST DATA BYTE!
         shld  SCBLK+SCBLK:RDBUF

         lhld  CATSIZ
         shld  SCBLK+SCBLK:RDLEN

         call  SYSCALLONUSERCHAN

         LDA   EOFHITFLAG              ; IF EOF HIT, SKIP INPUT STATEMENT
         jrnz  XOPINL1

         lhld  SCBLK+SCBLK:RPLEN       ; INPUT LINE ENDS WITH CR --> DROP THE CR
         DEX                           ; (ASSERT: NOT EOF --> RPLEN >=1)
         shld  SCBLK+SCBLK:RPLEN

         LDD   SCBLK+SCBLK:RPLEN

         ADDD  CATBUF
         TDX    
         shld  CATPTR                  ; = INPUT LINE LIMIT
         LDA   ,X                      ; FETCH LAST BYTE READ
         CMPA  #ASCII:CR               ; =CR?
         jrnz  CATEN5J                 ; B/ NO <CR> PRESENT ON END OF BUFFER
         LDA   CHANEL                  ; INPUT FROM CHANNEL 0 ?
         jrnz  INPUT4                  ; B/ NO, DON'T PROCESS LINE FLAGS AFTER INPUT COMPLETED!
         JMP   XOPLINE0                ; GO PROCESS ^B, ^T, ^V
;                                      IF ENTERED WHILE IN INPUT MODE

XOPINL1  lhld  [ILERR]                 ; EOF HIT DURING READ
         JMP   NTRPTX                  ; (X) = WHERE TO GO IF EOF HIT

CATEN5J  call  RTPERR
         db    :IBUFOVF
         PAGE    
;        XOPINP -- INPUT A VALUE TO TOS FROM THE INPUT LINE
;
XOPINP   LDD   CATPTR                  ; CALCULATE # OF CHARS TO EAT (MAX)
         SUBD  INPTR
         lhld  INPTR
         BSR   CONVERT
         jr    INPUT3                  ; ALL IS OK
         lhld  ERTRAP                  ; INPUT CONVERSION ERROR (SYNTAX OR OVERFLOW)
         jrnz  INPUT1                  ; B/ ERROR TRAPPING ENABLED, CAUSE TRAP!
         LDA   CHANEL                  ; INPUT CONVERSION ERROR (SYNTAX OR OVF)
         jrz   INPUT2
INPUT1   call  RTPERR
         db    :CONVER

INPUT2   call  XBCODE
         OPLSC                         ; LOAD STRING CONSTANT
         db    14
         db    7                       ; BELL CODE IN ERROR MESSAGE
         db    'Input Error!'
         db    CR
         OPPS                          ; PRINT STRING
         OPRMPT                        ;  PRINT PROMPT
         OPASM                         ; ENTER ASSY LANGUAGE
         lhld  ILERR
         DEX                           ; SO IT POINTS TO "OPINL" OPCODE
         lspd  ERRORRECOVERYSTACK      ; RECOVER FROM ERROR BY RESETTING STACK TO EMPTY...
         JMP   NTRPTX                  ; AND RE-EXECUTING FROM THE "OPINL" OPCODE

INPUT3   shld  INPTR
INPUT4   JMP   NTRPT1
         PAGE    
;        CONVERT -- CONVERT HEX VALUE OR FLOATING POINT NUMBER
;        (X) POINTS TO 1ST BYTE OF STRING TO CONVERT
;        (A,B) CONTAINS # CHARACTERS TO PROCESS
;        RETURNS POINTER TO END OF STRING
;
CONVERT  STD   LOOPCT                  
         shld  TEMPX                   ; COMPUTE POINTER PAST STRING
         ADDD  TEMPX
         STD   CONVERTLIMIT
         PULD    
         STD   RTPRET
         LDD   LOOPCT                  ; GET THE MAX CHARS TO EAT
         call  FCONVI
         jr    CONVER10                ; ALL IS OK
         jr    CONVER11                ; OVERFLOW
         shld  BUFERP                  ; CONVERSION (SYNTAX) ERROR, TRY HEX NUM
         lhld  LOOPCT                  ; SET UP MAX # TO EAT
         shld  LOOPX
CONVER1  call  GETCHAR
         CMPA  #ASCII:SPACE
         jrz   CONVER1                 ; IGNORE LEADING BLANKS
         CMPA  #ASCII:HT
         jrz   CONVER1
         CMPA  #':
         jrnz  CONVER11                ; INPUT ERROR
         CLRA    
         STA   MS1
         STA   MS2
         STA   MS3                     ; DIGIT COUNT
CONVER2  call  GETCHAR
         CMPA  #'0                     ; DIGIT?
         jrc   CONVER6                 ; NOT A DIGIT
         CMPA  #'9
         BHI   CONVER3
         SUBA  #'0
         jr    CONVER4
CONVER3  ANDA  #%01011111              ; FOLD UPPER INTO LOWER CASE TO ALLOW LOWER CASE HEX!
         CMPA  #'A                     ; 'A'-'F' DIGIT?
         jrc   CONVER6                 ; NOT A DIGIT
         CMPA  #'F
         BHI   CONVER6                 ; NOT A DIGIT
         SUBA  #'A-10
CONVER4  LDB   #1                      ; I SAW A DIGIT
         STB   MS3
         ASLA    
         ASLA    
         ASLA    
         ASLA    
         LDB   #4
CONVER5  ASLA    
         ROL   MS2
         ROL   MS1
         jrc   CONVER11                ; OVERFLOW
         DECB    
         jrnz  CONVER5
         jr    CONVER2
CONVER6  LDB   MS3
         jrz   CONVER11                ; NO DIGITS, INPUT ERROR
         LDD   MS1
         PSHD    
         LEAS  -3,S
         CLRB    
         PSHB    
         lhld  BUFERP
         DEX                           ; BECAUSE OF GETCHAR
CONVER10 CPX   CONVERTLIMIT
         jrz   CONVER9                 ; B/ YES, JUST LEAVE
         LDA   ,X                      ; NO, TRAILING COMMA?
         CMPA  #$2C
         jrnz  CONVER9
         INX                           ; YES, EAT THE COMMA
         IF    M6800!M6801
CONVER9  LDD   RTPRET
         PSHD    
         ELSE  (M6809)
CONVER9  JMP   [RTPRET]
         FIN    
PROUSRTS ret

CONVER11 lhld  RTPRET                  ; SYNTAX OR OVERFLOW ERROR
         JMP   2,X
         PAGE  *****  P R I N T  *****
;
;        WASCII-FOR THOSE WHO CAN AFFORD THE VERY WORST
;
WASCII   STA   CHAR
         PSHB    
         call  SETSCOP
         db    SYSCALL:WRITEA
         db    WRITEA:SCLEN
         db    CHANGED,IGNORED

         call  SETSCWRBUF
         DW    CHAR
         DW    1

         PULA    
         JMP   SYSCALLONCHANNELA       ; BYE!

;
;        PRINT PROMPT
;
XOPRMPT  LDA   #'?
         CLRB    
         BSR   WASCII
         jr    XOPPSP                  ; NOW OUTPUT A SPACE (WE KNOW CHANNEL # IS ZERO)
         PAGE    
;        PRINT REST OF USING STRING
;        USED BY PRINT USING ... ;
;        DOES NOT OUTPUT A CR
;
XOPPRUS  BSR   PROUS                   ; GO PRINT REST OF USING STRING
         JMP   NTRPT1                  ; AND EXECUTE THE NEXT OPCODE
;
PROUS    call  SETSCOP                 ; PRINT OUT REST OF USING STRING
         db    SYSCALL:WRITEA
         db    WRITEA:SCLEN
         db    CHANGED,IGNORED         ; WHERE STRING STARTS
         LDD   USINGMAX                ; COMPUTE LENGTH OF STRING
         SUBD  USING
         lhld  USING
         call  SYSCALLGETWRBUF1
         lhld  USINGMAX                ; ADVANCE USING TO MAKE NULL USING STRING
         shld  USING
         lhld  SYSCALLWRLEN            ; POSTAMBLE = 0 BYTES?
         jrz   PROUSRTS                ; B/ YES, DON'T BOTHER!
         JMP   SYSCALLONUSERCHAN
;
;        PRINT CR
;        DUMP OUT REST OF USING STRING IF <> 0
;        FOLLOW BY CR
;
XOPPCR   BSR   PROUS                   ; GO PRINT REST OF USING STRING
         LDA   #CR
         jr    PRINTA
;
;        PUT A SPACE TO THE OUTPUT
;
XOPPSP   LDA   #BLANK
PRINTA   LDB   CHANEL                  ; OUTPUT CHARACTER IN (A)
         call  WASCII
         JMP   NTRPT1
         PAGE    
;        RESOLVE THE STRING LENGTH ON TOS; RETURNS RESULT IN (X), TEMPX
;        PRESERVES (A,B)!
;
GSTRCNT  lhld  R1SDC1+2,S
         CPX   #$FFFF
         jrnz  GSTRCNT1
         lhld  R1SDA+2,S
         lhld  CURLEN,X
GSTRCNT1 shld  TEMPX                   ; AS ADVERTISED
         ret
;
;        PRINT STRING POINTED TO BY SD ON TOS
;
XOPPS    call  SETSCOP
         db    SYSCALL:WRITEA
         db    WRITEA:SCLEN
         db    CHANGED,IGNORED

         TSX    
         call  SYSCALLGETWRBUF
         call  SYSCALLONUSERCHAN
         JMP   PL1PC1
         PAGE    
;        ISFORMAT -- CHECK TO SEE IF (X) POINTS TO A VALID FORMAT STRING
;        (A,B) POINTS TO BYTE PAST END OF STRING
;        RETURNS IF FORMAT, (X) POINTS PAST FORMAT STRING
;        (A) RETURNS LENGTH
;        SETS UP LDOLLAR, LMINUS,LSHARP,DPCOUNT,RSHARP,RMINUS,RCARET...
;        TO APPROPRIATE COUNT AS SPECIFIED BY FORMAT STRING
;        SKIP RETURNS IF NOT A FORMAT
;
ISFORMAT EQU   *
         STD   ENDFORMAT
         CLRA                          ; INITIALIZE
         STA   LDOLLAR
         STA   LMINUS
         STA   LSHARP
         STA   DPCOUNT
         STA   RSHARP
         STA   RMINUS
         STA   RCARET
;
;        RECOGNIZES LEADING '$' '-' '$-' ''
;
         BSR   GETCHR
         CMPA  #'$
         jrnz  ISFRMT2
         INC   LDOLLAR
         BSR   GETCHR
         CMPA  #'-
         jrnz  ISFRMT4
ISFRMT1  INC   LMINUS
         jr    ISFRMT3
ISFRMT2  CMPA  #'-
         jrz   ISFRMT1
         jr    ISFRMT4
;
;        THIS SECTION SCANS LEFT SHARPS
;
ISFRMT3  BSR   GETCHR                  ; SCAN OFF LEFT SHARPS
ISFRMT4  CMPA  #'#
         jrnz  ISFRMT6
         LDA   LSHARP
         INCA    
         STA   LSHARP
         CMPA  #9
         BLS   ISFRMT3
         BSR   GETCHR
ISFRMT6  CMPA  #'.                     ; LOOK FOR DP
         jrnz  ISFRMT8                 ; NO DP, NO RIGHT SHARPS
         INC   DPCOUNT
         LDA   LSHARP
         CMPA  #9
         BHI   ISFRMT10                ; IF ENOUGH #'S FOUND, SKIP NEXT SECTION
ISFRMT7  BSR   GETCHR                  ; LOOK FOR RIGHT SHARPS
         CMPA  #'#
         jrnz  ISFRMT8
         LDA   RSHARP
         INCA    
         STA   RSHARP
         ADDA  LSHARP
         CMPA  #9
         BLS   ISFRMT7
ISFRMT10 BSR   GETCHR
ISFRMT8  LDB   LDOLLAR
         ORAB  LMINUS
         jrnz  ISFRMTD
         CMPA  #'-                     ; CAN HAVE '-', 3-5 CARETS, OR NOTHING
         jrnz  ISFRMTA
ISFRMT9  INC   RMINUS
         jr    ISFRMTF                 ; DONE
         PAGE    
;        GETCHR -- USED ONLY BY ISFORMAT...
;        TO FETCH POSSIBLE FORMAT STRING BYTES
;        RETURN 0 IN (A) IF END OF FORMAT STRING HIT
;
GETCHR       
         IF    M6800!M6801
         CLRA    
         CPX   ENDFORMAT
         jrz   GETCHR1
         LDA   ,X
GETCHR1  INX    
         ret
         ELSE  (M6809)
         LDA   ,X+
         CPX   ENDFORMAT
         BLS   GETCHR1
         CLRA    
GETCHR1  ret
         FIN    
;
ISFRMTE  EQU   *                       ; LEFT '-', NO LEFT '$': MAY HAVE '^'S OR NOTHING
ISFRMTA  CMPA  #'^
         jrnz  ISFRMTX                 ; DONE
         LDB   #5
         jr    ISFRMTB1
ISFRMTB  BSR   GETCHR
ISFRMTB1 CMPA  #'^
         jrnz  ISFRMTC
         INC   RCARET
         DECB    
         jrnz  ISFRMTB
         jr    ISFRMTF

ISFRMTC  LDA   RCARET                  ; VERIFY EXPONENT FIELD >=3 CHARACTERS
         CMPA  #2
         BHI   ISFRMTX
ISFRMTC1 DEX                           ; ASSERT: (A) <=2
         DECA    
         jrnz  ISFRMTC1
         CLR   RCARET
         jr    ISFRMTX                 ; DONE
;
ISFRMTD  LDB   LDOLLAR                 ; A STILL HAS CHAR
         ANDB  LMINUS
         jrnz  ISFRMTX                 ; DONE
         LDB   LDOLLAR
         jrz   ISFRMTE                 ; B/ LMINUS MUST BE ON
         CMPA  #'-                     ; LEFT '$', MAY HAVE '-' OR NOTHING
         jrz   ISFRMT9
ISFRMTX  DEX                           ; HANDLES CASE WHERE UNWANTED CHAR IS PICKED UP
ISFRMTF  LDA   LSHARP
         ADDA  RSHARP
         jrz   ISFRMTG                 ; AHA! THE NO-LEFT-OR-RIGHT-SHARPS TRICK
         CMPA  #10
         BHI   ISFRMTG                 ; NO GOOD
         ADDA  LDOLLAR
         ADDA  LMINUS
         ADDA  DPCOUNT
         ADDA  RMINUS
         ADDA  RCARET
         STA   FLENGTH                 ; REMEMBER THE FORMAT LENGTH HERE
         ret

ISFRMTG  PULX                          ; NOT A FORMAT STRING
         JMP   2,X
         PAGE    
;        PRINT VALUE ON TOS
;
XOPPV    call  FORCEFLOAT
         lhld  #FAC1
         call  FCONVO
         STA   LEAD
         STB   SIG
         lhld  USING
         CPX   USINGMAX
         jrz   PRNTV3

PRNTV1   shld  BEGINFORMAT             ; SAVE START OF POTENTIAL "FORMAT" STRING
         LDD   USINGMAX
         call  ISFORMAT                ; DOES A FORMAT STRING START AT BEGINFORMAT?
         jr    PRNTV4                  ; B/ YES
         lhld  BEGINFORMAT             ; NO
         INX                           ; ADVANCE TO NEXT BYTE OF USING STRING
         CPX   USINGMAX                ; USING STRING EXHAUSTED?
         jrnz  PRNTV1                  ; B/ NO.
         call  PROUS                   ; YES, NO FORMAT STRING WAS FOUND
PRNTV3   LDA   LEAD                    ; DO UNFORMATTED PRINT
         LDB   SIG
         lhld  #OUTBUF                 ; THIS IS WHERE TO PUT THE STUFF
         BSR   UFPRINT
         jr    PRNTV5
         PAGE    
PRNTV4   shld  ENDFORMAT               ; SAVE END OF FORMAT STRING
         lhld  BEGINFORMAT             ; SET USINGMAX := START OF FORMAT STRING
         LDD   USINGMAX
         shld  USINGMAX
         STD   BEGINFORMAT             ; SAVE REAL USING MAX
         call  PROUS                   ; GO PRINT THE NON-FORMAT PART
         lhld  BEGINFORMAT             ; RESTORE TRUE END OF "USING" STRING
         shld  USINGMAX
         lhld  ENDFORMAT               ; END OF LAST FORMAT =...
         shld  USING                   ; START OF REST OF USING STRING
         LDA   LEAD
         lhld  #OUTBUF                 ; THIS IS WHERE TO PUT THE STUFF
         call  FPRINT
;
;        PRINT NUMBER
;
PRNTV5   PSHA    
         call  SETSCOP
         db    SYSCALL:WRITEA
         db    WRITEA:SCLEN
         db    CHANGED,IGNORED

         PULA    
         STA   SCBLK+SCBLK:WRLEN+1
         lhld  #OUTBUF
         shld  SCBLK+SCBLK:WRBUF
         call  SYSCALLONUSERCHAN
         JMP   NTRPT1
        PAGE    
;        UNFORMATTED PRINT
;        SUBROUTINE FOR XOPPV, XOPNUM
;
;        A HAS # OF DIGITS LEFT OF THE DP IF E WERE = 0 (# OF INT DIGITS)
;        B HAS # OF SIGNIFICANT DIGITS (10 - # OF RIGHTMOST ZEROES)
;        X POINTS TO WHERE THE STUFF IS TO BE PUT
;        LDOLLAR CONTAINS LEFT DOLLAR COUNT
;        LMINUS CONTAINS LEFT MINUS COUNT
;        LSHARP CONTAINS LEFT SHARP COUNT
;        DP CONTAINS DP COUNT
;        RSHARP CONTAINS RIGHT SHARP COUNT
;        RMINUS CONTAINS RIGHT MINUS COUNT
;        RCARET CONTAINS RIGHT CARET COUNT
;        FLENGTH CONTAINS LENGTH OF ENTIRE FORMAT
;        FAC1-FAC6                     CONTAINS "S.DDDD"
;        FACEXT1-FACEXT5               CONTAINS "DDDDDD"
;        MS1-MS6                       CONTAINS "DESXXX"
;        WHERE S IS A '-' OR '+'
;        . IS A '.'
;        D IS AN ASCII DIGIT IN THE RANGE '0'-'9'
;        E IS A 'E'
;        X IS AN ASCII EXPONENT DIGIT IN THE RANGE '0'-'9'
;        ON EXIT, A RETURNS LENGTH
;        X POINTS PAST OUTPUT
;
;        CASE1 (ZERO)
;        A = 0 & ALL DIGITS ARE ZERO
;        (B = 0 SUFFICIENT)
;        PRINT ' 0'
;
;        CASE2 (INTEGER)
;        10 >= A >= 1 & RIGHTMOST 10-A DIGITS ARE ZERO
;        (A >= B)
;        PRINT SIGN, A DIGITS
;
;        CASE3 (INT W/FRAC)
;        9 >= A >=0 & RIGHTMOST 10-A DIGITS ARE NON-ZERO
;        (A < B)
;        PRINT SIGN, A DIGITS, '.' B DIGITS
;
;        CASE4 (SMALL FRACTION ONLY)
;        -1 >= A >= -5
;        PRINT SIGN, '.' (ABS(A)) ZEROES, B DIGITS
;
;        CASE5 (ALL ELSE)
;        PRINT SIGN, '.', B DIGITS
;        PRINT 'E', ESIGN, UP TO 3 DIGITS LEAD ZERO SUPPRESS
;
UFPRINT  shld  TWORD                   ; REMEMBER WHERE TO PUT THE RESULT
         CLR   TBYTE                   ; CLEAR THE LENGTH COUNTER
         TSTB                          ; ANY SIGNIFICANCE?
         jrnz  UFPRNT1                 ; YES
         INCA    
UFPRNT0  BSR   UFPRSN                  ; CASE 2, PRINT SIGN
         BSR   UFPRLFT                 ; PRINT LEFT DIGITS
         jr    UFPRNT6                 ; EXIT
UFPRNT1  CMPA  #10
         BGT   UFPRNT4                 ; GO DO CASE 5
         TSTA    
         BLE   UFPRNT3                 ; NOT CASE 2 OR 3, TRY 4
         CBA    
         BGE   UFPRNT0                 ; CASE 3
         BSR   UFPRSN                  ; CASE 3, PRINT SIGN
         BSR   UFPRLFT                 ; PRINT LEFT DIGITS
         BSR   UFPRDP                  ; PRINT '.'
         BSR   UFPRRT                  ; PRINT RIGHT DIGITS
         jr    UFPRNT6                 ; EXIT
UFPRNT3  CMPA  #-6                     ; SEE IF CASE 4, A IS ALREADY FOUND <= 0
         BLE   UFPRNT4
         BSR   UFPRSN                  ; CASE 4, PRINT SIGN
         BSR   UFPRDP                  ; PRINT DP
         BSR   UFPRZR                  ; PRINT THE ZEROES IF ANY
         BSR   UFPRRT                  ; PRINT RIGHT DIGITS
         jr    UFPRNT6                 ; EXIT
UFPRNT4  BSR   UFPRSN                  ; CASE 5, PRINT SIGN
         BSR   UFPRDP                  ; PRINT '.'
         BSR   UFPRRT
         LDA   #'E
         BSR   UFPR                    ; PRINT 'E'
         LDA   MS3
         BSR   UFPR                    ; PRINT SIGN
         lhld  #MS4
UFPRNT5  LDA   ,X
         CMPA  #'0
         jrnz  UFPRNT7
         INX    
         CPX   #MS6
         jrnz  UFPRNT5
UFPRNT8  LDA   ,X
UFPRNT7  BSR   UFPR
         INX    
         CPX   #MS6+1
         jrnz  UFPRNT8
UFPRNT6  LDA   TBYTE
         lhld  TWORD
         ret
         PAGE    
;        SUBROUTINES FOR UFPRINT, FPRINT

;        PRINT SIGN
;
UFPRSN   STA   LOOPCT
         LDA   FAC1
         CMPA  #'-
         jrz   UFPRSN3
UFPRSN2  LDA   #ASCII:SPACE
UFPRSN3  BSR   UFPR
         lhld  #FAC2
         ret
;
;        PRINT RIGHT DIGITS
;
UFPRRT1  LDB   RSHARP
UFPRRT   STB   LOOPCT
;
;        PRINT LEFT DIGITS
;
UFPRLFT  LDA   LOOPCT
         BLE   UFPRLFT2
UFPRLFT1 INX    
         LDA   ,X
         BSR   UFPR
         DECB                          ; ADJUST # OF SIG DIGITS RIGHT OF DP
         DEC   LOOPCT
         jrnz  UFPRLFT1
UFPRLFT2 ret
;
;        PRINT A DECIMAL POINT
;
UFPRDP   LDA   #'.
         BSR   UFPR
         ret
;
;        PRINT ZEROES
;
UFPRZR   LDA   LOOPCT
         BPL   FPRADSP1
         INCA    
         STA   LOOPCT
         CLRA    
         BSR   UFPR1
         jr    UFPRZR
;
;        ADD TO SPACE COUNT
;
FPRADSP  LDB   LMINUS
         jrz   FPRADSP1
         LDB   FAC1
         CMPB  #'+
         jrnz  FPRADSP1
         INCA    
FPRADSP1 TSTA                          ; FOR THE BENEFIT OF FORMATTED E-TYPE
         ret
;
;        PRINT LEADING MINUS IF LMINUS <> 0 & FAC1 = '-'
;
FPRLM    LDA   LMINUS
         jrz   FPRLM1
         LDA   FAC1
         CMPA  #'-
         jrnz  FPRLM1
         BSR   UFPR
FPRLM1   ret
;
;        PUT THE CHAR INTO THE OUTPUT BUFFER, PRESERVING X, B
;
UFPR1    ADDA  #'0
UFPR     shld  LOOPX
         lhld  TWORD
         STA   ,X+
         shld  TWORD
         lhld  LOOPX
         INC   TBYTE
         ret
         PAGE    
;        FORMATTED PRINT
;        SUBROUTINE FOR XOPPV, XOPNUMF
;
;        A HAS # OF DIGITS LEFT OF DP IF E WERE = 0 (SEE FCONVO)
;        X POINTS TO WHERE TO PUT THE STUFF
;        (ISFORMAT SETS UP THE FOLLOWING:)
;        LDOLLAR CONTAINS LEFT DOLLAR COUNT
;        LMINUS CONTAINS LEFT MINUS COUNT
;        LSHARP CONTAINS LEFT SHARP COUNT
;        DP CONTAINS DP COUNT
;        RSHARP CONTAINS RIGHT SHARP COUNT
;        RMINUS CONTAINS RIGHT MINUS COUNT
;        RCARET CONTAINS RIGHT CARET COUNT
;        FLENGTH CONTAINS LENGTH OF ENTIRE FORMAT
;        FAC1-FAC6                     CONTAINS "S.DDDD"
;        FACEXT1-FACEXT5               CONTAINS "DDDDDD"
;        MS1-MS6                       CONTAINS "DESXXX"
;        WHERE S IS A '-' OR '+'
;        . IS A '.'
;        D IS AN ASCII DIGIT IN THE RANGE '0'-'9'
;        E IS A 'E'
;        X IS AN ASCII EXPONENT DIGIT IN THE RANGE '0'-'9'
;        ON EXIT A RETURNS LENGTH
;        X POINTS PAST OUTPUT
;
;        CASE 1                        E-TYPE FORMAT
;        OVERFLOW IF NO '-' SPEC & VALUE IS NEGATIVE OR
;        ABS(A-LSHARP) > 100 & RCARET < 5 (3 EXP DIGITS) OR
;        100 > ABS(A-LSHARP) > 10 & RCARET < 4 (2 EXP DIGITS)
;        # SPACES = 1 IF LMINUS <> 0 & FAC1 = '+', ELSE = 0
;        PRINT LEADING SPACES
;        PRINT '-' IF LMINUS <> 0 & FAC1 = '-'
;        PRINT LSHARP DIGITS
;        PRINT '.' IF DP <> 0
;        PRINT RSHARP DIGITS (MAY BE NONE)
;        PRINT 'E'
;        LET EXP = A - LSHARP
;        PRINT SIGN(EXP) ('-' OR '+')
;        PRINT RCARET - 2 EXP DIGITS
;
;        CASE 2                        NOT E-TYPE FORMAT
;        OVERFLOW IF NO '-' SPEC & VALUE IS NEGATIVE OR
;        A > 0 & LSHARP - A < 0 
;        IF A <= 0 THEN
;        # SPACES = LSHARP (+ 1 IF LMINUS <> 0 & FAC1 = '+')...
;                                      ...-1*SGN(LSHARP)
;        IF A > 0 THEN
;        # SPACES = LSHARP - A (+ 1 IF LMINUS <> 0 & FAC1 = '+')
;        IF NUMBER OF LEADING SPACES > 0, THEN PRINT THEM
;        PRINT '$' IF LDOLLAR <> 0
;        PRINT '-' IF LMINUS <> 0 & FAC1 = '-'
;        PRINT A DIGITS ('0' IF A<=0 & LSHARP<>0 )
;        PRINT '.' IF DP <> 0
;        PRINT RSHARP DIGITS (MAY BE NONE)
;        PRINT '-' IF RMINUS <> 0 & FAC1 = '-', ELSE PRINT ' '
;
FPRINT   STA   LOOPCT
         shld  TWORD
         lhld  #FAC2
         CLR   TBYTE
;
         LDB   LMINUS                  ; CHECK OVERFLOW
         ORAB  RMINUS                  ; SIGN PROBLEM?
         jrnz  FPRINT1                 ; NO
         LDB   FAC1                    ; POSSIBLY, SEE IF VALUE IS NEG
         CMPB  #'-
         jrnz  FPRINT1
FPRINT10J      JMP                     ; FPRINT10 YES, FILL ASTERISKS
FPRINT1  LDB   RCARET                  ; E FORMAT?
         jrnz  FPRINT6                 ; YES
;
;        F-TYPE FORMAT (CASE 2)
;
         TSTA    
         BPL   FP1
         LDA   LSHARP
         jr    FP2
FP1      SUBA  LSHARP                  ; NO, CHECK MORE OVERFLOW
         NEGA    
         BMI   FPRINT10J               ; OVERFLOW
FP2      BSR   FPRADSP
         LDB   LOOPCT                  ; PICK UP A
         BGT   FP10
         LDB   LSHARP
         jrz   FP10
         DECA    
FP10     TAB    
         BLE   FPRINT0
FPRINT2  call  UFPRSN2                 ; PRINT SPACES
         DECB    
         jrnz  FPRINT2
FPRINT0  LDA   LDOLLAR                 ; NEED A DOLLAR SIGN PRINTED ?
         jrz   FPRINT3
         LDA   DOLLARSIGN              ; USE VALUE FROM FIXED LOCATION SO BRITISH CAN CHANGE IT
         BSR   UFPR
FPRINT3  BSR   FPRLM                   ; PRINT LEAD '-' IF REQUIRED
         LDA   LOOPCT
         BGT   FP11
         LDA   LSHARP
         jrz   FP13
         CLRA    
         BSR   UFPR1
FP11     EQU   *
FP13     call  UFPRLFT                 ; PRINT LEAD DIGITS
         LDA   DPCOUNT                 ; PRINT DP
         jrz   FPRINT4                 ; (NOW LOOPCT <= 0!)
         LDA   #'.
         BSR   UFPR
         LDB   RSHARP                  ; COMPUTE # SIGNIFICANT DIGITS TO PRINT
         ADDB  LOOPCT
         STB   LOOPCT
         BPL   FP3A                    ; B/ SIGNIFICANCE EXISTS
         CLRB                          ; PRINT RSHARP LEADING ZEROS
FP3A     SUBB  RSHARP                  ; PRINT OLD LOOPCT LEAD ZEROS
         jrz   FP4
FP3      CLRA    
         BSR   UFPR1
         INCB    
         jrnz  FP3
FP4      call  UFPRLFT
FPRINT4  LDA   RMINUS                  ; DO TRAILING MINUS IF ANY
         jrz   FPRINTH                 ; EXIT
         LDA   #ASCII:SPACE
         LDB   FAC1
         CMPB  #'-
         jrnz  FPRINT5
         TFR   B,A
FPRINT5  call  UFPR
FPRINTH  JMP   FPRINTG                 ; EXIT
;
;        E-TYPE FORMAT (CASE 1)
;
FPRINT6  STA   TEMPB                   ; SIGN EXTEND A INTO TEMPA
         CLRB    
         ROLA    
         SBCB  #0
         STB   TEMPA
         CLRA                          ; GET LSHARP SIGN EXTENDED
         LDB   LSHARP
         STB   LOOPCT
         SUBD  TEMPA                   ; SUBTRACT 'A'
         PSHD    
         BPL   FP5                     ; TAKE ABS(LSHARP - 'A')
         NEGD    
FP5      TSTA    
         jrnz  FPRINT8                 ; ABS(EXPONENT) > 255, NEED 5 CARETS
         CMPB  #99
         BHI   FPRINT8
         CMPB  #9
         BLS   FPRINTB                 ; EXP < 10, WE'RE OK
         LDA   RCARET
         CMPA  #4                      ; EXP >= 10 & < 100, REQUIRES AT LEAST 4 CARETS
         BLT   FPRINT9                 ; ERROR
         jr    FPRINTB                 ; AT LEAST 4 CARETS, WE'RE OK
FPRINT8  LDA   RCARET
         CMPA  #5                      ; EXP >= 100, REQUIRES 5 CARETS
         jrz   FPRINTB                 ; 5 CARETS, WE'RE OK
FPRINT9  LEAS  2,S
FPRINT10 LDB   FLENGTH                 ; PUT OUT '*'
FPRINTA  LDA   #'*
         call  UFPR
         DECB    
         jrnz  FPRINTA
         jr    FPRINTG                 ; EXIT
FPRINTB  CLRA    
         call  FPRADSP
         jrz   FPRINTC                 ; ANY BLANKS?
         call  UFPRSN2                 ; ONLY ONE POSSIBLE
FPRINTC  lhld  #FAC2
         call  FPRLM                   ; PRINT LEAD '-' IF REQUIRED
         call  UFPRLFT                 ; PRINT LEFT DIGITS
         LDA   DPCOUNT                 ; PRINT DP
         jrz   FPRINTD
         LDA   #'.
         call  UFPR
         call  UFPRRT1                 ; PRINT RIGHT DIGITS
FPRINTD  LDA   #'E                     ; PRINT 'E'
         call  UFPR
         LDA   SIG                     ; ANY SIGNIFICANCE?
         jrnz  FP9                     ; YES
         STA   MEXP                    ; NO, USE EXP 'E+000'
         LEAS  2,S
         jr    FP6
FP9      PULD    
         STB   MEXP                    ; PRINT ESIGN
         jrz   FP6                     ; EXP = 0, USE '+'
         TSTA    
         BPL   FPRINTE                 ; EXPONENT IS NON-ZERO AT THIS TEST
         NEGB    
         STB   MEXP
FP6      LDA   #'+                     ; THIS IS REVERSED BECAUSE THE SUBTRACT WAS 
         jr    FP6A
FPRINTE  LDA   #'-
FP6A     call  UFPR
         lhld  #0                      ; MAKE BCD EXPONENT DIGITS IN FAC1 & FAC2
         shld  FAC1
         LDB   #8                      ; 8 BITS TO SHIFT
FPRINTF  ASL   MEXP
         LDA   FAC2
         ADCA  FAC2
         DAA    
         STA   FAC2
         LDA   FAC1
         ADCA  FAC1
         DAA    
         STA   FAC1
         DECB    
         jrnz  FPRINTF
         LDB   RCARET                  ; SEE HOW MANY EXPONENT DIGITS TO USE
         SUBB  #4
         jrz   FP7                     ; PRINT 2 EXP DIGITS
         BMI   FP8                     ; PRINT 1 EXP DIGIT
         LDA   FAC1                    ; UPPER NIBBLE MUST BE 0, PRINT 3 EXP DIGITS
         call  UFPR1
FP7      LDA   FAC2
         LSRA    
         LSRA    
         LSRA    
         LSRA    
         call  UFPR1
FP8      LDA   FAC2                    ; ALWAYS PRINT THIS DIGIT
         ANDA  #$F
         call  UFPR1
FPRINTG  LDA   TBYTE
         lhld  TWORD
         ret
         PAGE    
;        CHANGE TOS VALUE TO HEX STRING
;
XOPHEX   call  FIXTOS                  ; AND DON'T COME BACK IF YOU CAN'T
         LEAS  4,S                     ; TOS FORM IS (X,X,X,X,I,I); DROP X,X,X,X
         LDA   #':
         STA   OUTBUF
         lhld  #OUTBUF+1
         PULA    
         BSR   HEX1
         PULA    
         BSR   HEX1
         LDA   #5
         jr    NUM2

;
;        CONVERT BYTE TO ASCII HEX
;
HEX1     TFR   A,B
         LSRA    
         LSRA    
         LSRA    
         LSRA    
         BSR   HEX2
         TFR   B,A
         ANDA  #$F
;
;        CONVERT NIBBLE TO HEX DIGIT IN ASCII
;
HEX2     CMPA  #9
         BLE   HEX3
         ADDA  #7
HEX3     ADDA  #$30
         STA   ,X+
HEXRTS   ret
         PAGE    
;        NUM$    
;        REPLACE TOS VALUE WITH SD
;
XOPNUM   BSR   FORCEFLOAT              ; MAKE SURE TOS IS FLOATING
         lhld  #FAC1
         call  FCONVO                  ; CONVERT IT TO RAW STUFF
         lhld  #OUTBUF
         call  UFPRINT                 ; DO UNFORMATTED MASSAGING
NUM2     PSHA    
         CLRA    
         PSHA    
         LDD   #(OUTBUF-4)
         PSHD    
         LDA   #1                      ; MAKE EXP BYTE OF SD <> 0
         PSHD    
         JMP   NTRPT2
;
;        FORCEFLOAT -- ENSURE THAT TOS IS FLOATING
;
FORCEFLOAT     EQU                     ; *
         LDA   R1TYPE+2,S
         jrnz  HEXRTS                  ; B/ ALREADY FLOAT, GO 'WAY
;
;        BFLOAT -- INTERFACE TO FP ROUTINE FLOAT
;
BFLOAT   PULD    
         STD   ,S
         IF    M6800!M6801
         CLR   2,X
         CLR   3,X
         ELSE  (M6809)
         CLR   2,S
         CLR   3,S
         FIN    
         JMP   FLOAT
         PAGE    
;        NUMF$ CONVERTS VALUE ON TOS TO SD USING FORMAT STRING SD AT TOS-1
;        FORMAT STRING MUST CONTAIN ONLY VALID # FORMAT
;
XOPNUMF  lhld  R2SDC1,S
         CPX   #$FFFF
         jrnz  NUMF0
         CLR   R2SDC1,S                ; SET FORMAT STRING LENGTH TO CURLEN
         IF    M6800!M6801
         lhld  R2SDA,X
         ELSE  (M6809)
         lhld  R2SDA,S
         FIN    
         LDA   CURLEN,X
         jrnz  NUMF1
         LDB   CURLEN+1,X
         STB   R2SDC2,S
NUMF0    LDA   R2SDC1,S
         jrnz  NUMF1
         IF    M6800!M6801
         LDB   R2SDC2,X                ; (A,B):= STRING LENGTH
         lhld  R2SDA,X                 ; GET ADDRESS OF FORMAT STRING
         ELSE  (M6809)
         LDB   R2SDC2,S
         lhld  R2SDA,S
         FIN    
         LEAX  STRING,X                ; = ADDRESS OF START OF FORMAT STRING
         shld  TWORD                   ; NOW SET (A,B):=END OF FORMAT STRING
         ADDD  TWORD                   ; = ADDRESS OF STRING + LENGTH IN BYTES
         call  ISFORMAT
         jr    NUMF2

NUMF1    call  RTPERR
         db    :FORMAT

NUMF2    CMPA  R2SDC2,S                ; LENGTH MUST MATCH
         jrnz  NUMF1
         BSR   FORCEFLOAT              ; MAKE SURE ITS FLOATING
         lhld  #FAC1
         call  FCONVO                  ; CONVERT TO RAW STUFF
         lhld  #OUTBUF
         call  FPRINT
         LDD   #(OUTBUF-4)
         STD   R1SDA,S
         JMP   NTRPT2
         PAGE  *****  I / O  *****
;
;        SET CHANNEL NUMBER TO ZERO
;
XOPZCHN  CLR   CHANEL
         IF    M6800!M6801
         JMP   NTRPT1
         ELSE  (M6809)
         JMP   NTRPTX
         FIN    
;
;        COLUMN FUNCTION
;
XOPCOL   call  RNDTOS
         DW    SETCHNERR
         TSTA    
         jrnz  SETCHNERR
         BSR   GETCOL
         CLRA    
         ADDD  #1
         PSHD    
         LEAS  -3,S
         CLRA    
         PSHA    
         JMP   NTRPT2
         PAGE    
;
;        GET COLUMN NUMBER
;
GETCOL   PSHB    
         call  SETSCOP
         db    SYSCALL:STATUS
         db    STATUS:SCLEN
         db    CHANGED
         db    SC:GETCOL

         call  SETSCRDBUF
         DW    CHAR
         DW    1

         PULA    
         STA   SCBLK+SCBLK:PARAMS
         call  ISYSCALL

         LDB   CHAR
         ret
         PAGE    
;
;        SET CHANNEL NUMBER
;
XOPCHNL  call  RNDTOS
         DW    SETCHNERR
         TSTA    
         jrnz  SETCHNERR
         STB   CHANEL
         JMP   NTRPT1

SETCHNERR      call                    ; RTPERR
         db    :CHNLR
         PAGE    
;
;        DO TAB TO NEXT PRINT COLUMN
;
XOPTABCOL      LDB                     ; CHANEL
         BSR   GETCOL
COLMN0   SUBB  #18                     ; REDUCE COLUMN COUNT MODULO 18
         BCC   COLMN0
         NEGB                          ; = # BLANKS TO OUTPUT (>=1)
COLMN1   STB   TBYTE
         call  SETSCOP                 ; SET UP SYSCALL OPCODE
         db    SYSCALL:WRITEA          ; WRITE ASCII
         db    WRITEA:SCLEN
         db    CHANGED,IGNORED
COLMNL   ; WRITE BLOCKS OF BLANKS
         CLR   SYSCALLWRLEN
         LDB   TBYTE                   ; ASSUME WRITE BUF LENGTH = COUNT
         STB   SYSCALLWRLEN+1
         LDB   #BLANKSTRINGEND-BLANKSTR; ING
         CMPB  TBYTE                   ; IS ACTUAL STRING SIZE < COUNT ?
         BCC   COLMN4                  ; B/ NO
         STB   SYSCALLWRLEN+1          ; YES, USE LENGTH OF BLANK CONSTANT
COLMN4   lhld  #BLANKSTRING            ; SET UP WRITE BUFFER
         shld  SYSCALLWRBUF
         call  SYSCALLONUSERCHAN       ; AND DO THE SYSTEM CALL!
         LDB   TBYTE                   ; SUBTRACT # BLANKS PRINTED...
         SUBB  SYSCALLWRLEN+1          ; FROM ACTUAL COUNT
         jrnz  COLMN1                  ; B/ MOVE TO PRINT.
COLMN3   JMP   NTRPT1
BLANKSTRING    db                      ; "                  "
BLANKSTRINGEND EQU                     ; *
         PAGE    
;
;        TAB TO SPECIFIED COLUMN #
;
XOPTAB   call  RNDTOS
         DW    TAB3
         TSTA    
         jrnz  TAB3
         PSHB    
         LDB   CHANEL
         call  GETCOL
         INCB                          ; TAB(1) = 1ST PRINT COLUMN
         PULA    
         jrz   COLMN3
         SBA    
         jrc   COLMN3
         jrz   COLMN3
         TFR   A,B
         jr    COLMN1

TAB3     call  RTPERR
         db    :TABBIG
         PAGE    
;        EOF CHECK
;
XOPEOF   call  RNDTOS
         jr    SETCHNERR
EOF2     TSTA    
         jrnz  SETCHNERR
;
;        GET EOF STATUS ON CHANNEL (B)
;
         BITB  #$E0                    ; B=0..31?
         jrnz  SETCHNERR
         STB   SCBLK+SCBLK:PARAMS
         call  EOFBGEN
         BITA  ,X
         JMP   NOTEQUALQ
         PAGE    
;        DEBUG
;
XOPDBG   call  SETSCOP
         db    SYSCALL:DEBUG
         db    DEBUG:SCLEN
         DW    IGNORED

         call  ISYSCALL
         JMP   NTRPT2
;
;        CLOSE A FILE
;
XOPCLS   call  SETSCOP
         db    SYSCALL:CLOSE
         db    CLOSE:SCLEN
         db    CHANGED,IGNORED
         call  SYSCALLONUSERCHAN
         JMP   NTRPT1
         PAGE    
;        READ A # FROM A FILE
;
XOPRV    call  SETSCOP
         db    SYSCALL:READB
         db    READB:SCLEN
         db    CHANGED,IGNORED

         IF    M6800!M6801
         LEAS  -(RSESIZ-1),S
         sspd  SCBLK+SCBLK:RDBUF
         DES    
         ELSE  (M6809)
         LEAS  -RSESIZ,S
         sspd  SCBLK+SCBLK:RDBUF
         FIN    
         LDA   #6
         STA   SCBLK+SCBLK:RDLEN+1
         call  SYSCALLONUSERCHAN
         JMP   NTRPT1
         PAGE    
;        OPEN FILE SPECIFIED BY TOS DESCRIPTOR
;
XOPOPN   call  SETSCOP
         db    SYSCALL:OPEN
         db    OPEN:SCLEN
         db    CHANGED,IGNORED

XOPOPN2  call  SETSCRDBUF
         DW    SCRATCH
         DW    4

         TSX    
         call  SYSCALLGETWRBUF
         call  SYSCALLONUSERCHAN
         JMP   PL1PC1

;
;        CHAIN TO FILE SPECIFIED BY TOS DESCRIPTOR
;
XOPCHAIN call  SETSCOP
         db    SYSCALL:CHAIN
         db    CHAIN:SCLEN
         DW    IGNORED
         JMP   XOPOPN2

         PAGE    
;        CREATE A FILE SPECIFIED BY TOS DESCRIPTOR
;
XOPCREAT call  SETSCOP
         db    SYSCALL:CREATE
         db    CREATE:SCLEN
         db    CHANGED,IGNORED
         JMP   XOPOPN2

;
;        DELETE FILE WHOSE NAME IS STRING ON TOS
;
XOPDEL   call  SETSCOP
         db    SYSCALL:DELETE
         db    DELETE:SCLEN
         DW    IGNORED
         JMP   XOPOPN2

         PAGE    
;        RENAME FILE NAMED TOS-1 (SD) TO TOS (SD)
;        NEW NAME LENGTH ON TOS, THEN ADDRESS, THEN RETURN ADDRESS
;        X PASSES POINTER TO OLD NAME, A TO OLD NAME LENGTH
;
XOPREN   call  SETSCOP
         db    SYSCALL:OPEN
         db    OPEN:SCLEN
         db    CHANGED,IGNORED

         IF    M6800!M6801
         TSX    
         shld  TEMPX
         ELSE  (M6809)
         sspd  TEMPX
         FIN    
         call  SYSCALLGETNEXTSTRING
         call  SYSCALLGETWRBUF1
         call  SETSCRDBUF
         DW    SCRATCH
         DW    4

         call  FINDACHAN

         call  SETSCOP
         db    SYSCALL:RENAME
         db    RENAME:SCLEN
         db    CHANGED,IGNORED

         TSX    
         call  SYSCALLGETWRBUF

         call  SETSCRDBUF
         DW    SCRATCH
         DW    4

         call  SYSCALLONMYCHAN
         call  CLOSEMYCHAN
         JMP   PL2PC1

         PAGE    
;        POSITION A FILE TO A SPECIFIED RECORD
;
XOPRESTR PULA    
         TSTA    
         jrz   POS1
         PSHA    
         lhld  #FPOINT5
         call  FLOAD
         call  FADD
         call  FIX
         jr    POS4
         call  RTPERR                  ; FILE POSITION IS TOO BIG!
         db    :POSERR
POS1     INS                           ; CONVERT TOS TO (0,0,X,X)
         CLR   ,S
         IF    M6800!M6801
         CLR   1,X
         ELSE  (M6809)
         CLR   1,S
         FIN    
POS4     call  SETSCOP
         db    SYSCALL:CONTROL
         db    SCBLK:RPLEN
         db    CHANGED
         db    CC:POSITION

         IF    M6800!M6801
         TSX    
         shld  SCBLK+SCBLK:WRBUF
         ELSE  (M6809)
         sspd  SCBLK+SCBLK:WRBUF
         FIN    
         lhld  #4
         shld  SCBLK+SCBLK:WRLEN
         call  SYSCALLONUSERCHAN

         LEAS  4,S                     ; DITCH POSITION INTEGER
         JMP   NTRPT1
         PAGE    
;
;        WRITE A NUMBER TO A FILE
;
XOPWV    call  SETSCOP
         db    SYSCALL:WRITEB
         db    WRITEB:SCLEN
         db    CHANGED,IGNORED

         IF    M6800!M6801
         TSX    
         shld  SCBLK+SCBLK:WRBUF
         ELSE  (M6809)
         sspd  SCBLK+SCBLK:WRBUF
         FIN    
         lhld  #RSESIZ
         shld  SCBLK+SCBLK:WRLEN
         call  SYSCALLONUSERCHAN

         JMP   PL1PC1
         PAGE    
;        READ A STRING USING TOS SD, READ MAX LENGTH IF COUNT = -1
;
XOPRS    call  SETSCOP
         db    SYSCALL:READB
         db    READB:SCLEN
         db    CHANGED,IGNORED

         TSX    
         call  SYSCALLGETRDBUF
         STD   SCBLK+SCBLK:RDLEN
         call  SYSCALLONUSERCHAN
         lhld  SYSCALLSTRHEADPTR
         jrz   READS2
         LDD   SCBLK+SCBLK:RPLEN
         STD   CURLEN,X
READS2   JMP   PL1PC1
         PAGE    
;        WRITE A STRING TO A FILE
;
XOPWS    call  SETSCOP
         db    SYSCALL:WRITEB
         db    WRITEB:SCLEN
         db    CHANGED,IGNORED

         TSX    
         call  SYSCALLGETWRBUF
         call  SYSCALLONUSERCHAN
         JMP   PL1PC1

CLOCKSTR db    'CLOCK:'
         PAGE    
;        QUICK MULTIPLY FOR UNSIGNED, 16 bit quantities
;        (BC) CONTAINS MULTIPLICAND
;        (DE) CONTAINS MULTIPLIER, SMALLER PREFERRED
;        (HL) WILL CONTAIN RESULT
;        SKIP RETURN IF OVERFLOW
;        Computes 3 cross products to generate result
;        (Crossproduct of B and D would simply cause overflow)
;
**** this routine needs work!
MLTPLY   shld  MR1                     ; SAVE MULTIPLIER
         jrz   MLTPLY0                 ; B/ MULTIPLIER IS 0 --> PRODUCT IS ZERO
         mov   a,b                     ; is upper byte of mpcnd non-zero ?
         ana   a                       ; ... ?
ms12 is bc  mr1 is de
         jz    MLTPLYA                 ; B/ upper byte of mpcnd is zero
         mov   a,d                     ; is upper byte of multiplier non-zero ?
         ana   a                       ; ...?
         jnz   movf                    ; b/ yes, product would be >= 2^16
         LDB   MR2                     ; MR2 MUST BE NON-ZERO HERE!
MLTPLYU  CALL  MULBYTES                ; DO 6809 STYLE MULTIPLY OF (A) AND (B)
         TSTA                          ; IS PRODUCT >= 2^16 ?
         jrnz  MOVF                    ; B/ YES, BYE!
         STB   MS1                     ; SAVE UPPER 8 BITS
MLTPLYL  LDA   MS2                     ; MS1 <> 0, DON'T BOTHER CHECKING MS2
         LDB   MR2                     ; MR2 <> 0!
         CALL  MULBYTES
         ADDA  MS1                     ; ADD PARTIAL PRODUCT FROM OTHER CROSS PRODUCT
         jrc   MOVF                    ; B/ SUM >= 2^16
         ret                           ; PRODUCT IS OK

MLTPLYA  mov   a,c                     ; upper byte of mpcnd is zero
         ana   a                       ; is lower byte of mpcnd zero ?
         jrz   MLTPLY0                 ; B/ yes, PRODUCT IS ZERO
         LDA   MR1
         jrz   MLTPLYL                 ; MS1,MR1 = 0
         JMP   MLTPLYU                 ; MR1, MS2 <>0, GO COMPUTE UPPER CROSS PRODUCT

MLTPLY0  lxi   h,0                     ; PRODUCT IS ZERO
         ret    

MOVF     PULX    
         JMP   2,X
         PAGE    
MulBytes ; multiply unsigned (E) by unsigned (A), product to (HL)
         mov   h,a                     ; (5~) multiplier
         mvi   l,0                     ; (7~) partial multiplicand
         mov   d,l                     ; (5~) make multiplicand 16 bits
         dad   h                       ; (10~) shift out multiplier bit
         jrnc  $+4                     ; (10~) b/ 1st multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 2nd multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 3rd multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 4th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 5th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 6th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 7th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4                     ; (10~) b/ 8th multipler bit is zero
         ret    
         page
divideintegers ; enter with (DE) containing divisor, (BC) holding dividend
; exit with (BC) holding quotient, (HL) with remainder
         mov h,b ! mov l,c             ; move dividend to HL
         xra a ! sub e ! mov c,a       ; set (BC) to -(DE)
         mvi a,0 ! sbb d ! mov b,a     ; (sets up for restoring divide)
         shld  dividend                ; save the dividend
         mov   a,h                     ; set (A) to upper 8 bits of dividend
         lxi   h,0                     ; set up initial remainder
         call  dividegen8qbits         ; generate 8 quotient bits
         sta   dividend+1              ; save upper 8 quotient bits
         lda   dividend                ; set (A) to lower 8 bits of dividend
         call  dividegen8qbits         ; generate final 8 quotient bits
         mov   c,a                     ; set (BC) to quotient
         lda   dividend+1
         mov   b,a
         ret                           ; (BC) has quotient, (HL) has remainder

divgen8quotientbits ; generate 8 quotient bits
;  Enter with (HL) = dividend/2 (remainder), (BC) = - divisor, (DE) = divisor
;  (A) starts with 8 bits of dividend, shifts out dividend bits into remainder,
;  and shifts in quotient bits.
;  Exit with HL = positive remainder, (A) = 8 bits of quotient,
;  (BC) and (DE) with entry values.
;  This code operates by running a non-restoring divide loop, which has
;  been unrolled because there is no place in the registers for a loop
;  count, and we only need to generate 8 quotient bits.
         dad   h                       ; double the remainder, put 0 in LSB
         add   a                       ; shift-out dividend bit
         jrzc  div0                    ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div0     dad   b                       ; generate 1st quotient bit
         jrnc  div1q0                  ; b/ 1st quotient bit is zero

div1q1 ; 1st quotient bit is a one
         dad   h                       ; (10~) double the remainder
         add   a                       ; (4~)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div1q1z                 ; (10~) b/ dividend bit is zero
         inx   h                       ; (5~)  insert dividend bit in remainder LSB
div1q1z  inr   a                       ; (5~)  record dividend bit
         dad   b                       ; (10~) generate 2nd quotient bit
         jrnc  div2q0                  ; (10~) b/ 2nd quotient bit is zero

div2q1 ; 2nd quotient bit is a one
         dad   h                       ; double the remainder
         add   a                       ; shift-in 0 bit, shift-out Dividend bit
         jrzc  div2q1z                 ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div2q1z  inr   a                       ; record quotient bit
         dad   b                       ; generate 3rd quotient bit
         jrnc  div3q0                  ; b/ 3rd quotient bit is zero

div3q1 ; 3rd quotient bit is a one
         dad   h                       ; double the remainder
         add   a                       ; shift-in 0 bit, shift-out Dividend bit
         jrzc  div3q1z                 ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div3d0   inr   a                       ; record quotient bit
         dad   b                       ; generate 4th quotient bit
         jrnc  div4q0                  ; b/ 4th quotient bit is zero

div4q1 ; 4th quotient bit is a one
         dad   h                       ; double the remainder
         add   a                       ; shift-in 0 bit, shift-out Dividend bit
         jrzc  div4q1z                 ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div4q1z  inr   a                       ; record quotient bit
         dad   b                       ; generate 5th quotient bit
         jrnc  div5q0                  ; b/ 5th quotient bit is zero

div5q1 ; 5th quotient bit is a one
         dad   h                       ; double the remainder
         add   a                       ; shift-in 0 bit, shift-out Dividend bit
         jrzc  div5q1z                 ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div5q1z  inr   a                       ; record quotient bit
         dad   b                       ; generate 6th quotient bit
         jrnc  div6q0                  ; b/ 6th quotient bit is zero

div6q1 ; 6th quotient bit is a one
         dad   h                       ; double the remainder
         add   a                       ; shift-in 0 bit, shift-out Dividend bit
         jrzc  div6q1z                 ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div6q1z  inr   a                       ; record quotient bit
         dad   b                       ; generate 7th quotient bit
         jrnc  div7q0                  ; b/ 7th quotient bit is zero

div7q1 ; 7th quotient bit is a one
         dad   h                       ; double the remainder
         add   a                       ; shift-in 0 bit, shift-out Dividend bit
         jrzc  div7q1z                 ; b/ dividend bit is zero
         inx   h                       ; insert dividend bit in remainder LSB
div7q1z  inr   a                       ; record quotient bit
         dad   b                       ; generate 8th quotient bit
         jrnc  div8q0                  ; b/ 8th quotient bit is zero

div8q1 ; 8th quotient bit is a one
         adc   a                       ; shift-in 8th quotient bit
; exit with 8 quotient bits in (A), unshifted positive remainder in (HL)
         ret

div1q0 ; 1st quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div1q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div1q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 2nd quotient bit
         jrc   div2q1                  ; (10) b/ 2nd quotient bit is one

div2q0 ; 1st quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div2q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div2q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 3rd quotient bit
         jrc   div3q1                  ; (10) b/ 3rd quotient bit is one

div3q0 ; 3rd quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div3q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div3q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 4th quotient bit
         jrc   div4q1                  ; (10) b/ 4th quotient bit is one

div4q0 ; 4th quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div4q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div4q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 5th quotient bit
         jrc   div5q1                  ; (10) b/ 5th quotient bit is one

div5q0 ; 5th quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div5q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div5q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 6th quotient bit
         jrc   div6q1                  ; (10) b/ 6th quotient bit is one

div6q0 ; 6th quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div6q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div6q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 7th quotient bit
         jrc   div7q1                  ; (10) b/ 7th quotient bit is one

div7q0 ; 7th quotient bit is a zero
         dad   h                       ; (10) double the remainder
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         jrzc  div7q0z                 ; (10) b/ dividend bit is zero
         inx   h                       ; (5)  insert dividend bit in remainder LSB
div7q0z ;adi   0                       ; (0)  record quotient bit
         dad   d                       ; (10) generate 8th quotient bit
         jrc   div8q1                  ; (10) b/ 8th quotient bit is one

div8q0 ; 8th quotient bit is a zero
         add   a                       ; (4)  shift-in 0 bit, shift-out Dividend bit
         dad   d                       ; restore final remainder correctly
; exit with (A) = 8 bits of quotient, (HL) = positive remainder
         ret
 page
        PAGE  *** T R A N S C E N D E ; N T A L S *** 
;****  R A N D O M   N U M B E R  G E N E R A T I O N *****
;
;        SET SEED (OPSETSEED): COMPILER STMT "LET RND=exp"
;
XOPSETSEED     call                    ; FORCEFLOAT SO ALL THE SIGNIFICANCE IS IN LEFTMOST 4 BYTES
         lhld  #SEED                   ; AND STORE THE VALUE
         call  FSTORE                  ; (XOPRND ONLY USES 1ST 4 BYTES OF "SEED")
         JMP   NTRPT2

;
;        OPRND-- GENERATE RANDOM NUMBER BETWEEN 0 AND 1
;        PUSH VALUE ONTO STACK
;        USES SEED':=(SEED*A+C) MOD M
;        RESULT = SEED'/2^31
;        A = 2^23+2^14+2^2+1, C=1, M=2^31 (SEE KNUTH)
;
XOPRND   LDD   SEED+2                  ; SET SEED':=SEED
         PSHD                          ; (SEED' IS TOP 4 BYTES OF STACK)
         LDA   SEED+1
         PSHA    
         LDA   SEED
         PSHA    
         TSX                           ; NOW (X) POINTS TO SEED'
         ASLB                          ; TEMP:=SEED*2^2
         ROL   SEED+2
         ROL   SEED+1
         ROL   SEED
         ASLB    
         ROL   SEED+2
         ROL   SEED+1
         ROL   SEED
         SEC                           ; SEED':=SEED'+TEMP+1
         TFR   B,A                     ; (B CONTAINS LOWER 8 BITS OF SEED)
         ADCA  3,X
         STA   3,X
         LDA   2,X
         ADCA  SEED+2
         STA   2,X
         LDA   1,X
         ADCA  SEED+1
         STA   1,X
         LDA   ,X
         ADCA  SEED
         STA   ,X
         ASLB                          ; TEMP:=TEMP*2^12 (=2^8*2^4)
         ROL   SEED+2                  ; (*2^8 ACCOMPLISHED BY IGNORING SEED+0)
         ROL   SEED+1                  ; = SEED*2^14
         ASLB    
         ROL   SEED+2
         ROL   SEED+1
         TFR   B,A                     ;  SEED':=SEED'+SEED*2^14
         ADDA  2,X
         STA   2,X
         LDA   1,X
         ADCA  SEED+2
         STA   1,X
         LDA   ,X
         ADCA  SEED+1
         STA   ,X
         ASLB                          ; TEMP:=TEMP*2^9 =  SEED*2^23
         ROL   SEED+2                  ; (*2^8 ACCOMPLISHED BY IGNORING SEED+0,SEED+1)
         LDA   SEED+2
         ADDD  ,X                      ; SEED':=SEED'+SEED*2^23
         ANDA  #$7F                    ; ... MOD ( 2^31 )
         STD   ,X
         STD   SEED                    ; SEED:=SEED'
         lhld  2,X
         shld  SEED+2
         call  FLOAT                   ; CONVERT 31 BIT INTEGER TO FLOATING VALUE
         lhld  #FP2TOM31               ; AND DIVIDE BY 2^31
         call  FLOAD
         call  FMUL                    ; ACCORDING TO THE MANUAL, HE CAN'T OVERFLOW!
XOPSQXIT EQU   *
         JMP   NTRPT2
         PAGE  *****  T R A N S C E N D;  E N T A L S  *****
;
;        OPSQR -- COMPUTE SQUARE ROOT OF TOS
;        ESTIMATES SQR(100^X*M):
;        = 100^(X/2)*SQR(M)            IF X IS EVEN
;        = 100^(X/2)*SQR(M)*10         IF X IS ODD
;        ESTIMATES SQR(M) == SQR(AVERAGE(M)) == SQR(AVERAGE(.01,.99)) == SQR(.5) == .7
;        USES ESTIMATE IN NEWTON-RAPHSON ITERATION TO GET ACTUAL SQUARE ROOT
;
XOPSQERR call  RTPERR                  ; SQRT OF NEGATIVE NUMBER
         db    :SQTERR

XOPSQR   LDA   VTYPE,S
         BMI   XOPSQERR                ; B/ TOUGH SHIT, CHARLIE
         jrnz  XOPSQ1                  ; B/ HE'S FLOATING AND NOT ZERO
         IF    M6800
         LDA   VINT1,X                 ; TAKE EASY WAY OUT IF NUMBER IS ZERO
         ORAA  VINT2,X
         ELSEIF                        ; M6801
         LDD   VINT1,X
         ELSE  M6809
         LDD   VINT1,S
         FIN    
         jrz   XOPSQXIT                ; B/ IT IS
         call  BFLOAT                  ; MAKE SURE HE'S FLOATING
XOPSQ1   call  XBSUBR                  ; DUPLICATE VALUE SO WE CAN GENERATE ESTIMATE...
         OPDUP                         ; OF SQUARE ROOT
         OPASM                         ; = (VALUE MANTISSA)*100^(EXPONENT/2)
         LDA   VTYPE,S                 ; GO GET THE EXPONENT
         SUBA  #$40                    ; CONVERT FROM EXCESS 64 TO SIGNED
         ASRA                          ; DIVIDE BY 2, PRESERVE SIGN
         LDB   #70                     ; EVEN EXPONENT --> USE .7 AS ESTIMATE
         BCC   XOPSQ2                  ; B/ EVEN EXPONENT
         LDB   #07                     ; ODD EXPONENT --> USE .7*10 AS ESTIMATE
XOPSQ2   ADCA  #$40                    ; CONVERT BACK TO EXCESS 64
         IF    M6800!M6801
         STD   VTYPE,X                 ; TOS NOW HAS VERY ROUGH SQRT
         ELSE  (M6809)
         STD   VTYPE,S                 ; STORE ESTIMATED MANTISSA
         FIN    
         LDA   #7                      ; NUMBER OF NEWTON-RAPHSON ITERATIONS
         STA   LOOPCT
XOPSQL   call  XBCODE                  ; DO NEWTON-RAPHSON ITERATIONS
         OPSTORE                       ;  TTEMP1:=ESTIMATE
         DW    TTEMP1
         OPDUP                         ; STACK NOW HAS VALUE,VALUE
         OPLOAD                        ;  VALUE,VALUE,ESTIMATE
         DW    TTEMP1
         OPDIV                         ; VALUE,VALUE/ESTIMATE
         OPLOAD                        ;  VALUE,VALUE/ESTIMATE,ESTIMATE
         DW    TTEMP1
         OPADD                         ; VALUE,VALUE/ESTIMATE+ESTIMATE
         OPLOAD                        ;  VALUE,(VALUE/ESTIMATE+ESTIMATE),.5
         DW    FPOINT5
         OPMUL                         ; VALUE,(VALUE/ESTIMATE+ESTIMATE)/2.0
         OPASM                         ; TOS HAS NEW, IMPROVED ESTIMATE
         DEC   LOOPCT
         jrnz  XOPSQL                  ; B/ NEED MORE ITERATIONS
         call  XBCODE                  ; NO, CLEAN UP
         OPSTORE                       ;  TTEMP1:=SQR(VALUE)
         DW    TTEMP1
         OPSTORE                       ;  DUMP THE OLD VALUE
         DW    TTEMP2
         OPLOAD                        ;  GET SQR(VALUE) BACK TO STACK
         DW    TTEMP1
         OPASM
XBRET2   lhld  BPCSAV                  ; RETURN FROM BASIC SUBROUTINE FOR 2 BYTE OPCODE
         JMP   NTRPT2X
         PAGE    
;
;        OPOWER -- COMPUTE TOS-1 (Y) RAISED TO TOS POWER (X)
;
XOPOWER  call  XBSUBR                  ; ANALYZE POWER PART
         OPDUP                         ; STORE POWER IN CASE OF Y ^ NON-INTEGER
         OPSTORE
         DW    TTEMP2
         OPDUP                         ; SIGNZ:=SGN(POWER)
         OPSGN
         OPSTORE
         DW    SIGNZ
         OPABS                         ; NOW COMPUTE ABS(POWER)
         OPDUP                         ; DIVIDE POWER INTO INTEGER AND FRACTION PARTS
         OPINT                         ; INTX:=INT(X) (**WHAT IF FLOAT ?**)
         OPDUP
         OPSTORE
         DW    TTEMP1                  ; = INT(ABS(POWER))
         OPEQ                          ; COMPARE INT(X) TO X...
         OPASM                         ; AT THIS POINT STACK CONTAINS ONLY (Y)
         LDA   FLAG                    ; IS EXPONENT AN INTEGER ?
         jrz   XOPOWER1                ; NO, DO EXP(LOG(TOS-1)*TOS)
         LDA   TTEMP1                  ; YES, IS IT > 65535 ?
         jrnz  XOPOWER1                ; YES, DO EXP(LOG(TOS-1)*TOS)
         call  FORCEFLOAT              ; NO, GENERATE Y^X BY MULTIPLICATIVE PROCESS
         lhld  #TTEMP2
         call  FSTORE
         lhld  #FONE                   ; SET TOS TO F.P. "1"
         call  FLOAD
         jr    XOPEXPINT               ; GO DO MULTIPLICATIVE PROCESS

XOPOWER1 lhld  BPCSAV                  ; MAKE BPC POINT AT OPEXP OPCODE AGAIN
         shld  BPC
         JMP   XOPLOG                  ; GO DO LOG(Y)
;        THE REST IS DONE BY LOG ROUTINE!
         PAGE    
;        OPEXP -- COMPUTE EXPONENTIAL OF TOS
;
XOPEXP   call  XBSUBR                  ; COMPUTE EXP(TOS)
XOPEXP0  OPDUP                         ; INVOKE BASIC SUBROUTINE
         OPSGN                         ; SIGNZ=SGN(Z)
         OPSTORE
         DW    SIGNZ
         OPABS                         ; Z=ABS(Z)
         OPDUP
         OPINT
         OPDUP
         OPSTORE
         DW    TTEMP1                  ; INTX=INT(X)
         OPSUB                         ; Z=Z-INTZ
         OPPOLY
         db    $3D,27,94,87,58,42      ; EVALUATE POLYNOMIAL FOR EXP(Z)
         db    $3E,02,79,99,34,44      ; 0<= Z < 1
         db    $3E,24,79,94,01,77
         db    $3F,01,98,39,09,35
         db    $3F,13,88,88,92,56
         db    $3F,83,33,33,61,07
         db    $40,04,16,66,66,67
         db    $40,16,66,66,66,66
         db    $40,50,00,00,00,00
         db    $41,01,00,00,00,00
         db    $41,01,00,00,00,00
         db    0                       ; END OF COEFFICIENT LIST
         OPINIT
         DW    TTEMP2
         DW    6
         db    $41,02,71,82,81,82      ; 2.71828182 IS E!
         OPASM                         ; NOW COMPUTE RESULT:=RESULT*E^INTX
         LDA   TTEMP1                  ; E TO SOME HUGE NUMBER ?
         jrnz  XOPEXPO                 ; YES, GO SEE IF 1/E^HUGE
XOPEXPINT      lhld                    ; #XOPEXPO MULTIPLY E^FRACTION BY E^INTX
         shld  FPTRAP                  ; IN CASE WE GET OVERFLOW
XOPEXPL  LSR   TTEMP1+VINT1            ; ANY MORE INTX BITS?
         ROR   TTEMP1+VINT2
         BCC   XOPEXP1                 ; B/ THIS BIT IS ZERO, MAYBE NOT...
         lhld  #TTEMP2
         call  FLOAD                   ; ASSERT: TTEMP2 IS F.P FORMAT HERE
         call  FMUL                    ; ASSERT: TOS IS F.P. FORMAT HERE
XOPEXP1  lhld  TTEMP1+VINT1            ; MORE INTEGER POWER BITS?
         jrz   XOPEXP2                 ; B/ NO, WE'RE DONE WITH INTEGER PART
         lhld  #TTEMP2                 ; EXPN:=EXPN*EXPN
         call  FLOAD                   ; ASSERT: TTEMP2 ...
         TSX    
         call  FLOAD                   ; IS F.P. FORMAT HERE!
         call  FMUL
         lhld  #TTEMP2
         call  FSTORE
         jr    XOPEXPL

XOPEXP2  LDA   SIGNZ                   ; E TO THE POSITIVE X ?
         BPL   XBRET2J                 ; B/ YES, STACK HAS CORRECT ANSWER
         BSR   XBCODE                  ; NO, MUST TAKE RECIPROCAL
         OPSTORE
         DW    TTEMP1
         OPLOAD
         DW    FONE
         OPLOAD
         DW    TTEMP1
         OPDIV
         OPASM
XBRET2J  JMP   XBRET2                  ; AND EXIT

XOPEXPERR      JMP                     ; FLOATOVFLOW

XOPEXPO  LDA   SIGNZ                   ; OVERFLOW IN COMPUTING EXP(ABS(TOS))
         BPL   XOPEXPERR               ; B/ TOS WAS POSITIVE ORIGINALLY
         CLRA                          ; OTHERWISE, ANSWER IS ZERO
         STA   VTYPE,S
         IF    M6800!M6801
         STA   VINT1,X
         STA   VINT2,X
         ELSE  (M6809)
         STA   VINT1,S
         STA   VINT2,S
         FIN    
         JMP   XBRET2
;
;        EXIT FROM BASIC "POPCODE" AND START EXECUTION OF NEXT USER POPCODE
;
;XBRET   lhld  BPCSAV                  RETURN FROM "BASIC" POPCODE SUBROUTINE
;        JMP   NTRINX                  FOR 1 BYTE OPCODE
;
;        EXECUTE SUBROUTINE (TOS) WHICH IS WRITTEN IN "BASIC" OPCODES
;        SAVE CURRENT BPC FOR RESTORATION VIA XBRET OR XBRET2
;
XBSUBR   lhld  BPC
         shld  BPCSAV                  ; EXECUTE BASIC SUBROUTINE
;
;        EXECUTE IN-LINE BASIC CODE
;
XBCODE   PULX                          ; RETURN ADDRESS POINTS TO LIST OF BASIC OPCODES
         JMP   NTRPTX
         PAGE    
         PAGE    
;
;        XOPLOG -- COMPUTE NATURAL LOGARITHM OF TOS
;
XOPLOGERR      call                    ; RTPERR
         db    :LOGARG

XOPLOG   LDA   VTYPE,S                 ; COMPUTE NATURAL LOG(TOS) USING BOOK INDEX # 2684
         BMI   XOPLOGERR               ; B/ LOG OF NEGATIVE NUMBER, SCREW YOU!
         jrnz  XOPLOG1                 ; MAKE SURE ARGUMENT IS FLOATING
         IF    M6800
         LDA   VINT1,X                 ; AND THAT IT IS NOT ZERO
         ORAA  VINT2,X
         ELSEIF                        ; M6801
         LDD   VINT1,X
         ELSE  (M6809)
         LDD   VINT1,S
         FIN    
         jrz   XOPLOGERR               ; OH.... THAT'S BAD NEWS....
         call  BFLOAT
XOPLOG1  LDB   VTYPE,S                 ; REDUCE ARGUMENT TO RANGE .01 TO 1
         LDA   #$40
         IF    M6800!M6801
         STA   VTYPE,X
         ELSE  (M6809)
         STA   VTYPE,S
         FIN    
         CLRA                          ; SET (A,B) TO POWER OF 100
         SUBD  #$40
         LEAS  -2,S                    ; MAKE STACK SPACE FOR "STD 2,S" BELOW
         PSHA                          ; (SIGN EXTEND TO 4 BYTES)

         PSHA    
         ASLD                          ; (A,B) := POWER OF 10
         ASLD                          ; (A,B) := POWER OF SQRT(10)
         STD   2,S
         call  FLOAT                   ; FLOAT POWER OF SQRT(10)
         BSR   XBSUBR
XOPLOGL  OPSTORE                       ;  STORE POWER OF SQRT(10)
         DW    TTEMP1                  ; REDUCE ARG TO RANGE...
         OPDUP                         ; 1/SQRT(10) TO SQRT(10)
         OPLOAD
         DW    RECIPSQRT10             ; 1/SQRT(10)
         OPLT                          ; IS ARG < 1/SQRT(10) ?
         OPBF    
         DW    XOPLOG2
         OPLOAD                        ;  YES, ARG:=ARG*SQRT(10)
         DW    RECIPSQRT10
         OPDIV
         OPLOAD
         DW    TTEMP1                  ; POWER OF SQRT(10):=POWER OF SQRT(10) - 1
         OPLOAD
         DW    FONE
         OPSUB
         OPJMP
         DW    XOPLOGL

XOPLOG2  OPLOAD                        ;  ARG:=(ARG-1)/(ARG+1)
         DW    FONE
         OPSUB                         ; (ARG:=ARG-1...)
         OPDUP
         OPLOAD                        ;  (GENERATE ARG-1+2 GIVES ARG+1)
         DW    FTWO
         OPADD
         OPDIV
         OPDUP                         ; X2:=X*X
         OPDUP                         ; (LEAVE ARG ON STACK)
         OPMUL
         OPPOLY                        ;  COMPUTE PX OF ARGUMENT
         db    $C1,16,96,06,81,38
         db    $41,78,83,08,31,87
         db    $C1,71,98,16,19,89
         db    0
         OPMUL                         ; FORM ARG*PX
         OPLOAD
         DW    OPPOLYARG
         OPPOLY                        ;  COMPUTE QX ON ARG SQUARED
         db    $41,01,00,00,00,00
         db    $C1,18,41,97,25,31
         db    $41,51,41,23,56,27
         db    $C1,35,99,08,09,99
         db    0
         OPDIV                         ; FORM ARG*PX/QX
         OPLOAD
         DW    TTEMP1                  ; POWER OF SQRT(10)
         OPLFI                         ; LOGE(SQRT(10))
         db    $41,01,15,12,92,55
         OPMUL                         ; ADD POWER OF SQRT(10) * LOGE(SQRT(10))...
         OPADD                         ; TO LOGARITHM OF REDUCED RANGE ARGUMENT
         OPASM
         LDA   [BPCSAV]                ; DID WE DO "LOG" FOR OPLOG...
         CMPA  #OPLOG&$FF              ; OR FOR OPOWER?
         jrz   XOPLOG3                 ; WE DID IT FOR LOG, TIME TO GET OUT
;
;        FOLLOWING CODE FINISHES AN "OPOWER" INSTRUCTION
;
         call  XBCODE                  ; LOG(Y) NOW ON STACK...
         OPLOAD                        ;  MULTIPLY BY POWER
         DW    TTEMP2
         OPMUL                         ; FORM LOG(Y)*X
         OPJMP                         ; AND TAKE EXP(RESULT)
         DW    XOPEXP0

XOPLOG3  JMP   XBRET2                  ; THAT'S IT (WOW...)
         PAGE    
;        XOPPOLY-- EVALUATE INLINE POLYNOMIAL ON ARGUMENT (TOS)
;        LEAVES ARGUMENT IN "OPPOLYARG"
;        RETURNS RESULT ON VALUE STACK
;
XOPPOLY  call  FORCEFLOAT              ; EVALUATE INLINE POLYNOMIAL
         lhld  #OPPOLYARG              ; STORE ARGUMENT
         call  FSTORE
         lhld  BPC
         LEAX  1,X                     ; PUSH 1ST COEFFICIENT (OPPOLY IS 2 BYTE OPCODE)
         shld  BPC
         call  FLOAD
XOPPOLYL EQU   *
         lhld  BPC                     ; SKIP LAST COEFFFICIENT
         LEAX  RSESIZ,X
         LDA   ,X                      ; ANOTHER COEFFICIENT ? (END OF LIST?)
         jrz   XOPPOLYX                ; B/NO (NO 0 EXPONENTS ALLOWED!)
         shld  BPC                     ; YES, SAVE COEFFFICIENT ADDRESS
         lhld  #OPPOLYARG              ; MULTIPLY TOS BY ARG...
         call  FLOAD
         call  FMUL                    ; (CAN'T OVERFLOW, ***RULE***)
         lhld  BPC
         call  FLOAD
         call  FADD
         jr    XOPPOLYL

XOPPOLYX JMP   NTRINX                  ; ARG HAS ORIGINAL TOS VALUE IN IT
         PAGE    
;
;        XOPCOS -- COMPUTE COS(TOS)
;
XOPCOS   call  XBSUBR                  ; COMPUTE COS(TOS)=SIN(TOS+HALFPI)
         OPLOAD
         DW    HALFPI
         OPADD
         OPJMP
         XOPSIN1
;
;        XOPSIN -- COMPUTE SIN(TOS)
;
XOPSIN   call  XBSUBR                  ; COMPUTE SIN(TOS) USING BOOK INDEX # 3342
XOPSIN1  OPDUP                         ; SIGNZ:=SIGN OF ARGUMENT
         OPSGN
         OPLOAD                        ;  ...*10 (ALLOWS MORE ACCURATE COEFFFICIENTS)
         DW    FTEN
         OPMUL
         OPSTORE
         DW    SIGNZ
         OPABS                         ; ARG:=ABS(ARG)
         OPLOAD                        ;  QUADRANT:=INT(ARG/HALFPI)
         DW    HALFPI
         OPDIV                         ; (ARG:=ARG/HALFPI-QUADRANT)
         OPDUP
         OPINT
         OPDUP                         ; QUADRANT:=QUADRANT-4*INT(QUADRANT/4)
         OPDUP
         OPLOAD
         DW    FFOUR
         OPDIV
         OPINT
         OPLOAD
         DW    FFOUR
         OPMUL
         OPSUB
         OPSTORE
         DW    TTEMP1                  ; (HOLDS QUADRANT)
         OPSUB                         ; (FINISH SUBTRACTING QUADRANT FROM ARG/HALFPI)
         OPASM
         LDA   TTEMP1+5                ; (QUADRANT IS GAURANTEED AN INTEGER)
         ASRA                          ; IF QUADRANT IS 1 OR 3,
         BCC   XOPSIN2                 ; (B/ 0 OR 2)
         call  XBCODE                  ; THEN ARG:=1-ARG
         OPLOAD
         DW    FONE
         OPSUB
         OPNEG
         OPASM                         ; CHEAP TRICK AGAIN...
XOPSIN2  call  XBCODE
         OPDUP                         ; COMPUTE ARG*ARG
         OPDUP                         ; LEAVING ARG ON STACK, TOO...
         OPMUL
         OPPOLY                        ;  COMPUTE SIN(X) USING POLYNOMIAL
         db    $3D,34,28,79,07,30
         db    $BE,16,02,47,02,88
         db    $3F,04,68,16,51,02
         db    $BF,79,69,26,01,26
         db    $40,06,45,96,40,95
         db    $C0,15,70,79,63,27
         db    0
         OPMUL                         ; MULTIPLY POLYNOMIAL BY ARG
         OPLOAD
         DW    SIGNZ                   ; AND BY SIGN OF ARGUMENT
         OPMUL
         OPLOAD                        ; AND BY (QUADRANT&:2)-1...
         DW    TTEMP1                  ; WHICH PROPERLY FIDDLES SIGN FOR CORRECT QUA
         db    OPLSMI+$2
         OPAND
         OPLOAD
         DW    FONE
         OPSUB
         OPMUL
         OPASM
         JMP   XBRET2
         PAGE    
;
;        XOPATN -- COMPUTE ARC TANGENT OF TOS
;
XOPTAN   call  XBSUBR                  ; COMPUTE ATN(TOS) USING BOOK # 5094
         OPDUP                         ; SIGNX=SGN(ARG)
         OPSGN
         OPSTORE
         DW    SIGNZ
         OPABS
         OPDUP                         ; IF X<=1...
         OPLOAD
         DW    HALFPI
         OPDIV
         OPINT
         OPDUP                         ; (LEAVE A COPY FOR LATER SUBTRACT)
         OPDUP                         ; HEMISPHERE':=HEMISPHERE-2*INT(HEMISPHERE/2)
         OPLOAD
         DW    FPOINT5
         OPMUL
         OPINT
         OPLOAD
         DW    FTWO
         OPMUL
         OPSUB
         OPSTORE
         DW    TTEMP1
         OPLOAD                        ;  ARG:=ARG-HEMISPHERE*HALFPI
         DW    HALFPI
         OPMUL
         OPSUB                         ; NOW 0 <= ARG < HALFPI
         OPASM
         LDA   TTEMP1+VINT2            ; LOOK AT LSB OF HEMISPHERE
         ASRA    
         BCC   XOPTAN1                 ; B/ LEFT HEMISPHERE, LEAVE ARG ALONE
         call  XBCODE
         OPLOAD                        ;  ARG:=HALFPI-ARG
         DW    HALFPI
         OPSUB
         OPNEG
         OPASM                         ; CHEAP TRICK
XOPTAN1  call  XBCODE                  ; TO GET BACK INTO BASIC CODE
         OPLOAD
         DW    HALFPI                  ; ARG:=(ARG/2)(PI/4)
         OPDIV
         OPDUP                         ; LEAVE ARG ALONE
         OPDUP                         ; COMPUTE ARG*ARG
         OPMUL
         OPPOLY                        ;  COMPUTE P(X)
         db    $3F,52,86,44,45,55
         db    $C0,88,76,62,37,70
         db    $41,12,92,21,03,50
         db    0
         OPMUL                         ; COMPUTE ARG*PX
         OPLOAD                        ;  GET ARG SQUARED
         DW    OPPOLYARG
         OPPOLY                        ;  COMPUTE Q(X)
         db    $40,10,00,00,00,00
         db    $C1,04,51,32,05,61
         db    $41,16,45,29,33,18
         db    0
         OPDIV                         ; TANX2=ARG*PX/QX
         OPDUP
         OPDUP
         OPMUL                         ; TANX2*TANX2
         OPLOAD
         DW    FONE
         OPSUB
         OPDIV                         ; TANX2/(TANX2*TANX2-1)
         OPLOAD
         DW    FTWO
         OPMUL                         ; 2*TANX2/(TANX2*TANX2-1)
         OPLOAD
         DW    SIGNZ
         OPMUL                         ; ...$SIGN
         OPLOAD
         DW    TTEMP1                  ; * ( HEMISPHERE + HEMISPHERE - 1)
         OPDUP
         OPADD
         OPLOAD
         DW    FONE
         OPSUB
         OPMUL
         OPASM
         JMP   XBRET2
         PAGE    
;
;        XOPATN -- COMPUTE ARC TANGENT OF TOS
;
XOPATN   call  XBSUBR                  ; COMPUTE ATN(TOS) USING BOOK # 5094
         OPDUP                         ; SIGNX=SGN(ARG)
         OPSGN
         OPSTORE
         DW    SIGNZ
         OPABS
         OPDUP                         ; IF X<=1...
         OPLOAD
         DW    FONE
         OPLE    
         OPBF    
         DW    XOPATN2
         OPLOAD                        ;  THEN RESULT=0
         DW    FZERO
         OPJMP
         DW    XOPATN1
XOPATN2  OPLOAD                        ;  ELSE X=(X-1)/(X+1)
         DW    FONE
         OPSUB
         OPDUP
         OPLOAD
         DW    FTWO
         OPADD
         OPDIV                         ; (X-1+2 --> X+1 FOR DIVISOR)
         OPLOAD                        ;  AND RESULT = PI/4
         DW    PIOVER4
XOPATN1  OPSTORE
         DW    TTEMP1                  ; (RESULT)
         OPDUP                         ; COMPUTE ARG*ARG
         OPDUP                         ; (RETAINING ARG ON THE STACK)
         OPMUL
         OPPOLY                        ;  COMPUTE PX ON ARG^2
         db    $BF,46,26,98,19,16
         db    $40,24,38,05,01,28
         db    $41,04,42,89,03,41
         db    $41,13,54,23,79,43
         db    $41,10,38,83,26,24
         db    0
         OPLOAD
         DW    OPPOLYARG               ; GET ARG^2 BACK
         OPPOLY                        ;  COMPUTE QX
         db    $41,01,00,00,00,00
         db    $41,08,01,96,25,68
         db    $41,17,00,51,54,75
         db    $41,10,38,83,26,24
         db    0
         OPDIV                         ; PX/QX
         OPMUL                         ; ARG*PX/QX
         OPLOAD
         DW    TTEMP1                  ; ADD RESULT
         OPADD
         OPLOAD
         DW    SIGNZ                   ; AND MULTIPLY BY SIGN OF ANSWER
         OPMUL
         OPASM
         JMP   XBRET2
        PAGE  *** F L O A T I N G   P ; O I N T ***
FMONE    db    $C1,01,00,00,00,00
FZERO    db    $00,00,00,00,00,00      ; THIS IS THE ONLY VALID FORM OF "ZERO"
FPOINT5  db    $40,50,00,00,00,00
FONE     db    $41,01,00,00,00,00
FTWO     db    $41,02,00,00,00,00
FFOUR    db    $41,04,00,00,00,00
FTEN     db    $41,10,00,00,00,00
MINFINITY      db                      ; $FF,99,99,99,99,99
INFINITY db    $7F,99,99,99,99,99
PIOVER4  db    $40,78,53,98,16,35
HALFPI   db    $41,01,57,07,96,33
PI       db    $41,03,14,15,92,65
FP2TOM31 db    $3C,04,65,66,12,87
RECIPSQRT10    db                      ; $40,31,62,27,76,60
;
;        FLOATING NEGATE
;
FNEG     LDA   2,S
         jrz   FNEG1
         EORA  #$80
         IF    M6800!M6801
         STA   2,X
         ELSE  (M6809)
         STA   2,S
         FIN    
FNEG1    ret
         PAGE    
;        FLOATING STORE ROUTINE
;        X REG CONTAINS POINTER TO LOCATION TO STORE
;        NUMBER IS POPPED OFF THE STACK & PUT @X
;
FSTORE
         IF    M6800!M6801
         PULD                          ; POP RETURN ADDRESS OFF OF THE STACK
         STD   FSTORET
         ELSE  (M6809)
         PULS  Y
         FIN    
         PULD                          ; GET MSBYTE (SIGN-EXPONENT BYTE)
         STD   ,X
         PULD    
         STD   2,X
         PULD    
         STD   4,X
         IF    M6800!M6801
         JMP   [FSTORET]
         ELSE  (M6809)
         JMP   ,Y
         FIN    
         PAGE    
;        FLOATING COMPARE (TOS-1) TO (TOS)
;        NUMBER AT TOP-OF-STACK-1 IS COMPARED TO TOP-OF-STACK
;        STATUS BITS ARE SET INDICATING RESULT OF COMPARE
;        BOTH NUMBERS ARE POPPED OFF
;
;
         IF    M6800!M6801
FCMPMI   LDA   2,X
         BMI   FCMP4
         jr    FCMP2

FCMP     sspd  TEMPX                   ; COMPUTE POPPED STACK POINTER FOR EXIT
         LDB   #RSESIZ*2+2
         ADDB  TEMPX+1
         STB   TEMPX+1
         BCC   FCMP0
         INC   TEMPX
FCMP0    TSX    
         LDB   8,X
         BMI   FCMPMI
         LDA   2,X
         BMI   FCMP2
FCMP4    CMPB  2,X
         jrnz  FCMP1
         LDA   9,X
         CMPA  3,X
         jrnz  FCMP1
         LDA   10,X
         CMPA  4,X
         jrnz  FCMP1
         LDA   11,X
         CMPA  5,X
         jrnz  FCMP1
         LDA   12,X
         CMPA  6,X
         jrnz  FCMP1
         LDA   13,X
         SUBA  7,X
         jrz   FCMP5
FCMP1    BHI   FCMP2
         LDA   #-1
         SK2    
FCMP2    LDA   #1
         ANDB  #$80
         ABA    
FCMP5    lhld  ,X
         lspd  TEMPX
         TSTA    
         JMP   ,X
         ELSE  (M6809)
         PAGE    
;        FCMP -- FLOATING COMPARE
;        NOTE: THIS ROUTINE USES (A,B) BACKWARDS COMPARE TO 6800 VERSION OF FCMP!
;
FCMP     LDA   R2FLT1+2,S
         BMI   FCMPMI                  ; B/ TOS-1 < 0
         LDB   R1FLT1+2,S
         BMI   FCMP2A                  ; B/TOS-1 >=0, TOS-1 < 0
FCMP4    CMPA  R1FLT1+2,S              ; SIGNS MATCH, DO EXPONENTS ?
         jrnz  FCMP1                   ; B/ NO, EXPONENTS DETERMINE RESULT OF COMPARE
         lhld  R2FLT2+2,S              ; COMPARE 16 MANTISSA BITS
         CMPX  R1FLT2+2,S
         jrnz  FCMP1
         lhld  R2FLT4+2,S
         CMPX  R1FLT4+2,S
         jrnz  FCMP1
         LDA   R2FLT6+2,S
         SUBA  R1FLT6+2,S
         jrz   FCMP5                   ; B/ EQUAL
FCMP1    BHI   FCMP2                   ; B/ MAGNITUDE (TOS) > MAGNITUDE (TOS-1)
         LDA   R2FLT1+2,S              ; TOS VALUE < TOS-1 VALUE
         lhld  ,S                      ; GET RETURN
         LEAS  RSESIZ*2+2,S            ; POP VALUES AND RETURN ADDRESS
         ANDA  #$80
         EORA  #$FF                    ; ENSURE RESULT IS "<>" 0
         JMP   ,X

FCMP2    LDA   R2FLT1+2,S              ; TOS VALUE > TOS-1 VALUE
FCMP2A   lhld  ,S                      ; GET RETURN ADDRESS TO X
         LEAS  RSESIZ*2+2,S
         ANDA  #$80
         INCA                          ; ENSURE RESULT IS "<>" 0, LEAVES OVERFLOW RESET!
         JMP   ,X

FCMP5    lhld  ,S                      ; FETCH RETURN ADDRESS
         LEAS  RSESIZ*2+2,S            ; POP OPERANDS FROM STACK
         TSTA                          ; SET CC BITS TO RESULT
         JMP   ,X

FCMPMI   LDB   R1FLT1+2,S
         BMI   FCMP4                   ; B/ SIGNS MATCH
         jr    FCMP2A
         FIN    
         PAGE    
;        FLOATING POINT MULTIPLY
;        MS1:MS6 CONTAINS MULTIPLICAND, NOT AFFECTED
;        MR1:MR6 CONTAINS MULTIPLIER, NOT AFFECTED
;        PRODUCT IN FAC WITH X REG POINTING TO IT
;
FMUL     PULD    
         STD   RETADD
         lhld  #MR1
         call  FSTORE
         lhld  #MS1
         call  FSTORE
;
         lhld  #0                      ; CLEAR FAC, FACEXT
         shld  FAC1                    ; NEED THESE IF SOME MULTIPLIER DIGITS = 0
         shld  FAC3
         shld  FAC5
         shld  FACEXT1
         shld  FACEXT3
;
         LDA   MR1                     ; COMPUTE SIGN OF RESULT
         jrz   FMUL3                   ; MULTIPLIER IS ZERO, DONE
         TFR   A,B
         EORA  MS1
         STA   MSIGN                   ; TRASH MASKED OFF AT FLTEXIT
;
         LDA   MS1                     ; ESTIMATE EXPONENT OF RESULT
         jrz   FMUL3                   ; MULTIPLICAND IS ZERO, DONE
         ANDA  #$7F
         ANDB  #$7F
         ABA    
         SUBA  #$80
         STA   MEXP                    ; CHECK OVERFLOW AT FLTEXIT
;
         lhld  #FACEXT4+1              ; POINTER INTO RESULT
         shld  FACX
         lhld  #MR6+1                  ; POINTER TO NEXT MULTIPLIER DIGIT
FMUL1    DEC   FACX+1
         DEX    
         CPX   #MR1
         jrz   FMUL3                   ; DONE WITH MULTIPLY
         shld  MRX
FMUL2    LDA   ,X                      ; GET MULTIPLIER DIGITS, LSBYTES FIRST
         jrz   FMUL1                   ; MULTIPLIER BYTE = 0, DO FAST LOOP
         STA   ML                      ; HOLDS MULTIPLIER DIGIT FOR 5 CROSS-PRODUCTS
         CLR   CTNB                    ; = CARRY INTO NEXT BASE 100 DIGIT COLUMN
         lhld  FACX                    ; POINTS INTO FLOATING ACCUMULATOR
         LDB   MS6                     ; GET LBYTE OF MULTIPLICAND DIGIT
         BSR   FCROSP                  ; GO MULTIPLY AND ADD CROSS PRODUCT
         LDB   MS5
         BSR   FCROSP
         LDB   MS4
         BSR   FCROSP
         LDB   MS3
         BSR   FCROSP
         LDB   MS2                     ; MSBYTE OF MULTIPLICAND
         BSR   FCROSP
         STA   ,X                      ; STORE LAST CARRY IN A ZEROED BYTE
         LDA   #3
         ADDA  FACX+1
         STA   FACX+1
         lhld  MRX
         DEX    
         shld  MRX
         CPX   #MR1
         jrnz  FMUL2
;
FMUL3    JMP   FLTEXIT
         PAGE    
;        THIS ROUTINE WILL MULTIPLY ML * B REG AND ADD THE
;        RESULT IN A,B TO 0,X THEN DEX & RTS
;
FCROSP   jrz   FCROSPZ                 ; CHECKING B
         shld  FACX
         call  MULBASE100
         lhld  FACX
FCROSP0  ADDB  CTNB                    ; ASSERT: SUM <= 200!
         ADDB  ,X                      ; ASSERT: SUM <= 299!
         BMI   FCROSBB                 ; B/ 255>=SUM>=128
         jrc   FCROSBC                 ; B/ 256<=SUM<=299
         CMPB  #100                    ; IS SUM >= 100 ?
         jrc   FCROSP1A                ; B/ NO, GET OUT!
FCROSP1  SUBB  #100                    ; YES, DO BASE 100 ADJUST
         INCA    
FCROSP1A STB   ,X                      ; SAVE PARTIAL PRODUCT DIGIT
         STA   CTNB                    ; ASSERT: CTNB<=101 <=99+ 2 CARRIES)
         DEX                           ; AS PROMISED
         ret

FCROSBB  CMPB  #200                    ; IS SUM >= 200 ?
         jrc   FCROSP1                 ; B/ 199>=SUM>=128
         SUBB  #200                    ; GET RID OF EXCESS OVER 99
         ADDA  #2                      ; ADJUST CARRY TO NEXT BYTE
         STB   ,X                      ; STORE PARTIAL PRODUCT DIGIT
         STA   CTNB
         DEX                           ; AS PROMISED
         ret

FCROSBC  SUBB  #(200-256)&$FF          ; SUBTRACT 200 FROM SUM
         ADDA  #2                      ; ADD 2 TO CARRY TO NEXT BYTE
         STB   ,X                      ; STORE PARTIAL PRODUCT DIGIT
         STA   CTNB
         DEX                           ; AS PROMISED
         ret

FCROSPZ  CLRA                          ; MAKE PRODUCT INTO ZERO
         JMP   FCROSP0
         PAGE    
;
;        DIGIT MULTIPLY
;        MULTIPLIES REG (E) BY ML, RETURNS RESULT IN (BA)
;
MULBASE100 ; ML*(E) -> (HL) BASE 100 WITH BINARY DIGITS
         lda   a,ML                    ; get multiplier
         ; multiply unsigned (E) by unsigned (A), product to (HL)
         mov   h,a                     ; (5~) multiplier, note MSB is zero
         mvi   l,0                     ; (7~) partial multiplicand
         mov   d,l                     ; (5~) make multiplicand 16 bits
         dad   h                       ; (10~) shift out multiplier bit
;        jrnc  $+4+i8085 (always jmps) ; (10~) b/ 1st multipler bit is zero
;        dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 2nd multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 3rd multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 4th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 5th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 6th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 7th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
         dad   h                       ; (10~) double product, sniff mpr bit
         jrnc  $+4+i8085               ; (10~) b/ 8th multipler bit is zero
         dad   d                       ; (10~) add multiplicand to product
;        NOW ADJUST BINARY PRODUCT TO MAKE INTO BASE 100
CONVERTTOBASE100 ; (HL)<=9999 gets converted to base 100 in (BA)
         mov   a,l                     ; save lower half of product in (A)
         mov l,h ! mvi h,0             ; now (HL):=Int(product/256) (value<39)
         dad   h                       ; so (HL) will point at a pair of bytes
         lxi   d,MulDiv100             ; compute approx product divided by 100
         dad d ! mov b,m               ; (B):= approx value of product / 100
         inx h ! add a,m               ; add (PRODUCT MOD 256) MOD 100
         jrnc  converttobase100a       ;
         ; b/ PRODUCT MOD 256 + (PRODUCT - (PRODUCT MOD 256)) MOD 100
         inr b ! inr b                 ; REMAINDER >= 256, ADJUST LEFT HAND DIGIT
         sui   200                     ; ADJUST REMAINDER
converttobase100a
         jp    converttobase100b       ; B/ (A)<=127 (.5 OF THE TIME)
         inr   b                       ; (A)>=128, ADJUST LEFT HAND DIGIT
         sui   100                     ; ADJUST REMAINDER
converttobase100b
         cpi   100                     ; (A) STILL TO BIG ?
         rc                            ; B/ NO, GET OUT!
         inr   b                       ; ADJUST LEFT HAND DIGIT
         sui   100                     ; MAKES RIGHT HAND DIGIT LEGAL
         ret                           ; TOTAL: 131 CYCLES FOR MULTIPLY AND CONVERT

MULDIV100 ; CONVERTS MSB OF PRODUCT TO APPROX PRODUCT/100
; composed of byte pairs of  xx/100, xx-int(xx/100)*100
; where xx are all multiples of 256 from 0 to 9999.
         RPT   9999//256
 DB ($-MULDIV100)/2*256/100,($-MULDIV100)/2*256\100 ; (PRODUCT-(PRODUCT MOD 256))/100
         PAGE    
FDIVNORM EQU   $-1                     ; MULTIPLICATIVE FACTOR USED TO NORMALIZE DIVISOR
         RPT   100/2-1                 ; (SEE KNUTH VOL 2 PAGE 237)
         db    100/($-FDIVNORM+1)
;
FDIVNORMDIGIT ; Floating divide Normalize digit
;        Used to help normalize divisor so leading digit is >=50
;        MULTIPLY DIGIT AT (HL) BY ML AND ADD (B); STORE BACK AT (HL)
;        RETURNS: (B) = UPPER BASE 100 DIGIT OF @(HL)*ML+old(B)
;                 DECREMENTED (HL)
;        Returned values are set up so FDIVNORMDIGIT can be called
;        repeatedly to adjust digits from rightmost to leftmost
         mov   e,m                     ; GET DIGIT TO BE MULTIPLIED
         push  h                       ; save normalized digit location
         push  b                       ; save carry to next byte
         call  MULBASE100              ; MULTIPLY BY ML, PRODUCT TO (BA)
         pop   d                       ; restore carry to next byte
         add   d                       ; add carry from last digit column
         cpi   100                     ; do base 100 adjust
         jrc   fdivnormdigit1          ; b/ digit is ok
         inr   b                       ; BUMP CARRY TO NEXT DIGIT COLUMN
         sui   100                     ; MAKE DIGIT VALID
fdivnormdigit1
         pop h ! mov m,a               ; STORE MODIFIED DIGIT
         dcx h                         ; MOVE (HL) TO DIGIT TO LEFT
         ret                           ; WITH CARRY TO NEXT BYTE IN (B)
         PAGE    
FDIV ; FLOATING DIVIDE
;        TOS-1 CONTAINS DIVIDEND
;        TOS CONTAINS DIVISOR
;        QUOTIENT RETURNED ON TOS
;
         pop h ! shld RetAdd           ; save return address
         lhld  #MS1                    ; DIVISOR
         call  FSTORE
         lhld  #FAC1                   ; DIVIDEND
         call  FSTORE
;
         lhld  #0                      ; CLEAR FACEXT
         shld  FACEXT1
         shld  FACEXT3
         shld  FACEXT4
;
         LDA MS1 ! ana a               ; division by zero ?
         jz    FOVER                   ; b/ yes, go complain
         mov   b,a                     ; save sign/exponent of divisor
         lda FAC1 ! ana a              ; get sign/exponent of dividend
         jz    FRZERO                  ; dividend zero --> Quotient is zero
         xra   b                       ; compute sign of result
         STA   MSIGN                   ; TRASH MASKED OFF AT FLTEXIT

         mov a,b ! ani 07fh ! mov b,a  ; extract exponent of divisor
         lda FAC1 ! ani 07fh           ; extract exponent of dividend
         sub b                         ; compute exponent of result...
         inr a                         ; assuming first quotient digit > 0
         sta MEXP
;
         xra a ! sta FAC1              ; U0 IN "KNUTH"IAN NOTATION
         PAGE
;
;        NOW "NORMALIZE" THE DIVISOR (I.E., MAKE MSD >= 50; SEE KNUTH)
;
         lda   MS2                     ; MSD OF DIVISOR (<>0 BECAUSE IS F.P.)
         cpi   100/2                   ; IS DIVISOR NORMALIZED ?
         jrnc  FDIVGN                  ; B/ YES, GO DO THE DIVIDE!
         lxi   h,FDivNorm              ; look normalization multiplier up...
         mvi b,0 ! mov c,a ! dad b ! mov a,m ; in a table
         STA   ML                      ; SAVE MULTIPLICATIVE FACTOR
         lxi   h,MS6                   ; MULTIPLY DIVISOR BY (ML)
;        MULTIPLY DIGIT AT (HL) BY ML AND ADD (B); STORE BACK AT (HL)
;        RETURNS: (B) = UPPER BASE 100 DIGIT OF @(HL)*ML+old(B)
;                 DECREMENTED (HL)
         mvi   b,0                     ; ZERO CARRY INTO FIRST DIGIT
         CALL  FDIVNORMDIGIT           ; GAURANTEES MSD DIVISOR >= 100/2
         CALL  FDIVNORMDIGIT           ; SINCE BOTH DIVISOR AND DIVIDEND ARE MULTIPLIED...
         CALL  FDIVNORMDIGIT           ; BY SAME VALUE, THE QUOTIENT REMAINS THE SAME
         CALL  FDIVNORMDIGIT
         CALL  FDIVNORMDIGIT
         lxi   h,FAC6                  ; MULTIPLY DIVIDEND BY NORMALIZING FACTOR
;        ASSERT (B)=0 HERE BECAUSE WE NORMALIZED MULTIPLIER
         CALL  FDIVNORMDIGIT
         CALL  FDIVNORMDIGIT
         CALL  FDIVNORMDIGIT
         CALL  FDIVNORMDIGIT
         CALL  FDIVNORMDIGIT
         mov a,b ! STA FAC1            ; NEW MSD OF FAC (MAY BE NON-ZERO)
         LDA   MS2                     ; GRAB MSD OF DIVISOR
FDIVGN   lxi   h,FAC1                  ; WHERE TO PLACE 1ST QUOTIENT DIGIT
         PAGE    
;        GUTS OF THE FLOATING DIVIDE
;
         CALL  FDIVS                   ; GENERATE 1ST QUOTIENT DIGIT
         CALL  FDIVS                   ; GENERATE 2ND QUOTIENT DIGIT
         CALL  FDIVS
         CALL  FDIVS
         CALL  FDIVS                   ; GENERATE 5TH QUOTIENT DIGIT
         LDA   FAC1                    ; CHECK: FIRST QUOTIENT DIGIT = 0 ?
         ana   a
         jrnz  FDIVG1                  ; B/ NO, DONE
         LDA   FACEXT1                 ; YES, GENERATE ONE MORE QUOTIENT DIGIT
         CALL  FDIVS
FDIVG1   JMP   FLTEXIT
         PAGE    
FDIVS ; Floating Divide Step
;       Entered with (HL) pointing to dividend (i.e., remainder)
;       Compute quotient digit of (@(HL)*100+@(HL+1))/MS2
;       Then subtract quotient digit * divisor (MS2) from dividend
;       Exit with (HL) incremented by one
;
;        FIRST, GUESS THE QUOTIENT DIGIT (SEE KNUTH VOL 2 PAGE 237)
;        BY COMPUTING ((C)*100+(A))/MS2
;        NOTE: (C)<=MS2; MS2 >=50
;
GUESSD   mov   c,m                     ; fetch MSDigit of remainder
         push  h                       ; save exit value of (HL)-1
         inx   h                       ; find next to MS digit of remainder
         mov   e,m                     ; save lower digit in (E)
         lda   MS2                     ; QUOTIENT DIGIT = 99 ?
         cmp   c
         jrnz  GUESSD1                 ; B/ NO, COMPUTE IT THE HARD WAY
         mvi   a,99                    ; YES, GRAB actual quotient digit
         JMP   GUESSD2                 ; GO USE IT

GUESSD1  ; (C)<MS2; MULTIPLY (C) BY 100 AND ADD (E)
         mvi b,0 ! mov d,b             ; convert 8 bit (C),(E) to 16 (BC),(DE)
         mov   h,b ! mov l,c           ; (HL):=1*(BC)
         dad   h                       ; (HL):=2*(BC) ASSERT:<=198
         dad   b                       ; (HL):=3*(BC) <= 297
         dad   h                       ; (HL):=6*(BC)
         dad   h                       ; (HL):=12*(BC)
         dad   h                       ; (HL):=24*(BC)
         dad   b                       ; (HL):=25*(BC)
         dad   h                       ; (HL):=50*(BC)
         dad   h                       ; (HL):=100*(BC)
         dad   d                       ; (HL):=100*(BC)+A <= 9999
                                       ; NOTE: NOW H REGISTER <= 39
         lda   ms2                     ; fetch divisor digit
         mov   d,a                     ; set up abs(divisor)
         neg ! mov b,a                 ; set up -abs(divisor)
         xra   a                       ; bits to shift into remainder
         mov e,a ! mov c,a             ; extend divisor(s) to 16 bits
;        FIRST QUOTIENT BIT IS 0 SINCE MS2>=50 AND HL<=3900 --> 7 bit quotient
         call  divgen8quotientbits     ; generate 8 quotient bits to (A)
; speed up by inserting code from divide here, or special casing front door ?
         ana   a                       ; is quotient digit zero ?
         jrnz  GUESSD2                 ; B/ DIGIT IS NONZERO
         pop   h                       ; restore exit value for HL,-1
         mov   m,a                     ; STORE QUOTIENT DIGIT OF ZERO
         inx   h                       ; increment HL to obtain correct exit
         ret
         PAGE    
GUESSD2  STA   ML                      ; SAVE APPROXIMATE QUOTIENT DIGIT
                                       ; (OFF BY AT MOST 2! [see Knuth])
         pop   h                       ; pointer to leftmost remainder digit
         lxi   d,5                     ; find rightmost remainder digit
         dad   h
         mvi   b,0                     ; HOLDS BORROW FOR THE NEXT DIGIT COLUMN
         LDA   MS6                     ; GET DIVISOR LSBYTE & MULTIPLY & SUBTRACT
         call  FDIVSS                  ; (I.E., SUBTRACT QUOTIENT DIGIT*DIVISOR FROM REMAINDER)
         LDA   MS5
         call  FDIVSS
         LDA   MS4
         call  FDIVSS
         LDA   MS3
         call  FDIVSS
         LDA   MS2
         call  FDIVSS
         mov   a,b                     ; place borrow in (A)
         mvi   b,0                     ; zero upper half of digit product
         call  FDIVSSL                 ; THIS HANDLES LAST borrow
         jrz   FDIVS2                  ; # IS STILL POS, ESTIMATED QUO RIGHT ON
FDIVS1 ; Estimated Quotient digit is too big, try Quotient which is one smaller
         ; HL points to left of leftmost digit in remainder active at GUESSD
         lda ML ! dcr a ! sta ML       ; shrink the quotient digit
         lxi   d,5+1                   ; find rightmost digit of remainder
         dad   h                       ; and add divisor back once

         lda ms6 ! add m ! adi -100    ; FORCE CARRY IF DIGIT >= 100
         jrc   $+4+i8085               ; B/ CARRY TO NEXT DIGIT
         sui   -100                    ; ASSERT: THIS ZEROS THE CARRY!
         mov m,a ! dcx h

         lda ms5 ! adc m ! adi -100    ; FORCE CARRY IF DIGIT >= 100
         jrc   $+4+i8085               ; B/ CARRY TO NEXT DIGIT
         sui   -100                    ; ASSERT: THIS ZEROS THE CARRY!
         mov m,a ! dcx h

         lda ms4 ! adc m ! adi -100    ; FORCE CARRY IF DIGIT >= 100
         jrc   $+4+i8085               ; B/ CARRY TO NEXT DIGIT
         sui   -100                    ; ASSERT: THIS ZEROS THE CARRY!
         mov m,a ! dcx h

         lda ms3 ! adc m ! adi -100    ; FORCE CARRY IF DIGIT >= 100
         jrc   $+4+i8085               ; B/ CARRY TO NEXT DIGIT
         sui   -100                    ; ASSERT: THIS ZEROS THE CARRY!
         mov m,a ! dcx h

         lda ms2 ! adc m ! adi -100    ; FORCE CARRY IF DIGIT >= 100
         jrc   $+4+i8085               ; B/ CARRY TO NEXT DIGIT
         sui   -100                    ; ASSERT: THIS ZEROS THE CARRY!
         mov m,a ! dcx h

         mvi a,0 ! adc m ! adi -100    ; Adjust remainder sign upwards
         jrc   $+4+i8085               ; B/ CARRY TO NEXT DIGIT
         sui   -100                    ; ASSERT: THIS ZEROS THE CARRY!
         mov m,a ! dcx h

         jrnz  FDIVS1                  ; EST QUO DIG BIG BY UP TO 2, ADD ONE LAST TIME!

FDIVS2   LDA   ML
         mov   m,a                     ; save quotient digit
         inx   h                       ; so (HL) points to next MS remainder
         shld  FACX                    ; SO WE CAN MAKE IT POINT TO NEXT QUOTIENT DIGIT SLOT
?? I'm not sure HL comes out quite right!!!?
         ret
         PAGE    
FDIVSS ; THIS ROUTINE MULTIPLIES THE QUOTIENT DIGIT ML BY (A)
;        AND SUBTRACTS IT FROM @HL THEN DECREMENTS HL
;        On entry, (B) holds borrow from previous iteration
;        On exit, (B) holds borrow for next iteration
;        Condition code reflects state of updated digit
;
FDIVSS   ana   a                       ; check multiplied digit
         jrnz  FDIVSS1                 ; B/ DIGIT (B) IS NON-ZERO
;                                      ; DIGIT IS ZERO --> PRODUCT IS ZERO
         mov   a,b                     ; place borrow in (A)
         mvi   b,0                     ; zero upper half of digit product
         JR    FDIVSS1A                ; SKIP INTO LOOP AT CORRECT PLACE

FDIVSS1  EQU   *
         push  b                       ; save borrow
         push  h                       ; save pointer to digit to adjust
         call  MULBASE100              ; PRODUCE BASE 100 PRODUCT
         ; returns product in (BC)
         pop   h
         pop   d                       ; restore borrow to (D)
         mov   a,c                     ; TOTAL TO SUBTRACT; ASSERT (A)<=200
         add   c                       ; now digit product is in (BA)
FDIVSS1A ; re-entry from FDIVSS
FDIVSSL  STC ! CMA                     ; ADD THE NEGATIVE TO GET A SUBTRACT
         ADC   m                       ; (0..99)-(0..201) => (99..-201)
         jrc   FDIVSSA                 ; B/ ANSWER IS OK AS IT
         cpi   -100                    ; OOPS, ANSWER IS NEGATIVE
         jrc   FDIVSS2                 ; B/ 0>ANSWER>=-100
         inr   b                       ; ANSWER < -100, ADJUST PROPERLY
         inr   b
         adi   200
FDIVSSA  mov   m,a                     ; SAVE RESULT DIGIT
         dcx   h                       ; decrement HL, as per spec
         ret

FDIVSS2  inr   b                       ; ADJUST BORROW TO NEXT BYTE
         adi   100                     ; MAKE DIGIT POSITIVE
         mov   m,a                     ; SAVE RESULT DIGIT LAST TO MAKE EASY TEST
         dcx   h                       ; decrement HL, as per spec
         ret
         PAGE    
;        FLOATING POINT SUBTRACT
;        TOS-1 CONTAINS MINUEND
;        TOS CONTAINS SUBTRAHEND
;        DIFFERENCE RETURNED ON TOS
;
FSUB     LDA   #$80                    ; TWIDDLE SIGN ON TOS
         EORA  2,S
         IF    M6800!M6801
         STA   2,X
         ELSE  (M6809)
         STA   2,S
         FIN    
;
;        FLOATING POINT ADD
;        TOS-1 CONTAINS AUGEND (GOES INTO MR1)
;        TOS CONTAINS ADDEND (GOES INTO MS1)
;        SUM RETURNED ON TOS
;        152???*** CYCLES IF NO NORMALIZE, NO CARRY OUT
;
FADD     PULD    
         STD   RETADD
         LDA   ,S                      ; ADD OR SUBTRACT?
         IF    M6800!M6801
         TAB    
         EORA  6,X
         STA   MSIGN
         LDA   6,X                     ; FIND DIFFERENCE IN EXPONENTS
         ELSE  (M6809)
         TFR   A,B
         EORA  6,S
         STA   MSIGN
         LDA   6,S
         FIN    
         ANDA  #$7F
         ANDB  #$7F
         SBA                           ; (MR1 EXP) - (MS1 EXP)
         jrz   FADD23                  ; NO NORMALIZATION REQUIRED
         BPL   FADD10                  ; MS IS SMALLER
FADD23   PULB                          ; SAVE (TOS) AS MS
         STB   MS1
         PULB    
         STB   MS2
         PULB    
         STB   MS3
         PULB    
         STB   MS4
         PULB    
         STB   MS5
         PULB    
         STB   MS6
         PULB    
         STB   MR1
         TSTA    
         jrnz  FADD22                  ; B/ DIFFERENT EXPONENTS
         TSTB    
         jrz   FADD30                  ; MR = 0, DONE
         PULD    
         STD   MR2
         PULD    
         STD   MR4
         PULB    
         STB   MR6
         jr    FADD9

FADD22   PULB    
         INCA                          ; MR IS SMALLER
         jrnz  FADD1
         STB   MR3
         PULB    
         STB   MR4
         PULD    
         STD   MR5
         CLRB    
         jr    FADD8                   ; CLEARS OUT MR2

FADD1    INCA    
         jrnz  FADD2
         STB   MR4
         PULD    
         STD   MR5
         CLRB    
         jr    FADD7                   ; CLEARS OUT MR2, MR3

FADD2    INCA    
         jrnz  FADD3
         STB   MR5
         PULB    
         STB   MR6
         CLRB    
         jr    FADD6                   ; CLEARS OUT MR2, MR3, MR4

FADD10   jr    FADD24

FADD3    INCA    
         jrnz  FADD4
         STB   MR6
         CLRB    
FADD5    PULA    
         STB   MR5
FADD6    PULA    
         STB   MR4
FADD7    PULA    
         STB   MR3
FADD8    PULA    
         STB   MR2
FADD9    LDA   MS1                     ; MS IS LARGER
         ANDA  #$7F
         SUBA  #$40-1
         STA   MEXP
         jr    FADD20
;
FADD30   INS    
FADD4    lhld  #MS1                    ; DON'T ADD OR SUB, MR HAS NO
         LEAS  4,S                     ; RELATIVE SIGNIFICANCE TO MS
         JMP   FLOAD1
;
FADD14   LEAS  4,S                     ; DON'T ADD OR SUB, MS HAS NO RELATIVE SIGNIFICANCE TO MR
         JMP   FLOAD2
;
FADD24   PULB    
         STB   MS1
         DECA    
         jrnz  FADD11
         PULD    
         STD   MS3
         PULD    
         STD   MS5
         CLRB    
         jr    FADD18                  ; CLEARS OUT MS2

FADD11   DECA    
         jrnz  FADD12
         PULB    
         STB   MS4
         PULD    
         STD   MS5
         CLRB    
         jr    FADD17                  ; CLEARS OUT MS2, MS3

FADD12   DECA    
         jrnz  FADD13
         PULD    
         STD   MS5
         CLRB    
         jr    FADD16                  ; CLEARS MS2, MS3, MS4

FADD13   PULB    
         DECA    
         jrnz  FADD14
         STB   MS6
         CLRB    
         PULA    
         STB   MS5
FADD16   PULA    
         STB   MS4
FADD17   PULA    
         STB   MS3
FADD18   PULA    
         STB   MS2
         PULD    
         STD   MR1
         PULD    
         STD   MR3
         PULD    
         STD   MR5
         LDA   MR1                     ; MR1 IS LARGER
         ANDA  #$7F
         SUBA  #$40-1
         STA   MEXP
FADD20   LDA   MSIGN                   ; ADD OR SUB?
         BMI   FSUB1                   ; SUBTRACT
         JMP   FADD21

FSUB1    lhld  #0
         shld  FACEXT1
         shld  FACEXT3
         shld  FACEXT4
         LDD   MR5                     ; SUBTRACT MS FROM MR
         SUBB  MS6
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDB  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STB   FAC6
         SBCA  MS5
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC5
         LDD   MR3
         SBCB  MS4
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDB  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STB   FAC4
         SBCA  MS3
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC3
         LDA   MR2
         SBCA  MS2
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC2
         BCC   FSUB4J
;
         CLRA                          ; WE WENT NEGATIVE
         SUBA  FAC6                    ; COMPLEMENT THE RESULT, SIGH...
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC6
         LDA   #0
         SBCA  FAC5
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC5
         LDA   #0
         SBCA  FAC4
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC4
         LDA   #0
         SBCA  FAC3
         BCC   *+4                     ; B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC3
         LDA   #0
         SBCA  FAC2                    ; ASSERT: FAC2 <> 0 HERE!
         ADDA  #100                    ; WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
         STA   FAC2
         LDA   #$80                    ; SIGN = - (SIGN OF LARGER)
         EORA  MR1
         jr    FSUB3
FSUB4J   jr    FSUB4
;
FADD21   LDD   MR5                     ; ADD MS TO MR
         ADDB  MS6
         ADDB  #-100                   ; DO BASE 100 ADJUST
         jrc   *+4                     ; AND PROPOGATE THE CARRY TO NEXT DIGIT
         SUBB  #-100
         STB   FAC6
         ADCA  MS5
         ADDA  #-100                   ; DO BASE 100 ADJUST
         jrc   *+4                     ; AND PROPOGATE THE CARRY TO NEXT DIGIT
         SUBA  #-100
         STA   FAC5
         LDD   MR3
         ADCB  MS4
         ADDB  #-100                   ; DO BASE 100 ADJUST
         jrc   *+4                     ; AND PROPOGATE THE CARRY TO NEXT DIGIT
         SUBB  #-100
         STB   FAC4
         ADCA  MS3
         ADDA  #-100                   ; DO BASE 100 ADJUST
         jrc   *+4                     ; AND PROPOGATE THE CARRY TO NEXT DIGIT
         SUBA  #-100
         STA   FAC3
         LDD   MR1
         ADCB  MS2
         ADDB  #-100                   ; DO BBSE 100 ADJUST
         jrc   *+4                     ; AND PROPOGATE THE CARRY TO NEXT DIGIT
         SUBB  #-100
         STB   FAC2
         STA   MSIGN                   ; USE MR1'S SIGN
         BCC   FLTEXIT1
         LDB   #1                      ; SET FAC1 FOR EXIT
         STB   FAC1
;        NOW FALL INTO FLTEXIT
         PAGE    
;        FLOATING POINT EXIT
;        ASSUMES ESTIMATED EXPONENT IN MEXP, SIGN IN MSIGN
;        ASSUMES FAC1 IS LEADING DIGIT OF RESULT
;        CHECKS FOR FLOATING ZERO
;        ALSO ASSUMES RETURN ADDRESS IS IN RETADD
;        EXITS THRU "FPTRAP" IF OVERFLOW
;
FLTEXIT  CLRB    
         lhld  #MEXP                   ; = FAC1-1
FLTEX1   LDA   1,X
         jrnz  FLTEX2
FLTEX0   INCB    
         INX    
         CPX   #FAC6
         jrnz  FLTEX1
FUNDER   EQU   *
FRZERO   lhld  #FZERO                  ; RETURN FLOATING ZERO AS RESULT
         JMP   FLOAD1

FSUB4    LDA   MR1
FSUB3    STA   MSIGN
FLTEXIT1 LDB   #1                      ; FAST EXIT (FAC1 IS ZERO)
         lhld  #FAC1
         LDA   1,X
         jrz   FLTEX0
FLTEX2   LDA   MEXP
         SBA    
         CMPA  #$7F-$40
         BGT   FOVER
         ADDA  #$40                    ; ADD BIAS
         jrz   FUNDER                  ; FLOATING UNDERFLOW, REETCH
         BMI   FUNDER
         LDB   MSIGN
         ANDB  #$80
         ABA    
         STA   ,X
         JMP   FLOAD1

FOVER    lhld  #INFINITY
         call  FLOAD
         LDA   MSIGN
         ANDA  #$80
         ORA   ,S                      
         IF    M6800!M6801
         STA   ,X
         ELSE  (M6809)
         STA   ,S
         FIN    
         JMP   [FPTRAP]
         PAGE    
;        FLOATING LOAD ROUTINE
;        X REG CONTAINS POINTER TO FLOATING POINT NUMBER
;        NUMBER POINTED TO IS PUSHED ONTO THE STACK
;        STORE RETURN ADDRESS IN RETADD AND EXITS THRU RETADD
;
FLOAD
         PULD                          ; POP RETURN ADDRESS OFF THE STACK
         STD   RETADD
FLOAD1   LDD   4,X                     ; GET LS 16 BITS
         PSHD    
         LDD   2,X
         PSHD    
         LDD   ,X                      ; GET MSBYTE (SIGN-EXPONENT BYTE)
         PSHD    
FLOAD2
         JMP   [RETADD]
        PAGE    
;        FLOATING INPUT CONVERSION ROUTINES
;        A,B CONTAIN MAX # OF CHARS TO EAT (INCLUDING BLANKS)
;        X REG CONTAINS POINTER TO CHARACTER STRING TO CONVERT
;        RESULT IS CONVERTED TO FLOATING POINT FORMAT AND PUSHED ONTO THE STACK
;        X REG WILL POINT PAST STRING WHEN DONE
;        DOES NOT EAT THE CR OR ANY OTHER DELIMITER
;        WHOLE STRING IS EATEN EVEN IF ERROR OCCURED
;        ROUTINE WILL EAT STRINGS OF THE FOLLOWING FORMAT:
;        <0 OR MORE BLANKS> FOLLOWED BY
;        <'+' OR '-' OR NOTHING> FOLLOWED BY
;        <1 OR MORE DIGITS WHICH MAY CONTAIN A '.' ANYWHERE IN THIS FIELD
;        FIELD MAY CONTAIN UP TO 10 SIGNIFICANT DIGITS
;        (LEADING ZEROES ARE NOT CONSIDERED SIGNIFICANT
;        EXAMPLE:
;        0.000000103456789
;        THE "0.000000" PART IS NOT CONSIDERED SIGNIFICANT,
;        WHILE THE "103456789" PART IS CONSIDERED SIGNIFICANT)
;        MAY NOT BE > 127 NON-SIG ZEROS RIGHT OF DP & PRECEEDING SIG DIGITS
;        EXCESS SIGNIFICANT DIGITS ARE READ AND IGNORED> FOLLOWED BY
;        <'e', 'E' OR NOT A 'E'> (DONE IF NOT 'E', ELSE...) FOLLOWED BY
;        <'+' OR '-' OR NOTHING> FOLLOWED BY
;        <UP TO 3 DIGITS NOT TO EXCEED 126> FOLLOWED BY
;        <NOT A DIGIT>
;
;        call  FCONVI
;        jr    ALL OK
;        jr    OVERFLOW
;        jr    SYNTAX ERROR
;
FCONVI31 BSR   GETCHAR
LEFTDIG  BSR   ISDIG
         jr    FCONVI32
         CMPA  #'.
         jrnz  FCONVI33
         LDA   DPFLAG
         jrnz  FCONVI33
         INCA    
         STA   DPFLAG
         jr    FCONVI31
FCONVI32 TFR   A,B                     ; MULTIPLY LEFT DIGIT OF PAIR BY 10
         ASLA    
         ASLA    
         ABA    
         ASLA    
         STA   ,X
FCONVI36 LDA   DPFLAG
         jrnz  FCONVI37
         INC   DPCOUNT
         BPL   FCONVI37
         LEAS  2,S
         JMP   SYNERR
FCONVI37 ret
FCONVI33 PULX    
         JMP   2,X
;
FCONVI34 BSR   GETCHAR
RIGHTDIG BSR   ISDIG                   ; PICK UP RIGHT HAND DIGIT OF PAIR
         jr    FCONVI35
         CMPA  #'.
         jrnz  FCONVI33
         LDA   DPFLAG
         jrnz  FCONVI33
         INCA    
         STA   DPFLAG
         jr    FCONVI34
FCONVI35 ADDA  ,X                      ; ADD RIGHT HAND DIGIT TO LEFTHAND ALREADY COLLECTED
         STA   ,X+
         jr    FCONVI36
         PAGE    
;        DIGIT CHECK ROUTINE
;        SKIP RETURN IF A IS NOT A DIGIT
;        RETURN W/BCD EQUIVALENT IF CHAR IS A DIGIT
;
ISDIG    CMPA  #'0
         BLT   ISDIG2
         CMPA  #'9
         BGT   ISDIG2
         STA   DIGFLG
         SUBA  #'0
         ret
ISDIG2   STA   TEMPA                   ; SKIP RETURN, PRESERVE A, X
         PULD    
         ADDD  #2
         PSHD    
         LDA   TEMPA
         ret
;
;        GET CHARACTER ROUTINE
;        GET CHAR @BUFERP BUMP X & RETURN
;
GETCHAR  shld  FACX
         lhld  LOOPX                   ; CHECK MAX # OF CHARS READ
         jrz   GETCHAR0
         DEX    
         shld  LOOPX
         lhld  BUFERP
         LDA   ,X+
GETCHAR2 shld  BUFERP
         lhld  FACX
         ret
GETCHAR0 lhld  BUFERP
         INX    
         CLRA    
         jr    GETCHAR2
         PAGE    
FCONVI   STD   LOOPX                   ; MAX # OF CHARS TO EAT
         CLRA    
         STA   DPFLAG
         STA   DPCOUNT
         STA   DIGFLG
         shld  BUFERP
         shld  FCVIRT                  ; NOT USED RIGHT AWAY
         lhld  #0
         shld  FAC1
         shld  FAC3
         shld  FAC5
         shld  FACEXT1                 ; 10TH DIGIT GOES INTO LEFT HALF OF FACEXT1
FCONVI1  BSR   GETCHAR
         CMPA  #ASCII:SPACE
         jrz   FCONVI1                 ; EAT BLANKS
         CMPA  #ASCII:HT
         jrz   FCONVI1
         CMPA  #'+
         jrz   FCONVI2
         CMPA  #'-
         jrnz  FCONVI3
         LDA   #$80
         STA   FAC1                    ; MAKE SIGN NEG
;
;        IGNORE LEADING ZEROES
;
FCONVI2  BSR   GETCHAR                 ; GO GET SOME DIGITS
FCONVI3  CMPA  #'0
         jrnz  FCONVI50
         STA   DIGFLG
         LDA   DPFLAG
         jrz   FCONVI2                 ; NO DP SEEN YET
         DEC   DPCOUNT
         BMI   FCONVI2
         JMP   SYNERR                  ; TOO MANY ZEROES
FCONVI50 CMPA  #'.
         jrnz  FCONVI51
         STA   DPFLAG
         jr    FCONVI2
;
;        EAT SIGNIFICANT DIGITS
;
FCONVI51 lhld  #FAC2
         LDB   #DIGMAX/2
         STB   DIGCNT                  ; USE THIS AS A COUNTER
         jr    FCONVI4A
FCONVI4  BSR   GETCHAR
FCONVI4A call  RIGHTDIG
         jr    FCONVI5                 ; ALL IS OK
         jr    FCONVI8                 ; 2ND DP FOUND, OR NOT A DIGIT
FCONVI5  BSR   GETCHAR
         call  LEFTDIG
         jr    FCONVI6                 ; ALL IS OK
         jr    FCONVI8                 ; 2ND DP FOUND, OR NOT A DIGIT
FCONVI6  DEC   DIGCNT
         jrnz  FCONVI4                 ; NOT DONE, KEEP GOING
         LDA   DPFLAG                  ; DECIMAL POINT SEEN ?
         jrnz  FCONVI7B                ; B/ YES, COLLECT AND IGNORE REMAINING DIGITS
         jr    FCONVI7A                ; SKIP INTO EXCESS DIGIT COLLECTION LOOP

FCONVI7  INC   DPCOUNT                 ; BUMP # DIGITS SEEN BEFORE DECIMAL POINT
         BMI   SYNERRJ                 ; B/ TOO MANY DIGITS TO LEFT OF DECIMAL POINT
FCONVI7A call  GETCHAR
         call  ISDIG
         jr    FCONVI7                 ; SCAN OFF REMAINING DIGITS
         CMPA  #'.                     ; DECIMAL POINT ?
         jrnz  FCONVI8                 ; B/ NOPE
FCONVI7B call  GETCHAR                 ; YES, COLLECT DIGITS AFTER DP
         call  ISDIG
         jr    FCONVI7B
FCONVI8  LDB   DIGFLG                  ; SEE IF SYNTAX OK SO FAR...
         jrnz  FCONVI26
SYNERRJ  JMP   SYNERR                  ; NO DIGITS FOUND YET, ERROR
;
;        SYNTAX OK SO FAR, TRY FOR EXPONENT
;
FCONVI26 lhld  BUFERP                  ; REMEMBER THIS POINTER
         shld  FCVIRT
         CLRB    
         STB   DIGFLG                  ; EXPONENT DIGIT FLAG
         STB   MSIGN                   ; EXPONENT SIGN
         STB   MEXP                    ; EXPONENT VALUE
         STB   EXPOVF                  ; EXPONENT OVERFLOW FLAG
         CMPA  #'e
         jrz   FCONVI26A
         CMPA  #'E
         jrnz  FCONVI13                ; GO CLEAN UP, NO ERRORS
FCONVI26A      call                    ; GETCHAR
         CMPA  #'+
         jrz   FCONVI9                 ; B/ IGNORE LEADING PLUS
         CMPA  #'-
         jrnz  FCONVI11
         LDA   #$80
         STA   MSIGN
FCONVI9  call  GETCHAR
         jr    FCONVI11
;
;        COLLECT EXPONENT DIGITS
;
FCONVI10 call  GETCHAR
FCONVI11 call  ISDIG
         jr    FCONVI12
         jr    FCONVI90                ; GO CLEAN UP
FCONVI12 LDB   MEXP
         ASLB                          ; *2
         jrc   FCONVI91                ; CATCH THE OVERFLOW
         ASLB                          ; *4
         jrc   FCONVI91                ; CATCH THE OVERFLOW
         ADDB  MEXP                    ; *5
         jrc   FCONVI91                ; CATCH THE OVERFLOW
         ASLB                          ; *10
         ABA    
         STA   MEXP
         BCC   FCONVI10
FCONVI91 LDA   #1
         STA   EXPOVF
         jr    FCONVI10
FCONVI90 LDA   DIGFLG                  ; ANY EXPONENT DIGITS?
         jrnz  FCONVI13
         lhld  FCVIRT                  ; NO, BACKUP AND IGNORE E PHRASE
         shld  BUFERP
;
;        CLEAN UP HERE
;
FCONVI13 LDA   FAC2                    ; IF FAC2 IS ZERO, WE'RE OK
         jrnz  FCONVI14                ; B/ NONZERO DIGIT SEEN
         STA   FAC1
         jr    UNDERFLOW               ; (IT ISN'T REALLY, JUST AN OK EXIT)
FCONVI14 LDA   EXPOVF
         jrnz  OVERFLOW                ; EXPONENT OVERFLOW, SEMANTIC ERROR
         LDB   MEXP
         jrz   FCONVI15
         LDA   MSIGN
         BPL   FCONVI16
         NEGB    
         LDA   #$FF
         jr    FCONVI16
FCONVI15 CLRA    
;
;        A,B HAVE 16 BIT SIGNED VALUE REPRESENTING THE VALUE OF
;        THE SPECIFIED EXPONENT. ADD TO THAT THE # OF DIGITS LEFT OF
;        THE DP
;
FCONVI16 STD   FACX
         LDB   DPCOUNT                 ; SIGN EXTEND THE DP COUNT
         CLRA    
         ROLB    
         SBCA  #0
         ASRD    
         ADDB  FACX+1                  ; *** CANNOT OPTIMIZE FOR 6809 ****
         ADCA  FACX
;
;        IF A <> 0 OR A <> $FF, ERROR
;
         jrz   FCONVI22
         CMPA  #$FF
         jrz   FCONVI22
         TSTA    
         BPL   OVERFLOW
UNDERFLOW      lhld                    ; #FZERO
         jr    FCONVI21
;
;        NOW NORMALIZE IF EXP IS ODD
;
FCONVI22 ASRD    
         jrc   FCONVI18                ; B/ NO NORMALIZE
         PSHB                          ; SIGN IS PROPOGATED, SAVE EXPONENT
         CLRA                          ; MAKE FORWARD CARRY = 0
         LDB   #10                     ; MULTIPLIER...
         STB   ML
         lhld  #FACEXT1                ; MULTIPLY COLLECTED RESULT BY TEN
         call  FDIVNORMDIGIT
         call  FDIVNORMDIGIT
         call  FDIVNORMDIGIT
         call  FDIVNORMDIGIT
         call  FDIVNORMDIGIT
         call  FDIVNORMDIGIT           ; PROCESS MSD
;        ASSERT:                       (A)=0 (NO CARRY!)
         PULB    
         CLC    
FCONVI18 ADCB  #$40                    ; ADD BIAS
         BVS   OVERFLOW
         BLE   UNDERFLOW
         ORAB  FAC1                    ; PICK UP THE SIGN
         STB   FAC1
         lhld  #FAC1
         jr    FCONVI21
OVERFLOW LDA   FAC1
         BPL   FCONVI20
         lhld  #MINFINITY
         jr    FCONVI25
FCONVI20 lhld  #INFINITY
FCONVI25 PULD    
         ADDD  #2
         jr    FCONVI21A
FCONVI21 PULD    
FCONVI21A      STD                     ; FCVIRT
         call  FLOAD
         LDD   FCVIRT
         PSHD    
         lhld  BUFERP
         DEX    
         ret

SYNERR   lhld  FCVIRT                  ; GET ORIGINAL BUFFER POINTER
         PULD    
         ADDD  #4
         PSHD    
         ret
        PAGE    
;
;        FIX16 -- CONVERT NON-ZERO FP NUM ON TOS TO 4 BYTE INTEGER..
;        IN RANGE 0..65535
;        SKIP 2 BYTES AT EXIT IF CAN'T FIX OR NOT AN INTEGER IN PROPER RANGE
;
FIX16
         IF    M6800                   ; GET POINTER TO VALUE TO FIX
         LDB   7,S                     ; IS THERE A FRACTIONAL PART OR MORE SIGIFICANCE THAN WE CAN FIX ?
         ORAB  6,X                     ; ...?
         jrnz  FIXERRJ                 ; B/ YEP
         LDA   2,X                     ; GET EXPONENT BYTE (ASSERT: TOS IS NONZERO FP NUM)
         ELSE  M6801!M6809
         LDD   6,S
         jrnz  FIXERRJ
         IF    M6809
         LDA   2,S
         ELSE  M6801
         LDA   2,X
         FIN    
         FIN    
         BMI   FIXERRJ                 ; B/ < 0, CAN'T FIX16
         CMPA  #$43                    ; MAX FIXABLE EXPONENT ?
         BHI   FIXERRJ                 ; B/ CAN'T FIX16
         jrz   FIX16A                  ; B/ YES, GO CHECK FOR > 65536
         CMPA  #$41                    ; SINGLE DIGIT RESULT ?
         jrc   FIXERRJ                 ; B/ FRACTIONAL, CAN'T FIX16
         BHI   FIX16$42                ; B/ CAN FIX IF NO FRACTIONAL PART!
         IF    M6800!M6801
         ORAB  4,X                     ; SEE IF FRACTIONAL PART EXISTS
FIX16$42 ORAB  5,X                     ; ...
         ELSE  M6809
         ORAB  4,S
FIX16$42 ORAB  5,S
         FIN    
         jrnz  FIXERRJ                 ; B/ CAN'T FIX16
         TFR   A,B                     ; IT CAN BE FIXED!
         JMP   FIX1                    ; SO GO DO IT

FIX16A
         IF    M6800!M6801
         LDB   3,X                     ; MAX EXPONENT FOUND, CHK <=65535
         ELSE  (M6809)
         LDB   3,S
         FIN    
         CMPB  #65535/(100*100)
         jrc   FIX16B                  ; B/ CAN DO IT!
         BHI   FIXERRJ                 ; B/ CAN'T DO IT
         IF    M6800!M6801
         LDB   4,X                     ; RATS, CAN'T TELL FROM FIRST DIGIT
         ELSE  (M6809)
         LDB   4,S
         FIN    
         CMPB  #55                     ; =2ND DIGIT OF 6 55 36
         jrc   FIX16B                  ; B/ CAN DO IT!
         BHI   FIXERRJ                 ; B/ > 655XX
         IF    M6800!M6801
         LDB   5,X                     ; MUST LOOK AT LAST DIGIT
         ELSE  (M6809)
         LDB   5,S
         FIN    
         CMPB  #36                     ; = LAST DIGIT OF 6 55 36
         BCC   FIXERRJ                 ; B/ > 65536, CAN'T FIX16
FIX16B   TFR   A,B
         jr    FIX1
         PAGE    
         PAGE    
;        FIX FLOATING POINT NUMBER
;        6 BYTE NUMBER ON TOS IS CONVERTED TO
;        4 BYTE SIGNED 2'S COMPLEMENT INTEGER
;        SKIP RETURN IF CAN'T FIX (# < - 2^31 OR # > 2^31 - 1)
;        IF # < 1, RETURN ZERO
;
FIX      TSX    
         LDA   2,X                     ; GET EXPONENT
         TFR   A,B
         ANDA  #$7F                    ; CHECK EXPONENT RANGE
         CMPA  #$46
         BGE   FIXERRJ                 ; TOO BIG FOR 32 BITS
         CMPA  #$40
         BGT   FIX1
         CLRA                          ; # < 1, LOAD ZERO
         STA   4,X                     ; RETURN ONLY 4 BYTES HERE
         STA   5,X
         STA   6,X
         STA   7,X
         JMP   FIX8

FIXERRJ  JMP   FIXERR

FIX1
         IF    M6809
         TFR   S,X                     ; SIGH... THIS IS THE MOST CONVENIENT WAY TO DO THIS...
         FIN    
         CLRA    
         STA   FAC3
         STA   FAC4
         STA   FAC5
         LDA   3,X                     ; USE 1ST F.P. DIGIT ON 1ST ITERATION
         STA   FAC6
         ANDB  #7                      ; LOOP CNTR, 5 >= B >= 1
         DECB                          ; ONLY ONE DIGIT ?
         STB   TEMPB                   ; SET UP LOOP COUNT
         jrnz  FIX2                    ; B/ MORE THAN 1 DIGIT TO PROCESS
         JMP   FIX4A                   ; B/ ONLY ONE DIGIT, TAKE FAST EXIT
         PAGE    
FIX2     INX                           ; INSERT NEXT F.P. DIGIT INTO FIXED RESULT
FIXMULBY100    EQU                     ; * MULTIPLY (FAC3,4,5,6) BY 100 AND ADD NEW DIGIT
         LDD   FAC3                    ; FACEXT1,2,3,4:=FAC3,4,5,6
         STD   FACEXT1
         LDD   FAC5                    ; (A,B,FAC5,FAC6):=INPUT*3
         STD   FACEXT3
         ASLD    
         ROL   FAC4
         ROL   FAC3
         jrc   FIXERRBCS
         ADDD  FACEXT3
         STD   FAC5
         LDD   FAC3
         ADCB  FACEXT2
         ADCA  FACEXT1
         jrc   FIXERRBCS               ; B/ OVERFLOW, CAN'T FIX
         ASL   FAC6                    ; *2 --> INPUT * 6
         ROL   FAC5
         ROLD    
         jrc   FIXERRBCS
         ASL   FAC6                    ; *2 --> INPUT * 12
         ROL   FAC5
         ROLD    
         jrc   FIXERRBCS
         ASL   FAC6                    ; *2 --> INPUT * 24
         ROL   FAC5
         ROLD    
         jrc   FIXERRBCS
         STD   FAC3
         LDD   FAC5                    ; ADD ORIGINAL VALUE TO GET INPUT * 25
         ADDD  FACEXT3
         STA   FAC5
         LDA   FAC4
         ADCA  FACEXT2
         STA   FAC4
         LDA   FAC3
         ADCA  FACEXT1
         jrc   FIXERRBCS
         ASLB                          ; *2 --> INPUT * 50
         ROL   FAC5
         ROL   FAC4
         ROLA    
FIXERRBCS      jrc                     ; FIXERR
         ASLB                          ; *2 --> INPUT * 100
         ROL   FAC5
         ROL   FAC4
         ROLA    
         ADDB  3,X                     ; ADD IN NEW DIGIT
         STB   FAC6
         BCC   FIXMUL100A              ; B/ NO CARRY
         INC   FAC5
         jrnz  FIXMUL100A
         INC   FAC4
         jrnz  FIXMUL100A
         INCA    
         jrz   FIXERR
FIXMUL100A     STA                     ; FAC3 SAVE FINAL RESULT (WHEW!)
         DEC   TEMPB                   ; DOWN COUNT # DIGITS LEFT TO PROCESS
         jrz   FIX4A                   ; B/ DONE
         JMP   FIX2
         PAGE    
FIX4A    TSX                           ; CLEAN UP AND EXIT
         LDA   2,X                     ; SEE IF # IS POSITIVE
         BPL   FIX5
         LDD   #0
         SUBA  FAC6
         STA   FAC6
         TFR   B,A
         SBCA  FAC5
         STA   FAC5
         TFR   B,A
         SBCA  FAC4
         STA   FAC4
         TFR   B,A
         SBCA  FAC3
         STA   FAC3
         BVS   FIXERR                  ; CAN'T COMPLEMENT
FIX5     LDD   FAC5
         STD   6,X
         LDD   FAC3
         STD   4,X
FIX8
         IF    M6800!M6801
         lhld  ,X
         LEAS  4,S                     ; LEAVE 4 BYTES ON STACK
         ELSE  (M6809)
         PULX    
         LEAS  2,S
         FIN    
         JMP   ,X

FIXERR   PULX                          ; ERROR RETURN, CAN'T FIX  LEAVE 6 BYTES ON TOS
         JMP   2,X
         PAGE    
;        FLOAT INTEGER
;        4 BYTE INTEGER ON TOS IS CONVERTED TO 6 BYTE FLOATING POINT FORMAT
;        NO ERROR RETURN
;
FLOAT    PULD    
         STD   RETADD
         lhld  #0
         shld  FAC2
         shld  FAC4
         shld  FAC6
         PULD                          ; GET MOST SIGNIFICANT BYTES
         STB   FACEXT2
         PULB    
         STB   FACEXT3
         PULB    
         STB   FACEXT4
         CLRB    
         STA   FACEXT1                 ; SAVE MSB; IS VALUE < 0 ?
         BPL   FLOAT1                  ; NO
         TFR   B,A                     ; YES, COMPLEMENT
         SUBA  FACEXT4
         STA   FACEXT4
         TFR   B,A
         SBCA  FACEXT3
         STA   FACEXT3
         TFR   B,A
         SBCA  FACEXT2
         STA   FACEXT2
         TFR   B,A
         SBCA  FACEXT1
         STA   FACEXT1                 ; OVERFLOW ON COMPLEMENT IS NO SWEAT
         LDB   #$80
         PAGE    
FLOAT1   STB   MSIGN
         LDA   FACEXT1                 ; CHECK: CAN WE FLOAT IT QUICKLY ?
         ORAA  FACEXT2
         jrnz  FLOAT32                 ; B/ NOPE, GO DO IT THE HARD WAY
         LDA   FACEXT3
         jrz   FLOATQ1                 ; B/ NUMBER MAY BE ZERO!
         CMPA  #9999/256
         BHI   FLOAT16                 ; B/ 2^16>VALUE>9999
         LDB   FACEXT4                 ; NUMBER IS CLOSE TO 9999...
         jrc   FLOATQJ                 ; B/ < 9999
         CMPB  #9999&$FF               ; IS IT REALLY <= 9999 ?
         BHI   FLOAT16                 ; B/ NO, GO FLOAT 16 BITS
FLOATQJ  JMP   FLOATQUICK              ; GO DO FLOAT OF VALUE (0..9999)

FLOATQ1  LDB   FACEXT4                 ; GET LOWER 16 BITS
         jrnz  FLOATQJ                 ; B/ VALUE IS <> 0 !
         JMP   FRZERO                  ; ENTIRE VALUE IS ZERO

FLOAT16  lhld  FACEXT3                 ; ONLY 16 BITS TO FLOAT
         shld  FACEXT1                 ; SKIP FIRST 16 SHIFTS
         LDB   #16
         jr    FLOAT32A
FLOAT32  LDB   #32                     ; LOOP COUNTER (32 BITS TO FLOAT)
FLOAT32A LDA   FACEXT4                 ; TO HELP SPEED UP THE SHIFTING PROCESS
FLOAT3   ASLA                          ; SHIFT OVER LEADING ZEROS
         ROL   FACEXT3
         ROL   FACEXT2
         ROL   FACEXT1
         DECB                          ; CANNOT GO TO ZERO BECAUSE INPUT WAS <> 0
         BCC   FLOAT3                  ; B/ NO SIGNIFICANCE ENCOUNTERED YET
         STA   FACEXT4                 ; SAVE THIS BACK WHERE IT BELONGS
         INCB                          ; BECAUSE WE OVERSHOT BY 1
         jr    FLOAT14                 ; NOW GO COLLECT SIGNIFICANCE

FLOAT4   ASL   FACEXT4
         ROL   FACEXT3
         ROL   FACEXT2
         ROL   FACEXT1
FLOAT14  LDA   FAC6
         ADCA  FAC6
         ADDA  #-100                   ; DO BASE 100 DIGIT ADJUSTMENT
         jrc   *+4
         SUBA  #-100
         STA   FAC6
         LDA   FAC5
         ADCA  FAC5
         ADDA  #-100                   ; DO BASE 100 DIGIT ADJUSTMENT
         jrc   *+4
         SUBA  #-100
         STA   FAC5
         LDA   FAC4
         ADCA  FAC4
         ADDA  #-100                   ; DO BASE 100 DIGIT ADJUSTMENT
         jrc   *+4
         SUBA  #-100
         STA   FAC4
         LDA   FAC3
         ADCA  FAC3
         ADDA  #-100                   ; DO BASE 100 DIGIT ADJUSTMENT
         jrc   *+4
         SUBA  #-100
         STA   FAC3
         LDA   FAC2
         ADCA  FAC2
         ADDA  #-100                   ; DO BASE 100 DIGIT ADJUSTMENT
         jrc   *+4
         SUBA  #-100
         STA   FAC2
         DECB    
         jrnz  FLOAT4
;
         LDA   FAC2                    ; PUT THE # INTO THE STACK
         jrz   FLOAT5
         LDB   FAC6
         PSHB    
         LDB   FAC5
         PSHB    
         LDB   FAC4
         PSHB    
         LDB   FAC3
         PSHD    
         LDA   #$45                    ; 5 BYTES OF SIGNIFICANCE
         jr    FLOAT9
FLOAT5   LDA   FAC3
         jrz   FLOAT6
         CLRB    
         PSHB    
         LDB   FAC6
         PSHB    
         LDB   FAC5
         PSHB    
         LDB   FAC4
         PSHD    
         LDA   #$44                    ; 4 BYTES OF SIGNIFICANCE
         jr    FLOAT9
FLOAT6   CLRB                          ; MUST BE 3 BYTES OF SIGNIFICANCE
         PSHB    
         LDA   FAC6
         PSHD    
         LDD   FAC4
         PSHD    
         LDA   #$43
         jr    FLOAT9

FLOATQUICK     EQU                     ; * USED TO FLOAT VALUES 0..9999
         call  CONVERTTOBASE100        ; RIP VALUE APART TO GET BASE 100 DIGITS
         STA   FAC5                    ; SAVE UPPER DIGIT
         jrz   FLOAT8                  ; B/ UPPER DIGIT IS ZERO
         CLRA    
         PSHA    
         PSHA    
         PSHA    
         LDA   FAC5
         PSHD    
         LDA   #$42                    ; 2 BYTES OF SIGNIFICANCE
         jr    FLOAT9

FLOAT8   PSHA  ASSERT: (A)=0
         PSHA    
         PSHA    
         PSHA    
         PSHB                          ; THIS BYTE CANNOT BE ZERO
         LDA   #$41                    ; 1 BYTE OF SIGNIFICANCE
FLOAT9   ORAA  MSIGN
         PSHA    
         JMP   [RETADD]
         PAGE    
;        FLOATING OUTPUT CONVERSION ROUTINE
;        TOS CONTAINS FLOATING POINT NUMBER TO CONVERT
;        X REG POINTS TO THE OUTPUT BUFFER
;        CONVERTS NUMBER TO ASCII STRING IN 'E' FORMAT:
;        <SIGN> <'.'> <10 DIGITS> <'E'> <ESIGN> <3 DIGITS>
;        A RETURNS A NUMBER REPRESENTING # OF DIGITS
;        TO THE LEFT OF THE '.' IF THE # WERE NORMALIZED SUCH THAT 'E' = 0
;        (EXAMPLE: A CONTAINS  0 --> ".DDDDDDDDDD"
;                  A CONTAINS -2 --> ".00DDDDDDDDDD"
;                  A CONTAINS  2 --> "DD.DDDDDDDD"
;        B RETURNS # OF SIGNIFICANT DIGITS (10 - # OF RIGHTMOST ZERO DIGITS)
;        NUMBER IS POPPED OFF TOS
;        NO ERROR EXIT
;        FOR ZERO, THIS ROUTINE RETURNS: ????
FCONVO   shld  BUFERP
         PULD                          ; GET RETURN ADDDRESS
         STD   RETADD
         PULA                          ; GET EXPONENT
         STA   MEXP                    ; SAVE IT
         LDA   #5
         STA   ML
FCVO1    PULB                          ; PUT OUT 10 DIGITS
         LDA   #-1                     ; A = LEFT HAND DIGIT
FCVO1L   INCA                          ; BUMP LEFT HAND DIGIT
         SUBB  #10
         BPL   FCVO1L
         ADDB  #10
         ADDA  #'0
         INX    
         STA   1,X
         ADDB  #'0
         INX    
         STB   1,X
         DEC   ML
         jrnz  FCVO1
         LDB   #'+                     ; PUT OUT SIGN
         LDA   MEXP
         BPL   FCVO2
         LDB   #'-
FCVO2    lhld  BUFERP
         STB   ,X
         LDB   #'.                     ; PUT OUT DECIMAL POINT
         STB   1,X
         LDB   #'E                     ; PUT OUT 'E'
         STB   12,X
         LDB   #'+                     ; PUT OUT ESIGN
         ASLA    
         BMI   FCVO3
         LDB   #'-
FCVO3    STB   13,X
         STA   MEXP
         LDA   2,X
         CMPA  #'0
         jrnz  FCVO5
         TFR   A,B
         DEC   MEXP
         LDA   #9
         STA   ML
FCVO4    INX                           ; ENSURE LEAD DIGIT IS NON-ZERO
         LDA   2,X
         STA   1,X
         DEC   ML
         jrnz  FCVO4
         STB   2,X
FCVO5    LDA   MEXP
         SUBA  #$40*2
         PSHA    
         BPL   FCVO10
         NEGA    
FCVO10   STA   ML                      ; MAKE EXPONENT DIGITS
         CLRA    
         STA   TEMPA
         STA   TEMPB
         LDB   #8
FCVO6    ASL   ML
         LDA   TEMPB
         ADCA  TEMPB
         DAA    
         STA   TEMPB
         LDA   TEMPA
         ADCA  TEMPA
         DAA    
         STA   TEMPA
         DECB    
         jrnz  FCVO6
         lhld  BUFERP
         LDA   TEMPA                   ; CONVERT BCD TO ASCII
         ADDA  #'0
         STA   14,X
         LDA   TEMPB
         TFR   A,B
         LSRA    
         LSRA    
         LSRA    
         LSRA    
         ADDA  #'0
         STA   15,X
         TFR   B,A
         ANDA  #$F
         ADDA  #'0
         STA   16,X
         LDA   #10
         STA   ML
         TFR   A,B
FCVO7    DEX   COUNT # OF SIG DIGITS
         LDA   12,X
         CMPA  #'0
         jrnz  FCVO8
         DECB    
         DEC   ML
         jrnz  FCVO7
FCVO8    PULA    
         TSTB                          ; SEE IF # WAS ZERO
         jrnz  FCVO9
         CLRA                          ; YES, SET # OF INT DIGITS TO ZERO TOO
FCVO9    JMP   [RETADD]
         PAGE    
;        FLOATING POINT INTEGER FUNCTION
;        TRUNCATES FRACTION BITS IF ANY
;        RETURN NEXT INTEGER NOT LARGER THAN TOS
;        EXAMPLE:
;        INT(1.0) = 1.0
;        INT(1.2) = 1.0
;        INT(-2.0) = -2.0
;        INT(-1.2) = -2.0
;        NO ERROR RETURN
;
FINT     PULD    
         STA   FINTRT
         STB   FINTRT+1
         LDB   ,S
         STB   MSIGN
         ANDB  #$7F
         CMPB  #$44
         BHI   FINT3                   ; DONE
         CMPB  #$40
         BHI   FINT4
         LEAS  RSESIZ,S                ; POP STACK ENTRY
         LDA   MSIGN
         BPL   FINT2                   ; POSITIVE, MAGNITUDE > 0 & < 1, LOAD UP 0.0
         lhld  #FMONE                  ; NEGATIVE, MAGNITUDE < 0, LOAD UP -1
         jr    FINT1
FINT2    lhld  #FZERO
FINT1    call  FLOAD

FINT3    JMP   [FINTRT]

FINT4    LDA   #$45
         SBA                           ; A HAS # OF RIGHT BYTES TO CHECK
         CLRB                          ; CHECK FOR FRACTIONAL PART
         TSX    
FINT5    DEX    
         ORAB  6,X                     ; (B) <>0 --> FRACTION
         CLR   6,X                     ; ZERO FRACTIONAL PART
         DECA    
         jrnz  FINT5
         LDA   MSIGN                   ; IF <0 AND FRACTIONAL PART, SUBTRACT 1
         BPL   FINT3                   ; # IS POSITIVE
         TSTB    
         jrz   FINT3                   ; # IS NEGATIVE, BUT NO FRACTION, DONE
         lhld  #FMONE                  ; SIGH..., SUBTRACT 1 FROM #
         call  FLOAD
         call  FADD                    ; SUBTRACT 1, NO OVERFLOW POSSIBLE
         jr    FINT3

BASICRTPEND$   EQU                     ; *

         ORG   (*//256)*256            ; SKIP UP TO NEXT PAGE BOUNDARY
;        CHAIN AND GO
;        MODELS THE FOLLOWING BASIC PROGRAM:
;              DIM PROGRAM$(50)
;              INPUT '' PROGRAM$
;              CHAIN PROGRAM$
;              END    
;
CHAINGO  call  $100                    ; OFF TO THE RTP!
         +VERSION                      ;  VERSION NUMBER
         #0                            ; FREF LABEL CHAIN
         #$100                         ; CAT BUF SIZE REQUIRED (FOR INPUT LINE)
         #CHAINGOEND                   ; BASE OF SCALAR VARS (USELESS, HERE!)
         #CHAINGOEND                   ;  TOP OF DATA SPACE
         OPZCHN                        ;  ZERO THE CHANNEL NUMBER
         OPINL                         ; INPUT A LINE FROM THE KEYBOARD
         #:1                           ; WHERE TO GO IF EOF ERROR
:1       OPINS                         ; PUSH DESCRIPTOR FOR INPUT STRING
         OPCHAIN                       ;  AND CHAIN TO IT!
CHAINGOEND     EQU                     ; *
         END   CHAINGO

