         Title 'SD BASIC Version 1.4k Z80 Runtime Package (C) 1983'
;        SD BASIC 1.4K Z80 Runtime Package
;        COPYRIGHT 1983 Software Dynamics
;        2111 W. Crescent, Suite G
;        Anaheim, CA 92801
;        All Rights Reserved
;
Version  equ   $14                     ; Version 1, Revision 4
;
;        This version of the Runtime package is intended to execute
;        programs on an 8085 or Z80, compiled by SD BASIC 1.4,
;        which normally runs on a Motorola 6800/6809 microprocessor.
;        IN PARTICULAR, IT IS INTENDED TO EXECUTE OBJECT FILES
;        GENERATED ON THE 6800/6809 WITHOUT CHANGE (other than conversion
;        from SDOS load record object form to CP/M load record form).
; ?? what about leading JSR, and entry points to subrs ??
;        It uses the Software Dynamics Z80C convention for coding
;        so that the source file is useful on both the 8085 or Z80,
;        just by re-assembling. Program development tools used are
;        CP/M and RMAC.  SDOS system calls are issued, and
;        simulated by a support package, so that this program can
;        run in the CP/M environment.
;
;        Coding rules: use same label as 6800/6809 RTP if at all possible.
;        A label which is (partially) uppercase is a target of a
;        non-local reference.  An all lowercase label is local to
;        the routine.
;
;        12/10/83 Version 1.4k
?;              Also, added READ#<channel>@<position>,<record> and
?;                          WRITE#<channel>@<position>,<record> opcodes
?;                          KEY(<channel>,<key>,<keystring>, etc.
?;              Allow dynamic strings when concatenating?
;
z80      equ   1                       ; this assembly is for a Z80
i8085    equ   1-z80                   ; set i8085 switch, too

;
;        Numeric BASIC data items are stored on the stack, and in main
;        memory, in an order which is non-standard for 8080/z80
;        class systems in order to be compatible with Software Dynamics
;        6800/6809 BASIC 1.4 internal data and external file data formats.
;        This is true for floating point data, and the optimized integer
;        data formats. This allows Records to be read with a binary read
;        without any attempt to re-format the data.
;
;        The compiled programs on the 6809 put address and 16 bit integers
;        into the popcodes in a non-reversed order; this too must be treated
;        exactly as on the 6809 or object code will not port.
;
;        On 8080 and Z80, (BC), (DE) and (HL) are 16 bit register pairs.
;        Because of the nonstandard stacking order, data popped from
;        the stack gets reversed, so a 16 bit value popped into (BC)
;        actually has its MSB in (C); we denote this by writing "register (CB)"
;        This notation is used throughout this runtime package.
;
;        Since string descriptors and variable addresses are never written
;        to external data files, they are stored on the stack structurally
;        like in 6800/6809 implementation, but with address and count bytes
;        reversed as convenient for 8080/z80.
;
         page
         if    z80
         maclib Z80                    ; get Z80 macros
         endif

         maclib sdz80c                 ; get Z80/8085 compatability macros

dada     macro                         ;; macro to add (A) to (HL)
;;       if    method1
         add   l                       ;; (4~)
         mov   l,a                     ;; (5~)
         if    method1a
;;       mvi   a,0                     ;; (7~)
;;       aci   h                       ;; (7~)
;;       mov   h,a                     ;; (5~)
;;       else  ; method1b
         jnc   $+4                     ;; (10~) usually takes the branch
         inr   h                       ;; (5~)
;;       endif
;;       else  method2
;;       mov   e,a                     ;; (5~)
;;       mvi   d,0                     ;; (7~)
;;       dad   d                       ;; (10~)
         mend    

         org   code
code equ 0100h ?
         INCLUDE                       ; SDOSUSERDEFS.ASM SO WE GET SDOS INTERFACE STUFF
         PAGE  ***** ERROR AND ADDRESS CONSTANTS *****
         TABS  20,28,44,45
         page    
;        THINGS LEFT TO DO/CONSIDER:
;              ALLOW RECURSIVE USE OF CATBUF
;              , IN FORMAT ?
;              * FILL IN FORMAT ?
;              FORMATTED INPUT ?
;              ISSUE SPECIAL SYSCALL TO START UP LINEFLAGS ACQUISITION TASK ?
;              IF TRACE THEN...
;              Lineflags get turned off over a Chain; perhaps shouldn't ?
;              NUM$,NUMF$, CAT should use Stack instead of fixed buffer;
;                                      this would allow truly recursive use.
;              Input I/O error while in Break on Line causes an error trap.
;                                      This is only an annoyance.
;
VERSION  EQU   $14                     ; VERSION 1, REVISION 4
         PAGE    
;        MACHINE STACK USAGE:
;
;        !-----------------------!
;        !                       !  <-------STACKFRAMEBASE
;        !  GOSUB RETURN ADDR    !
;        !                       !
;        !-----------------------!
;        !           .           !
;        !           .           !
;        !           .           !
;        !-----------------------!
;        !                       !
;        !  GOSUB RETURN ADDR    !
;        !                       !
;        !-----------------------!
;        !                       !  <------ ERRORRECOVERYSTACK
;        !         VALUE         !
;        !                       !
;        !-----------------------!
;        !           .           !
;        !           .           !
;        !           .           !
;        !-----------------------!
;        !                       !
;        !         VALUE         !
;        !                       !
;        !-----------------------!
;        !                       !
;        !    SUBR/FUNCTION      !
;        !    CALL/RETURN BLOCK  !
;        !                       !
;        !-----------------------!
;        !                       !  <------ STACKFRAMEBASE'
;        !                       !
;
         PAGE    
;        *** MODIFY RESTORE FOR KEYED FILES!!! *****

         IFUND PZBASE                  ; PLACE WERE PAGE ZERO VARS GO
PZBASE   EQU   $28                     ; DEFAULT
         FIN    

         IFUND CODE                    ; PLACE WHERE RUNTIME PACKAGE CODE GOES
CODE     EQU   $100                    ; DEFAULT
         FIN    

;
;        ERROR CODES
;
ERR@STOP EQU   0                       ; STOP STATEMENT EXECUTED
ERR@ABORT EQU   1                      ; OPERATOR ABORT
;        EQU   2                       *** NOT USED ***
;        EQU   3                       *** NOT USED ***
;        EQU   4                       *** NOT USED ***
;        EQU   5                       *** NOT USED ***
ERR@GSBUND  EQU   6                    ; GOSUB STACK UNDERFLOW
ERR@CONVER  EQU   7                    ; INPUT CONVERSION ERROR
ERR@IBUFOVF EQU   8                    ; INPUT BUFFER OVERFLOW
ERR@ARYRNG  EQU   9                    ; ARRAY OR VECTOR SUBSCRIPT ERROR
ERR@BADRTP  EQU   10                   ; CHECKSUM OVER RTP FAILED
ERR@SSBRNG  EQU   11                   ; STRING SUBSCRIPT ERROR
ERR@SLNRNG  EQU   12                   ; SUBSTRING LENGTH TOO LONG
ERR@UDFLIN  EQU   13                   ; UNDEFINED LINE # (AN UNLUCKY #)
ERR@FLTOVF  EQU   14                   ; FLOATING OVERFLOW
ERR@FLTNXP  EQU   15                   ; UNEXPECTED FLOATING VALUE
ERR@CATOVF  EQU   16                   ; CATBUF OVERFLOW
ERR@TABBIG  EQU   17                   ; SPECIFIED TAB > 255
ERR@FORMAT  EQU   18                   ; FORMAT STRING ERROR
ERR@STORBE  EQU   19                   ; # IS TOO BIG ON STORE BYTE
ERR@LOGARG  EQU   21                   ; LOG OF ZERO OR NEG #
ERR@SQTERR  EQU   22                   ; SQRT 0F NEG NUMBER
ERR@POKADD  EQU   23                   ; PEEK OR POKE ADD < 0 OR > 65535
ERR@POKVAL  EQU   24                   ; POKE VALUE > 255
ERR@POKRTP  EQU   25                   ; YOU POKED AT THE RUNTIME PACKAGE, TURKEY
ERR@VERERR  EQU   26                   ; BASIC PROGRAM VERSION # DOESN'T AGREE WITH RTP
ERR@ARGCNTERR EQU 27                   ; WRONG # ARGUMENTS TO FUNCTION/SUBROUTINE
ERR@DATASPACECONFLICT EQU 28           ; DATA SPACE OVERLAPS SDOS
ERR@OVERLAPSRTP EQU 29                 ; PROGRAM (SUBROUTINE) OVERLAPS RTP
ERR@CHNLR   EQU   50                   ; ILLEGAL CHANEL #
ERR@FNAME   EQU   52                   ; FILE NAME IS TOO LONG
ERR@POSERR  EQU   60                   ; POSITIONING ERROR, # TOO BIG
         PAGE  *****  E R R O R   A N D   A D D R E S S   C O N S T A N T S  *****
;        DEFINE LENGTH OF STACK ENTRIES
;
RSESIZ   EQU   6                       ; RUN (VALUE) STACK ENTRY SIZE
;
;        STRING STRUCTURE ADDRESS DISPLACEMENT CONSTANTS
;
MAXLEN   EQU   0                       ; MAX STRING LENGTH
CURLEN   EQU   2                       ; CURRENT STRING LENGTH
STRING   EQU   4                       ; START OF STRING
BYTE     EQU   0                       ; LOAD OR STORE SINGLE BYTE
;
;        IN LINE DATA STRUCTURES & ADDRESS DISPLACEMENT CONSTANTS
;
OPCODE   EQU   -1                      ; DISPLACEMENT OF OPCODE FROM BPC WHEN POP ROUTINE GETS CONTROL
ILADDH   EQU   0                       ; IN LINE ADDRESS HIGH
ILADDL   EQU   1                       ; IN LINE ADDRESS LOW
ILADD    EQU   0                       ; IN LINE ADDRESS
;
ILSDC    EQU   0                       ; IN LINE STRING DESCRIPTOR COUNT
;
ILINTH   EQU   0                       ; IN LINE INTEGER HIGH
ILINTL   EQU   1                       ; IN LINE INTEGER LOW
ILINT    EQU   0                       ; IN LINE INTEGER
;
;        DATA STRUCTURES & ADDRESS DISPLACEMENT CONSTANTS FOR VARIABLES
;
VFLT1    EQU   0                       ; FLOATING VARIABLE FIRST BYTE
VFLT2    EQU   1                       ; 2ND BYTE
VFLT3    EQU   2                       ; 3RD BYTE
VFLT4    EQU   3                       ; 4TH BYTE
VFLT5    EQU   4                       ; 5TH BYTE
VFLT6    EQU   5                       ; 6TH BYTE
;
VINT1    EQU   4                       ; INTEGER VARIABLE FIRST BYTE
VINT2    EQU   5                       ; 2ND BYTE
;
VTYPE    EQU   0                       ; TYPE BYTE, 0 IF INT, ELSE FLOATING
         PAGE    
;        DATA STRUCTURE & ADDRESS DISPLACEMENT CONSTANTS FOR
;        RUNTIME (OR VALUE) STACK
;
R1ADDH   EQU   4                       ; TOS ADDRESS HIGH
R1ADDL   EQU   5                       ; TOS ADDRESS LOW
R1ADD    EQU   4                       ; TOS ADDRESS
;
R2ADDH   EQU   10                      ; TOS-1 ADDRESS HIGH
R2ADDL   EQU   11                      ; TOS-1 ADDRESS LOW
R2ADD    EQU   10                      ; TOS-1 ADDRESS
;
R3ADD    EQU   16
R3ADDH   EQU   16
R3ADDL   EQU   17
;
R1FLT1   EQU   0                       ; TOS FLOATING VALUE FIRST BYTE
R1FLT2   EQU   1                       ; 2ND BYTE
R1FLT3   EQU   2                       ; 3RD BYTE
R1FLT4   EQU   3                       ; 4TH BYTE
R1FLT5   EQU   4                       ; 5TH BYTE
R1FLT6   EQU   5                       ; 6TH BYTE
;
R2FLT1   EQU   6                       ; TOS-1 FLOATING VALUE FIRST BYTE
R2FLT2   EQU   7                       ; 2ND BYTE
R2FLT3   EQU   8                       ; 3RD BYTE
R2FLT4   EQU   9                       ; 4TH BYTE
R2FLT5   EQU   10                      ; 5TH BYTE
R2FLT6   EQU   11                      ; 6TH BYTE
;
R3FLT1   EQU   12
R3FLT2   EQU   13
R3FLT3   EQU   14
R3FLT4   EQU   15
R3FLT5   EQU   16
R3FLT6   EQU   17
;
R1INT1   EQU   4                       ; TOS INTEGER VALUE MSBYTE
R1INT2   EQU   5                       ; TOS INTEGER 2ND BYTE
;
R2INT1   EQU   10                      ; TOS-1 INTEGER MSBYTE
R2INT2   EQU   11                      ; TOS-1 INTEGER 2ND BYTE
;
R3INT1   EQU   R2INT1+RSESIZ           ; TOS-2 INTEGER UPPER HALF
R3INT2   EQU   R3INT1+1                ; TOS-2 INTEGER LOWER HALF
;
R1SDA    EQU   2                       ; TOS STRING DESCRIPTOR ADDRESS
R1SDAH   EQU   2                       ; TOS STRING DESCRIPTOR ADDRESS HIGH
R1SDAL   EQU   3                       ; TOS STRING DESCRIPTOR ADDRESS LOW
R1SDC1   EQU   4                       ; TOS STRING DESCRIPTOR COUNT MSBYTE
R1SDC2   EQU   5                       ; TOS STRING DESCRIPTOR COUNT LSBYTE
R1SDC    EQU   R1SDC1
;
R2SDA    EQU   8                       ; TOS-1 STRING DESCRIPTOR ADDRESS
R2SDAH   EQU   8                       ; TOS-1 STRING DESCRIPTOR ADDRESS HIGH
R2SDAL   EQU   9                       ; TOS-1 STRING DESCRIPTOR ADDRESS LOW
R2SDC1   EQU   10                      ; TOS-1 STRING DESCRIPTOR COUNT MSBYTE
R2SDC2   EQU   11                      ; TOS-1 STRING DESCRIPTOR COUNT LSBYTE
R2SDC    EQU   R2SDC1
;
R3SDA    EQU   14
R3SDAH   EQU   14
R3SDAL   EQU   15
R3SDC1   EQU   16
R3SDC2   EQU   17
R3SDC    EQU   R3SDC1
;
R1TYPE   EQU   0                       ; TYPE BYTE FOR TOS
R2TYPE   EQU   6                       ; TYPE BYTE FOR TOS-1
R3TYPE   EQU   12                      ; TYPE BYTE FOR TOS-2
         PAGE    
;        FOR STACK DATA STRUCTURES & ADDRESS DISPLACEMENT CONSTANTS
;
FSTYPE   EQU   0                       ; FLOATING STEP VALUE IN FOR STACK 1ST BYTE
FSTEP2   EQU   1                       ; 2ND BYTE
FSTEP3   EQU   2                       ; 3RD BYTE
FSTEP4   EQU   3                       ; 4TH BYTE
FSTEP5   EQU   4                       ; 5TH BYTE
FSTEP6   EQU   5                       ; 6TH BYTE
;
FISTEP1  EQU   4
FISTEP2  EQU   5
;
FLTYPE   EQU   6                       ; FLOATING LIMIT VALUE IN FOR STACK 1ST BYTE
FLIM2    EQU   7                       ; 2ND BYTE
FLIM3    EQU   8                       ; 3RD BYTE
FLIM4    EQU   9                       ; 4TH BYTE
FLIM5    EQU   10                      ; 5TH BYTE
FLIM6    EQU   11                      ; 6TH BYTE
;
FILIM1   EQU   10
FILIM2   EQU   11
         PAGE    
;        LINE BYTE DEFINITIONS
;
GOBIT    EQU   $8                      ; GO FROM BREAKPOINT/SINGLE STEP
SSTEPBIT EQU   $10                     ; SINGLE STEP REQUEST
BREAKBIT EQU   $20                     ; REQUEST LINE NUMBER BREAKPOINT
TRACEBIT EQU   $40                     ; REQUEST LINE NUMBER TRACE
ABORTBIT EQU   $80                     ; REQUEST PROGRAM ABORT
;
;        ASCII CODES
;
BELL     EQU   7
CR       EQU   $D
BLANK    EQU   $20
;
;        POPCODE HEADER DISPLACEMENTS
;
         ORG   0
RTP@VERSIONNUMBER    DS  1             ; CONTAINS RTP VERSION NUMBER
RTP@FREFLABELCHAIN   DS  2             ; POINTER TO FORWARD REFERENCE LABEL CHAIN
RTP@CATSIZEREQD      DS  2             ; AMOUNT OF CONCATENATION BUFFER SPACE NEEDED
RTP@LASTPARAMADDR EQU RTP@CATSIZEREQD  ; POINTER TO LAST PARAMETER IF FUN/SUBR ENTRY
RTP@BASEOFSCALARVARS DS  2             ; POINTER TO...
RTP@TOPOFDATASPACE   DS  2             ; POINTER TO 1ST BYTE PAST DATA SPACE
RTP@POPCODESTART     DS  0             ; FIRST BASIC POPCODE
RTP@ARGCOUNT         DS  1             ; ARG COUNT FOR FUNCTIONS/SUBROUTINES
RTP@FUNSUBPOPCODE    DS  0             ; FIRST BASIC POPCODE FOR FUNCTIONS/SUBROUTINES

         IFUND RTPTOTALCKSUM
RTPTOTALCKSUM EQU 0                    ;
         FIN    
         PAGE  *****  P R O G R A M   V A R I A B L E S  *****
;
         ORG   $20                     ; TO AVOID 6801 PAGE ZERO REGISTERS *!?>.
;        SCRATCH VARIABLES -- ANY ROUTINE MAY USE
         IFUND TEMPA
TEMPA    DS    1
TEMPB    DS    1
TEMPX    EQU   TEMPA
         FIN    

         ORG   PZBASE

;***
FPTRAP   DS    2                       ; POINTER TO FLOATING POINT ERROR TRAP ROUTINE
;***

;        CONTEXT INFORMATION FOR BASIC SUBROUTINE/FUNCTION INCARNATION
;        NOTE: THESE VARIABLES MUST BE IN THE SPECIFIED ORDER!
;        (SEE SUBFUNENTRY,XOPRETURN,XOPERRST)
;
CONTEXTSTART EQU $
ERCODE   DS    2                       ; HOLDS THE ERROR CODE
LINEADDR DS    2                       ; POINTER TO LAST EXECUTED "OPLINE"(/OPLABEL) OPCODE
BPC      DS    2                       ; SIMULATED "BASIC" PROGRAM COUNTER
VARTABLE DS    2                       ; POINTER TO BASE OF SCALAR VARIABLES
ERTRAP   DS    2                       ; HOLDS POINTER TO USER'S ERROR RECOVERY CODE
ERADDR   DS    2                       ; POINTER TO LINE # OPCODE OF LAST LINE IN WHICH ERROR OCCURRED
STACKFRAMEBASE DS  2                   ; POINTER TO BASE OF THIS INCARNATION'S STACK SPACE
ERRORRECOVERYSTACK DS  2               ; POINTER TO TOP OF GOSUB BLOCKS FOR THIS INCARNATION
CHANEL   DS    1                       ; I/O CHANNEL FOR STATEMENT BEING EXECUTED
USING    DS    2                       ; POINTS TO REST OF "USING" STRING
USINGMAX DS    2                       ; POINTS TO END OF "USING" STRING
ILERR    DS    2                       ; RECOVERY ADDRESS FOR "XOPINLINE" OPCODE
CONTEXTEND EQU $

SUBROUTINENESTING DS 1                 ; = NESTING OF SUBROUTINES/FUNCTIONS

ORIGINALSINADDR DS 2                   ; HOLDS ADDRESS OF LINE WHERE ORIGINAL SIN OCCURRED
         PAGE    

BREAKLINE DS   6                       ; HOLDS THE BREAKPOINT LINE NUMBER
LINEFLAGS DS   1                       ; HOLDS THE LINE FLAGS
TBYTE    DS    1                       ; TEMP BYTE
FLAG     DS    1                       ; TRUE <> 0 FALSE = 0
;
;        THE FOLLOWING VARS ARE USED BY THE SYSCALL ROUTINE
;        THEY ARE STRATEGICALLY LOCATED SUCH THAT THEY OVERLAP
;        SOME TEMPS WHICH AREN'T USED BY THE SYSCALL FUNCTION
;        IF YOU FOOL AROUND HERE, YOU BETTER BE CAREFUL...
;
SYSCALLSTRHEADPTR DS  2                ; POINTER TO STRING DESCRIPTOR
SYSCALLBLOCKPTR   DS  2
SYSCALLBLOCK      EQU *
SCBLK             DS  2                ; SYSCALL PARAMETER LIST
SYSCALLPARAMS     DS  2                ; PARAMETERS
SYSCALLWRBUF      DS  2                ; WRITE BUFFER ADDRESS
SYSCALLWRLEN      DS  2                ; WRITE BUFFER LENGTH
SYSCALLRPLEN      DS  2                ; READ BUFFER REPLY LENGTH
SYSCALLRDBUF      DS  2                ; READ BUFFER ADDRESS
SYSCALLRDLEN      DS  2                ; READ BUFFER SIZE
;
;        THESE ARE THE OVERLAPPED VARS
;
         ORG   *-$E                    ; BECAUSE THESE VARS ARE NOT USED BY SYSCALL
TWORD    DS    2                       ; TEMPORARY WORD
LOOPCT   DS    1                       ; LOOP COUNTER
S1LEN    DS    2                       ; HOLDS LEN OF STR 1 FOR COMPARE
S2LEN    DS    2                       ; HOLDS LEN OF STR 2 FOR COMPARE
S1ADD    DS    2                       ; HOLDS ADD OF STR 1 FOR COMPARE
S1ADDT   DS    2                       ; HOLDS ADD OF STR 1 FOR OPFIND
S2ADD    DS    2                       ; HOLDS ADD OF STR 2 FOR COMPARE
S2ADDT   DS    2                       ; HOLDS ADD OF STR 2 FOR OPFIND
;
;        THIS IS THE END OF THE OVERLAPPED VARIABLES
         PAGE    
INPTR    DS    2                       ; POINTS TO NEXT CHAR TO SCAN
CATPTR   DS    2                       ; POINTS PAST CURRENT CATBUF CONTENTS
RTPRET   DS    2                       ; HOLDS A RETURN ADDRESS
ACMRET   DS    2                       ; RETURN ADDRESS FOR COMPARE ROUTINE
BPCSAV   DS    2                       ; HOLE FOR SAVING BPC WHILE EXECUTING INTERNAL BASIC POPS
SIGNZ    DS    6                       ; TEMPORARIES FOR TRANSCENDENTAL ROUTINES
TTEMP1   DS    6
TTEMP2   DS    6
OPPOLYARG DS   6                       ; HOLDS ARGUMENT FOR POLYNOMIAL EVALUATION
SEED     DS    6                       ; FOR RAND FUNCTION
;
;        FORMATTING VARIABLES
;
LDOLLAR  DS    1                       ; HOLDS DOLLAR COUNT FOR FORMAT SPEC
LMINUS   DS    1                       ; HOLDS LEFT MINUS COUNT FOR FORMAT SPEC
LSHARP   DS    1                       ; HOLDS LEFT SHARP COUNT FOR FORMAT SPEC
RSHARP   DS    1                       ; HOLDS RIGHT SHARP COUNT FOR FORMAT SPEC
RMINUS   DS    1                       ; HOLDS RIGHT MINUS COUNT FOR FORMAT SPEC
RCARET   DS    1                       ; HOLDS RIGHT CARET COUNT FOR FORMAT SPEC
FLENGTH  DS    1                       ; HOLDS LENGTH OF FORMAT SPEC
SIG      DS    1                       ; HOLDS # OF SIGNIFICANT DIGITS
LEAD     DS    1                       ; HOLDS # OF LEADING DIGITS IF E=0
ENDFORMAT DS   2                       ; POINTS TO BYTE PAST END OF POSSIBLE NUMBER FORMAT STRING

OUTBUFSIZE EQU 18                      ; SIZE OF OUTPUT/TEMP BUFFER
OUTBUF   DS    OUTBUFSIZE              ; OUTPUT FORMATTING BUFFER
TIMESTR  EQU   OUTBUF                  ; NOTE: TIMESTR IS SHORTER THAT OUTBUFSIZE
DATESTR  EQU   TIMESTR+9
SCRATCH  EQU   OUTBUF
         PAGE    
;        MULTIPLY & DIVIDE VARS
;
DIGMAX   EQU   10                      ; MAX NUMBER OF DIGITS ALLOWED
ML       DS    1                       ; MULTIPLIER DIGIT FOR FMUL, FDIV; TEMP FOR OTHERS
;
MR1      DS    1                       ; 6 BYTES FOR FLOATING POINT ACCUMULATORS
MR2      DS    1
MR3      DS    1
MR4      DS    1
MR5      DS    1
MR6      DS    1
;
MSIGN    DS    1                       ; HOLDS SIGN OF RESULT
MEXP     DS    1                       ; HOLDS EXP, MUST PRECEED FAC
FAC1     DS    1                       ; FLOATING ACCUMULATOR WITH EXTENSION
FAC2     DS    1                       ; FAC, FACEXT MAY NOT CROSS PAGE BOUNDARY
FAC3     DS    1
FAC4     DS    1
FAC5     DS    1
FAC6     DS    1
FACEXT1  DS    1
FACEXT2  DS    1
FACEXT3  DS    1
FACEXT4  DS    1
FACEXT5  DS    1
;
MS1      DS    1                       ; 6 BYTES FOR FLOATING POINT ACCUMULATORS
MS2      DS    1                       ; MS1 MUST FOLLOW FACEXT5
MS3      DS    1
MS4      DS    1
MS5      DS    1
MS6      DS    1
;
MINUSDIVISORDIGIT DS  1                ; CONTAINS -(LEADING DIGIT OF DIVISOR) FOR FDIV (GUESSD)
CTNB     DS    1                       ; HOLDS CARRY (0..199) TO NEXT BYTE
FACX     DS    2                       ; HOLDS POINTER TO FLOATING ACC
MRX      DS    2                       ; HOLDS POINTER TO MR
FINTRT   DS    2                       ; RETURN ADDRESS FOR INT FUNCTION
FCVIRT   DS    2                       ; RETURN ADDRESS FOR INPUT CONVERSION
FSTORET  DS    2                       ; RETURN ADDRESS FOR FSTORE
RETADD   DS    2                       ; RETURN ADDRESS
BUFERP   DS    2                       ; CONVERSION BUFFER POINTER
DPFLAG   DS    1                       ; HOLDS DECIMAL POINT COUNT FOR FCONVI
DPCOUNT  DS    1                       ; HOLDS DECIMAL PLACE COUNT FOR FCONVI
DIGCNT   DS    1                       ; HOLDS SIG DIGIT COUNT FOR FCONVI
DIGFLG   DS    1                       ; DIGIT FLAG FOR FCONVI
EXPOVF   DS    1                       ; HOLDS EXPONENT OVERFLOW FLAG
LOOPX    DS    2                       ; 2 BYTE LOOP COUNTER
MYCHAN   DS    1
EOFTABLE DS    4                       ; TABLE OF 32 BITS, ONE FOR EACH POSSIBLE I/O CHANNEL
CHAR     DS    1
EOFHITFLAG     DS  1                   ; LAST ERROR HAD EOF
STORETARGET    DS  2                   ; POINTER TO SCALAR/TARGET VARIABLE
COPYRIGHTSUM   DS  1                   ; = SUM OF COPYRIGHT MESSAGE BYTES
CONVERTLIMIT   DS  2                   ; LIMIT OF CONVERSION
BEGINFORMAT    DS  2                   ; POINTER TO 1ST BYTE OF FORMAT WITHIN "USING" STRING
         PAGE  INITIALIZATION DATA
;
;
CATBUF   DS    2                       ; START OF THE CAT BUFFER
CATSIZ   DS    2                       ; SIZE OF CAT BUFFER
CATSTRINGSIZE  DS                      ; 2 SIZE OF CONCATENATED STRING

         IF    *>/$F0                  ; CHECK FOR SDOS PAGE ZERO OVERFLOW
         ?PAGE ZERO OVERFLOW?
         FIN    
         PAGE  *** INIT AND ERROR ENTRY POINTS ***
         ORG   CODE
         JMP   INIT                    ; TABLE FORMAT IS SPECIFIED BY BASIC VERSION 1.2 MANUAL
         JMP   IOERROR                 ; BUT NOT MUCH OF IT IS LEFT!
         JMP   SUBFUNENTRY             ; SUBROUTINE OR FUNCTION ENTRY POINT
;
;        FLOATING POINT ROUTINES -- ENTRY POINTS
;              NOTE: FPTRAP IS IN LOCATION "PZBASE"
;
FLOADX   JMP   FLOAD
FSTOREX  JMP   FSTORE
FCMPX    JMP   FCMP
FNEGX    JMP   FNEG
FADDX    JMP   FADD
FSUBX    JMP   FSUB
FMULX    JMP   FMUL
FDIVX    JMP   FDIV
FCONVOX  JMP   FCONVO
FCONVIX  JMP   FCONVI
FINTX    JMP   FINT
FIXX     JMP   FIX
FIX16X   JMP   FIX16
FLOATX   JMP   FLOAT

DOLLARSIGN db  '$                      ; MONEY CHARACTER ('# FOR BRITAIN)
         PAGE                          ; *****  O P   C O D E   A D D R E S S   T A B L E  *****
JMPTBL   SET   *                       ; ADDRESS OF POINTER TO "OPLSMI 0" OPCODE ROUTINE
OPLSMI   EQU   (*-JMPTBL)/2
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (0)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (1)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (2)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (3)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (4)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (5)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (6)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (7)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (8)
         DW    XOPLSMI                 ; LOAD LOAD SMALL INTEGER (9)
OPLOAD   EQU   (*-JMPTBL)/2
         DW    XOPLOAD                 ; LOAD LOAD VALUE AT IN LINE ADDRESS
OPLV     EQU   (*-JMPTBL)/2
         DW    XOPLV                   ; LOAD LOAD VALUE USING ADDRESS ON TOS
OPSESCALAR EQU (*-JMPTBL)/2
         DW    XOPSESCALAR             ; STORE: STORE EXTENDED SCALAR
OPLINT   EQU   (*-JMPTBL)/2
         DW    XOPLINT                 ; LOAD LOAD 2 BYTE INTEGER
OPLESCALAR EQU (*-JMPTBL)/2
         DW    XOPLESCALAR             ; LOAD LOAD EXTENDED SCALAR
OPLFI    EQU   (*-JMPTBL)/2
         DW    XOPLFI                  ; LOAD LOAD FLOATING INLINE CONSTANT
OPLDB    EQU   (*-JMPTBL)/2
         DW    XOPLDB                  ; LOAD LOAD BYTE USING SD ON TOS
OPDUP    EQU   (*-JMPTBL)/2
         DW    XOPDUP                  ; LOAD DUPLICATE TOS
OPLSD    EQU   (*-JMPTBL)/2
         DW    XOPLSD                  ; STRINGS PUSH STRING DESCRIPTOR
OPLSC    EQU   (*-JMPTBL)/2
         DW    XOPLSC                  ; STRINGS PUSH STRING CONSTANT
OPLEN    EQU   (*-JMPTBL)/2
         DW    XOPLEN                  ; STRINGS LOAD LENGTH OF INLINE STRING ADDRESS
OPSS1    EQU   (*-JMPTBL)/2
         DW    XOPSS1                  ; STRSUB DO SINGLE STRING SUBSCRIPT
OPSS2    EQU   (*-JMPTBL)/2
         DW    XOPSS2                  ; STRSUB DO DOUBLE SUBSCRIPT ON STRING
OPVSA    EQU   (*-JMPTBL)/2
         DW    XOPVSA                  ; ARYSUB DO SUBSCRIPT ON VECTOR AND PUSH ADDRESS
OPVSV    EQU   (*-JMPTBL)/2
         DW    XOPVSV                  ; ARYSUB DO SUBSCRIPT ON VECTOR AND PUSH VALUE
OPVSS    EQU   (*-JMPTBL)/2
         DW    XOPVSS                  ; ARYSUB DO SUBSCRIPT ON VECTOR AND STORE TOS
OPVPA    EQU   (*-JMPTBL)/2
         DW    XOPVPA                  ; ARYSUB DO SUBSCRIPT ON VECTOR PARAMETER AND PUSH ADDRESS
OPASA    EQU   (*-JMPTBL)/2
         DW    XOPASA                  ; ARYSUB DO SUBSCRIPT ON ARRAY AND PUSH ADDRESS
OPASV    EQU   (*-JMPTBL)/2
         DW    XOPASV                  ; ARYSUB DO SUBSCRIPT ON ARRAY AND PUSH VALUE
OPASS    EQU   (*-JMPTBL)/2
         DW    XOPASS                  ; ARYSUB DO SUBSCRIPT ON ARRAY AND STORE TOS
OPAPA    EQU   (*-JMPTBL)/2
         DW    XOPAPA                  ; ARYSUB DO SUBSCRIPT ON ARRAY PARAMETER AND PUSH ADDRESS
OPST     EQU   (*-JMPTBL)/2
         DW    XOPST                   ; STORE STORE TOS USING TOS-1
OPSTS    EQU   (*-JMPTBL)/2
         DW    XOPSTS                  ; STORE STORE STRING ON TOS TO TOS-1
OPSTB    EQU   (*-JMPTBL)/2
         DW    XOPSTB                  ; STORE STORE VALUE ON TOS INTO STRING TOS-1
OPADD    EQU   (*-JMPTBL)/2
         DW    XOPADD                  ; ARITH ADD TOS TO TOS-1
OPSUB    EQU   (*-JMPTBL)/2
         DW    XOPSUB                  ; ARITH SUB TOS FROM TOS-1
OPNEG    EQU   (*-JMPTBL)/2
         DW    XOPNEG                  ; ARITH NEGATE TOS
OPMUL    EQU   (*-JMPTBL)/2
         DW    XOPMUL                  ; ARITH MULTIPLY TOS BY TOS-1
OPDIV    EQU   (*-JMPTBL)/2
         DW    XOPDIV                  ; ARITH DIVIDE TOS INTO TOS-1
OPAND    EQU   (*-JMPTBL)/2
         DW    XOPAND                  ; ARITH AND TOS TO TOS-1
OPIOR    EQU   (*-JMPTBL)/2
         DW    XOPIOR                  ; ARITH INCLUSIVE OR TOS TO TOS-1
OPSHF    EQU   (*-JMPTBL)/2
         DW    XOPSHF                  ; ARITH SHIFT TOS-1 BY TOS
OPCOM    EQU   (*-JMPTBL)/2
         DW    XOPCOM                  ; ARITH COMPLEMENT TOS
OPEQ     EQU   (*-JMPTBL)/2
         DW    XOPEQ                   ; COMPARE COMPARE TOS TO TOS-1 FOR =, SET FLAG
OPNE     EQU   (*-JMPTBL)/2
         DW    XOPNE                   ; COMPARE TOS : TOS-1 FOR <>
OPLT     EQU   (*-JMPTBL)/2
         DW    XOPLT                   ; COMPARE TOS : TOS-1 FOR <
OPLE     EQU   (*-JMPTBL)/2
         DW    XOPLE                   ; COMPARE TOS : TOS-1 FOR <=
OPGE     EQU   (*-JMPTBL)/2
         DW    XOPGE                   ; COMPARE TOS : TOS-1 FOR >=
OPGT     EQU   (*-JMPTBL)/2
         DW    XOPGT                   ; COMPARE TOS : TOS-1 FOR >
OPBF     EQU   (*-JMPTBL)/2
         DW    XOPBF                   ; CONTROL BRANCH IF FLAG IS FALSE
OPBT     EQU   (*-JMPTBL)/2
         DW    XOPBT                   ; CONTROL BRANCH IF FLAG IS TRUE
OPINV    EQU   (*-JMPTBL)/2
         DW    XOPINV                  ; CONTROL COMPLEMENT THE FLAG
OPJMP    EQU   (*-JMPTBL)/2
         DW    XOPJMP                  ; CONTROL UNCONDITIONAL BRANCH
OPGSB    EQU   (*-JMPTBL)/2
         DW    XOPGSB                  ; CONTROL GO TO A SUBROUTINE
OPRET    EQU   (*-JMPTBL)/2
         DW    XOPRET                  ; CONTROL RETURN FROM A SUBROUTINE
OPSTP    EQU   (*-JMPTBL)/2
         DW    XOPSTP                  ; CONTROL I QUIT...
OPLINE   EQU   (*-JMPTBL)/2
         DW    XOPLINE                 ; CONTROL SET LINE NUMBER
OPCALL   EQU   (*-JMPTBL)/2
         DW    XOPCALL                 ; CONTROL CALL AN ASSEMBLY LANGUAGE SUBROUTINE
OPPV     EQU   (*-JMPTBL)/2
         DW    XOPPV                   ; PRINT PRINT VALUE ON TOS
OPPCR    EQU   (*-JMPTBL)/2
         DW    XOPPCR                  ; PRINT PRINT A CR
OPPS     EQU   (*-JMPTBL)/2
         DW    XOPPS                   ; PRINT PRINT STRING POINTED TO BY TOS SD
OPPSP    EQU   (*-JMPTBL)/2
         DW    XOPPSP                  ; PRINT PRINT A SPACE
OPINS    EQU   (*-JMPTBL)/2
         DW    XOPINS                  ; STRINGS INPUT A STRING
OPCHNL   EQU   (*-JMPTBL)/2
         DW    XOPCHNL                 ; IO SET CHANNEL FROM TOS
         PAGE    
OPCIN    EQU   (*-JMPTBL)/2
         DW    XOPCIN                  ; STRINGS INIT CATBUF
OPCAT    EQU   (*-JMPTBL)/2
         DW    XOPCAT                  ; STRINGS CONCATENATE A STRING TO CATBUF
OPCND    EQU   (*-JMPTBL)/2
         DW    XOPCND                  ; STRINGS PUSH CATBUF SD
OPRIGHT  EQU   (*-JMPTBL)/2
         DW    XOPRIGHT                ; STRSUB TAKE RIGHT PART OF STRING
OPRESTR  EQU   (*-JMPTBL)/2
         DW    XOPRESTR                ; IO POSITION A FILE TO SPECIFIED RECORD
OPWV     EQU   (*-JMPTBL)/2
         DW    XOPWV                   ; IO WRITE A NUMBER TO A FILE
OPWS     EQU   (*-JMPTBL)/2
         DW    XOPWS                   ; IO WRITE A STRING TO A FILE
OPRV     EQU   (*-JMPTBL)/2
         DW    XOPRV                   ; IO READ A NUMBER FROM A FILE
OPRS     EQU   (*-JMPTBL)/2
         DW    XOPRS                   ; IO READ A STRING FROM A FILE
OPFOR    EQU   (*-JMPTBL)/2
         DW    XOPFOR                  ; FORNEXT INITIALIZE A FOR LOOP
OPNEXT   EQU   (*-JMPTBL)/2
         DW    XOPNEXT                 ; FORNEXT DO NEXT CYCLE OF A FOR LOOP
OPTABCOL EQU   (*-JMPTBL)/2
         DW    XOPTABCOL               ; IO DO TAB TO NEXT PRINT COLUMN
OPINP    EQU   (*-JMPTBL)/2
         DW    XOPINP                  ; INPUT INPUT A NUMBER
OPEOF    EQU   (*-JMPTBL)/2
         DW    XOPEOF                  ; IO CHECK FOR END OF FILE
OPINL    EQU   (*-JMPTBL)/2
         DW    XOPINL                  ; INPUT INPUT A LINE FOR STRING OR NUMERIC INPUT
OPTAB    EQU   (*-JMPTBL)/2
         DW    XOPTAB                  ; IO TAB TO SPECIFIED COLUMN
OPSEQ    EQU   (*-JMPTBL)/2
         DW    XOPSEQ                  ; COMPARE STRING COMPARE FOR =
OPSNE    EQU   (*-JMPTBL)/2
         DW    XOPSNE                  ; COMPARE STRING COMPARE FOR <>
OPSLT    EQU   (*-JMPTBL)/2
         DW    XOPSLT                  ; COMPARE STRING COMPARE FOR <
OPSLE    EQU   (*-JMPTBL)/2
         DW    XOPSLE                  ; COMPARE STRING COMPARE FOR <=
OPSGT    EQU   (*-JMPTBL)/2
         DW    XOPSGT                  ; COMPARE STRING COMPARE FOR >
OPSGE    EQU   (*-JMPTBL)/2
         DW    XOPSGE                  ; COMPARE STRING COMPARE FOR >=
OPON     EQU   (*-JMPTBL)/2
         DW    XOPON                   ; CONTROL ON - GOTO OPERATOR
OPXOR    EQU   (*-JMPTBL)/2
         DW    XOPXOR                  ; ARITH XOR TOS TO TOS-1
OPOKE    EQU   (*-JMPTBL)/2
         DW    XOPOKE                  ; PEEKPOKE TOS HAS VALUE TOS-1 HAS ADDRESS
OPEEK    EQU   (*-JMPTBL)/2
         DW    XOPEEK                  ; PEEKPOKE TOS HAS ADDRESS, REPLACE BY VALUE
OPUSE    EQU   (*-JMPTBL)/2
         DW    XOPUSE                  ; PRINT PRINT USING
OPRMPT   EQU   (*-JMPTBL)/2
         DW    XOPRMPT                 ; PRINT PUT OUT THE PROMPT
OPINT    EQU   (*-JMPTBL)/2
         DW    XOPINT                  ; FCN COMPUTE INTEGER PORTION OF TOS 
OPERR    EQU   (*-JMPTBL)/2
         DW    XOPERR                  ; FCN RETURN ERROR # ON TOS 
OPOPN    EQU   (*-JMPTBL)/2
         DW    XOPOPN                  ; IO OPEN FILE SPECIFIED BY TOS SD
OPCLS    EQU   (*-JMPTBL)/2
         DW    XOPCLS                  ; IO CLOSE FILE
OPCREAT  EQU   (*-JMPTBL)/2
         DW    XOPCREAT                ; IO CREATE FILE SPECIFIED BY TOS SD
OPCHAIN  EQU   (*-JMPTBL)/2
         DW    XOPCHAIN                ; IO CHAIN TO ANOTHER PROGRAM
OPLFREFL EQU   (*-JMPTBL)/2
         DW    XOPLFREFL               ; LIKE OPSETLABEL BUT SKIP 5 BYTES
OPELN    EQU   (*-JMPTBL)/2
         DW    XOPELN                  ; FCN LOAD LAST ERROR LINE NUMBER ONTO TOS
OPPI     EQU   (*-JMPTBL)/2
         DW    XOPPI                   ; FCN LOAD "3.14159..." ONTO STACK
OPFIND   EQU   (*-JMPTBL)/2
         DW    XOPFIND                 ; STRINGS FIND OCCUR OF STR TOS IN TOS-1
OPUSL    EQU   (*-JMPTBL)/2
         DW    XOPUSL                  ; PRINT SET USING STRING TO FORMAT STRING
OPJUC    EQU   (*-JMPTBL)/2
         DW    XOPJUC                  ; PRINT JUMP AROUND USING STRING
OPINIT   EQU   (*-JMPTBL)/2
         DW    XOPINIT                 ; INIT INITIALIZE INLINE ADDRESS TO BYTE STRING
OPZCHN   EQU   (*-JMPTBL)/2
         DW    XOPZCHN                 ; IO ZERO THE CHANNEL #
OPONG    EQU   (*-JMPTBL)/2
         DW    XOPONG                  ; CONTROL DO "ON ... GOSUB"
OPDEL    EQU   (*-JMPTBL)/2
         DW    XOPDEL                  ; IO DELETE FILE NAMED TOS
OPREN    EQU   (*-JMPTBL)/2
         DW    XOPREN                  ; IO RENAME FILE NAMED TOS-1 TO TOS
OPSSL    EQU   (*-JMPTBL)/2
         DW    XOPSSL                  ; STRINGS SET STRING LENGTH OF SD AT TOS-1 TO TOS
OPSTORE  EQU   (*-JMPTBL)/2
         DW    XOPSTD                  ; STORE STORE TOS AT INLINE ADDRESS
OPSGN    EQU   (*-JMPTBL)/2
         DW    XOPSGN                  ; FCN RETURN SIGN OF TOS
OPASM    EQU   (*-JMPTBL)/2
         DW    XOPASM                  ; ASY ENTER ASSEMBLY CODE
OPLBOOL  EQU   (*-JMPTBL)/2
         DW    XOPLBOOL                ; LOAD: LOAD BOOLEAN VALUE OF FLAG
OPPRUS   EQU   (*-JMPTBL)/2
         DW    XOPPRUS                 ; IO PRINT REST OF USING STRING
OPSETLABEL EQU (*-JMPTBL)/2
         DW    XOPSETLABEL             ; SIMILAR TO OPLINE
OPMAXLEN EQU   (*-JMPTBL)/2
         DW    XOPMAXLEN               ; SIMILAR TO OPLEN
OPSYSCALL1ARG EQU (*-JMPTBL)/2
         DW    XOPSYSCALL1ARG          ; SYSCALL 1 ARGUMENT
OPSYSCALL2ARG EQU (*-JMPTBL)/2
         DW    XOPSYSCALL2ARG          ; SYSCALL 2 ARGUMENTS
OPSYSCALL3ARG EQU (*-JMPTBL)/2
         DW    XOPSYSCALL3ARG          ; SYSCALL 3 ARGUMENTS
OPSYSCALL4ARG EQU (*-JMPTBL)/2
         DW    XOPSYSCALL4ARG          ; SYSCALL 4 ARGUMENTS
OPCOPYRIGHT EQU (*-JMPTBL)/2
         DW    XOPCOPYRIGHT            ; STRING PUSH COPYRIGHT MESSAGE STRING DESCRIPTOR
OPEXTENDED EQU (*-JMPTBL)/2
         DW    XOPEXTENDED             ; 2 BYTE OPCODE: NEEDS FURTHER DECODING
OPSUBRET EQU   (*-JMPTBL)/2
         DW    XOPSUBRET               ; CONTROL: RETURN FROM PARAMETERIZED SUBROUTINE
OPFNCALL EQU   (*-JMPTBL)/2
         DW    XOPFNCALL               ; CONTROL CALL AN ASSEMBLY LANGUAGE FUNCTION
OPLBINT  EQU   (*-JMPTBL)/2
         DW    XOPLBINT                ; LOAD: LOAD CONSTANT IN RANGE 10-255 (1 BYTE)
OPEXITLOOP EQU (*-JMPTBL)/2
         DW    XOPEXITLOOP             ; CONTROL: PASS CONTROL TO STMT PAST "NEXT"
OPTRP    EQU   (*-JMPTBL)/2
         DW    XOPTRP                  ; CONTROL: ON ERROR GOTO ...
         IF    (*-JMPTBL)/2>>$80
         ?MAIN JUMP TABLE TOO LARGE?
         FIN                           ; FIX BY MOVING SOME MORE OPS TO THE EXTENDED TABLE
         PAGE  ***** E X T E N D E D   O P   J U M P   T A B L E   *****
EXTENDEDJMPTBL EQU *
OPATN    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPATN                  ; FCN COMPUTE ARCTANGENT OF TOS 
OPSIN    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPSIN                  ; FCN COMPUTE SINE OF TOS 
OPCOS    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPCOS                  ; FCN COMPUTE COSINE OF TOS 
OPLOG    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPLOG                  ; FCN COMPUTE NATURAL LOG OF TOS 
OPEXP    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPEXP                  ; FCN COMPUTE E RAISED TO TOS POWER 
OPSQR    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPSQR                  ; FCN COMPUTE SQUARE ROOT OF TOS 
OPRND    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPRND                  ; FCN COMPUTE RANDOM # USING TOS 
OPABS    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPABS                  ; FCN COMPUTE ABSOLUTE VALUE OF TOS 
OPDBG    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPDBG                  ; IO ENTER DEBUGGER
OPOWER   EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPOWER                 ; FCN TOS-1 IS EXPONENTIATED BY TOS
OPERRST  EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPERRST                ; ERROR ERROR STMT
OPSETSEED EQU  OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPSETSEED              ; ASSIGN SET RANDOM SEED
OPCOL    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPCOL                  ; FCN LOAD CURRENT COL COUNT ONTO TOS
OPGPOP   EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPGPOP                 ; CONTROL POP OR REAM THE GOSUB STACK BY TOS
OPDAT    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPDAT                  ; STRINGS RETURNS TOS SD FOR DATE
OPTIM    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPTIM                  ; STRINGS RETURNS TOS SD FOR TIME
OPNUM    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPNUM                  ; PRINT CONVERT TOS VALUE TO STRING
OPNUMF   EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPNUMF                 ; PRINT CONVERT TOS VALUE TO STRING USING FORMAT
OPVAL    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPVAL                  ; PRINT CONVERT TOS STRING TO VALUE
OPTAN    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPTAN                  ; FCN COMPUTE TANGENT OF TOS
OPPOLY   EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPPOLY                 ; FCN EVALUATE INLINE POLYNOMIAL
OPHEX    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPHEX                  ; STRINGS CONVERT TOS INTEGER TO STRING
OPGOELN  EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPGOELN                ; "GOTO ELN" OPCODE
OPUPPERC EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPUPPERC               ; CONVERT STRING TO UPPERCASE
OPLOWERC EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPLOWERC               ; CONVERT STRING TO LOWERCASE
OPEXIT   EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPEXIT
OPLENVECTOR EQU OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPLENVECTOR            ; SUBSCRIPTS: PUSH DIM'D LENGTH OF VECTOR
OPROWSARRAY EQU OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPROWSARRAY            ; SUBSCRIPTS: PUSH DIM'D NUMBER OF ROWS
OPCOLSARRAY EQU OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPCOLSARRAY            ; SUBSCRIPTS: PUSH DIM'D NUMBER OF COLUMNS
OPFUNRET EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPFUNRET               ; CONTROL: RETURN FROM A PARAMETERIZED FUNCTION
OPCHR    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPCHR                  ; STRING FN: RETURN SINGLE BYTE STRING
OPERRCAUSE EQU OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPERRCAUSE             ; CONTROL: CAUSE A SPECIFIED ERROR CODE
OPSSA    EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPSSA                  ; STRINGS: DO STRING ARRAY SUBSCRIPT
OPSAINIT EQU   OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
         DW    XOPSAINIT               ; STRINGS: INITIALIZE STRING ARRAY
         IF    (*-EXTENDEDJMPTBL)>/$80
         ?EXTENDED JUMP TABLE TOO LARGE ?
         ENDIF
         PAGE    
COPYRIGHT EQU $
         db    'BASIC Runtime Package Version 1.4k'
         db    $0D
         db    'Copyright (C) 1977 Software Dynamics'
COPYRIGHTEND EQU $
         PAGE  *****  I N T E R P E T E R   L O O P S  *****
         page    
         subttl 'Interpreter Loops'
XOPExtended
         lhld  bpc                     ; (16~) fetch 2nd byte of opcode
         mov   a,m                     ; (7~) assert: byte is <= 126
         add   a                       ; (4~) double to make word index
         lxi   h,ExtendedJmpTbl        ; (10~) locate word in jump table

         add   l                       ; (4~)
         mov   l,a                     ; (5~)
         jnc   $+4                     ; (10~) almost always take the branch
         inr   h                       ; (5~)

         mov   e,m                     ; (7~) fetch target address to HL
         inx   h                       ; (5~)
         mov   d,m                     ; (7~)
         xchg                          ; (4~)
         pchl                          ; (5~) and go there!

PL2PC3 ; pull 2 value stack entries, bump BPC by 3 and execute next opcode
         lxi   h,rsesiz*2              ; (10~)
         jmp   plhlpc3                 ; (10~)
PL1PC1 ; pull 1 value stack entry, bump;  BPC by one
         lxi   h,rsesiz*1              ; (10~)
plhlpc3  dad   sp                      ; (10~)
         sphl                          ; (5~)
NTRPT3X ; HL contains addr of opcode+1; bump past 3 byte opcode, execute next
         inx   h                       ; (5~)
         inx   h                       ; (5~)
         mov   a,m                     ; (7~) fetch opcode
         inx   h                       ; (5~) advance BPC past opcode
         shld  bpc                     ; (16~)
         lxi   h,JmpTbl                ; (10~) fetch jump table index
         add   a                       ; (4~) double to make word index
         jc    XOPLScalar              ; (10~) b/ Load or Store Scalar opcode
         add   l                       ; (4~) locate word in jump table
         mov   l,a                     ; (5~)
         jnc   NTRPT3X1                ; (10~)
         inr   h                       ; (5~)
NTRPT3X1 ; come here after handling carry to upper half
         mov   e,m                     ; (7~) fetch target address to HL
         inx   h                       ; (5~)
         mov   d,m                     ; (7~)
         xchg                          ; (4~)
         pchl                          ; (5~) and go there!

PL1PC2 ; pull 1 value stack entry, bump BPC by 2
         lxi   h,rsesiz*1              ; (10~)
         dad   sp                      ; (10~)
         sphl                          ; (5~)
NTRPT2 ; bump BPC by 2 to get past opcode, execute next opcode
         lhld  bpc                     ; (16~)
NTRPT2HL ; HL contains address of opcode plus 1, execute next opcode
         inx   h                       ; (5~)
         mov   a,m                     ; (7~) fetch opcode
         inx   h                       ; (5~) advance BPC past opcode
         shld  bpc                     ; (16~)
         lxi   h,JmpTbl                ; (10~) fetch jump table index
         add   a                       ; (4~) double to make word index
         jc    XOPLScalar              ; (10~) b/ Load or Store Scalar opcode
NTROpcode ; interpret opcode in (A), HL points to JmpTbl
         add   l                       ; (4~) locate word in jump table
         mov   l,a                     ; (5~)
         jnc   NTRPT2HL1               ; (10~)
         inr   h                       ; (5~)
NTRPT2HL1 ; come here after handling carry to upper half
         mov   e,m                     ; (7~) fetch target address to HL
         inx   h                       ; (5~)
         mov   d,m                     ; (7~)
         xchg                          ; (4~)
         pchl                          ; (5~) and go there!

PL2PC1 ; pull 2 value stack entries, bump BPC by one
         lxi   h,rsesiz*2              ; (10~)
         jmp   pl1pc1a
PL1PC1 ; pull 1 value stack entry, bump BPC by one
         lxi   h,rsesiz*1              ; (10~)
pl1pc1a  dad   sp                      ; (10~)
         sphl                          ; (5~)
NTRPT1 ; finished with 1 byte opcode, do next opcode
         lhld  bpc                     ; (16~) fetch pointer to next opcode
NTRPHL ; finished with 1 byte opcode, HL points to next
         mov   a,m                     ; (7~) fetch opcode
         inx   h                       ; (5~) advance BPC past opcode
         shld  bpc                     ; (16~)
         lxi   h,JmpTbl                ; (10~) fetch jump table index
         add   a                       ; (4~) double to make word index
         jc    NTROpcode               ; (10~) b/ opcode, just go do it
XOPLSCALAR ; handle LOAD/STORE scalar opcode
;        Opcode byte in (A) holds doubled scalar number (range 0..63)
         mov   b,a                     ; Carry = ?, A=/<OP>NNNNNN0/
         add   a                       ; C=OP, A=/NNNNNN00/, B=/<OP>NNNNNN0/
         jc    XOPSSCALAR              ; b/ Store Scalar opcode, go do it
         add   b                       ; since OP=0, (A) is now 6*ScalarNumber
         ; note: carry has 7th bit of significance here
         lhld  vartable                ; form address of scalar

;        jzc   $+4                     ; (10~)
;        inr   h                       ; (5~)
;        dada                          ; (22~) add A to HL

         mov   c,a                     ; (5~) form 16 bit Scalar offset
; ??? if load scalar were restricted to 256/6 scalars, we could save
; some (miniscule?) time here; load extended scalar could handle
; the rest of the scalars with very little actual loss is capability
         mvi   a,0                     ; (7~) mvi doesn't blitz carry
         aci   0                       ; (7~)
         mov   b,a                     ; (5~)
         dad   b                       ; (10~)

PushScalarAtHL ; HL points to scalar to push onto stack
         mov   a,m                     ; fetch VTYPE
         mov   c,a                     ; need this here, too...
         ana   a                       ; (4~) integer data ?
         jrz   xoplscalar2             ; (10~) b/ step this way, mr. integer
         inx   h                       ; (5~) float, copy to (BC),(DE),(HL)
         mov   b,m                     ; (7~)
         inx   h                       ; (5~)
         mov   e,m                     ; (7~)
         inx   h                       ; (5~)
         mov   d,m                     ; (7~)
         inx   h                       ; (5~)
         mov   a,m                     ; (7~)
         inx   h                       ; (5~)
         mov   h,m                     ; (7~)
         mov   l,a                     ; (5~)
         push  h                       ; (11~) now push float number onto stack
         push  d                       ; (11~)
         push  b                       ; (11~)
         jmp   ntrpt1

xoplscalar2 ; push integer
         inx   h                       ; (5~) skip to 16 bit integer portion
         inx   h                       ; (5~)
         inx   h                       ; (5~)
         inx   h                       ; (5~)
         mov   e,m                     ; (7~)
         inx   h                       ; (5~)
         mov   d,m                     ; (7~)
         push  d                       ; (11~) push integer portion
         push  d                       ; (11~) fill middle two bytes
         push  b                       ; (11~) push zero marker in (A) and dummy
         jmp   ntrpt1

XOPSSCALAR ; Store Scalar Opcode
         sui   080h                    ; remove bias caused by <OP> bit
         add   b                       ; (A) = 6*ScalarNumber+080h
         ; note: carry has 7th bit of significance here
         lhld  vartable                ; form address of scalar
         mov   c,a                     ; (5~) form 16 bit Scalar offset
         mvi   a,0                     ; (7~) mvi doesn't blitz carry
         aci   0                       ; (7~)
         mov   b,a                     ; (5~)
         dad   b                       ; (10~)
PopScalarToHL ; pop scalar on TOS, store in memory at HL
         pop   b                       ; fetch VTYPE
         mov   a,b                     ; integer value ?
         ana   a                       ; ...?
         jz    sscalari                ; b/ yes, don't bother fixing it!
         push  b                       ; no, go try to fix
         shld  storetarget             ; save where result will go
         call  fix16                   ; take rover to the vet...
         jr    sscalar2                ; b/ it fixed, result in DE
         lhld  storetarget             ; didn't fix, store the hard way
         pop   b                       ; (10~) store <exponent,1stdigit>
         mov   m,b                     ; (7~)
         inx   h                       ; (5~)
         mov   m,c                     ; (7~)
         inx   h                       ; (5~)
         pop   d                       ; (10~)
         mov   m,d                     ; (7~)
         inx   h                       ; (5~)
         mov   m,e                     ; (7~)
         inx   h                       ; (5~)
         pop   d                       ; (10~)
         mov   m,d                     ; (7~)
         inx   h                       ; (5~)
         mov   m,e                     ; (7~)
         jmp   ntrpt1                  ; (10~)

sscalar2 ; store fixed version of floating point number
         lhld  storetarget             ; where to store the result
         xra   a                       ; make an "integer" tag
         jmp   sscalari1               ; go store integer portion

sscalari ; store integer from stack
         pop   b                       ; (10~) remove garbage pair
         pop   d                       ; (10~) pop integer value
sscalari1 ; enter here from sscalar2
         mov   m,a                     ; (7~) store "integer" tag
         inx   h                       ; (5~) skip over dummy bytes
         inx   h                       ; (5~)
         inx   h                       ; (5~)
         inx   h                       ; (5~)
         mov   m,e                     ; (7~) store integer
         inx   h                       ; (5~)
         mov   m,d                     ; (7~)
         jmp   ntrpt1

XOPLESCALAR ; load extended scalar (LOADEXTENDEDSCALAR)(SCALAR#-64)
         lhld  bpc                     ; fetch scalar selector
         mov   a,m
         inx   h                       ; advance BPC past scalar selector
         shld  bpc
         mov   l,a                     ; now multiply by size of scalar
         mvi   h,0                     ; HL = scalar number * 1
         movdehl                       ; DE = scalar number * 1
         dad   h                       ; HL = scalar number * 2
         dad   d                       ; HL = scalar number * 3
         dad   h                       ; HL = scalar number * 6
         lxi   d,64*6                  ; since scalar number is biased -64
         dad   d                       ; HL = scalar offset
         xchg                          ; make room in HL
         lhld  vartable                ; compute scalar address
         dad   d                       ; HL points to scalar to push
         jmp   PushScalarAtHL          ; go do common work

XOPSESCALAR ; store extended scalar (STOREEXTENDEDSCALAR)(SCALAR#-64)
         lhld  bpc                     ; fetch scalar selector
         mov   a,m
         inx   h                       ; advance BPC past scalar selector
         shld  bpc
         mov   l,a                     ; now multiply by size of scalar
         mvi   h,0                     ; HL = scalar number * 1
         movdehl                       ; DE = scalar number * 1
         dad   h                       ; HL = scalar number * 2
         dad   d                       ; HL = scalar number * 3
         dad   h                       ; HL = scalar number * 6
         lxi   d,64*6                  ; since scalar number is biased -64
         dad   d                       ; HL = scalar offset
         xchg                          ; make room in HL
         lhld  vartable                ; compute scalar address
         dad   d                       ; HL points to scalar to push
         jmp   PopScalarToHL           ; go do common work
         PAGE  *****  I N I T  *****
;
;        MAIN PROGRAM ENTRY POINT CODE:
;              call                    $100
;              db                      versionnumber
;              DW                      forwardreflabelchain
;              DW                      catbufsizerequired
;              DW                      baseofscalarvariables
;              DW                      addressof1stbyteabovedataspace
;              ...basic popcodes...
;
;
INIT ; Initialize Runtime Package for o; peration with P-Code BASIC program
         lxi   h,0
         shld  BreakLine+VINT
         shld  USING                   ; SET USING:=USINGMAX
         shld  USINGMAX
         shld  ERTRAP
         shld  ERCODE
         shld  ERADDR                  ; TO CAUSE ERROR ON "GOTO ELN" BEFORE ERROR OCCURS
         shld  EOFTABLE                ; NOT EOF ON CHANNEL 0-15
         shld  EOFTABLE+2              ; NOT EOF ON CHANNEL 16-31
         xra   a                       ; reset line flags at startup
         STA   LINEFLAGS
         STA   SUBROUTINENESTING       ; "NO SUBROUTINE CALLED"
         pop   h                       ; return address points at version #
         shld  BPC
         mov   a,m                     ; FETCH VERSION NUMBER OF COMPILER
         inx   h                       ; advance past version number
         cpi   VERSION                 ; MATCH RUNTIME PACKAGE VERSION NUMBER ?
         jnz   VERSIONERROR            ; B/ wrong version number
         MOVHLM                        ; FETCH CAT BUFFER SIZE REQUIRED
         SHLD  CATSIZ
         MOV A,H ! CMA ! MOV B,A ! MOV A,L ! CMA ! MOV C,A ; BC := COM(HL)
???      LHLD  SYSCALL$+1              ; GET TOP OF THE WORLD
         DAD   B                       ; SUBTRACT CATSIZ FROM TOP OF WORLD
         LXI   B,1                     ; FINISH "NEGATE = COMPLEMENT PLUS 1"
         DAD   B                       ; WORLDTOP-CATSIZE --> CATBUF base
         SHLD  CATBUF
         SPHL                          ; SET STACK FOR USE BY PROGRAM
         SHLD  STACKFRAMEBASE          ; FIRST BYTE WE CAN'T USE FOR STACK SPACE
         SHLD  ERRORRECOVERYSTACK      ; THIS TOO, IF AN ERROR TRAP OCCURS
         LHLD  BPC
         CALL  INITCOMMON              ; GO DO COMMON SETUP LOGIC
;        NOW COMPUTE CHECKSUM OF ENTIRE RTP
         LHLD  #CODE                   ; COMPUTE SUM OVER RTP
         LDA   DOLLARSIGN              ; IS CHECKSUM OK, IGNORING VALUE OF DOLLARSIGN ?
         NEG
         LXI   b,256*(low BASICRTPEND$-CODE)+high(BASICRTPEND$-CODE)+1
               ; = number of bytes to checksum in (CB)
TOTALRTPSUM ; LOOP TO ACCUMULATE CHECKSUM OVER RUNTIME PACKAGE
         ADD   M                       ; ADD RUNTIME PACKAGE BYTE
         INX   H                       ; ADVANCE POINTER
         djnz  TotalRTPSum             ; down count # bytes remaining to cksum
         dcr   c
         jrnz  TOTALRTPSUM             ; B/ MORE BYTES TO SUM
;        SET RTPTOTALCKSUM:=RTPTOTALCKSUM-(A) AT THIS POINT
         ANA   A                       ; IS CHECKSUM CORRECT ?
         jrnz  INITCKERR               ; B/ WRONG CHECKSUM!
         LXI   D,RTP@POPCODESTART      ; COMPUTE POINTER TO 1ST POPCODE
         LHLD  BPC
         DAD   D
         SHLD  BPC
         SHLD  LINEADDR                ; FOR PROPER ERROR HANDLING PRIOR TO LINE NUMBER (SEE PRINTLINEADDR)
         JMP   XOPLINE0                ; GO LOOK AT LINE FLAGS

;*********************************************************************
         DB    RTPTOTALCKSUM           ; *** THIS NEEDS PATCHING AFTER ASSEMBLY ***
;*********************************************************************

;        DON'T WE NEED A STACK POINTER HERE ???????
VERSIONERROR ; cause ERR@VERERR
         call  RTPERR
         DB    ERR@VERERR              ; CAN'T EXECUTE A DIFFERENT VERSION PROGRAM!

INITCKERR ; WRONG CHECKSUM OVER RTP, GIVE UP NOW!
         CALL  RTPERR
         DB    ERR@BADRTP
         PAGE    
;        RESOLVEFREFLABELS -- FOLLOW FORWARD REF LABEL CHAIN AND SET VARIABLE VALUES
;
resolvel movbchl                       ; SAVE VALUE OF THIS LABEL
         inx   h                       ; skip opcode to address of label var
         mov a,m ! inx h ! mov l,m ! mov h,a ; fetch address of label variable
         xra                           ; make it an integer
         mov   m,a                     ; zero VTYPE
         lxi   d,VINT1                 ; advance HL to Integer part of Scalar
         dad   d
         mov m,b ! inx h ! mov m,c     ; store label address into scalar
         lxi   h,3                     ; HL := addr of pointer to next FREF
         dad   b
         mov a,m ! inx h ! mov l,m ! mov h,a ; fetch pointer to next FREF
ResolveFRefAnother ; see if HL points to another Forward Reference to resolve
         mov   a,h                     ; is HL non-zero ?
         ora   l
         jrnz  resolvel                ; B/ NOT END OF LIST, KEEP GOING
         ret    
;
;        INITCOMMON -- DO WORK THAT IS COMMON TO RTP INITZ AND SUB/FUN INITZ
;
INITCOMMON ; HL points at VersionNumber of RTP@... header
         inx   h                       ; skip past version number
         mov   e,m                     ; fetch ForwardRefLabelChain to DE
         inx   h
         mov   d,m
         inx   h
         inx   h ! inx   h             ; skip over CATBUFSIZEREQUIRED
         mov   a,m                     ; fetch BASEOFSCALARVARIABLES
         inx   h
         sta   VarTable+1
         mov   a,m
         inx   h
         sta   VarTable
         mov   a,m                     ; fetch RTP@TOPOFDATASPACE
         inx   h                       ; and negate
         cma    
         mov   c,a
         mov   a,m
         inx   h
         cma    
         mov   b,a
???      shld  bpc                     ; address of 1st popcode byte
         lhld  catbuf                  ; data space overrun catbuffer ?
         inx   h                       ; (finish COM(TOPOFDATASPACE)+1)
         dad   b                       ; ...?
         jrc   DATASPACEERROR          ; b/ yes, no room for data!
         lhld  BPC                     ; does data space overlap RTP ?
         lxi   b,-(BASICRTPEND+3)
         dad   b
         jrc   OVERLAPERROR
         xchg                          ; now HL contains FREFLABELCHAIN
         jmp   ResolveFRefAnother      ; see if more Foward Refs to resolve

DATASPACEERROR ; Data Space overlaps end of world, abort execution
         CALL  FORCEERROR              ; FORCE UNTRAPPABLE ERROR
         call  RTPERR
         DB    ERRR@DATASPACECONFLICT

OVERLAPERROR ; Data Space overlaps RunTime package, abort execution
         CALL  FORCEERROR
         call  RTPERR
         DB    ERR@OVERLAPSRTP

FORCEERROR ; FORCE ERROR IN HL TO BE DISPLAYED
;        XCHG                          ; make HL free
         LXI   H,0                     ; MAKE ERROR TRAP ROUTINE DISAPPEAR
         SHLD  ERTRAP
;        XCHG                          ; restore error code
         XRA   A                       ;
         STA   SUBROUTINENESTING       ; SO NO ERROR PROPOGATION OCCURS
         RET    
         PAGE    
;        OPINIT
;        INITIALIZE MEMORY
;        OPINIT, ADDH, ADDL, # BYTES (16 BITS), BYTES
;
XOPINIT  ; INITIALIZE STORAGE OPCODE
         lhld  BPC
         mov   d,m ! inx h ! mov e,m ! inx h ; fetch target address
         mov   b,m ! inx h ! mov c,m ! inx h ; fetch number of bytes to move
         ; HL now points to 1st byte to be moved
         call  BLOCKMOVEDOWN
         JMP   NTRPTHL                 ; ALL DONE!
         PAGE  *****  L O A D  *****
;
;        LOAD INLINE FLOATING CONSTANT
;
XOPLFI   ; LOAD FLOATING INLINE CONSTANT
         lhld  BPC
         push  h                       ; save pointer to value to push
         lxi   b,rsesiz                ; find location of next popcode
         dad   b
         shld  BPC
         pop   h                       ; = pointer to value to push
         jmp   PushScalarAtHL
;
;        LOAD VALUE
;        ADDRESS IN LINE, PUSH 6
;
XOPLOAD  ; LOAD VALUE AT INLINE ADDRESS;  OPCODE
         lhld  BPC
         mov a,m ! inx h ! mov c,m ! inx h ; now (AC) points to value
         shld  BPC                     ; advance pointer past value
         mov h,a ! mov l,c             ; now HL points to value
         jmp   PushScalarAtHL
         PAGE    
;        LOAD INTEGER
;        2 BYTE INTEGER IN LINE, PUT INTO STACK
;
XOPLINT  ; LOAD INLINE INTEGER CONSTANT ONTO STACK
         lhld  BPC
         mov   c,m ! inx h ! mov b,m ! inx h  ; move integer to (CB)
         push  b                       ; push the integer value
         push  b                       ; push garbage word
         mvi   c,0                     ; make "integer" tag
         push  b
         jmp   ntrpthl                 ; and go do next opcode

XOPLADDR ; LOAD INLINE ADDRESS OPCODE
         lhld  BPC
         mov   b,m ! inx h ! mov c,m ! inx h  ; move address to (BC)
         push  b                       ; push the pointer
         push  b                       ; push garbage word
         push  b                       ; push garbage descriptor
         jmp   ntrpthl                 ; go do next opcode

         page
??? is the following code used ???
LOADCB   push  b
         mvi   c,0                     ; MAKE A TYPE BYTE TAGGED "INTEGER"
LOADINT1 push  b                       ; ASSERT: (C)=0 --> "INTEGER"
         push  b                       ; push "integer" flag byte
         JMP   NTRPT3
LOADB1 ; come here with (C) containing 8 bit value to push onto stack
; ??? needs work, who references this code ??
; XOPLDB used to, but was easy to recode
         IF    M6800!M6801
         TSX    
         CLR   R1INT1,X
         STB   R1INT2,X
         CLR   R1TYPE,X                ; MARK RESULT AS "INTEGER"
         page
;
;        LOAD 1 BYTE IN-LINE INTEGER ONTO TOS
;        *** WARNING: BYTE REPRESENTS VALUES 0-255, ONLY USED FOR 10-255
;
XOPLBINT EQU   *
         lhld  BPC
         mov   b,m                     ; fetch the byte
         inx   h                       ; bump HL past the byte
         mvi   c,0                     ; extend to 16 bits in (CB)
         push  b                       ; push the integer value
         push  b                       ; push garbage word
         push  b                       ; push integer tag
         JMP   NTRPTHL
         PAGE    
;
;        LOAD BYTE, ADDRESS ON TOS
;
XOPLDB   pop   b                       ; pop "string descriptor" mark
         popix                         ; pop offset pointer to index register
         pop   b                       ; pop garbage byte pair to clean stack
         ldx   b,string                ; get byte to (B)
         mvi   c,0                     ; extend to 16 bits in (CB)
         push  b                       ; push integer representing byte value
         push  b                       ; push garbage word
         push  b                       ; push "integer" descriptor mark
         JMP   NTRPT1
         PAGE    
;        LOAD VALUE
;        ADDRESS ON STACK, REPLACE WITH VALUE
;
XOPLV    pop   h                       ; pop garbage descriptor word
         pop   h                       ; pop garbage middle word
         pop   h                       ; pop pointer to data to fetch
         jmp   PushScalarAtHL

??????
; this appears to be redundant code
PushValueAtHL ; come here with (HL) pointing to data to push onto stack
         mov   a,m                     ; fetch descriptor byte
         inx   h                       ; and advance past it
         mov   c,a                     ; save descriptor byte
         ana   a                       ; an integer ?
         jrz   pushvalueathlinteger    ; B/ INTEGER, TAKE QUICK PATH
         mov   b,m                     ; fetch rest of 1st word
         inx   h
         mov   e,m                     ; fetch 2nd word of value to (ED)
         inx   h
         mov   d,m
         inx   h
         mov   a,m                     ; fetch 3rd word of value to (LH)
         inx   h
         mov   h,m
         mov   l,a
         push  h                       ; save the value on the stack
         push  d
         push  b
         JMP   NTRPT1

pushvalueathlinteger ; (HL)-1 points to data, (A),(C) holding zero
         inx   h                       ; advance over garbage byte
         inx   h                       ; advance over garbage word
         inx   h
         mov   e,m                     ; fetch integer to (ED)
         inx   h
         mov   d,m
         push  h                       ; push integer value
         push  b                       ; push garbage word
         push  b                       ; push "integer" tag word
         JMP   NTRPT1
end redundant ???
         PAGE
;        LOAD SMALL INTEGER
;        OPCODE VALUE = INTEGER TO PUSH ONTO STACK
;
XOPLSMI ; load small integer
         lhld  bpc                     ; backup to get opcode byte
         dcx   h
         mov   b,m                     ; fetch the opcode (the value)
         inx   h                       ; now HL points to next opcode
PushByteBNextHL ; (B) has byte integer, (HL) points to next opcode
;        Push (B) as Basic Integer onto stack
         mvi   c,0                     ; extend to 16 bits in (CB)
         push  b                       ; push integer representing byte value
         push  b                       ; push garbage word
         push  b                       ; push "integer" descriptor mark
         JMP   NTRPTHL
;
;        OPLBOOL -- LOAD BOOLEAN VALUE (OF FLAG)
;
XOPLBOOL LDA   FLAG                    ; GET THE TRUE/FALSE FLAG
         NEG                           ; MAPS 0 TO 0, $FF TO 1
         mov   b,a                     ; convert flag into pushed value
PushByteB ; (B) has byte integer
;        Push (B) as Basic Integer onto stack
         mvi   c,0                     ; extend to 16 bits in (CB)
         push  b                       ; push integer representing byte value
         push  b                       ; push garbage word
         push  b                       ; push "integer" descriptor mark
         jmp   NTRPT1
         PAGE  *****  F U N C T I O N S  *****
;        OPDUP -- DUPLICATE TOS
;
XOPDUP   lxi   h,0                     ; get Stack Pointer to HL
         dad   sp
         jmp   PushScalarAtHL
;
;        LOAD VALUE OF PI
;
XOPPI    lhld  #PI
         jmp   PushScalarAtHL
;
;        FUNERR, PUSH LAST ERROR CODE ON STACK
;
XOPERR   lhld  ERCODE
         jr    PushIntegerHL
;
;        LOAD LAST ERROR LINE NUMBER
;
;        NOTE: "IF ELN=2000 THEN ..." compiles as:
;        OPELN,OPLINT,#addressofline2000
;        OPEQ,OPBT,#... etc.
;
XOPELN   lhld  ERADDR                  ; SEE WHAT KIND OF ERROR WE GOT
         mov   a,m                     ; fetch the opcode at erroring line #
         cpi   OPLINE                  ; A LINE NUMBER OPCODE ?
         jrnz  PushIntegerHL           ; b/ no, use line number address
         inx   h                       ; yes, fetch line number to (CB)
         mov   c,m
         inx   h
         mov   b,m
         jr    PushIntegerCB

PushIntegerHL ; push (HL) as Basic Integer
         mov   c,h                     ; move (HL) to (CB)
         mov   b,l
PushIntegerCB ; push (CB) as Basic Integer
         push  b                       ; push integer
         push  b
         mvi   c,0                     ; invent "integer" tag
         push  b
         jmp   NTRPT1                  ; go do next opcode
         PAGE    
;        ABS FUNCTION
;
XOPABS   pop   b                       ; fetch descriptor word
         mov   a,c                     ; copy exponent/integer tag to (A)
         ani   01111111b               ; mask off sign bit
         mov   c,a                     ; restore adjusted descriptor
         push  b
ABS1     JMP   NTRPT2
;
;        INTEGER FUNCTION
;
XOPINT   pop   b                       ; fetch descriptor word
         push  b                       ; assume integer, push it back
         mov   a,c                     ; inspect tag byte
         ana   a                       ; already an integer ?
         jrz   INT3                    ; b/ yes, all done
         call  FINT                    ; fix integer on top of stack
INT3     JMP   NTRPT1
         PAGE    
;        SIGNUM FUNCTION
;
XOPSGN   pop   b                       ; fetch descriptor word
         pop   d                       ; middle word
         pop   h                       ; and lower word
         mvi   b,1                     ; assume "positive"
         mov   a,c                     ; inspect tag byte
         ana   a
         jrz   sgn1
         jp    PushByteB               ; b/ positive float, go push "1"
         lhld  #FMONE                  ; negative, push -1
         JMP   PushScalarAtHL

sgn1 ; we seem to have an integer on our hands
         mov   a,l                     ; is integer value non-zero ?
         ora   h
         jrnz  PushByteB               ; b/ yes, go push a one
         jr    PushIntegerHL           ; no, push "zero"
         PAGE  *****  A R I T H M E T I C   G R O U P  *****
;        MAKEBOTHFLOAT -- ENSURES THAT TOS, TOS-1 ARE BOTH IN FLOATING POINT FORMAT
;
MAKEBOTHFLOAT
         pop   h                       ;  SAVE RETURN ADDRESS
         shld  RTPRET
         call  FORCEFLOAT              ; FLOAT TOS
         lxi   h,rsesiz                ; inspect tag byte of TOS-1 for float
         dad   sp
         mov   a,m
         ana   a
         jrnz  MFLOAT2
         lhld  #OPPOLYARG
         call  FSTORE
         call  BFLOAT                  ; FLOAT TOS-1
         lhld  #OPPOLYARG
         call  FLOAD
MFLOAT2  lhld  RTPRET                  ; DONE
         pchl
;
;        MULTIPLY TOS BY TOS-1
;
XOPMUL   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         ora   c                       ; are both operands integers ?
         jrnz  mul1                    ; B/ NO, MUST DO FLOATING MULTIPLY
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch multiplicand
         push  b                       ; save multiplicand in case of overflow
         mov   a,c ! mov c,b ! mov b,a ; move (CB) to (BC)
         lxi   d,VINT1                 ; fetch multiplier
         dad   h
         mov   d,m ! inx h ! mov e,m   ; note non-standard stacking order
         call  MLTPLY                  ; multiply (BC) by (DE), result to (HL)
         jmp   mul3                    ; b/ no integer overflow of product
         push  b                       ; reconstruct TOS multiplier
         mvi   c,0                     ; reconstruct integer tag byte
         push  b
         jr    mul2                    ; must do floating arithmetic

mul3     mov   a,h ! mov h,l ! mov l,a ; move (HL) to (LH), to restack
         jmp   ReplaceTOWR2            ; go push result in non-standard order

mul1     push  d                       ; restore 1st word of TOS
mul2     call  MAKEBOTHFLOAT
         lhld  #FLOATOVFLOW
         shld  FPTRAP
         call  FMUL
         JMP   NTRPT1
         PAGE    
;        DIVIDE TOS INTO TOS-1
;
XOPDIV   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         ora   c                       ; are both operands integers ?
         jrnz  div1                    ; B/ NO, MUST DO FLOATING DIVIDE
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch divisor to (CB)
         push  b                       ; save divisor in case of overflow
         lxi   d,VINT1                 ; fetch dividend
         dad   h
         mov   d,m ! inx h ! mov e,m   ; note non-standard stacking order
         mov   h,c ! mov l,b           ; move (CB) to (HL)
         mov   a,h ! ora l             ; is divisor zero ?
         jz    FLOATOVFLOW             ; B/ DIVISION BY ZERO!!! (GULP)
         if    0
divshiftloop ; assume divisor is power of two, produce quotient
         ; assert: carry bit is reset
         mov a,d ! rar ! mov d,a       ; divide dividend by 2
         mov a,e ! rar ! mov e,a
         jrc   div2                    ; b/ not divisible by power of two
         mov a,h ! rar ! mov h,a       ; right shift divisor one place
         mov a,l ! rar ! mov l,a
         jrnc  divshiftloop            ; b/ must shift some more
         mov a,h ! ora l               ; was divisor a power of two ?
         jrnz  div2                    ; b/ no, quotient isn't correct
         endif
         call  divideintegers          ; (DE) has divisor, (BC) has dividend
         mov a,h ! ora l               ; evenly divisible ?
         jrnz  div2                    ; b/ no, must do floating divide
         mov h,c ! move l,b            ; move quotient to (LH), to restack
         jmp   ReplaceTOWR2            ; go push result in non-standard order

div2     mvi   e,0                     ; reconstruct integer tag byte
div1     push  d                       ; and push to reconstruct operand
         call  MAKEBOTHFLOAT           ; MUST DO FLOATING DIVIDE, RATS!!
         lhld  #FLOATOVFLOW
         shld  FPTRAP
         call  FDIV
         JMP   NTRPT1
         PAGE    
;        SUB TOS FROM TOS-1
;
XOPSUB   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         ora   c                       ; are both operands integers ?
         jrnz  sub1                    ; B/ NO, MUST DO FLOATING SUBTRACT
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch minuend (value to subtract)
         push  b                       ; save minuend in case of overflow
         lxi   d,VINT1                 ; fetch subtrahend
         dad   h                       ; (i.e., value subtracted from)
         mov   a,m ! inx h ! mov d,m   ; note non-standard stacking order
         sub b ! mov h,a ! mov a,d ! sbb c ! mov l,a ; compute diff to (LH)
         jrnc  ReplaceTOWR2            ; b/ result is still positive
         push  b                       ; reconstruct TOS minuend
         mvi   c,0                     ; reconstruct integer tag byte
         push  b
         jr    sub2                    ; rats, must do floating subtract

SUB1     push  d
SUB2     call  MAKEBOTHFLOAT
         lhld  #FLOATOVFLOW
         shld  FPTRAP
         call  FSUB
         jmp   NTRPT1

ReplaceTwoOperandsWithResult ; (HL) contains integer result
; replace two integer operands on top of stack with result
         pop   b                       ; pop tag word
ReplaceTOWR1 ; (HL) contains integer result, TOS tag word already popped
         pop   b                       ; pop TOS garbage word
ReplaceTOWR2 ; (LH) contains integer result, TOS tag + garbage word popped
         pop   b                       ; pop original TOS value
         pop   b                       ; pop TOS-1 "integer" tag word
         pop   d                       ; pop TOS-1 garbage word
         pop   d                       ; pop TOS-1 original value
         push  h                       ; push integer result
         push  d                       ; push garbage word
         push  b                       ; push "integer" tag word
         jmp   NTRPT1                  ; and go do next opcode
; TSXSUB3 used to be approximately here
         PAGE    
;
;        ADD TOS TO TOS-1
;
XOPADD   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         ora   c                       ; are both operands integers ?
         jrnz  add1                    ; B/ NO, MUST DO FLOATING ADD
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch augend (value to add)
         push  b                       ; save augend in case of overflow
         lxi   d,VINT1                 ; fetch addend
         dad   h                       ; (i.e., value added to)
         mov   a,m ! inx h ! mov d,m   ; note non-standard stacking order
         add b ! mov h,a ! mov a,d ! adc c ! mov l,a ; compute sum to (LH)
         jrnc  ReplaceTOWR2            ; b/ result is <= 65535
         push  b                       ; reconstruct TOS augend
         mvi   c,0                     ; reconstruct integer tag byte
         push  b
         jr    add2                    ; rats, must do floating add

add1     push  d
add2     call  MAKEBOTHFLOAT
         lhld  #FLOATOVFLOW
         shld  FPTRAP
         call  FADD
         jmp   NTRPT1

FLOATOVFLOW ; come here to signal overflow after arithmetic operation
         call  RTPERR
         db    RTPERR@FLTOVF
         PAGE    
;        AND TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
;
XOPAND   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         push  d                       ; restore tag byte
         ora   c                       ; are both operands integers ?
         cnz   makebothlogical         ; no, so force logical result
         pop   b                       ; pop and ignore tag byte
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch right hand operand
         pop   d                       ; pop and save "integer" tag
         pop   h                       ; pop garbage word
         pop   h                       ; pop left operand
         mov a,b ! ana h ! mov h,a     ; compute logical product
         mov a,c ! ana l ! mov l,a
         push  h                       ; push integer result
         push  h                       ; push garbage word
         push  d                       ; push "integer" tag word
         jmp   NTRPT1                  ; and go do next opcode
;
;        IOR TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
;
XOPIOR   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         push  d                       ; restore tag byte
         ora   c                       ; are both operands integers ?
         cnz   makebothlogical         ; no, so force logical result
         pop   b                       ; pop and ignore tag byte
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch right hand operand
         pop   d                       ; pop and save "integer" tag
         pop   h                       ; pop garbage word
         pop   h                       ; pop left operand
         mov a,b ! ora h ! mov h,a     ; compute logical sum
         mov a,c ! ora l ! mov l,a
         push  h                       ; push integer result
         push  h                       ; push garbage word
         push  d                       ; push "integer" tag word
         jmp   NTRPT1                  ; and go do next opcode
;
;        XOR TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
;
XOPXOR   lxi   h,rsesiz                ; locate tag byte of TOS-1
         dad   sp
         mov   a,m                     ; and move to (A)
         pop   d                       ; move tag byte of TOS to (C)
         push  d                       ; restore tag byte
         ora   c                       ; are both operands integers ?
         cnz   makebothlogical         ; no, so force logical result
         pop   b                       ; pop and ignore tag byte
         pop   b                       ; ignore garbage word
         pop   b                       ; fetch right hand operand
         pop   d                       ; pop and save "integer" tag
         pop   h                       ; pop garbage word
         pop   h                       ; pop left operand
         mov a,b ! xra h ! mov h,a     ; compute logical xor
         mov a,c ! xra l ! mov l,a
         push  h                       ; push integer result
         push  h                       ; push garbage word
         push  d                       ; push "integer" tag word
         jmp   NTRPT1                  ; and go do next opcode
         PAGE    
;        MAKEBOTHLOGICAL -- FORCE BOTH OPERANDS TO 16 BIT INTEGER FORM
;        OR CAUSE ERROR
;
MAKEBOTHLOGICAL ; FORCE BOTH OPERANDS TO BE "LOGICAL" OR ERROR
         pop   h                       ; get return address
         shld  RTPRET                  ; AND SAVE IT
         call  FIXTOS                  ; MAKE SURE TOS IS FIXED
         lxi   h,rsesiz                ; inspect TOS-1
         dad   sp                      ; points to tag word
         mov   a,m ! ana a             ; is it an integer ?
         jrz   MAKEBOTHLOGICAL2        ; B/ yes, TOS-1 IS FIXED ALREADY!
         lxi   h,OPPOLYARG             ; SIGH... SAVE TOS SOMEWHERE SAFE
         call  FSTORE
         call  FIXTOS                  ; FORCE OLD TOS-1 TO BE INTEGER
         lxi   h,OPPOLYARG             ; GET OLD TOS BACK
         call  FLOAD
MAKEBOTHLOGICAL2
         lhld  rtpret                  ; and exit
         pchl
         PAGE    
;        FIXTOS -- CONVERTS TOS TO 16 BIT INTEGER FORM
;        CAUSES ERROR IF NOT CONVERTABLE
;
FIXTOS   EQU   *
         pop   h                       ; get return address out of way
         pop   b                       ; inspect tag code
         mov a,c ! ana a               ; is it already an integer ?
         jrz   fixtosinteger           ; B/ YEP
         shld  ACMRET
         call  FIX16
         jr    FIXTOSOK
FIXTOSERR
         call  RTPERR
         db    :FLTNXP

FIXTOSOK ; succeeded in fixing tos
         lhld  ACMRET                  ; fetch return address
         mvi   c,0                     ; mark TOS as "Integer"
fixtosinteger
         push  b                       ; restore tag word
         pchl                          ; and exit
;
;        COM - COMPLEMENT INTEGER ON TOS
;
XOPCOM   call  FIXTOS                  ; FORCE TOS TO BE IN INTEGER FORM
         lxi   h,R1INT                 ; find integer portion
         dad   sp                      ; now HL points to integer portion
         mov a,m ! cma ! mov m,a       ; complement integer portion
         inx h ! mov a,m ! cma ! mov m,a
         jmp   NTRPT1
         PAGE    
;        LOGICAL SHIFT TOS-1 BY TOS, NO FLOATING ARGUMENTS ALLOWED
;        EXCEPT FLOATING NEGATIVE SMALL CONSTANTS FOR COUNT ONLY
;
XOPSHF   pop b ! mov a,c ! ana a       ; IS TYPE FLOATING?
         jp    shift2                  ; B/ MAYBE NOT
         lhld  #FPOINT5                ; negative, definitely float, so round
         call  FLOAD
         call  FADD                    ; no overflow possible here
         pop b ! mov a,c ! ana a       ; is result positive ?
         jp    PL1PC1                  ; b/ yes, is effectively "shift zero"
         call  FINT                    ; no, chop to integer...
         call  FNEG                    ; take absolute value
         call  FIX16                   ; and make into 16 bit value
         jr    shiftm                  ; it fixed ok!
         lxi   h,rsesiz*2              ; number is too big to fix
         jr    shiftzdadsp

shzero ; result is zero
         lxi   h,rsesiz*1              ; remove operand from stack
shiftzdadsp ; pop HL bytes from stack, push zero result
         dad sp ! sphl                 ; remove operands from stack
         lxi   h,0                     ; and push result of zero
         push h ! push h ! push h
         jmp   NTRPT1                  ; go do next opcode

shiftm   pop   h                       ; shift right desired
         pop   b                       ; move shift count to (BC)
         mov a,b ! ana a ! jrnz shzero ; > 256 TO RIGHT
; ?? no complaint if right operand is negative ??
         mov a,c ; ana a ! jz NTRPT1   ; ASSERT: SHIFT COUNT <> 0
         sta   tbyte                   ; save shift distance
         call  FIXTOS                  ; fix value to be shifted
         lda tbyte ! mov b,a           ; get shift distance
         pop   d                       ; save integer tag
         pop h ! pop h                 ; fetch value to shift
shift7   xra a                         ; clear carry to shift in a zero
         mov a,h ! rar ! mov h,a       ; shift HL right one place
         mov a,l ! rar ! mov l,a
         djnz  shift7
shift8   push h ! push h ! push b      ; push result
         jmp   NTRPT1
         PAGE    
shift2   call  RNDTOS                  ; SHIFT COUNT IS POSITIVE
         DW    SHZERO                  ; B/ CAN'T ROUND!
         mov a,h ! ana a ! jrnz shzero ; b/ shift count > 255
         mov a,c ! ana a ! jz NTRPT1   ; done if shift by zero
         sta   tbyte                   ; save shift distance
         call  FIXTOS
         lda tbyte ! mov b,a           ; get shift distance
         pop   d                       ; save integer tag
         pop h ! pop h                 ; fetch value to shift
shift5   dad h ! djnz shift5           ; shift operand left
         jr    SHIFT8

;
;        NEGATE TOS
;
XOPNEG   call  FORCEFLOAT
         call  FNEG
         JMP   NTRPT1
         PAGE  *****  S T R I N G   A N D   A R I T H M E T I C  C O M P A R E S  *****
;        ALGEBRAIC COMPARES
;
XOPEQ    call  ACMP
         jrnz  CMP0
CMP1     mvi   a,0ffh                  ; ASSERT: FLAG HAS VALUE 0 OR $FF!
         sta   FLAG
         JMP   NTRPT1

XOPNE    call  ACMP
NOTEQUALQ ; not equal predicate
         jrnz  CMP1
CMP0     xra   a                       ; result is false
         sta   flag
         JMP   NTRPT1

XOPLT    call  ACMP
         jrc   CMP1
         jr    CMP0

XOPLE    call  ACMP
         jrc   CMP1
         jrz   CMP1
         jr    CMP0

XOPGT    call  ACMP
         jrz   CMP0
         jrnc  CMP1
         jr    CMP0

XOPGE    call  ACMP
         jrnc  CMP1
         jr    CMP0
         PAGE    
;        STRING COMPARES
;
XOPSEQ   call  SCMP
         jrz   CMP1
         jr    CMP0

XOPSNE   call  SCMP
         jrnz  CMP1
         jr    CMP0

XOPSLT   call  SCMP
         jrc   CMP1
         jr    CMP0

XOPSLE   call  SCMP
         jrc   CMP1
         jrz   CMP1
         jr    CMP0

XOPSGT   call  SCMP
         jrz   CMP0
         jrnc  CMP1
         jr    CMP0

XOPSGE   call  SCMP
         jrnc  CMP1
         jr    CMP0
         PAGE    
;        ACMP -- ARITHMETIC COMPARE SUBROUTINE
;        COMPARE TOS-1 WITH TOS
;        SET CARRY IF TOS-1 VALUE < TOS VALUE
;        SET "Z" IF TOS-1 VALUE = TOS VALUE
;        Note: CC bits set are different than 6800/6809 implementation...
;        because they are significantly easier to set this way
;
acmpf2 ; TOS-1 is not integer, but TOS is
         push  b                       ; restore TOS-1 tag word
         push d ! push d               ; restore TOS value
acmpf1   push  b                       ; restore TOS tag word
acmpf    shld  acmret                  ; SAVE RETURN ADDRESS
         call  MAKEBOTHFLOAT
         lhld acmret ! push h          ; NOW DO: "CALL FCMP/ RTS"
         JMP   FCMP
;
ACMP ; THIS IS MAIN ENTRY POINT OF SUBROUTINE
         pop   h                       ; pop return address
         pop   b                       ; fetch TOS tag word
         mov a,c ! ana a ! jrnz acmpf1 ; b/ TOS is not integer
         pop d ! pop d                 ; fetch TOS integer value
         pop   b                       ; fetch TOS-1 tag word
         mov a,c ! ana a ! jrnz acmpf2 ; b/ TOS-1 is not integer
         pop b ! pop b                 ; fetch TOS-1 operand
         mov a,e ! sub c ! jrz acmplz  ; compare TOS-1 to TOS
         mov a,d ! sbb b               ; compare upper halves
         jrnz  acmpdone                ; if non-zero, CC bits are right
         ; assert: carry must be set here. Further, values don't match.
         inr a                         ; set "Not zero", leave carry alone
acmpdone pchl

acmplz ; lower halves match
         mov a,d ! sub b               ; set condition codes to result
         pchl                          ; and exit
         PAGE    
;        SCMP -- STRING COMPARE SUBROUTINE
;        STR1 IS COMPARED TO STR2 (COMPARE TOS-1 WITH TOS)
;        STRINGS EQUAL IFF STRING LENGTHS ARE = AND STRING HEADS ARE =
;        LESS THAN IF (HEADS SAME & SL1 < SL2) OR HEAD1 < HEAD2
;        GT IF (HEADS SAME & SL1 > SL2) OR HEAD1 > HEAD2
;        SET CARRY IF TOS-1 STRING < TOS STRING
;        SET "Z" IF TOS-1 STRING = TOS STRING
;        Note: CC bits set are different than 6800/6809 implementation...
;        because they are significantly easier to set this way
;
SCMP     pop h ! shld acmret           ; main entry point, pop return address
         pop b ! pop d ! pop h         ; pop S2 string length to DE, ptr to HL
         inx h ! inx h                 ; make HL point to CURLEN of string
         inx d ! mov a,d ! ora e ! jrnz scmp1 ; b/ string length not "ALL"
         mov e,m ! inx h ! mov d,m     ; use CURLEN for ALL
         jr    scmp1a                  ; re-enter main-line code

scmp1    dcx   d                       ; offsets "inx d" above
         inx   h                       ; to match other path
scmp1a   inx   h                       ; now DE is length, HL is body
         shld  tword                   ; save S2 body address
         pop b ! pop b ! pop h         ; pop S1 string length to BC, ptr to HL
         inx h ! inx h                 ; make HL point to CURLEN of string
         inx b ! mov a,b ! ora c ! jrnz scmp2 ; b/ string length not "ALL"
         mov c,m ! inx h ! mov b,m     ; use CURLEN for ALL
         jr    scmp2a                  ; re-enter main-line code

scmp2    dcx   b                       ; offsets "inx b" above
         inx   h                       ; to match other path
scmp2a   inx   h                       ; now BC is length, HL is body
         mov a,c ! sub e ! jrz scmp3   ; choose min(S1LEN,S2LEN)
         mov a,b ! sbb d
         mvi a,081h ! jrc scmp4        ; b/ S1LEN < S2LEN
scmp3a   ; assert: S1LEN (BC) > S2LEN (HL)
         mvi a,001h                    ; string head match CC is "GreaterThan"
         mov b,d ! mov c,e             ; use shorter string length
         jr    scmp4

scmp3    mov a,b ! sbb d
         mvi a,081h ! jrc scmp4        ; b/ S1LEN < S2LEN
         jrnz  scmp3a                  ; b/ S1LEN > S2LEN
         xra   a                       ; S1LEN = S2LEN
scmp4 ; (A)*2 will set carry and Z bit properly if string heads match
;       (BC) has count
         sta   tbyte                   ; preserve string head match CC
         xchg ! lhld tword             ; now (DE) is S1BODY, (HL) is S2BODY
         xchg                          ; so we compare TOS-1 string to TOS
; String Block Compare: Compare bytes at (HL) to (DE) for (BC) bytes
; Exits with Z bit set if (BC) exhausts and all bytes match
; else exits with Z reset, carry set if byte @HL-1 < byte @DE-1
;        (HL) and (DE) point past mismatched bytes
;
         mov   a,b                     ; compare for zero bytes ?
         ora   c
         jrz   scmploopexit            ; b/ yes, strings match
         if    z80
scmploop ; loop here to compare the next byte
+++++ RULE: SYSCALL ERROR CODES COME BACK IN REGISTER BC
         ldax  d                       ; fetch byte to compare
         inx   d                       ; advance source pointer
         cci                           ; match ?
         jrnz  scmploopexit            ; b/ no
         jpo   scmploop                ; b/ more bytes to compare
scmploopexit ; come here with Z set for match, C set if "less than"
         else  ; i8085
         inr   b                       ; to make DCR possible below
scmploop ; loop here to compare the next byte
         ldax  d                       ; fetch byte to compare
         inx   d                       ; advance source pointer
         cmp   m                       ; simulate Z80 CPI instruction
         inx   h                       ; (advance compare pointer)
         jnz   scmploopnotequal        ; b/ no match
         dcr   c                       ; down count # bytes remaining
         jnz   scmploop                ; b/ more bytes to compare
         dcr   b                       ; down count # bytes remaining
         jnz   scmploop                ; b/ more bytes to compare
         ; assert: Z bit set, C bit reset
         jmp   scmploopexit

scmploopnotequal
         dcr   c                       ; finish simulation of CPI instruction
         inr   a                       ; set CC to "Not Zero" again
         jrnz  scmploopexit            ; exit if we got CC right
         inr   a                       ; sigh, we goofed... make CC "Not Zero"
scmploopexit ; come here with Z set for match, C set if "less than"
         endif
         lhld  acmret                  ; get return address
         rnz                           ; exit if strings don't match
         lda   tbyte                   ; get final CC if string heads match
         add   a                       ; set final CC
         ret
         PAGE  *****  S T R I N G S  *****
;
;        TIME    
;
XOPTIM ; produce string descriptor referencing time-of-day
         call  GTD                     ; get time and date into a buffer
         lxi   h,timestr-string        ; = pointer to dummy string head
TIME1    lxi   b,8                     ; push string descriptor for 8 byte string
         push  b                       ; push count
         push  h                       ; push pointer to dummy string header
         mvi   c,1                     ; push marker for string descriptor
         push  b
         jmp   ntrpt2
;
;        DATE    
;
XOPDAT ; produce string descriptor referencing "MM/DD/YY"
         call  GTD                     ; get time and date into a buffer
         lxi   h,datestr-string        ; = pointer to dummy string head
         jr    TIME1
         PAGE    
GTD ; GET TIME and DATE SUBROUTINE
; opens CLOCK: and read 17 character string containing time and date...
; into the TIMESTR/DATESTR buffer
         call  SETSCOP                 ; set syscall opcode
         db    SYSCALL:OPEN
         db    OPEN:SCLEN
         db    CHANGED,IGNORED

         call  SETSCWRBUF
         DW    CLOCKSTR
         DW    6

         call  SETSCRDBUF
         DW    SCRATCH
         DW    4

         call  FINDACHAN

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

         call  SETSCRDBUF
         DW    TIMESTR
         DW    011h

         call  SYSCALLONMYCHAN

CLOSEMYCHAN ; close the channel selected by the variable MYCHAN
         call  SETSCOP                 ; set syscall opcode
         db    SYSCALL:CLOSE
         db    CLOSE:SCLEN
         db    CHANGED,IGNORED

SYSCALLONMYCHAN ; execute the constructed system call on I/O channel MYCHAN
         lda   mychan
         sta   scblk+scblk$params      ; set the desired I/O channel
         jmp   isyscall                ; go do syscall and handle any error
         PAGE    
;
;        SET OPCODE
;
SETSCOP ; set syscall block opcode according to in-line parameters
         lxi   h,0                     ; set default values into syscall block
         shld  scblk+scblk$wrlen       ; this assumes we don't want to write
;        shld  scblk+scblk$wrbuf       ; set to "pretty" value
         shld  scblk+scblk$rdlen       ; set up empty reply buffer
;        shld  scblk+scblk$rdbuf       ; set to "pretty" value
         lxi   b,scblk                 ; which block to fill in
         jr    COPY4                   ; copy 4 bytes from inline, store @ HL

;        SET RDBUF/WRBUF TO VALUES SUPPLIED IN-LINE
;        CALL FORMAT:
;              call   SETSCRD/WRBUF
;              DW     bufferaddress
;              DW     buffercount
;              ...return here...
;
SETSCRDBUF ; set syscall block RDBUF and RDLEN from inline parameters
         lxi   b,scblk+scblk$rdbuf
         jr    COPY4

SETSCWRBUF ; set syscall block WRBUF and WRLEN from inline parameters
         lxi   b,scblk+scblk$wrbuf
;        jr    COPY4

COPY4 ; Copy 4 bytes from inline, store at (BC) and then return after inline data
         pop   h                       ; grab return address
         ldax b ! inx b ! mov m,a ! inx h ; copy 1st byte
         ldax b ! inx b ! mov m,a ! inx h ; copy 2nd byte
         ldax b ! inx b ! mov m,a ! inx h ; copy 3rd byte
         ldax b ! inx b ! mov m,a ! inx h ; copy 4th byte
         ret                           ; and exit
FINDACHAN ; FIND A CHANNEL FOR MY VERY OWN
         xra a ! sta mychan            ; start at 0 (who knows.. it might be closed)
findachan2
         call  syscallonmychan         ; see if channel is open
         rnc                           ; exit if we succeeded in opening MYCHAN
         lxi h,mychan ! inr m          ; choose another channel
         lxi   h,-err$chbusy           ; is the problem that channel is busy ?
         jrz   findachan2              ; b/ yes, go try next higher channel
         lxi h,mychan ! dcr m          ; oops... put channel back
         jmp   checkbcs                ; and see if error recovery is desired
EDIT
         PAGE
;        OPVAL
;        SD ON TOS REPLACED BY NUMERIC VALUE
;
XOPVAL   call  GSTRCNT                 ; get current length of string to (DE)
         pop   h                       ; throw away string descriptor size
         pop   h                       ; get pointer to string head (R1SDA)
         pop   b                       ; remove string descriptor tag from stk
         lxi b,string ! dad b          ; make pointer to string body
         call  CONVERT
         jr    OPVAL1                  ; B/ CONVERSION OK
; ????   **** CONVERT MIGHT BE IMPROVED!!! this is an old comment, what means?
         call  RTPERR
         db    CONVER                  ; SYNTAX ERROR OR OVERFLOW
OPVAL1   jmp   ntrpt2
         PAGE    
;        SET USING STRING TO STRING ON TOS
;
XOPUSE   call  GSTRCNT                 ; get current length of string to (DE)
         pop   h                       ; throw away string descriptor size
         pop   h                       ; get pointer to string head (R1SDA)
         pop   b                       ; remove string descriptor tag from stk
         lxi b,string ! dad b          ; make pointer to string body
         shld  USING                   ; save pointer to USING string
         dad   d                       ; pointer to end of USING string
         shld  USINGMAX
         jmp   ntrpt1
         PAGE    
;        SET USING STRING TO FORMAT STRING
;        IN LINE ADDRESS POINTS TO SET LINE # OPCODE
;        OPUSL,POINTERTOLINENUMBERORLABEL
;        NOTE: LINENUMBERORLABEL CAN ANY OF THE FOLLOWING FORMS:
;        1)    OPLINE,16BITLINENUMBER,OPJUC,LENGTH BYTE,FORMATSTRING
;        2)    OPSETLABEL,OPJUC,LENGTH BYTE,FORMATSTRING
;        3)    OPFREFLBL,4 BYTES,LENGTH BYTE,FORMATSTRING
;
XOPUSL   ; SET USING STRING TO FORMAT STRING AT INLINE ADDRESS
?        lhld  BPC                     ; get pointer to opcode
         mov a,m ! inx h ! mov l,m ! mov h,a ; get pointer to line # opcode
         mov   a,m                     ; get label opcode
         inx   h                       ; advance pointer past label opcode byte
         cpi   OPSETLABEL              ; really a "SET LABEL" opcode ?
         jrz   opusl1                  ; b/ set label, (HL) now pts to "OPJUC"
         inx h ! inx h                 ; advance pointer past assumed line number
         cpi   OPLINE                  ; is it really "OPLINE" opcode ?
         jrz   opusl1                  ; B/ yes, (HL) now pts to "OPJUC"
         inx h ! inx h                 ; assert: OPFREFLBL opcode, (HL) now pts to "OPJUC"
opusl1   mov a,m ! inx h               ; get purported "OPJUC" opcode
         cpi   OPJUC                   ; is this really a format statement ?
         jrnz  opusl3                  ; b/ no, illegal format
         mov   c,m                     ; get length of format
         inx   h                       ; make (HL) point to format string body
         shld  USING                   ; remember pointer to format string body
         mvi   b,0                     ; extend (C) to 16 bits in (BC)
         dad   b                       ; find end of USING string
         shld  USINGMAX                ; and remember it
         jmp   NTRPT3

opusl3   call  RTPERR
         db    FORMAT
         PAGE    
;        PUSH STRING CONSTANT DESCRIPTOR
;        OPLSC, COUNT, STRING
;        COUNT < 255
;
XOPLSC   ; LOAD STRING CONSTANT
?         lhld  BPC
         mov c,m ! mvi b,0             ; get string count to (BC)
         push  b                       ; push on stack to form string descriptor
         dcx h ! dcx h ! dcx h         ; pointer to non-existent string head
         push  h                       ; push on stack to form string descriptor
         mvi   e,1                     ; form "string descriptor" tag word
         push  d                       ; to complete string descriptor
         dad   b                       ; form pointer to end of string-4
         lxi   d,string                ; locate opcode past end of string
         dad   d
         jmp   NTRPTHL                 ; go interpret opcode at (HL)
;
;        JUC    
;        JUMP AROUND USING CONSTANT
;        OPJUC,LENGTH BYTE,STRING
;
XOPJUC   ; JUMP AROUND "USING" STRING (FORMAT STRING)
         lhld  BPC
         mov c,m ! mvi b,0             ; get string count to (BC)
         dad   b                       ; form pointer to end of string-1
         jmp   NTRPTHL1                ; go interpret opcode at (HL)+1
         PAGE    
;        PUSH CATBUF DESCRIPTOR
;        USED ONLY IN OPCIN...OPCAT...OPCND SEQUENCES
;
XOPCND   lhld  CATSTRINGSIZE           ; push size of CATBUF
         push  h
         lhld  CATBUF                  ; get pointer to CATBUF
CATDN2   lxi b,-STRING ! dad b         ; form pointer to string head
CATDN1   push  h                       ; push pointer to buffer "string head"
         mvi   c,1                     ; push "string descriptor" tag word
         push  b
         jmp   NTRPT1
;
;        PUSH COPYRIGHT MESSAGE DESCRIPTOR
;
XOPCOPYRIGHT ; push copyright message descriptor
         lxi   h,COPYRIGHTEND-COPYRIGHT ; push length of COPYRIGHT$ string
         push  h
         lxi   h,COPYRIGHT-STRING      ; pointer to dummy string head
         jr    CATDN1
         PAGE    
;        INPUT STRING TAKES AND PUSHES A STRING DESCRIPTOR
;        FOR THE STUFF REMAINING IN THE CATBUF
;        INPTR POINTS TO BYTE IN CATBUF
;
XOPINS ; push string descriptor for rest of input line in CATBUF
         lhld  CATPTR                  ; get pointer to end of input line
         xchg                          ; (place CATPTR in (DE))
         lhld  INPTR                   ; pointer to 1st byte of rest of line
         mov a,e ! sub l ! mov e,a     ; (DE):= size of rest of input line
         mov a,d ! sbb h ! mov d,a
         push  d                       ; push length of rest of input line
         jr    CATDN2                  ; make INPTR look like a string pointer
;
;        PUSH STRING DESCRIPTOR
;        OPCODE, ADDRESS (POINTS TO MAX BYTE OF SOME STRING)
;
XOPLSD   ; LOAD STRING DESCRIPTOR (FOR STRING VARIABLE)
?        lhld  BPC
         lxi   d,0fffh                 ; push marker indicating "entire string"
         push  d
         mov d,m ! inx h ! mov e,m     ; fetch pointer to string head
         push  d                       ; and push to make string descriptor
         mvi   c,1                     ; push "string descriptor" tag word
         push  b
         jmp   NTRPT1HL                ; advance (HL) by 1 and continue execution
         PAGE    
;        MAXLEN, TOS GETS MAX LENGTH OF STRING ON TOS
;
XOPMAXLEN ; replace TOS string descriptor by MAXLEN(stringdescriptor)
         pop   d                       ; pop "string descriptor" tag word
         pop   h                       ; get pointer to string head
         pop   b                       ; get length value from string descriptor
         inx b ! mov a,b ! ora c       ; "entire string" ?
         jrnz  xopmaxlen1              ; b/ nope, (BC) = string length
xoplen1
         mov b,m ! inx h ! mov c,m     ; yes, get MAXLEN from string head
xopmaxlen1
         mov a,b ! mov b,c ! mov c,a   ; swap to make backward byte integer
         push  b                       ; push integer length of string
         push  b                       ; push garbage word
         mvi   c,0                     ; push integer tag word
         push  b
         jmp   NTRPT1
;
;        LENGTH, TOS GETS CURRENT LENGTH OF STRING ON TOS
;
XOPLEN ; replace string descriptor on TOS by current length of string
         pop   d                       ; pop "string descriptor" tag word
         pop   h                       ; get pointer to string head
         pop   b                       ; get length value from string descriptor
         inx b ! mov a,b ! ora c       ; "entire string" ?
         jrnz  xopmaxlen1              ; b/ nope, (BC) = string length
         inx h ! inx h                 ; yes, get CURLEN fron string head
         jr    xoplen1
         PAGE    
RESOLVESTRING ; return current length of string descriptor in (BC)
; returns pointer to string body in (DE)
; pops string descriptor off top of stack
         pop   h                       ; recover return address
         pop   d                       ; pop and ignore string descriptor tag
         pop   d                       ; pop pointer to string head
         inx d ! inx d                 ; make pointer to current length
         pop   b                       ; pop string length
         mov a,b ! cmp c               ; = "entire string" ?
         jrnz  resolvestring1          ; b/ no, (BC) has string length
         inr   a                       ; (probably) ...?
         jrnz  resolvestring1          ; b/ no, (BC) has string length
         ldax d ! mov c,a ! inx d      ; fetch current length of string
         ldax d ! mov b,a ! inx d      ; now (DE) points to string body
         pchl                          ; and exit

resolvestring1
         inx d ! inx d                 ; set (DE) to point to string body
         pchl
^^^ above subroutine belongs with GSTRCNT

;        OPFIND, FIND OCCURENCE OF TOS SD IN TOS-1 SD
;        RETURN 0 IF NOT THERE, ELSE RETURN INDEX IN TOS-1
;        IF LEN(S1: STRING TO BE SEARCHED) = 0, RETURN 0
;        IF LEN(S2: STRING TO SEARCH FOR) = 0, RETURN 1
;        POP BOTH
;
opfindnull ; searching for null string
         inx   h                       ; null string is always found at index 1
         jr    opfindxit               ; b/ yes, exit with found null string

XOPFIND  call  RESOLVESTRING           ; (BC) = string size, (DE) = string body
         xchg ! shld S2ADD             ; save pointer to string to hunt for
         movhlbc ! shld S2LEN          ; save length of string to hunt for
         call  RESOLVESTRING           ; (BC) = string size, (DE) = string body
         lhld  S2LEN                   ; fetch length of string to hunt for
         tsthl                         ; are we searching for null string ?
         jrz   opfindnull              ; b/ yes, go handle
         mov a,c ! sub h ! mov c,a     ; (BC) := len(S1) - len(S2) +1
         mov a,b ! sbb l ! mov b,a     ; = # places that S2 could be found
         jrc   opfindcant              ; can't compare, LEN(S2) > LEN(S1)
         if    z80
         inx   b                       ; if lengths are equal, S2 can be found once
NEEDS WORK FOR Z80 VERSION
         lhld S2ADD ! mov a,m          ; fetch first byte of target string
         xchg                          ; now (HL) points to string to search
opfind1st z80scanformatch
         jrz   opfindrest              ; b/ matched character, try to match rest
opfindcant ; can't find target string in source string
         lxi   h,0                     ; get "not found" code
         jr    opfindxit               ; and exit with it

opfindnothere ; target string does not match source at this offset
         pop   psw                     ; restore 1st byte of string to find
         pop   h                       ; restore where to continue searching
         pop   b                       ; restore # bytes left to search
         bra   opfind1st???            ; branch back into fast search loop
Z80 STRING SEARCH NEEDS MORE WORK!
opfindrest ; 1st byte of searched-for string matches, see if rest matches
         push  b                       ; save remaining count
         push  h                       ; save where to continue searching
         push  psw                     ; save 1st byte of string to find
         xchg                          ; (DE) points into string to search
         lbcd  S2LEN                   ; fetch # bytes to match
         lhld  S2ADD                   ; (HL) points to string to match
         z80comparestrings             ; try to match strings
         jrnz  opfindnothere           ; b/ didn't match
opfindfound ; we found the target string in the source
         pop   b                       ; pop and ignore 1st byte of target
         pop   d                       ; pop where match was found
         pop   h                       ; pop and ignore remaining count
         lhld  S1ADD                   ; where source string starts
         mov a,e ! sub l ! mov l,a     ; (HL) = distance into string
         mov a,d ! sub h ! mov h,a     ; (zero origin)
         inx   h                       ; convert to one origin
         else  ; i8085
         mov a,l ! ana a               ; make S2LEN easy to decrement below
         jrz   opfind1a                ; b/ don't have to increment upper half
         inr   h                       ; make it easy to decrement S2LEN below
opfind1a shld  S2LEN                   ; save adjusted S2LEN
;        inx   b                       ; if lengths are equal, S2 can be found once
;        mov a,c ! ana a               ; make (BC) easy to decrement below
;        jrz   opfind2a                ; b/ don't have to increment upper half
;        inr   b                       ; make it easy to decrement (BC) below
;opfind2a equ *
; following two lines are equivalent to above
         inr   c                       ; bump (BC) (I know this looks strange)
         inr   b                       ; to make (BC) easy to decrement below
         lhld S2ADD ! mov a,m          ; fetch first byte of target string
         xchg                          ; (HL):= pointer to string to search
opfind1st ; compare first byte of string to be found against source string
         cmp   m                       ; (7T) compare 1st byte of target
         jrz   opfindrest              ; b/ found 1st, see if rest matches
opfindnext ; 1st byte didn't match, compare to next byte if there are more
         inx   h                       ; advance pointer past matched byte
         dcr   c                       ; down count remaining bytes to search
         jrnz  opfind1st               ; b/ more to search, continue search
         dcr   b                       ; down count remaining bytes to search
         jrnz  opfind1st               ; b/ more to search, continue search
opfindcant ; can't find target string in source string
         lxi   h,0                     ; get "not found" code
         jr    opfindxit               ; and exit with it

opfindnothere ; target string does not match source at this offset
         pop   psw                     ; restore 1st byte of string to find
         pop   h                       ; restore where to continue searching
         pop   b                       ; restore # bytes left to search
         bra   opfindnext              ; branch back into fast search loop

opfindrest ; 1st byte of searched-for string matches, see if rest matches
         push  b                       ; save remaining count
         push  h                       ; save where to continue searching
         push  psw                     ; save 1st byte of string to find
         xchg                          ; (DE) points into string to search
         lbcd  S2LEN                   ; fetch # bytes to match
         lhld  S2ADD                   ; (HL) points to string to match
opfindrestl ; match rest of string to find against string to search
         ldax d ! cmp m                ; next bytes of string match ?
         jrnz  opfindnothere           ; b/ no, target doesn't match source here
         inx d ! inx h                 ; advance pointers to strings to match
         dcr   c                       ; down count remaining bytes to match
         jrnz  opfindrestl             ; b/ more bytes to match
         dcr   b                       ; down count remaining bytes to match
         jrnz  opfindrestl             ; b/ more bytes to match
opfindfound ; we found the target string in the source
         pop   b                       ; pop and ignore 1st byte of target
         pop   d                       ; pop where match was found
         pop   h                       ; pop and ignore remaining count
         lhld  S1ADD                   ; where source string starts
         mov a,e ! sub l ! mov l,a     ; (HL) = distance into string
         mov a,d ! sub h ! mov h,a     ; (zero origin)
         inx   h                       ; convert to one origin
         endif
opfindxit ; (HL) contains offset into string where target was found
         push  h                       ; save offset
         push  h                       ; push garbage word
         mvi   l,0                     ; get "integer" tag word
         push  h                       ; and push it
         jmp   NTRPT1                  ; and go execute the next opcode
EDIT
         PAGE
;        SET LENGTH OF STRING ON TOS-1 TO TOS
;        CHECK MAX LENGTH
;        POP BOTH
;
XOPSSL   call  RNDTOS                  ; get new desired current length
+++ assume returned in BC
         DW    OPSSL1
         pop   d                       ; ignore string descriptor tag
         pop   h                       ; get pointer to string head
         pop   d                       ; get length
         inx d ! mov a,d ! ora e       ; string descriptor for entire string ?
         jrnz  OPSSL1                  ; B/ TRYING TO SET LENGTH OF SUBSTRING
         mov d,m ! inx h ! mov a,m     ; now (DA) holds MAXLEN
         inx h                         ; and (HL) points to current length
         stc                           ; (set up for compare below)
         sub a,c ! mov a,d ! sub a,b   ; new current length <= maxlen ?
         jrhs  opssl1                  ; b/ new current length > maxlen, err
         mov m,b ! inx h ! mov m,c     ; set new current length
         jmp   ntrpt1

OPSSL1   call  RTPERR
         db    ERR@SSBRNG
         PAGE    
;        INITIALIZE FOR CATENATE
;
XOPCIN   lxi   h,0                     ; SET CONCATENATED STRING SIZE TO ZERO
         shld  CATSTRINGSIZE
;
;        CATENATE 
;        COPY STRING AT TOS ONTO CATBUF
;        ADJUST COUNT & CHECK FOR OVERFLOW
;
XOPCAT   call  RESOLVESTRING           ; get string address and size
?? need params of resolvestring to finish. assume len in DE, address in HL
         push  h                       ; save source of bytes
         push  d                       ; save number of bytes to cat onto end
         lhld  catstringsize           ; get total size of cat'd string so far
         xchg                          ; save total size so far
         dad   d                       ; = total bytes when done concatting
         lda catsiz+1 ! sub l          ; make sure CATBUF won't overflow
         lda catsiz ! sbb h
         jrlo  caten5                  ; b/ CATBUF will overflow, go complain
         shld  catstringsize           ; store revised string size
         lhld  catbuf                  ; compute destination for cat'd string
         dad   d                       ; now (HL) points to where stuff goes
         xchg                          ; now (DE) points to destination
         pop   b                       ; restore number of bytes to cat
         pop   h                       ; restore source
         call  BLOCKMOVEDOWNS          ; go do block move
; above can be call to LDIR that handles 0 byte copies
         jmp   ntrpt1

caten5   call  RTPERR
         db    err@catovf
         PAGE    
;        CATBUF = UPPERCASE(TOS STRING)
;        TOS = CATBUF STRING DESCRIPTOR
;
UPPERSUB ; make sure CATBUF can hold string @ HL for DE bytes
;  Then set up to block move string to CATBUF, uppercasing as we go.
         lda catsiz+1 ! sub e          ; make sure CATBUF won't overflow
         lda catsiz ! sbb d
         jrlo  caten5                  ; b/ CATBUF will overflow, go complain
         shld  catstringsize           ; store string size
         mov b,e ! mov c,d             ; set up to do DJNZ loop below
         mov a,b ! ora c               ; copy zero bytes ?
         rz                            ; b/ yes, get out now
         mov a,c ! ana a               ; lower 8 bits of count = zero ?
         jrz   uppersub1               ; b/ yes, leave count alone
         inr   b                       ; no, bump B, makes DCR C below work
uppersub1
         ori   1                       ; make CC bits say "not zero" on exit
         lded  catbuf                  ; where to copy bytes to
         ret
         PAGE    
;        TAKE UPPER CASE OF STRING
;
XOPUPPERC ; CATBUF:= UPPERCASE(TOS STRING), push string descriptor of CATBUF
         call  RESOLVESTRING           ; string address to HL, length to DE
         call  UPPERSUB
         jrz   xopupperc3             ; B/ DONE
xopupperc1
         if    z80
         lda ,hl+
         else ; i8085
         mov a,m ! inx h
         endif
         cpi   'a
         jrlo  xopupperc2
         cpi   'z+1
         jrhs  xopupperc2
         sui   32                      ; CONVERT TO UPPER CASE ASCII
xopupperc2
         if    z80
         sta   ,de+
         else ; i8085
         stax d ! inx d
         endif
         djnz  xopupperc1
         dcr   c
         jrnz  xopupperc1
xopupperc3
         lhld  catstringsize           ; push string descriptor for CATBUF
         push  h
         lhld  CATBUF                  ; get pointer to CATBUF
         lxi b,-string ! dad b         ; form pointer to string head
         push  h                       ; push pointer to CATBUF "string head"
         mvi   c,1                     ; push "string descriptor" tag word
         push  b
         jmp   ntrpt2
         PAGE    
XOPLOWERC ; CATBUF:= LOWERCASE(TOS STRING), push string descriptor of CATBUF
         call  RESOLVESTRING           ; string address to HL, length to DE
         call  UPPERSUB
         jrz   xoplowerc3              ; B/ DONE
xoplowerc1
         if    z80
         lda ,hl+
         else ; i8085
         mov a,m ! inx h
         endif
         cpi   'a
         jrlo  xoplowerc2
         cpi   'z+1
         jrhs  xoplowerc2
         sui   32                      ; CONVERT TO UPPER CASE ASCII
xoplowerc2
         if    z80
         sta   ,de+
         else ; i8085
         stax d ! inx d
         endif
         djnz  xoplowerc1
         dcr   c
         jrnz  xoplowerc1
xoplowerc3
         jr    xopupperc3              ; push string descriptor for CATBUF
         PAGE
EDIT
;  *****  S T R I N G   S U B C R I P T I N G  *****
;
;        INDEX ON TOS, SD AT TOS-1
;        CHECK SUBSCRIPT RANGE
;        FIX TOS-1 SD TO POINT TO NEW SUBSTRING
;        FIX COUNT
;
XOPRIGHT call  RNDTOS
         DW    SSB13                   ; ERROR
         tstbc                         ; zero subscript is illegal
         jrz   SSB13                   ; b/ catch him on zero subscript
         dcx   b
         sbcd  TWORD
         call  RESOLVESTRING           ; String body ptr in (DE), len in (BC)
         lhld  TWORD                   ; is string subscript out of range ?
         mov a,c ! sub l ! mov c,a     ; (BC):=(BC)-subscript
         mov a,b ! sbb h ! mov b,a     ; [compare LEN with subscript]
         jrhs  SSB13                   ; b/ illegal subscript
         dad   d                       ; now (HL) points to new string body
         lxi   d,-string               ; make pointer to dummy string head
         dad   d
         push  b                       ; push remaining length of string
         push  h                       ; push pointer to string body
         mvi   c,1                     ; push "string descriptor" tag word
         push  b
         jmp   NTRPT1
         PAGE    
;        SINGLE STRING SUBSCRIPT
;        TAKE SD AT TOS-1 ADD VALUE AT TOS
;        CHECK SUBSCRIPT RANGE ON MAX LENGTH
;        MAKE NEW ADDRESS
;        LOWER BOUND BASED AT 1
;
XOPSS1   call  RNDTOS                  ; ROUND TOS & FIX
         dw    SSB13                   ; ERROR
         dcx   b                       ; change 1-origin index to 0-origin
         ; DCX makes 0 subscript look like 65535 subscript
         pop   h                       ; throw "string descriptor" tag away
         pop   h                       ; get pointer to string head
         pop   d                       ; and current string length
         mov a,d ! ana e ! inr a       ; reference to "entire string" ?
         jrnz  opss1b                  ; b/ no, (DE) is also MAXLEN of string
         IF    MAXLEN=0
         mov e,m ! inx h ! mov d,m ! dcx h ; fetch MAXLEN from string head
         ELSE    
         ) "need fancier code in XOPSS1"
         FIN    
opss1b   mov a,e ! sub c ! mov a,d ! sub b ; is subscript out of range ?
         jrhs  ssb13                   ; b/ >= not allowed, we already subtracted 1
         dad   b                       ; compute revised string head location
         lxi   b,1                     ; = new current length
         push  b                       ; push string descriptor
         push  h                       ; (pointer to dummy string head)
         push  b                       ; push "string descriptor" tag word
         jmp   NTRPT1

SSB13    call  RTPERR                  ; STRING SUBSCRIPT OUT OF RANGE
         db    err@ssbrng
         PAGE    
;        ROUND AND FIX TOS TO POSITIVE NUMBER
;        PLACE ROUNDED AND FIXED TOS IN (BC)
;        CALL FORMAT:
;              call  RNDTOS
;              DW    cantround         ; points to where to go if error
;              ...continue here with (BC) containing integer...
;
;        SKIP EXIT IF 0 <= (ROUNDED TOS) <= 65535
;        "CAN'T ROUND" EXIT IF (ROUNDED TOS) <0 OR (ROUNDED TOS) > 65535
;        IN EITHER CASE, TOS IS POPPED
;
RNDTOS   pop   h                       ; SEE IF WE CAN GET OUT OF HERE FAST
         pop   b                       ; pop tag word
         mov a,c ! ana a               ; an integer?
         jrz   rndtosi                 ; b/ integer, get out quick!
         shld  RTPRET                  ; sigh... its a float, do it the hard way
         push  b                       ; push exponent word back
         call  FIX16                   ; try to fix it first...
         dw    rndtos1                 ; b/ it fixed!
         lxi   b,FPOINT5               ; won't fix, so round first...
         call  FLOAD
         call  FADD                    ; no overflow possible here
         pop   b                       ; pop tag word again
         mov a,c ! ana a               ; is rounded result negative ?
         jm    rnderr2                 ; b/ yes, unreasonable result
         push  b                       ; no, truncate to integer
         call  FIX                     ; by throwing fraction part away
         dw    rndtos2                 ; all is well
??? FIX, FIX16 thinks a relative JMP follows it.  WRONG! on 8080, jr is 3 bytes!
!!! modify so takes jmp at return address if all is ok!
rnderr   pop   h                       ; can't fix, so throw TOS away
rnderr2  pop   h                       ; finish throwing TOS away
rndtos4  pop   h                       ; finish throwing TOS away
         lhld  RTPRET                  ; take error exit
         movhlm
         pchl
;        JMP thru return address here saves "JR outofrange" elsewhere
         PAGE    
rndtos2  ; TOS has form: (X,X,V,V)
         pop   h                       ; get upper 16 bits of 32 bit integer
         tsthl
         jrnz  rnderr4                 ; b/ result > 65535!
rndtos1  lhld  RTPRET                  ; TOS has form: (0,0,V,V)
         jr    rndtos3

rndtosi ; TOS is already an integer
         pop   b                       ; ignore garbage word
rndtos3  pop   d                       ; fetch integer to (ED)
         mov b,e ! mov c,d             ; make standard form integer in (BC)
rndtosx ; take skip exit, return address is in (HL)
         inx h ! inx h                 ; skip past error vector
         pchl
         PAGE    
;        DOUBLE STRING SUBSCRIPTING
;        TAKE SD AT TOS-2 & INDEX AT TOS-1 TO FORM
;        A NEW ADDRESS FOR SD. TAKE LENGTH AT TOS FOR
;        SD LENGTH
;
XOPSS2   call  RNDTOS                  ; convert desired length to integer
         dw    opss2err                ; can't convert length to integer
         sbcd  STORETARGET             ; save substring length
         call  RNDTOS                  ; convert index of 1st string byte to integer
         dw    SSB13                   ; can't convert index to integer
         dcx   b                       ; convert index to 0 origin
         sbcd  TWORD                   ; save 1st string index
         call  RESOLVESTRING           ; getch string length, addr to (BC), (DE)
         lhld  STORETARGET             ; fetch desired substring length
         push  h                       ; push final string length
         tsthl
         jrz   ssb26                   ; b/ desired length = 0, no error
         lhld  TWORD                   ; get 1st string index
         mov a,l ! sub c ! mov a,h ! sbb b ; 1st string index out of range ?
         jrhs  SSB13                   ; b/ yes, go complain
         xchg ! dad d ! xchg           ; compute substring address
         lda   STORETARGET             ; compute last index...
         add l ! mov l,a               ; of selected substring
         lda   STORETARGET+1
         adc h ! mov h,a
         jrc   OPSS2ERR                ; b/ substring runs off end of world
         mov a,c ! sub l ! mov a,b ! sbb h ; last byte within original string ?
         jrlo  opss2err
ssb26    lxi   h,-string               ; push dummy string head address
         dad   b
         push  b
         mvi   c,1                     ; push "string descriptor" tag word
         push  b
         jmp   NTRPT1

opss2err call  RTPERR                  ; substring is too big or illegal
         db    err@SLNRNG
         PAGE    
;        OPSSA -- SUBSCRIPT STRING ARRAY TO PRODUCE STRING DESCRIPTOR ON TOS
;        TOS CONTAINS STRING SUBSCRIPT, TOS-1 CONTAINS STRING ARRAY ADDRESS
;        STRING ARRAY FORMAT: (# STRINGS) (STRING)(STRING)(STRING)....
;
XOPSSA ; subscript a string array
         call  RNDTOS
         dw    DOSSE                   ; array subscript error if not integer
         dcx   b                       ; convert to 0 origin (map 0 into big number)
         pop d ! pop h ! pop d         ; get string array address to (HL)
         inx h ! mov a,c ! sub m ! dcx h ! mov a,b ! sbb m ; check bounds
         jrc   DOSSEJ                  ; b/ too big!
         inx h ! inx h ! push h        ; save pointer to 1st string
         movhlm                        ; grab DIM'd size of string elements
         lxi d,string ! dad d          ; adjust to include string head
; multiply (HL) by (BC), put result in (BC)
         call  MLTPLY                  ; compute displacement into string array
??? note error exit from MLTPLY
         jrnc  xopssa1                 ; product fits in 16 bits
DOSSEJ   jmp   DOSSE                   ; array subscript out of range

xopssa1  pop   h                       ; get address of 1st string
         dad   b                       ; now (HL) points to head of desired string
         lxi   d,0ffffh                ; "the whole string"
         push  d                       ; push string descriptor for string
         push  h                       ; push string address
         mvi   c,1                     ; push "string descriptor" tag word
         push  b
         jmp   NTRPT2
         PAGE    
;        OPSAINIT -- INITIALIZE A STRING ARRAY
;        (OPSAINIT) (ADDR OF STRING ARRAY) (# OF STRINGS) (MAXLEN)
;
XOPSAINIT ; initialize a string array
?        lhld  BPC
         inx h ! mov d,m ! inx h ! mov e,m ! inx h ; (DE):= addr of string array
         mov c,m ! inx h ! mov b,m ! inx h ; (CB):=number of strings
         mov a,c ! stax d ! inx d      ; store string count...
         mov a,b ! stax d ! inx d      ; at array head
         ana a               ; make DJNZ loop below work
         jrz   xopsainit1              ; b/ don't have to inc upper half
         inr   c                       ; make DCR C below work correctly
xopsainit1 ; now (CB) can be decremented nicely
         ora   b                       ; any strings to set up ?
; NOTE BUG IN 6800 RTP IF STRING ARRAY WITH DIMENSION ZERO SET UP: BOOM!
         jrz   xopsainitdone           ; b/ no, get out!
         mov a,m ! inx h               ; (A):= upper byte of MAXLEN
         push h                        ; save address of next opcode, -1
         mov l,m ! mov h,a             ; (HL):= MAXLEN of string
opsainitl ; loop here, initializing each string in the string array
; (CB) = # strings left to init, (DE) pts to next string head, (HL) has MAXLEN
         mov a,h ! stax d ! inx d      ; store MAXLEN into next string head
         mov a,l ! stax d ! inx d
         inx d ! inx d                 ; leave CURLEN garbage, bump past it
         xchg ! dad d ! xchg           ; advance (DE) to next string head
         djnz  opsainitl               ; b/ more strings to init
         dcr   c                       ; more strings to init ?
         jrnz  opsainitl               ; b/ yes
         pop   h                       ; recover next BPC-1
         jmp   NTRPHLplus1             ; go use (HL)+1 as BPC
        PAGE
;  ***** ARRAY SUBSCRIPTING *****
;        DO DOUBLE SUBSCRIPT (SUBROUTINE)
;              (X) POINTS TO ARRAY
;              (A,B) CONTAINS 2ND SUBSCRIPT
;              TWORD:= (A,B) * ROW DIMENSION
;              ARRAY STRUCTURE:  (# OF ROWS) (# COLUMNS) 6*(#COLS+1)*(#ROWS)
;
DODOUBLESUBSCRIPT                      ; EQU *
         shld  STORETARGET             ; SAVE ARRAY BASE
         CMPD  2,X
         BHI   DOSSE
DODS1A   lhld  ,X
         INX                           ; ACTUAL # ROWS = DIM'D # ROWS + 1
         call  MLTPLY                  ; ASSERT: CAN'T OVERFLOW!
         STD   TWORD                   ; SAVE ROW BASE
         ret
;
;        FINISHDBLSUBSCRIPT (SUBROUTINE)
;              STORETARGET POINTS TO ARRAY BASE
;              (A,B) CONTAINS 2ND SUBSCRIPT
;
FINISHDBLSUBSCRIPT                     ; EQU *
         lhld  STORETARGET             ; GET ARRAY ADDRESS
         CMPD  ,X                      ; CHECK ROW SUBSCRIPT BOUNDS
         BHI   DOSSE                   ; B/ ROW SUBSCRIPT OUT OF RANGE
DODS2A   ADDD  TWORD                   ; ADD ROW BASE
         LEAX  2,X                     ; MAKE ARRAY LOOK LIKE VECTOR
         jr    DOSS2
         PAGE    
;        DO SINGLE SUBSCRIPT (SUBROUTINE)
;              (X) POINTS TO VECTOR
;              (A,B) CONTAINS VECTOR INDEX AS INTEGER
;        RETURNS (A,B), (X) AND STORETARGET WITH POINTER TO VECTOR SLOT
;        VECTOR STRUCTURE:             (# SLOTS) (6*# SLOTS BYTES)
;        NOTE: SUBSCRIPT LOGIC ASSUMES VECTORS/ARRAYS FIT INTO MEMORY!
;
DOSINGLESUBSCRIPT                      ; EQU *
         CMPD  ,X                      ; CHECK FOR SUBSCRIPT OUT OF BOUNDS
         BLS   DOSS2                   ; IF <= THEN WE'RE OK!
DOSSE    call  RTPERR
         db    :ARYRNG

DOSS2    STD   TEMPX
         ASLD                          ; INDEX *2 (ASSERT: CAN'T OVERFLOW)
         ADDD  TEMPX                   ; *3 (ASSERT: CAN'T OVERFLOW)
         ASLD                          ; *6 (ASSERT: CAN'T OVERFLOW)
         shld  TEMPX                   ; +VECTOR NAME
         ADDD  TEMPX                   ; ASSERT: CAN'T OVERFLOW
         ADDD  #2                      ; ADD BIAS TO SKIP SLOT COUNT (CAN'T OVERFLOW)
         STD   STORETARGET
         lhld  STORETARGET
         ret
         PAGE    
;        DO VECTOR SUBSCRIPT AND PUSH ADDRESS
;              TOS CONTAINS INDEX VALUE
;              INSTRUCTION CONTAINS POINTER TO VECTOR
;
XOPVSA   EQU   *
         call  RNDTOS                  ; CONVERT INDEX TO INTEGER
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC
         lhld  ILADD,X
         BSR   DOSINGLESUBSCRIPT
         JMP   LOADAB
;
;        DO VECTOR SUBSCRIPT AND PUSH VALUE
;              TOS CONTAINS INDEX VALUE
;              INSTRUCTION CONTAINS POINTER TO VECTOR
;
XOPVSV   EQU   *
         call  RNDTOS
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC
         lhld  ILADD,X
         BSR   DOSINGLESUBSCRIPT
         JMP   LOADX
         PAGE    
;        DO VECTOR SUBSCRIPT AND STORE VALUE
;              TOS CONTAINS VALUE TO STORE
;              NEXT-TO-TOS CONTAINS INDEX
;              INSTRUCTION CONTAINS POINTER TO VECTOR
;
XOPVSS   EQU   *
         LDA   R2TYPE,S                ; CHECK TYPE OF INDEX
         jrnz  XOPVSSF                 ; B/ RATS, IT'S FLOAT...
         IF    M6800!M6801
         LDD   R2INT1,X                ; AHA! INTEGER INDEX (AND WHAT DID YOU EXPECT)
         ELSE  (M6809)
         LDD   R2INT1,S
         FIN    
         lhld  BPC
         lhld  ILADD,X
         BSR   DOSINGLESUBSCRIPT
         call  STORETOS
         JMP   PL1PC3

XOPVSSF  EQU   *                       ; INDEX IS FLOATING, DAMMIT!
         lhld  #OPPOLYARG              ; SAVE VALUE TO STORE
         call  FSTORE
         call  RNDTOS                  ; ROUND THE INDEX
         DW    DOSSE                   ; B/ CAN'T ROUND
         lhld  BPC                     ; GET VECTOR ADDRESS
         lhld  ILADD,X
         BSR   DOSINGLESUBSCRIPT
XOPVSSF1 lhld  #OPPOLYARG              ; GET VALUE TO STORE
         call  FLOAD
         lhld  STORETARGET             ; AND STORE IT
         call  STORETOS
         JMP   NTRPT3
         PAGE    
;        DO VECTOR SUBSCRIPT AND PUSH ADDRESS
;              TOS CONTAINS INDEX VALUE
;              INSTRUCTION CONTAINS POINTER TO VECTOR PARAMETER
;
XOPVPA   EQU   *
         call  RNDTOS                  ; CONVERT INDEX TO INTEGER
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC                     ; FETCH POINTER TO PARAMETER VECTOR
         lhld  ILADD,X
         lhld  R1ADD,X
         call  DOSINGLESUBSCRIPT
         JMP   LOADAB
;
;        DO ARRAY SUBSCRIPT AND PUSH ADDRESS
;              TOS CONTAINS SECOND INDEX (COLUMN)
;              NEXT-TO-TOS CONTAINS FIRST INDEX (ROW)
;              INSTRUCTION CONTAINS POINTER TO ARRAY BASE
;
XOPASA   EQU   *
         call  RNDTOS                  ; ROUND AND FIX COLUMN INDEX
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC
         lhld  ILADD,X
         call  DODOUBLESUBSCRIPT
         call  RNDTOS
         DW    DOSSE                   ; B/ CAN'T FIX
         call  FINISHDBLSUBSCRIPT
         JMP   LOADAB
         PAGE    
;        DO ARRAY SUBSCRIPT AND PUSH VALUE
;              TOS CONTAINS SECOND INDEX (COLUMN)
;              NEXT-TO-TOS CONTAINS FIRST INDEX (ROW)
;              NEXT-TO-TOS CONTAINS FIRST INDEX (ROW)
;              INSTRUCTION CONTAINS POINTER TO ARRAY BASE
;
XOPASV   EQU   *                       ; ARRAY SUBSCRIPT PUSH VALUE
         call  RNDTOS
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC
         lhld  ILADD,X
         call  DODOUBLESUBSCRIPT
         call  RNDTOS
         DW    DOSSE                   ; B/ CAN'T FIX
         call  FINISHDBLSUBSCRIPT
         JMP   LOADX
         PAGE    
;        DO ARRAY SUBSCRIPT AND STORE VALUE
;              TOS CONTAINS VALUE TO STORE
;              NEXT-TO-TOS CONTAINS COLUMN INDEX
;              NEXT-TO-TOS CONTAINS ROW INDEX
;              INSTRUCTION CONTAINS POINTER TO ARRAY BASE
;
;
XOPASS   EQU   *                       ; ARRAY SUBSCRIPT AND STORE
         LDA   R2TYPE,S                ; CHECK SUBSCRIPT TYPES
         IF    M6800!M6801
         ORAA  R3TYPE,X
         jrnz  XOPASSF                 ; B/ FLOATING SUBSCRIPT, RATS!
         LDD   R2INT1,X                ; GET COLUMN INDEX
         ELSE  (M6809)
         ORAA  R3TYPE,S
         jrnz  XOPASSF
         LDD   R2INT1,S
         FIN    
         lhld  BPC                     ; AND ARRAY BASE
         lhld  ILADD,X
         call  DODOUBLESUBSCRIPT
         LDD   R3INT1,S                ; GET ROW SUBSCRIPT
         call  FINISHDBLSUBSCRIPT
         call  STORETOS
         JMP   PL2PC3

XOPASSF  EQU   *                       ; SIGH, A SUBSCRIPT IS FLOATING....
         lhld  #OPPOLYARG              ; SAVE VALUE TO STORE
         call  FSTORE
         call  RNDTOS                  ; TO GET COLUMN VALUE
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC                     ; GET ARRAY ADDRESS
         lhld  ILADD,X
         call  DODOUBLESUBSCRIPT
         call  RNDTOS                  ; TO GET ROW VALUE
         DW    DOSSE                   ; B/ CAN'T FIX
         call  FINISHDBLSUBSCRIPT
         JMP   XOPVSSF1
         PAGE    
;        PARAMETER ARRAY SUBSCRIPT AND PUSH ADDRESS
;              TOS CONTAINS COL INDEX
;              NEXT-TO-TOS CONTAINS ROW INDEX
;              INSTRUCTION CONTAINS POINTER TO ARRAY PARAMETER
;
XOPAPA   EQU   *                       ; ARRAY (PARAMETER) SUBSCRIPT & PUSH ADDRESS
         call  RNDTOS                  ; TO GET COLUMN INDEX
         DW    DOSSE                   ; B/ CAN'T FIX
         lhld  BPC
         lhld  ILADD,X
         lhld  R1ADD,X
         call  DODOUBLESUBSCRIPT
         call  RNDTOS                  ; TO GET ROW INDEX
         DW    DOSSE                   ; B/ CAN'T FIX
         call  FINISHDBLSUBSCRIPT
         JMP   LOADAB
         PAGE    
;
;
;        LEN(vector) or LEN(stringarray)
;              TOS CONTAINS VECTOR/STRINGARRAY ADDRESS
;
XOPLENVECTOR   EQU                     ; *
         LDD   [R1ADD,S]               ; FETCH # VECTOR SLOTS (= DIM'D VALUE)
XOPLENVECTOR1  EQU                     ; *
         STD   R1INT1,S                ; REPLACE ADDRESS ON TOS BY INTEGER VALUE
         JMP   NTRPT2
;
;        ROWS(ARRAY)
;              TOS CONTAINS ARRAY ADDRESS
;
;
XOPROWSARRAY   EQU                     ; XOPLENVECTOR IT WORKS EXACTLY THE SAME!
;
;        COLS(ARRAY)
;        TOS CONTAINS ARRAY ADDRESS
;
XOPCOLSARRAY   EQU                     ; *
         lhld  R1ADD,S                 ; FETCH ARRAY ADDRESS
         LDD   2,X                     ; GET # COLUMNS
         jr    XOPLENVECTOR1
         PAGE  *****  S T O R E  *****
;
;        STORE TOS USING INLINE ADDRESS
;        OPSTD,ADDRESSOFSCALAR
;
XOPSTD   ; STORE DIRECT
         IF    M6800!M6801
         lhld  BPC
         FIN    
         lhld  ILADD,X                 ; GET "WHERE TO PUT RESULT"
         PULA                          ; GRAB EXPONENT BYTE
         STA   VFLT1,X                 ; SAVE IT IN TARGET
         jrz   XOPSTDI                 ; B/ AN INTEGER, TAKE OPTIMIZED PATH
         PSHA                          ; ITS FLOAT, PUSH EXPONENT BYTE BACK ON
         call  FIX16                   ; TRY TO FIX TO 16 BITS
         jr    XOPSTD2                 ; B/ IT FIXED!
         lhld  [BPC]                   ; WON'T FIX, JUST STORE IT LIKE IT IS
         INS                           ; POP EXPONENT BYTE OFF STACK, WE ALREADY STORED IT
         PULA                          ; STORE REST OF VALUE INTO TARGET
         STA   VFLT2,X
         PULD    
         STD   VFLT3,X
         PULD    
         STD   VFLT5,X
         JMP   NTRPT3

XOPSTD2  lhld  [BPC]                   ; TOS FORM IS (0,0,V,V); GET WHERE TO PUT VALUE
         CLR   VTYPE,X                 ; MARK AS INTEGER
         jr    XOPSTD3                 ; SKIP OVER EXTRANEOUS "POP"
XOPSTDI  EQU   *                       ; STORE INTEGER OPTIMIZED PATH
         INS                           ; TOS FORM IS (X,X,X,V,V)
XOPSTD3  LEAS  2,S                     ; TOS FORM IS (X,X,V,V), POP THE X,X GARBAGE OFF
         PULD    
         STD   VINT1,X
         JMP   NTRPT3
         PAGE    
;        STORE TOS USING TOS-1; USED TO STORE INTO PARAMETER VARIABLES
;
XOPST    lhld  R2ADD,S                 ; GET "WHERE TO PUT RESULT"
         BSR   STORETOS                ; GO STORE THE VALUE
         JMP   PL1PC1                  ; EXIT AND POP TARGET ADDRESS OFF STACK
;
;        STORETOS -- STORES NUMERIC VALUE ON TOS AT (X)
;        FIXES TO 16 BITS IF POSSIBLE
;        POPS TOS VALUE
;
STORETOS EQU   *
         PULD                          ; SAVE RETURN ADDRESS
         STD   RTPRET
         PULA                          ; EXPONENT BYTE
         STA   VFLT1,X                 ; SAVE IT AT TARGET
         jrz   STORETOSI               ; B/ AN INTEGER, TAKE FAST PATH
         PSHA                          ; FLOAT, PUSH EXPONENT BYTE BACK ON STACK
         shld  STORETARGET             ; SAVE WHERE TO PUT RESULT
         call  FIX16                   ; TRY TO FIX IT
         jr    STORETOSF               ; B/ IT FIXED!
         lhld  STORETARGET             ; WON'T FIX, GET TARGET ADDRESS AGAIN
         INS                           ; WE ALREADY STORED THE EXPONENT BYTE
         PULA                          ; FINISH STORING THE F.P. VALUE
         STA   VFLT2,X
         PULD    
         STD   VFLT3,X
         PULD    
         STD   VFLT5,X
         JMP   [RTPRET]                ; AND GET OUT
         PAGE    
STORETOSF      EQU                     ; *
         lhld  STORETARGET             ; GET WHERE TO STORE RESULT ACTION
         CLR   VTYPE,X                 ; MARK AS INTEGER
         jr    STORETOS2
STORETOSI      EQU                     ; *
         INS                           ; TOS FORM IS (X,X,X,V,V)
STORETOS2      LEAS                    ; 2,S TOS FORM IS (X,X,V,V)
         PULD                          ; INTEGER VALUE TO STORE
         STD   VINT1,X
         JMP   [RTPRET]                ; AND EXIT
         PAGE    
;        STORE BYTE, ADDRESS ON TOS-1 VALUE ON TOS
;
XOPSTB   LDA   R1TYPE,S
         jrz   STORB2
         call  FIX16                   ; TRY TO FIX IT
         jr    STORB5                  ; B/ IT WORKED
STORB3   call  RTPERR                  ; NUMBER IS TOO BIG TO STORE INTO A BYTE
         db    :STORBE

STORB5   LEAS  -2,S                    ; FILL OUT ENTRY ON TOS TO LOOK LIKE REGULAR 6 BYTE ENTRY
STORB2   LDA   R1INT1,S
         jrnz  STORB3
         IF    M6800!M6801
         LDA   R1INT2,X
         lhld  R2SDA,X
         ELSE  (M6809)
         LDA   R1INT2,S
         lhld  R2SDA,S
         FIN    
         STA   STRING,X
         JMP   PL2PC1
;
;        CHR$ -- PRODUCE STRING FROM NUMERIC VALUE
;
XOPCHR   call  RNDTOS                  ; GENERATE STRING WHOSE FIRST BYTE IS TOS
         DW    STORB3                  ; B/ CAN'T STORE IT!
         TSTA    
         jrnz  STORB3
         STB   OUTBUF
         LDA   #1                      ; = STRING LENGTH
         JMP   NUM2
         PAGE    
????
GSTRCNT ; subroutine to pop string descriptor and resolve string size
;        Returns string body address in HL, string length in BC
         pop   h                       ; recover return address
         pop   d                       ; recover pointer to string body
         pop   b                       ; recover string size
         push  h                       ; save return address on stack
         movhlde                       ; copy string address to output register
         mov   a,b                     ; is BC = 0ffffh ?
         cmp   c
         rnz                           ; b/ no
         inr   a
         rnz                           ; b/ no
         inx   h                       ; get current length
         inx   h
; String MAXLEN, CURLEN and array sizes are stored in 8080 reverse form
; since they cannot end up in data file
         mov   c,m                     ; fetch current length to (BC)
         inx   h
         mov   b,m
         dcx   h
         dcx   h
         dcx   h
         ret
????
;        STORE STRING
;        S1 IS TARGET STRING (TOS - 1) S2 IS SOURCE STRING (TOS)
;
XOPSTS   call  GSTRCNT                 ; GET SIZE OF SOURCE STRING
         shld  S2ADD
edit
         lhld  R1SDA,S
         shld  S1ADD

         IF    M6800!M6801
         TSX                           ; SET POINTER TO GARBAGE PLACE
         shld  TWORD
         lhld  R2SDC1,X                ; GET LENGTH OF S1
         ELSE  (M6809)
         sspd  TWORD
         lhld  R2SDC1,S
         FIN    
         CPX   #$FFFF
         jrnz  STORES2
         lhld  R2SDA,S
         shld  TWORD                   ; POINTER TO CURRENT LENGTH
         lhld  MAXLEN,X                ; USE MAX ON TARGET STRING
STORES2  shld  S1LEN
         CLR   LOOPX                   ; ASSUME ZERO BLANKS REQUIRED TO PAD STRING
         CLR   LOOPX+1
         LDD   S1LEN                   ; FIND LEN(S1) - LEN(S2)
         SUBD  TEMPX
         jrc   STORES3                 ; B/ S1 IS SMALLER, USE ITS LENGTH
         lhld  R2SDC1,S                ; S1 IS LARGER, IS TARGET "THE ENTIRE STRING" ?
         CPX   #$FFFF                  ; ...?
         jrz   STORES2A                ; B/ YES, DON'T DO BLANK PADDING!
         STD   LOOPX                   ; S1 IS LARGER, SAVE # BLANK PAD CHARACTERS TO INSERT
         LDD   S1ADD                   ; GET ADDRESS OF 1ST BYTE TO STORE INTO
         ADDD  TEMPX                   ; = ADDRESS OF 1ST PLACE TO PUT BLANKS
         STD   CONVERTLIMIT            ; SAVE WHERE TO PUT BLANKS
STORES2A lhld  TEMPX                   ; S1 IS LARGER, USE S2 LENGTH
STORES3  shld  LOOPCT                  ; # OF BYTES TO COPY
         lhld  TWORD                   ; SET CURLEN
         LDD   LOOPCT                  ; WATCH ME CARFULLY, I'LL CHEAT YOU IF I CAN...
         STD   CURLEN,X                ; LOOK WHERE X POINTS ON THIS STORE...
         lhld  LOOPCT
         jrz   STORES5                 ; HE SAYS DON'T COPY ANY BYTES
         PAGE    
         IF    M6800!M6801
         LDD   S1ADD                   ; NOW SEE IF S1ADD <= S2ADD
         SUBD  S2ADD
         BCC   STORES6                 ; B/ S1ADD >= S2ADD
STORES4  lhld  S1ADD                   ; COPY LEFT TO RIGHT, DO FAST MOVE
         LEAX  STRING,X                ; MAKE S1ADD POINT DIRECTLY TO TARGET STRING
         shld  TEMPX                   ; MOVE EVERYTHING AROUND UNTIL IT MATCHES BLOCKMOVE ARGUMENTS
         lhld  S2ADD                   ; = SOURCE STRING
         LDD   LOOPCT                  ; = # BYTES TO MOVE
         BSR   BLOCKMOVEDOWNS          ; GO GET 'EM, TIGER!
STORES5 ; STRING COPY COMPLETE, SEE IF ; BLANK PADDING IS REQUIRED
         LDB   LOOPX+1                 ; = RIGHT HALF OF BLANK COUNT
         jrnz  STORES5A                ; B/ NONZERO, ALL IS FINE.
         LDA   LOOPX                   ; = LEFT HALF OF BLANK COUNT
         jrz   STORES5B                ; B/ PAD WITH ZERO BLANKS, ALL DONE!
STORES5A INC   LOOPX                   ; TO ALLOW QUICK DECREMENT BELOW
         lhld  CONVERTLIMIT            ; = WHERE TO PUT BLANKS, IF ANY
         LDA   #ASCII:SPACE            ; GET CHARACTER TO STORE
STORES5L STA   STRING,X                ; PAD WITH ONE BLANK
         INX                           ; ADVANCE POINTER TO NEXT PLACE TO PAD
         DECB                          ; DONE PADDING ?
         jrnz  STORES5L                ; B/ NO
         DEC   LOOPX                   ; ...?
         jrnz  STORES5L                ; B/ NO
STORES5B ; BLANK PADDING COMPLETE
         JMP   PL2PC1

STORES6  LDD   S2ADD                   ; FAST STRING MOVE WILL SCREW UP...
         ADDD  LOOPCT                  ; IF THE STRINGS OVERLAP
         SUBD  S1ADD                   ; SO FIND OUT IF OVERLAP OCCURS
         jrc   STORES4                 ; B/ STRINGS DON'T OVERLAP, FAST MOVE IS SAFE!
         ADDD  S1ADD                   ; STRINGS OVERLAP, SHUFFLE BYTES RIGHT TO LEFT
         STD   S2ADD                   ; = ADDRESS OF RIGHTMOST BYTE TO MOVE
         LDD   S1ADD                   ; COPY RIGHT TO LEFT
         ADDD  LOOPCT
         STD   S1ADD
         LDB   LOOPCT+1                ; SET UP TO DECREMENT LOOPCT QUICKLY
         jrz   STORES7                 ; B/ DON'T HAVE TO INC UPPER HALF
         INC   LOOPCT
STORES7  lhld  S2ADD                   ; SHUFFLE BYTES THE SLOW WAY...
         DEX    
         LDA   STRING,X
         shld  S2ADD
         lhld  S1ADD
         DEX    
         STA   STRING,X
         shld  S1ADD
         DECB                          ; DECREMENT # BYTES TO MOVE
         jrnz  STORES7
         DEC   LOOPCT
         jrnz  STORES7
         jr    STORES5
         ELSE  (M6809)
         LDY   S1ADD                   ; GET TARGET STRING ADDRESS
         LEAY  STRING,Y                ; MAKE TARGET POINT TO STRING BODY
         lhld  S2ADD                   ; = SOURCE STRING ADDRESS
         LDD   S1ADD
         SUBD  S2ADD                   ; NOW SEE IF S1ADD <= S2ADD
         jrc   STORES6                 ; B/ S1ADD >= S2ADD
         LDD   LOOPCT
         BSR   BLOCKMOVEUPS
         jr    STORES5

STORES6  lbcd  LOOPCT                  ; fetch byte count to move
         call  BLOCKMOVEDOWNS
STORES5 ; STRING COPY COMPLETE, SEE IF BLANK PADDING IS REQUIRED
         LDA   LOOPX                   ; = LEFT HALF OF BLANK COUNT
         mov   c,a                     ; save it for blank pad loop below
         lda   loopx+1                 ; = right half of blank count
         mov   b,a                     ; set up for DJNZ below
         ora   c                       ; any blanks to pad ?
         jrz   STORES5B                ; B/ PAD WITH ZERO BLANKS, ALL DONE!
         inr   c                       ; TO ALLOW QUICK DECREMENT BELOW
         lhld  CONVERTLIMIT            ; = WHERE TO PUT BLANKS
         lxi   d,string
         dad   h                       ; (= ADDRESS OF 1ST BYTE TO BLANK PAD)
         mvi   a,ASCII@SPACE           ; GET CHARACTER TO STORE
STORES5L mov   m,a                     ; PAD WITH ONE BLANK
         inx   h                       ; advance pointer
         djnz  STORES5L                ; B/ more blanks to pad
         dcr   c                       ; ...?
         jrnz  STORES5L                ; B/ NO
STORES5B ; BLANK PADDING COMPLETE
         JMP   PL2PC1
         FIN    
BlockMoveDown ; moves bytes at (HL) to (DE) for (BC) bytes
;        This is a BlockMoveDown, i.e., regions can overlap if DE < HL
;        Simulates Z80 LDIR instruction
;        Move regions must not overlap
;        (BC) must be non-zero on entry
         mov   a,b                     ; move zero bytes ?
         ora   c
         rz                            ; return if zero, copy nothing
BlockMoveDownNonzero ; come here if BC is not zero
         if    z80
         ldir    
         ret    
         else  ; i8085
         mov   a,c                     ; enter into proper one-of-eight copy routine
         ani   111b                    ; obtain which of eight
         push  psw
         xra   c                       ; remove which of eight from count
         adi   8                       ; to offset first subtrac 8 below
         mov   c,a
         inr   b                       ; so decrementing B to zero terminates loop
         pop   psw
         rar                           ; inspect bit 0
         jc    BlockMoveDownA
         rar                           ; inspect bit 1
         jc    BlockMoveDownB
         rar                           ; inspect bit 4
         jc    BlockMoveDown4

BlockMoveDown8 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown7 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown6 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown5 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown4 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown3 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown2 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

BlockMoveDown1 ; move a block of 8 bytes
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)
         inx   h                       ; advance source pointer
         inx   d                       ; advance destination pointer

         mov   a,c                     ; (4~) decrement remaining byte count inBC
         sui   8                       ; (7~) = # of bytes moved
         mov   c,a
         jnz   BlockMoveDown8          ; b/ more to move, go move them
         dcr   b                       ; decrement upper half of B
         jnz   BlockMoveDown8
         ; here, (HL) and (BC) have been advanced by original contents (BC)
         ; (BC) now contains zero
         ret                           ; done

BlockMoveDownA ; bit 0 was set
         rar                           ; inspect bit 1
         jc    BlockMoveDownAB
         rar                           ; inspect bit 2
         jnc   BlockMoveDown1
         jc    BlockMoveDown5

BlockMoveDownAB ; bits 0 and 1 were set
         rar                           ; inspect bit 2
         jnc   BlockMoveDown3
         jc    BlockMoveDown7

BlockMoveDownB ; bit 0 is reset, bit 1 is set
         rar                           ; inspect bit 2
         jnc   BlockMoveDown2
         jc    BlockMoveDown6
         endif
         page
BlockMoveUp ; moves bytes at (HL) to (DE) for (BC) bytes
;        This is a BlockMoveUp, i.e., regions can overlap if HL <= DE
;        This simulates most of a Z80 LDDR instruction
;        exit with (HL) and (DE) advanced by original (BC), (BC) with zero
         mov   a,b                     ; move zero bytes ?
         ora   c
         rz                            ; return if zero, copy nothing
BlockMoveUpNonzero ; come here if BC is not zero
;        (BC) must be non-zero on entry
         dad   b                       ; find END+1 of source region
         xchg                          ; find END+1 of destination region
         dad   b
         xchg                          ; now DE points to end of destination
         push  h                       ; save final register values for exit
         push  d
         if    z80
         lddr                          ; do backwards block move
         pop   d                       ; restore pointer to end of destination
         pop   h                       ; restore pointer to end of source
         ret    
         else  ; i8085
;        i8085 implementation moves bytes at the rate of one every 24 cycles,
;        not counting overhead to start up the loop
         mov   a,c                     ; enter into proper one-of-eight copy routine
         ani   111b                    ; obtain which of eight
         push  psw
         xra   c                       ; remove which of eight from count
         adi   8                       ; to offset first subtract 8 below
         mov   c,a
         inr   b                       ; so decrementing B to zero terminates loop
         pop   psw
         rar                           ; inspect bit 0
         jc    BlockMoveUpA
         rar                           ; inspect bit 1
         jc    BlockMoveUpB
         rar                           ; inspect bit 4
         jc    BlockMoveUp4

BlockMoveUp8 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

BlockMoveUp7 ; move a block of 8 bytes
         dcx   h                       ; (5~) back up source pointer
         dcx   d                       ; (5~) back up destination pointer
         mov   a,m                     ; (7~) fetch byte from (HL)
         stax  d                       ; (7~) store into memory at (DE)

BlockMoveUp6 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

BlockMoveUp5 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

BlockMoveUp4 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

BlockMoveUp3 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

BlockMoveUp2 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

BlockMoveUp1 ; move a block of 8 bytes
         dcx   h                       ; back up source pointer
         dcx   d                       ; back up destination pointer
         mov   a,m                     ; fetch byte from (HL)
         stax  d                       ; store into memory at (DE)

         mov   a,c                     ; (4~) decrement remaining byte count inBC
         sui   8                       ; (7~) = # of bytes moved
         mov   c,a
         jnz   BlockMoveUp8            ; b/ more to move, go move them
         dcr   b                       ; decrement upper half of count
         jnz   BlockMoveUp8            ; loop if more bytes to copy
         pop   d                       ; restore final register values
         pop   h
         ret                           ; done

BlockMoveUpA ; bit 0 was set
         rar                           ; inspect bit 1
         jc    BlockMoveUpAB
         rar                           ; inspect bit 2
         jnc   BlockMoveUp1
         jc    BlockMoveUp5

BlockMoveUpAB ; bits 0 and 1 were set
         rar                           ; inspect bit 2
         jnc   BlockMoveUp3
         jc    BlockMoveUp7

BlockMoveUpB ; bit 0 is reset, bit 1 is set
         rar                           ; inspect bit 2
         jnc   BlockMoveUp2
         jc    BlockMoveUp6
         endif
; THERE'S A FASTER WAY TO DO THE ABOVE!
