mcopy exp.macros
****************************************************************
*
*  function lshr(x,y: longint): longint;
*
*  Inputs:
*        num1 - number to shift
*        num2 - # bits to shift by
*
*  Outputs:
*        A - result
*
****************************************************************
*
lshr     start exp

         subroutine (4:num1,4:num2),0

         lda   num2+2                   if num2 < 0 then
         bpl   lb2
         cmp   #$FFFF                     shift left
         bne   zero
         ldx   num2
         cpx   #-34
         blt   zero
lb1      asl   num1
         rol   num1+2
         inx
         bne   lb1
         bra   lb4
zero     stz   num1                       (result is zero)
         stz   num1+2
         bra   lb4
lb2      bne   zero                     else shift right
         ldx   num2
         beq   lb4
         cpx   #33
         bge   zero
lb3      lsr   num1+2
         ror   num1
         dex
         bne   lb3

lb4      lda   0                        fix stack and return
         sta   num2
         lda   2
         sta   num2+2

         return 4:num1
         end

****************************************************************
*
*  function udiv(x,y: longint): longint;
*
*  Inputs:
*        num1 - numerator
*        num2 - denominator
*
*  Outputs:
*        ans - result
*
****************************************************************
*
udiv     start exp
ans      equ   0                        answer
rem      equ   4                        remainder

         subroutine (4:num1,4:num2),8
;
;  Initialize
;
         stz   rem                      rem = 0
         stz   rem+2
         move4 num1,ans                 ans = num1
         lda   num2                     check for division by zero
         ora   num2+2
         beq   dv9

         lda   num2+2                   do 16 bit divides separately
         ora   ans+2
         beq   dv5
;
;  32 bit divide
;
         ldy   #32                      32 bits to go
dv3      asl   ans                      roll up the next number
         rol   ans+2
         rol   ans+4
         rol   ans+6
         sec                            subtract for this digit
         lda   ans+4
         sbc   num2
         tax
         lda   ans+6
         sbc   num2+2
         bcc   dv4                      branch if minus
         stx   ans+4                    turn the bit on
         sta   ans+6
         inc   ans
dv4      dey                            next bit
         bne   dv3
         bra   dv9                      go do the sign
;
;  16 bit divide
;
dv5      lda   #0                       initialize the remainder
         ldy   #16                      16 bits to go
dv6      asl   ans                      roll up the next number
         rol   a
         sec                            subtract the digit
         sbc   num2
         bcs   dv7
         adc   num2                     digit is 0
         dey
         bne   dv6
         bra   dv8
dv7      inc   ans                      digit is 1
         dey
         bne   dv6

dv8      sta   ans+4                    save the remainder
;
;  Return the result
;
dv9      return 4:ans                   move answer
         end

****************************************************************
*
*  function uge(x,y: longint): cboolean;
*
****************************************************************
*
uge      start exp
result   equ   0

         subroutine (4:x,4:y),4

         stz   result
         stz   result+2
         lda   x+2
         cmp   y+2
         bne   lb1
         lda   x
         cmp   y
lb1      blt   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function ugt(x,y: longint): cboolean;
*
****************************************************************
*
ugt      start exp
result   equ   0

         subroutine (4:x,4:y),4

         stz   result
         stz   result+2
         lda   x+2
         cmp   y+2
         bne   lb1
         lda   x
         cmp   y
lb1      ble   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function ule(x,y: longint): cboolean;
*
****************************************************************
*
ule      start exp
result   equ   0

         subroutine (4:x,4:y),4

         stz   result
         stz   result+2
         lda   x+2
         cmp   y+2
         bne   lb1
         lda   x
         cmp   y
lb1      bgt   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function ult(x,y: longint): cboolean;
*
****************************************************************
*
ult      start exp
result   equ   0

         subroutine (4:x,4:y),4

         stz   result
         stz   result+2
         lda   x+2
         cmp   y+2
         bne   lb1
         lda   x
         cmp   y
lb1      bge   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function umod(x,y: longint): longint;
*
*  Inputs:
*        num1 - numerator
*        num2 - denominator
*
*  Outputs:
*        ans+4 - result
*
****************************************************************
*
umod     start exp
ans      equ   0                        answer
rem      equ   4                        remainder

         subroutine (4:num1,4:num2),8
;
;  Initialize
;
         stz   rem                      rem = 0
         stz   rem+2
         move4 num1,ans                 ans = num1
         lda   num2                     check for division by zero
         ora   num2+2
         beq   dv9

         lda   num2+2                   do 16 bit divides separately
         ora   ans+2
         beq   dv5
;
;  32 bit divide
;
         ldy   #32                      32 bits to go
dv3      asl   ans                      roll up the next number
         rol   ans+2
         rol   ans+4
         rol   ans+6
         sec                            subtract for this digit
         lda   ans+4
         sbc   num2
         tax
         lda   ans+6
         sbc   num2+2
         bcc   dv4                      branch if minus
         stx   ans+4                    turn the bit on
         sta   ans+6
         inc   ans
dv4      dey                            next bit
         bne   dv3
         bra   dv9                      go do the sign
;
;  16 bit divide
;
dv5      lda   #0                       initialize the remainder
         ldy   #16                      16 bits to go
dv6      asl   ans                      roll up the next number
         rol   a
         sec                            subtract the digit
         sbc   num2
         bcs   dv7
         adc   num2                     digit is 0
         dey
         bne   dv6
         bra   dv8
dv7      inc   ans                      digit is 1
         dey
         bne   dv6

dv8      sta   ans+4                    save the remainder
;
;  Return the result
;
dv9      return 4:ans+4                 move answer
         end

****************************************************************
*
*  function umul(x,y: longint): longint;
*
*  Inputs:
*        num2,num1 - operands
*
*  Outputs:
*        ans - result
*
****************************************************************
*
umul     start exp
ans      equ   0                        answer

         subroutine (4:num1,4:num2),8
;
;  Initialize the sign and split on precision.
;
         stz   ans+4                    set up the multiplier
         stz   ans+6
         lda   num1
         sta   ans
         lda   num1+2
         sta   ans+2
         beq   ml3                      branch if the multiplier is 16 bit
;
;  Do a 32 bit by 32 bit multiply.
;
         ldy   #32                      32 bit multiply
         jsr   ml1
         brl   ml7

ml1      lda   ans                      SYSS1*SYSS1+2+SYSS1+2 -> SYSS1,SYSS1+2
         lsr   a
         bcc   ml2
         clc                            add multiplicand to the partial product
         lda   ans+4
         adc   num2
         sta   ans+4
         lda   ans+6
         adc   num2+2
         sta   ans+6
ml2      ror   ans+6                    shift the interim result
         ror   ans+4
         ror   ans+2
         ror   ans
         dey                            loop til done
         bne   ml1
         rts
;
;  Do and 16 bit by 32 bit multiply.
;
ml3      lda   num2+2                   branch if 16x16 is possible
         beq   ml4

         ldy   #16                      set up for 16 bits
         jsr   ml1                      do the multiply
         lda   ans+2                    move the answer
         sta   ans
         lda   ans+4
         sta   ans+2
         bra   ml7
;
;  Do a 16 bit by 16 bit multiply.
;
ml4      ldy   #16                      set the 16 bit counter
         ldx   ans                      move the low word
         stx   ans+2
ml5      lsr   ans+2                    test the bit
         bcc   ml6                      branch if the bit is off
         clc
         adc   num2
ml6      ror   a                        shift the answer
         ror   ans
         dey                            loop
         bne   ml5
         sta   ans+2                    save the high word
;
;  Return the result.
;
ml7      return 4:ans                   fix the stack
         end

****************************************************************
*
*  procedure umul64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
umul64   start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~UMUL8
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure udiv64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
udiv64   start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~UDIV8
         pl8   [x]
         pla
         pla
         pla
         pla
         
         return
         end

****************************************************************
*
*  procedure div64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
div64    start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~CDIV8
         pl8   [x]
         pla
         pla
         pla
         pla
         
         return
         end

****************************************************************
*
*  procedure umod64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
umod64   start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~UDIV8
         pla
         pla
         pla
         pla
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure rem64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
rem64    start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~CDIV8
         pla
         pla
         pla
         pla
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure add64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
add64    start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~ADD8
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure sub64 (var x: longlong; y: longlong);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
sub64    start exp

         subroutine (4:x,4:y),0

         ph8   [x]
         ph8   [y]
         jsl   ~SUB8
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure shl64 (var x: longlong; y: integer);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
shl64    start exp

         subroutine (4:x,2:y),0

         ph8   [x]
         lda   y
         jsl   ~SHL8
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure ashr64 (var x: longlong; y: integer);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
ashr64   start exp

         subroutine (4:x,2:y),0

         ph8   [x]
         lda   y
         jsl   ~ASHR8
         pl8   [x]
         
         return
         end

****************************************************************
*
*  procedure lshr64 (var x: longlong; y: integer);
*
*  Inputs:
*        x,y - operands
*
*  Outputs:
*        x - result
*
****************************************************************
*
lshr64   start exp

         subroutine (4:x,2:y),0

         ph8   [x]
         lda   y
         jsl   ~LSHR8
         pl8   [x]
         
         return
         end

****************************************************************
*
*  function ult64(a,b: longlong): integer;
*
****************************************************************
*
ult64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      bge   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function uge64(a,b: longlong): integer;
*
****************************************************************
*
uge64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      blt   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function ule64(a,b: longlong): integer;
*
****************************************************************
*
ule64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      bgt   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function ugt64(a,b: longlong): integer;
*
****************************************************************
*
ugt64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      ble   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function slt64(a,b: longlong): integer;
*
****************************************************************
*
slt64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         eor   [b],y
         bpl   lb0
         lda   [b],y
         cmp   [a],y
         bra   lb1

lb0      lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      bge   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function sge64(a,b: longlong): integer;
*
****************************************************************
*
sge64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         eor   [b],y
         bpl   lb0
         lda   [b],y
         cmp   [a],y
         bra   lb1

lb0      lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      blt   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function sle64(a,b: longlong): integer;
*
****************************************************************
*
sle64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         eor   [b],y
         bpl   lb0
         lda   [b],y
         cmp   [a],y
         bra   lb1

lb0      lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      bgt   lb2
         inc   result

lb2      return 2:result
         end

****************************************************************
*
*  function sgt64(a,b: longlong): integer;
*
****************************************************************
*
sgt64    start exp
result   equ   0

         subroutine (4:a,4:b),2

         stz   result
         ldy   #6
         lda   [a],y
         eor   [b],y
         bpl   lb0
         lda   [b],y
         cmp   [a],y
         bra   lb1

lb0      lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         dey
         dey
         lda   [a],y
         cmp   [b],y
         bne   lb1
         lda   [a]
         cmp   [b]
lb1      ble   lb2
         inc   result

lb2      return 2:result
         end