;  __  __       _   _      __          __            _     
; |  \/  |     | | | |     \ \        / /           | |    
; | \  / | __ _| |_| |__    \ \  /\  / /___  _ __ __| |___ 
; | |\/| |/ _` | __| '_ \    \ \/  \/ // _ \| '__/ _` / __|
; | |  | | (_| | |_| | | |    \  /\  /| (_) | | | (_| \__ \
; |_|  |_|\__,_|\__|_| |_|     \/  \/  \___/|_|  \__,_|___/


; 1+           w1 -- w2                      79         "one-plus" 
; w2 is the result of adding one to w1 according to the operations of + 
plus1h  data rspoph,2
        text '1+'
plus1   data _plus1                 ; code is in high-speed ram.
                                    ; see 1-15-Initialise.a99


; 1-           w1 -- w2                      79        "one-minus" 
; w2 is the result of subtracting one from w1 according to the operation of -
sub1h   data plus1h,2
        text '1-'
sub1    data $+2
        dec *stack
        b *next


; 2+           w1 -- w2                      79         "two-plus" 
; w2 is the result of adding two to w1 according to the operation of +
plus2h  data sub1h,2
        text '2+'
plus2   data _plus2                 ; code is in high-speed ram.
                                    ; see 1-15-Initialise.a99


; CELL+        w1 -- w2+2
; adds two (the cell size) to top of stack
cellph  data plus2h,5
        text 'CELL+ '
cellp   data _plus2


; CHAR+        w1 -- w2+2
; adds two (the cell size) to top of stack
charph  data cellph,5
        text 'CHAR+ '
charp   data _plus1


; 2-           w1 -- w2                      79        "two-minus" 
; w2 is the result of subtracting two from w1 according to the operation of -
sub2h   data charph,2
        text '2-'
sub2    data _sub2                  ; code is in high-speed ram.
                                    ; see 1-15-Initialise.a99


; 2* ( x -- x<<1 )
; shifts the value on the stack left by one bit.
mul2h   data sub2h,2
        text '2*'
mul2    data $+2
mul3    a *stack,*stack             ; :-)
        b *next


; CELLS ( x1 -- x1*2 )
; returns the memory size required to hold x1 cells 
cellsh  data mul2h,5
        text 'CELLS '
cells   data mul3                   ; use the word 2* to do our work for us


; 2/           n1 -- n2                      83       "two-divide" 
; n2 is the result of arithmetically shifting n1 right one bit.  
; The sign is included in the shift and remains unchanged.
div2h   data cellsh,2
        text '2/'
div2    data $+2
        mov *stack,r8               ; TOS in r8
        sra r8,1                    ; shift right
        mov r8,*stack               ; store on stack
        b *next


; +            w1 w2 -- w3                   79             "plus" 
; w3 is the arithmetic sum of w1 plus w2.
addh    data div2h,1
        text '+ '
add     data _add                   ; code is in high-speed ram.
                                    ; see 1-15-Initialise.a99


; -            w1 w2 -- w3                   79            "minus" 
; w3 is the result of subtracting w2 from w1.
subh    data addh,1
        text '- '
sub     data _sub                   ; code is in high-speed ram.
                                    ; see 1-15-Initialise.a99


; *            w1 w2 -- w3                   79            "times" 
; w3 is the least-significant 16 bits of the arithmetic product of w1 times w2.
mulh    data subh,1
        text '* '
mul     data _mul                   ; code is in high-speed ram.
                                    ; see 1-15-Initialise.a99


; */           n1 n2 n3 -- n4                83     "times-divide" 
; n1 is first multiplied by n2 producing an intermediate 32-bit result.
; n4 is the floor of the quotient of the intermediate 32-bit result divided by
; the divisor n3.
; The product of n1 times n2 is maintained as an intermediate 32-bit result for
; greater precision than the otherwise equivalent sequence: n1 n2 * n3 / .
; An error condition results if the divisor is zero or if the quotient falls
; outside of the range {-32,768..32,767}. 
sslash  data mulh,2
        text '*/'
        data docol
        data ssm                    ; */MOD
        data nip                    ; discard remainder
        data exit
        b *next


; UM*          u1 u2 -- ud                   83        "u-m-times"
; ud is the unsigned-double product of u1 times u2.  
; All values and arithmetic are unsigned.
; high word of ud to top of stack
umsh    data sslash,3
        text 'UM* '
        data $+2
        mov *stack,r0               ; get u2
        mov @2(stack),r1            ; get r1
        mpy r0,r1                   ; perform unsigned multiply
        mov r1,*stack               ; push high word
        mov r2,@2(stack)            ; push low word
        b *next


; /MOD         n1 n2 -- n3 n4                83       "divide-mod" 
; n3 is the remainder and n4 the floor of the quotient of n1 divided by the 
; divisor n2.
; n3 has the same sign as n2 or is zero.
; An error condition results if the divisor is zero or if the quotient falls 
; outside of the range {-32,768..32,767}.
smodh   data umsh,4
        text '/MOD'
smod    data $+2
        mov *stack,r0               ; get n2 (divisor)
        seto r1                     ; dividend is 32-bit, assume negative 
        mov @2(stack),r2            ; get n1 (dividend)
        jlt smod1                   ; if negative then skip
        clr r1                      ; otherwise it's positive. clear upper word
smod1   bl @sidiv                   ; do a signed division
        mov r1,*stack               ; push quotient
        mov r2,@2(stack)            ; push remainder
        b *next


; */MOD        n1 n2 n3 -- n4 n5             83 "times-divide-mod" 
; n1 is first multiplied by n2 producing an intermediate 32-bit result.
; n4 is the remainder and n5 is the floor of the quotient of the intermediate
; 32-bit result divided by the divisor n3.  A 32-bit intermediate product is
; used as for */ .  n4 has the same sign as n3 or is zero.  An error condition
; results if the divisor is zero or if the quotient falls outside of the range
; {-32,768..32,767}.  
ssmh    data smodh,5
        text '*/MOD '
ssm     data $+2
        mov @2(stack),r0            ; get n2
        mov @4(stack),r1            ; get n1
        bl @simul                   ; signed multiply 
        mov *stack+,r0              ; pop n3 to r0 (divisor)
        bl @sidiv                   ; signed divide
        mov r1,*stack               ; push quotient
        mov r2,@2(stack)            ; push remainder
        b *next


; UM/MOD       ud u1 -- u2 u3                83   "u-m-divide-mod" 
; u2 is the remainder and u3 is the floor of the quotient after dividing ud by
; the divisor u1.  All values and arithmetic are unsigned.  An error condition
; results if the divisor is zero or if the quotient lies outside the range
umodh   data ssmh,6
        text 'UM/MOD'
usmod   data $+2
        mov *stack+,r0              ; pop u1 to r0 (divisor)
        mov *stack,r1               ; high word of ud to r1
        mov @2(stack),r2            ; low word of ud to r2
        div r0,r1                   ; perform unsigned division
        mov r1,*stack               ; push quotient
        mov r2,@2(stack)            ; push remainder
        b *next


; /            n1 n2 -- n3                   83           "divide" 
; n3 is the floor of the quotient of n1 divided by the divisor n2. 
; An error condition results if the divisor is zero or if the quotient falls 
; outside of the range {-32,768..32,767}.
sdivh   data umodh,1
        text '/ '
sdiv    data docol,smod,nip,exit


; MOD          n1 n2 -- n3                   83                   
; n3 is the remainder after dividing n1 by the divisor n2.
; n3 has the same sign as n2 or is zero.
; An error condition results if the divisor is zero or if the quotient falls
; outside of the range {-32,768..32,767}.  
modh    data sdivh,3
        text 'MOD '
mod     data docol,smod,drop,exit


; NEGATE       n1 -- n2                      79                   
; n2 is the two's complement of n1, i.e, the difference of zero less n1.
negh    data modh,6
        text 'NEGATE'
neg_    data $+2
neg2    neg *stack                  ; negate the word on TOS
        b *next


; ABS          n -- u                        79         "absolute" 
; u is the absolute value of n.  If n is -32,768 then u is the same value.
; STATUS: TESTED OK 13 APR 2009
absh    data negh,3
        text 'ABS '
abs_    data $+2
        abs *stack                  ; compute abs of the word on TOS
        b *next


; MIN          n1 n2 -- n3                   79              "min" 
; n3 is the lesser of n1 and n2 according to the operation of < .
minh    data absh,3
        text 'MIN '
min     data $+2
        c *stack+,*stack            ; compare n2 and n1 (and pop n2)
        jlt keepn2                  ; keep n2 if it's lower
        b *next                     ; otherwise keep n1
keepn2  mov @-2(stack),*stack       ; keep n2
        b *next


; MAX          n1 n2 -- n3                   79              "max" 
; n3 is the greater of n1 and n2 according to the operation of > .
maxh    data minh,3
        text 'MAX '
max     data $+2
        c *stack+,*stack            ; compare n2 and n1 (and pop n2)
        jgt keepn2                  ; keep n2 if it's higher
        b *next                     ; otherwise keep n1



; Floored math subroutines:

; Signed divide using Floored Integer Division
; Divides a 32 bit value in r1 and r2 by a 16 bit value in r0
; Inputs:
;   r0=divisor
;   r1=upper 16 bits dividend
;   r2=lower 16 bits dividend
; Outputs:
;   r1=16-bit quotient
;   r2=16-bit remainder
sidiv   ; set flags to reflect signs of operands, and force operands positive...
        clr r14                     ; sign of divisor (-1=negative sign)
        clr r15                     ; sign of dividend (-1=negative sign)
        abs r0                      ; force divisor positive
        jgt sdiv1                   ; if positive then jump
        seto r14                    ; flag negative divisor
sdiv1   mov r1,r1                   ; check sign of dividend
        jeq sdiv2
        jgt sdiv2                   ; if positive then jump
        inv r1                      ; otherwise negate the dividend
        neg r2                      ;
        seto r15                    ; and flag dividend as negative
    ; perform division...
sdiv2   mov r2,r8                   ; store a copy of the dividend
        div r0,r1                   ; perform the division. r1=quot, r2=rem
    ; check if floor should be applied... (signs different and remainder<>0)
sdiv3   c r14,r15                   ; compare signs of dividend and divisor
        jeq signdo                  ; if same then jump
        neg r1                      ; negate quotient
        mov r2,r2                   ; check remainder
        jeq signdo                  ; jump if no remainder
    ; apply floor rule...
floor   dec r1                      ; floor the quotient
        ; compute remainder remainder=(divisor*quotient)-dividend
        mov r1,r9                   ; get floored quotient
        abs r9                      ; force positive
        mpy r0,r9                   ; divisor*quotient (result in r10)
        s r8,r10                    ; subtract dividend
        mov r10,r2                  ; overwrite original remainder
    ; apply sign of divisor to remainder
signdo  mov r14,r14                 ; check sign of divisor
        jlt floor1                  ; if negative then jump
        rt                          ; otherwise we're done
floor1  neg r2                      ; remainder takes sign of divisor
        rt                          ; done


; Signed Multiply
; multiplies two signed 16-bit values, n1 & n2, giving a signed 32-bit product
; Inputs:
;   r0=n1
;   r1=n2
; Outputs:
;   r1=product, upper 16-bits
;   r2=product, lower 16-bits
    ; check if signs of inputs are different
simul   mov r0,r6                   ; copy n1
        xor r1,r6                   ; check signs (r6=negative if signs differ)
        abs r0                      ; force positive
        abs r1                      ; force positive
        mpy r0,r1                   ; n1*n2 (product in r1 & r2)
    ; if input signs were different then negate results
        mov r6,r6                   ; check signs flag
        jgt simul1                  ; if same then leave positive
        inv r1                      ; invert high word
        neg r2                      ; negate low word
        jnc simul1                  ; skip if no carry
        inc r1                      ; add 1 to high word to compensate for carry
simul1  rt