INIT    TITLE   "Z80 BCPL Run Time System  -  Initialisation"
        GET     "HEADER"
        LAYOUT
;  Initialisation section of the Z80 BCPL Run Time System.  This section is
;  not BCPL callable, but defines all the run time system subroutines which
;  will be required by the compiled code.  The are two entry points:
;
;      BCPL      Entered once on start-up
;      RST38     Entered each time a BCPL "RST #X38" is executed
        LAYOUT
        REF     ROOT
        REF     GETVEC
        REF     GLOBIN

        DEF     BCPL
        DEF     RST38

G.ROOT  EQU     3*2                     ;  Global number of "root"
G.MAXG  EQU     150*2                   ;  Highest referenced global

STSIZE  EQU     500*2                   ;  Size of BCPL stack in bytes
        LAYOUT
        RELOCATABLE

        ORG     0

INIT    DEFB    'BCPL'                  ;  Entry flag for BCPL module
        DEFW    INITE-INIT              ;  Length of module in bytes
        LAYOUT
;  BCPL
;  ----
;
;  Main entry point of the BCPL program.  We must initialise the global vector,
;  which involves scanning the loaded modules looking for the highest global
;  referenced, and then allocating the global storage.  We then allocate the
;  stack, which is small initially, since we must leave room for buffers,
;  coroutine stacks etc.  We then call the "globin" function to initialise the
;  global vector with the values from the modules, and when all that is done,
;  we can call "start".

BCPL    NOP                             ;  Should be either NOP or ERRTRAP
        LD      HL,ROOT                 ;  Load entry point of BCPL code
        LD      DE,0                    ;  Current maximum global
        CALL    GSCAN                   ;  Scan the globals to find highest

;  When we return from GSCAN, the DE contains the HRG of the list of modules,
;  and HL points to the beginning of the non-BCPL code.  We can now allocate
;  the global vector and stack, since we know what size they should be.

        PUSH    DE                      ;  Save HRG
        EX      DE,HL                   ;  Put HRG in HL
        INC     HL                      ;  + 1
        INC     HL                      ;  + 2
        CALL    GETVEC                  ;  Allocate the storage
        JP      Z,INIT0                 ;  Zero rc, so all went well
        ERRTRAP                         ;  Failed, so call the error handler

;  If we come here, then alloctation of the global vector succeeded.  We should
;  also allocate the stack from the free pool as well.

INIT0   PUSH    HL                      ;  Save pointer to global vector
        LD      HL,STSIZE               ;  Get BCPL stack size
        CALL    GETVEC                  ;  Attempt to allocate it
        JP      Z,INIT1                 ;  Zero rc, so all went well
        ERRTRAP

;  If we come here, then we have both a stack and a global vector.  We should
;  set up the IX and IY registers, and then initialise the stack and global
;  vector.

INIT1   PUSH    HL                      ;  Save pointer to stack
        POP     IX                      ;  Set stack pointer
        POP     IY                      ;  Set global pointer

;  First, initialise the stack to be all zeros.

        PUSH    IX                      ;  Store stack pointer
        POP     HL                      ;  Load source address
        LD      E,L                     ;  Load low byte
        LD      D,H                     ;  And high byte
        INC     DE                      ;  Increment destination address
        INC     DE                      ;  And again
        LD      BC,STSIZE-2             ;  Load byte count

        LD      (IX+0),0                ;  Initialise byte 0
        LD      (IX+1),0                ;  Initialise byte 1
        LDIR                            ;  Initialise the rest of the bytes

;  Initialise the global vector with the "undefined global" address.  This
;  is all except global 0 which contains the size of the global vector.

        PUSH    IY                      ;  Store global pointer
        POP     HL                      ;  Load source address
        POP     BC                      ;  Get HRG (in bytes)
        PUSH    BC                      ;  Save it again

        SRL     B                       ;  Divide high byte
        RR      C                       ;  And low byte
        LD      (IY+0),C                ;  Store low byte
        LD      (IY+1),B                ;  Store high byte

        INC     HL                      ;  Increment source address
        INC     HL                      ;  And again
        LD      E,L                     ;  Load low byte
        LD      D,H                     ;  And high byte
        INC     DE                      ;  Increment destination address
        INC     DE                      ;  And again

        LD      BC,ERRGLOB              ;  Load error global address
        LD      (IY+2),C                ;  Initialise low byte
        LD      (IY+3),B                ;  Initialise high byte

        POP     BC                      ;  Restore HRG count (bytes)
        DEC     BC                      ;  Decrement count
        DEC     BC                      ;  And again
        LDIR                            ;  Initialise rest of global vector
                        
;  Now set the index registers to point 128 bytes above the base of their
;  respective vectors.  This is to get maximum addressability.  

        LD      DE,128                  ;  Actual offset of BCPL pointers
        ADD     IX,DE                   ;  Add in to the stack pointer
        ADD     IY,DE                   ;  Add in to the global pointer

;  All that remains now is to initialise the rest of the globals.

        LD      HL,ROOT                 ;  Load address of BCPL code
        CALL    GLOBIN                  ;  Initialise the globals

;  Call the routine "initio" if it exists.

        LD      E,(IY-28)               ;  Low byte of INITIO
        LD      D,(IY-27)               ;  High byte of INITIO
        LD      HL,ERRGLOB              ;  Default global value
        OR      A                       ;  Clear carry flag
        SBC     HL,DE                   ;  Are the values equal ?
        JP      Z,INIT2                 ;  Yes, so don't call it

;  If we drop through here, then "initio" is defined, and so we should call
;  it to define the I/O data structures.

        EX      DE,HL                   ;  Get function address in HL
        APPLY                           ;  Apply the procedure
        DEFB    0                       ;  Size of stack increment

;  The stage is now set for us to call "start".  The entry point is in
;  global 1, which we call in a BCPL manner.  

INIT2   LD      HL,0                    ;  Argument to called program
        EXX                             ;  Switch register sets
        LD      L,(IY-126)              ;  Low byte of "start"
        LD      H,(IY-125)              ;  High byte of "start"
        APPLY                           ;  Apply the procedure
        DEFB    0                       ;  Size of stack increment

;  When we return from "start", There is not very much we can do.  Call
;  ERRTRAP, so we find ourselves in the debugger.

        ERRTRAP                         ;  Enter the debugger
        JP      INIT2                   ;  Start all over again
        LAYOUT
;  GSCAN
;  -----
;
;  Scan the loaded modules, looking for the highest global referenced.
;  On entry:
;
;    HL   points to entry point of current module.
;    DE   zero

GSCAN   PUSH    HL                      ;  Save EP of current module
        LD      A,(HL)                  ;  Load first byte
        CP      'B'                     ;  Is this correct ?
        JP      NZ,GSCAN0               ;  No, so return
        INC     HL                      ;  Increment pointer
        LD      A,(HL)                  ;  Load second byte
        CP      'C'                     ;  Is this correct ?
        JP      NZ,GSCAN0               ;  No, so return
        INC     HL                      ;  Increment pointer
        LD      A,(HL)                  ;  Load third byte
        CP      'P'                     ;  Is this correct ?
        JP      NZ,GSCAN0               ;  No, so return
        INC     HL                      ;  Increment pointer
        LD      A,(HL)                  ;  Load fourth byte
        CP      'L'                     ;  Is this correct ?
        JP      NZ,GSCAN0               ;  No, so return
        INC     HL                      ;  Increment pointer

;  If we drop through here, then the first four bytes of the next module are
;  believed to be "BCPL", and so we assume that this is a BCPL module.  The
;  next two bytes contain the length of the module, and so we should look at
;  the end of it to find the HRG.

        LD      C,(HL)                  ;  Load low byte of length
        INC     HL                      ;  Increment pointer
        LD      B,(HL)                  ;  Load high byte of length

;  At the moment, HL points 6 bytes in to the new module, BC contains the
;  module length in bytes, and (SP) contains the pointer to the beginning
;  of the module.  Subtract 2 from the length, and then calculate the new
;  pointer.

        DEC     BC                      ;  - 1
        DEC     BC                      ;  - 2

        POP     HL                      ;  Restore pointer to base of module
        ADD     HL,BC                   ;  Add in the module length

;  At this point, HL points to the HRG of the current module.  Load the
;  HRG and then see if it should replace the current one.

        PUSH    DE                      ;  Save current HRG
        LD      E,(HL)                  ;  Load low byte of HRG
        INC     HL                      ;  Increment pointer
        LD      D,(HL)                  ;  Load low byte of HRG
        INC     HL                      ;  Increment pointer

;  At this point, DE contains the HRG of the current module, (SP) contains
;  the HRG so far, and HL points to the next module (if there is one).

        EX      (SP),HL                 ;  Swap module pointer and HRG
        PUSH    HL                      ;  And save HRG again
        OR      A                       ;  Clear carry flag
        SBC     HL,DE                   ;  Do the subtraction
        POP     HL                      ;  And restore the HRG

;  At this point, the condition codes are set depending on the comparison
;  of HL and DE.  Since DE contains the current HRG, and HL contains the
;  highest so far, we need not swap of HL < DE.

        JP      M,GSCAN1                ;  No swap, since right way round
        EX      DE,HL                   ;  Swap the HRGs

GSCAN1  POP     HL                      ;  Restore the module pointer
        JP      GSCAN                   ;  Loop until finished

;  If we come here, then we have hit the end of the modules.  Restore the
;  pointer to the end of store, and then return.

GSCAN0  POP     HL                      ;  Load end point
        RET                             ;  And return
        LAYOUT
;  ERRGLOB
;  -------
;
;    We jump to this address if an undefined global is executed.  At
;    the moment, there is not much point in doing anything other than
;    an error trap.

ERRGLOB PUSH    HL                      ;  Save return address
        EXX                             ;  Switch to argument registers
        ERRTRAP                         ;  Enter the debugger
        RET                             ;  Return from subroutine
        LAYOUT
;  RST38
;  -----
;
;    Handler for the RST #X38 instructions.  We enter with the return address
;    pointing to a byte function code defining the routine to be called.

RST38   EX      (SP),HL                 ;  Swap HL and return address
        LD      A,(HL)                  ;  Load function byte
        INC     HL                      ;  Increment return address
        EX      (SP),HL                 ;  Swap return address and HL
        PUSH    HL                      ;  Save HL
        PUSH    DE                      ;  Save DE
        LD      HL,RSTJP                ;  Get address of jump table
        LD      D,0                     ;  High byte of offset
        LD      E,A                     ;  Low byte of offset
        ADD     HL,DE                   ;  Get entry in table
        POP     DE                      ;  Restore DE
        EX      (SP),HL                 ;  Swap HL and entry point
        RET                             ;  Enter handler
        LAYOUT
;  M.APPLY
;  -------
;
;    Apply a subroutine.  The entry point is in HL, and the increase in stack
;    size is available as the inline argument.


M.APPL  EX      (SP),HL                 ;  Swap entry point and return link
        JP      GETARG                  ;  Get argument, and enter code
        LAYOUT
;  M.SETLINK0, M.SETLINK1, M.SETLINK2, M.SETLINK3
;  ----------------------------------------------
;
;    Define the linkage information when setting up a BCPL stack frame.  The
;    different entry points are for different numbers of parameters.


M.STL0  PUSH    IX                      ;  Save old stack pointer
        POP     BC                      ;  And save it in BC
        ADD     IX,DE                   ;  Add in stack increment
        LD      (IX-128),C              ;  Save low byte of stack pointer
        LD      (IX-127),B              ;  Save high byte of stack pointer
        LD      (IX-126),L              ;  Save low byte of return address
        LD      (IX-125),H              ;  Save high byte of return address
        RET                             ;  And return


M.STL1  PUSH    IX                      ;  Save old stack pointer
        POP     BC                      ;  And save it in BC
        ADD     IX,DE                   ;  Add in stack increment
        LD      (IX-128),C              ;  Save low byte of stack pointer
        LD      (IX-127),B              ;  Save high byte of stack pointer
        LD      (IX-126),L              ;  Save low byte of return address
        LD      (IX-125),H              ;  Save high byte of return address
        EXX                             ;  Swap register sets
        LD      (IX-124),L              ;  Save low byte of argument 1
        LD      (IX-123),H              ;  Save high byte of argument 1
        RET                             ;  And return


M.STL2  PUSH    IX                      ;  Save old stack pointer
        POP     BC                      ;  And save it in BC
        ADD     IX,DE                   ;  Add in stack increment
        LD      (IX-128),C              ;  Save low byte of stack pointer
        LD      (IX-127),B              ;  Save high byte of stack pointer
        LD      (IX-126),L              ;  Save low byte of return address
        LD      (IX-125),H              ;  Save high byte of return address
        EXX                             ;  Swap register sets
        LD      (IX-124),L              ;  Save low byte of argument 1
        LD      (IX-123),H              ;  Save high byte of argument 1
        LD      (IX-122),E              ;  Save low byte of argument 2
        LD      (IX-121),D              ;  Save high byte of argument 2
        RET                             ;  And return


M.STL3  PUSH    IX                      ;  Save old stack pointer
        POP     BC                      ;  And save it in BC
        ADD     IX,DE                   ;  Add in stack increment
        LD      (IX-128),C              ;  Save low byte of stack pointer
        LD      (IX-127),B              ;  Save high byte of stack pointer
        LD      (IX-126),L              ;  Save low byte of return address
        LD      (IX-125),H              ;  Save high byte of return address
        EXX                             ;  Swap register sets
        LD      (IX-124),L              ;  Save low byte of argument 1
        LD      (IX-123),H              ;  Save high byte of argument 1
        LD      (IX-122),E              ;  Save low byte of argument 2
        LD      (IX-121),D              ;  Save high byte of argument 2
        LD      (IX-120),C              ;  Save low byte of argument 3
        LD      (IX-119),B              ;  Save high byte of argument 3
        RET                             ;  And return
        LAYOUT
;  M.RETN
;  ------
;
;    Return to the previous stack level.  Load the return address and previous
;    stack pointer from the stack, and restore the old stack frame.  The return
;    address on the stack is actually useless, and should be thrown away.


M.RETN  LD      E,(IX-128)              ;  Load low byte of stack pointer
        LD      D,(IX-127)              ;  Load high byte of stack pointer
        LD      C,(IX-126)              ;  Load low byte of return address
        LD      B,(IX-125)              ;  Load high byte of return address
        PUSH    DE                      ;  Save stack pointer
        POP     IX                      ;  And restore into IX
        POP     DE                      ;  Discard return address
        PUSH    BC                      ;  Save BCPL return address
        RET                             ;  And return
        LAYOUT
;  LOADIX
;  ------
;
;    Load an item which is of of range of the normal IX instructions.


M.LDIX  EXX                             ;  Swap register sets
        POP     HL                      ;  Get return link
        CALL    GETARG                  ;  Get argument
        PUSH    HL                      ;  Save return link again

        PUSH    IX                      ;  Store index register
        POP     HL                      ;  And load it into HL
        ADD     HL,DE                   ;  Add in bare offset
        LD      DE,128                  ;  Load correction factor
        ADD     HL,DE                   ;  Add that in as well

        LD      A,(HL)                  ;  Load low byte
        INC     HL                      ;  Increment pointer
        LD      H,(HL)                  ;  Load high byte
        LD      L,A                     ;  And low byte again

        EX      (SP),HL                 ;  Swap result and return link
        PUSH    HL                      ;  Save return link again
        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  LOADIY
;  ------
;
;    Load an item which is of of range of the normal IY instructions.


M.LDIY  EXX                             ;  Swap register sets
        POP     HL                      ;  Get return link
        CALL    GETARG                  ;  Get argument
        PUSH    HL                      ;  Save return link again

        PUSH    IY                      ;  Store index register
        POP     HL                      ;  And load it into HL
        ADD     HL,DE                   ;  Add in bare offset
        LD      DE,128                  ;  Load correction factor
        ADD     HL,DE                   ;  Add that in as well

        LD      A,(HL)                  ;  Load low byte
        INC     HL                      ;  Increment pointer
        LD      H,(HL)                  ;  Load high byte
        LD      L,A                     ;  And low byte again

        EX      (SP),HL                 ;  Swap result and return link
        PUSH    HL                      ;  Save return link again
        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  STOREIX
;  -------
;
;    Store an item which is of of range of the normal IX instructions.


M.STIX  EXX                             ;  Swap register sets
        POP     HL                      ;  Get return link
        CALL    GETARG                  ;  Get argument
        EX      (SP),HL                 ;  Swap return link and argument
        PUSH    HL                      ;  Save argument again

        PUSH    IX                      ;  Store index register
        POP     HL                      ;  And load it into HL
        ADD     HL,DE                   ;  Add in bare offset
        LD      DE,128                  ;  Load correction factor
        ADD     HL,DE                   ;  Add that in as well

        POP     DE                      ;  Get argument back
        LD      (HL),E                  ;  Store low byte
        INC     HL                      ;  Increment pointer
        LD      (HL),D                  ;  Store high byte

        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  STOREIY
;  -------
;
;    Store an item which is of of range of the normal IY instructions.


M.STIY  EXX                             ;  Swap register sets
        POP     HL                      ;  Get return link
        CALL    GETARG                  ;  Get argument
        EX      (SP),HL                 ;  Swap return link and argument
        PUSH    HL                      ;  Save argument again

        PUSH    IY                      ;  Store index register
        POP     HL                      ;  And load it into HL
        ADD     HL,DE                   ;  Add in bare offset
        LD      DE,128                  ;  Load correction factor
        ADD     HL,DE                   ;  Add that in as well

        POP     DE                      ;  Get argument back
        LD      (HL),E                  ;  Store low byte
        INC     HL                      ;  Increment pointer
        LD      (HL),D                  ;  Store high byte

        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  LOADLVIX
;  --------
;
;    Load the BCPL address of an item relative to IX.


M.LVIX  EXX                             ;  Swap register sets
        POP     HL                      ;  Get return link
        CALL    GETARG                  ;  Get argument
        PUSH    HL                      ;  Save return link again

        PUSH    IX                      ;  Store index register
        POP     HL                      ;  And load it into HL
        ADD     HL,DE                   ;  Add in bare offset
        LD      DE,-128                 ;  Load correction factor
        ADD     HL,DE                   ;  Add that in as well

        SRL     H                       ;  Shift high byte right
        RR      L                       ;  And low byte

        EX      (SP),HL                 ;  Swap result and return link
        PUSH    HL                      ;  Save return link again
        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  LOADLVIY
;  --------
;
;    Load the BCPL address of an item relative to IY.


M.LVIY  EXX                             ;  Swap register sets
        POP     HL                      ;  Get return link
        CALL    GETARG                  ;  Get argument
        PUSH    HL                      ;  Save return link again

        PUSH    IY                      ;  Store index register
        POP     HL                      ;  And load it into HL
        ADD     HL,DE                   ;  Add in bare offset
        LD      DE,-128                 ;  Load correction factor
        ADD     HL,DE                   ;  Add that in as well

        SRL     H                       ;  Shift high byte right
        RR      L                       ;  And low byte

        EX      (SP),HL                 ;  Swap result and return link
        PUSH    HL                      ;  Save return link again
        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  FINISH
;  ------
;
;    End this BCPL run.  This is logically equivalent to "stop( 0 )", so
;    do just that!


M.FNSH  LD      HL,0                    ;  Argument to "stop"
        EXX                             ;  Swap register sets
        LD      L,(IY-124)              ;  Low byte of routine address
        LD      H,(IY-123)              ;  High byte of routine address
        APPLY                           ;  Apply the routine
        DEFB    2                       ;  Minimum stack increment
        LAYOUT
;  M.MULTIPLY
;  ----------
;
;    Sixteen bit multiply routine.  The two items to be multiplied are on
;    the stack, and the result should be left on the stack.


M.MULT  EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again

        LD      C,H                     ;  Set C to H
        LD      A,L                     ;  And A to L
        LD      B,16                    ;  Look count
        LD      HL,0                    ;  Result register

M.MULT0 SRL     C                       ;  Shift CA  ...
        RRA                             ;  ... right by one
        JP      NC,M.MULT1              ;  No carry, so don't add in

        ADD     HL,DE                   ;  Add in the result

M.MULT1 EX      DE,HL                   ;  Swap DE into HL
        ADD     HL,HL                   ;  Shift left by one
        EX      DE,HL                   ;  And restore again
        DJNZ    M.MULT0-$               ;  Loop until finished

        EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Restore old register set
        RET                             ;  And return
        LAYOUT
;  M.DIVIDE, M.RDIVIDE, M.REM, M.RREM
;  ----------------------------------
;
;    Sixteen bit divide/remainder functions.  The arguments are on the stack,
;    with the result to be put on the stack.  In the case of RDIVIDE and RREM,
;    the arguments should be swapped before being used.


M.DIV   EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        JP      DIV                     ;  Join common code


M.RDIV  EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        EX      DE,HL                   ;  Swap arguments
        JP      DIV                     ;  Enter common code


M.REM   EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        JP      REM                     ;  Join common code


M.RREM  EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        EX      DE,HL                   ;  Swap arguments
        JP      REM                     ;  Join common code

        

;  DIV
;  ---
;
;    Common code for the DIVIDE and RDIVIDE functions.  Call the internal
;    DIVREM function, and then decide on whether to negate the result.

DIV     CALL    DIVREM                  ;  Do the division
        LD      H,C                     ;  Answer is ...
        LD      L,A                     ;  ... in CA
        EX      AF,AF'                  ;  Get flag register
        JP      P,DIV0                  ;  Don't negate if positive

        LD      DE,0                    ;  Load zero in DE
        EX      DE,HL                   ;  And swap into HL
        OR      A                       ;  Clear the carry
        SBC     HL,DE                   ;  And negate HL

DIV0    EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Swap register sets
        RET                             ;  And return


;  REM
;  ---
;
;    Common code for the REM and RREM functions.  Call the internal DIVREM
;    function to do the division, and then return the remainder as the result.

REM     CALL    DIVREM                  ;  Do the division
        EX      AF,AF'                  ;  Get flag register
        JP      P,REM0                  ;  Don't negate if positive

        LD      DE,0                    ;  Load zero in DE
        EX      DE,HL                   ;  And swap into HL
        OR      A                       ;  Clear the carry
        SBC     HL,DE                   ;  And negate HL

REM0    EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Swap register sets
        RET                             ;  And return


;  DIVREM
;  ------
;
;    Internal subroutine to do a division.  The arguments are passed to us
;    in the HL and DE registers.  The quotient is return in CA, and the
;    remainder is returned in HL.

DIVREM  LD      A,H                     ;  High byte of argument
        XOR     D                       ;  Different signs ?
        EX      AF,AF'                  ;  Save the evidence

        BIT     7,D                     ;  Is DE negative ?
        JP      Z,DIVREM0               ;  No, so don't negate
        LD      A,D                     ;  High byte
        CPL                             ;  Complement it
        LD      D,A                     ;  Store it
        LD      A,E                     ;  Low byte
        CPL                             ;  Complement it
        LD      E,A                     ;  Store it
        INC     DE                      ;  Finish the negation

DIVREM0 BIT     7,H                     ;  Is HL negative ?
        JP      Z,DIVREM1               ;  No, so don't negate
        LD      A,H                     ;  High byte
        CPL                             ;  Complement it
        LD      H,A                     ;  Store it
        LD      A,L                     ;  Low byte
        CPL                             ;  Complement it
        LD      L,A                     ;  Store it
        INC     HL                      ;  Finish the negation

DIVREM1 LD      C,H                     ;  Set up the ...
        LD      A,L                     ;  ... CA register
        LD      HL,0                    ;  Initialise the remainder
        LD      B,17                    ;  Loop count
        OR      A                       ;  Clear carry flag

DIVREM2 ADC     HL,HL                   ;  Add in the remainder
        SBC     HL,DE                   ;  Test sign of remainder
        JP      NC,DIVREM3              ;  Not enough subtracted yet

        ADD     HL,DE                   ;  Repair the damage done

DIVREM3 CCF                             ;  Flip the carry flag
        RLA                             ;  And shift into ...
        RL      C                       ;  ... the CA register
        DJNZ    DIVREM2-$               ;  Loop until finished

        RET                             ;  And return
        LAYOUT
;  M.RSHIFT, M.RRSHIFT, M.LSHIFT, M.RLSHIFT
;  ----------------------------------------
;
;    Functions to accomplish right or left shifts.  In the case of the
;    RRSHIFT and RLSHIFT operations, the arguments are swapped before the
;    operation.


M.RSH   EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        JP      RSH                     ;  Join common code


M.RRSH  EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        EX      DE,HL                   ;  Swap arguments
        JP      RSH                     ;  Join common code
        

M.LSH   EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        JP      LSH                     ;  Join common code


M.RLSH  EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        EX      DE,HL                   ;  Swap arguments
        JP      LSH                     ;  Join common code


;  RSH
;  ---
;
;     Function to handle the Right Shift operation.  We are required to shift
;     HL right by the number of times given in DE.  The is only defined if
;     0 <= DE <= 16.

RSH     LD      A,E                     ;  Load loop count
        OR      A                       ;  Zero ?
        JP      Z,RSH1                  ;  Yes, so no shift necessary
        LD      B,A                     ;  Load real loop count

RSH0    SRL     H                       ;  Shift right H
        RR      L                       ;  And L
        DJNZ    RSH0-$                  ;  Loop until finished

RSH1    EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Swap register sets
        RET                             ;  And return


;  LSH
;  ---
;
;     Function to handle the Left Shift operation.  We are required to shift
;     HL left by the number of times given in DE.  The is only defined if
;     0 <= DE <= 16.

LSH     LD      A,E                     ;  Load loop count
        OR      A                       ;  Zero ?
        JP      Z,LSH1                  ;  Yes, so no shift necessary
        LD      B,A                     ;  Load real loop count

LSH0    ADD     HL,HL                   ;  Shift left by one
        DJNZ    LSH0-$                  ;  Loop until finished

LSH1    EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Swap register sets
        RET                             ;  And return
        LAYOUT
;  M.EQ, M.NE, M.LS, M.GR, M.LE, M.GE
;  ----------------------------------
;
;    Sixteen bit comparison routines.  Compare the top two items on the
;    stack, leaving the associated Boolean result also on the stack.


M.EQ    EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        OR      A                       ;  Clear carry flag
        SBC     HL,DE                   ;  Do subtraction
        JP      Z,M.EQ0                 ;  Values are equal, so no carry
        SCF                             ;  Otherwise, set the carry flag

M.EQ0   CCF                             ;  Swap the carry flag
        SBC     HL,HL                   ;  Set HL to boolean value
        EX      (SP),HL                 ;  Swap return address and result
        PUSH    HL                      ;  Save return address
        EXX                             ;  Restore old register set
        RET                             ;  And return


M.NE    EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        OR      A                       ;  Clear carry flag
        SBC     HL,DE                   ;  Do subtraction
        JP      Z,M.NE0                 ;  Values are equal, so no carry
        SCF                             ;  Otherwise, set the carry flag

M.NE0   SBC     HL,HL                   ;  Set HL to boolean value
        EX      (SP),HL                 ;  Swap return address and result
        PUSH    HL                      ;  Save return address
        EXX                             ;  Restore old register set
        RET                             ;  And return


M.LS    EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again

M.LS0   LD      A,H                     ;  Top byte of first value
        XOR     D                       ;  Check top bit of second value
        JP      P,M.LS1                 ;  Same, so can do subtraction

        RL      H                       ;  Get carry bit
        JP      M.LS2                   ;  Join common code

M.LS1   SBC     HL,DE                   ;  Do the subtraction

M.LS2   SBC     HL,HL                   ;  Calculate the result
        EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Get old register set
        RET                             ;  And return


M.GR    EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        EX      DE,HL                   ;  Swap arguments
        JP      M.LS0                   ;  Join common code


M.LE    EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again
        EX      DE,HL                   ;  Swap arguments
        JP      M.GE0                   ;  Join common code


M.GE    EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     DE                      ;  Get second argument
        POP     HL                      ;  Get first argument
        PUSH    BC                      ;  Save return link again

M.GE0   LD      A,H                     ;  Top byte of first value
        XOR     D                       ;  Check top bit of second value
        JP      P,M.GE1                 ;  Same, so can do subtraction

        RL      H                       ;  Get carry bit
        JP      M.GE2                   ;  Join common code

M.GE1   SBC     HL,DE                   ;  Do the subtraction

M.GE2   CCF                             ;  Swap carry flag
        SBC     HL,HL                   ;  Calculate the result
        EX      (SP),HL                 ;  Swap answer and return address
        PUSH    HL                      ;  Save return address
        EXX                             ;  Get old register set
        RET                             ;  And return
        LAYOUT
;  M.ABS
;  -----
;
;    Calculate the absolute value of the item on the stack, and return the
;    result on the stack.

M.ABS   EXX                             ;  Swap register sets
        POP     BC                      ;  Get return address
        POP     HL                      ;  Get argument
        PUSH    BC                      ;  Save return address

        LD      A,H                     ;  High byte of argument
        OR      A                       ;  Look at the sign
        JP      P,M.ABS0                ;  Already positive, so no problem

        LD      DE,0                    ;  Value to be subtracted
        EX      DE,HL                   ;  Swap registers
        SBC     HL,DE                   ;  And do the negation

M.ABS0  EX      (SP),HL                 ;  Swap return address and result
        PUSH    HL                      ;  Save return address
        EXX                             ;  Get old register set
        RET                             ;  And return
        LAYOUT
;  M.LINSEARCH
;  -----------
;
;    Do a linear search of a list of values/addresses.  This is called from
;    SWITCHON, and the value to be compared is always in DE.


M.LSCH  POP     HL                      ;  Get return address
        LD      B,(HL)                  ;  Load length of list
        INC     HL                      ;  Increment pointer

M.LSCH0 LD      A,(HL)                  ;  Load low byte
        CP      E                       ;  Low bytes equal ?
        JP      NZ,M.LSCH1              ;  No, so keep looking

        INC     HL                      ;  Increment pointer
        LD      A,(HL)                  ;  Load high byte
        CP      D                       ;  High bytes equal ?
        JP      Z,M.LSCH3               ;  Yes, so do the jump
        JP      M.LSCH2                 ;  Carry on looking

M.LSCH1 INC     HL                      ;  + 1
M.LSCH2 INC     HL                      ;  + 2
        INC     HL                      ;  + 3
        INC     HL                      ;  + 4

        DJNZ    M.LSCH0-$               ;  Loop until finished

;  When we drop out of that loop, we have failed to find the value in the
;  list, and so should load the default address, and jump to it.

        LD      A,(HL)                  ;  Load low byte of address
        INC     HL                      ;  Increment pointer
        LD      H,(HL)                  ;  Load high byte of address
        LD      L,A                     ;  And load byte again
        JP      (HL)                    ;  Go to default label

;  If we come here, then we have found the value in the list.  Load the
;  label address, and jump to it.

M.LSCH3 INC     HL                      ;  Increment pointer
        LD      A,(HL)                  ;  Load low byte of address
        INC     HL                      ;  Increment pointer
        LD      H,(HL)                  ;  Load high byte of address
        LD      L,A                     ;  And load byte again
        JP      (HL)                    ;  Go to relevant case label
        LAYOUT
M.FIX   ERRTRAP
        LAYOUT
;  RSTJP
;  -----
;
;    Jump table for decoding RST #X38 instructions.

RSTJP   JP      M.APPL
        JP      M.FIX
        JP      M.LDIX
        JP      M.LDIY
        JP      M.STIX
        JP      M.STIY
        JP      M.STL0
        JP      M.STL1
        JP      M.STL2
        JP      M.STL3
        JP      M.RETN
        JP      M.FNSH
        JP      M.LVIX
        JP      M.LVIY
        JP      M.MULT
        JP      M.DIV
        JP      M.REM
        JP      M.LSH
        JP      M.RSH
        JP      M.EQ
        JP      M.NE
        JP      M.LS
        JP      M.GR
        JP      M.LE
        JP      M.GE
        JP      M.RDIV
        JP      M.RREM
        JP      M.RLSH
        JP      M.RRSH
        JP      M.ABS
        JP      M.LSCH
        LAYOUT
;  GETARG
;  ------
;
;    Get the in-line argument from where HL points, and return it in DE.

GETARG  LD      E,(HL)                  ;  Load argument byte
        INC     HL                      ;  Step pointer on
        SLA     E                       ;  Shift to get carry
        JP      C,GETARG0               ;  Carry set, so more argument

        LD      D,0                     ;  Load high byte of argument
        RET                             ;  Return to caller
        
GETARG0 LD      D,(HL)                  ;  Load high byte of argument
        INC     HL                      ;  Step pointer on
        RET                             ;  Return to caller
        LAYOUT
        ALIGN

        DEFW    0                       ;  End of global list
        DEFW    G.ROOT,ROOT             ;  Root of BCPL modules
        DEFW    G.MAXG                  ;  HRG
        LAYOUT
INITE   END


