( fix32.tal )
( )
( 32-bit fixed point using 1000, i.e. 0x03e8, as a denominator. )

%POP4 { POP2 POP2 }
%POP8 { POP2 POP2 POP2 POP2 }
%DENOM16 { #03e8 }
%DENOM32 { #0000 #03e8 }

@x32-eq ( x/** y/** -> bool^ ) !u32-eq
@x32-ne ( x/** y/** -> bool^ ) !u32-ne

@x32-is-zero ( x/** -> bool^ ) !u32-is-zero
@x32-non-zero ( x/** -> bool^ ) !u32-non-zero
@x32-is-positive ( x/** -> bool^ ) POP2 #8000 LTH2 JMP2r
@x32-is-negative ( x/** -> bool^ ) POP2 #7fff GTH2 JMP2r

@x32-from-u8 ( x^ -> x/** )
    #0000 ROT OVR SWP DENOM32 !u32-mul

@x32-from-u16 ( x* -> x/** )
    #0000 SWP2 DENOM32 !u32-mul

@x32-from-u32 ( x** -> x/** )
    DENOM32 !u32-mul

@x32-signed-op ( x** y** f* -> f[x,y]** )
    STH2 LIT2r 0001                      ( x** y** [f* 0^ 1^] )
    OVR2 #8000 LTH2 ?{ u32-negate SWPr } ( x** y** [f* ab*] )
    ROT2 STH2 ROT2 STH2r                 ( y** x** [f* ab*] )
    OVR2 #8000 LTH2 ?{ u32-negate SWPr } ( y** x** [f* cd*] )
    ROT2 STH2 ROT2 STH2r SWP2r           ( x** y** [cd* f*] )
    STH2r JSR2                           ( f[x,y]** [cd*] )
    NIPr STHr ?{ u32-negate } JMP2r      ( z** )

@x32-prepare-cmp ( x/** y/** -> x/** y/** xp^ yp^ )
    OVR2 #8000 LTH2 ,&yp STR STH2 STH2
    OVR2 #8000 LTH2 ,&xp STR STH2r STH2r
    LIT2 [ &xp $1 &yp $1 ] JMP2r

( TODO: test these implementations )
@x32-lt-old ( x** y** -> x<y^ )
    STH2 SWP2 STH2 EOR2k #8000 LTH2 ?{    ( ; do x and y have different signs? )
        POP2r POP2r POP2 #8000 GTH2 JMP2r ( ; signs differ, is x negative? )
    } GTH2r STHr ?{                       ( ; same signs, is xlo < ylo? )
        LTH2 JMP2r                        ( ; no, is xhi < yhi? )
    } GTH2 #00 EQU JMP2r                  ( ; yes, is xhi <= yhi? )

( TODO: test these implementations )
@x32-gt-old ( x** y** -> x<y^ )
    STH2 SWP2 STH2 EOR2k #8000 LTH2 ?{    ( ; do x and y have different signs? )
        POP2r POP2r POP2 #8000 LTH2 JMP2r ( ; signs differ, is x positive? )
    } LTH2r STHr ?{                       ( ; same signs, is xlo > ylo? )
        GTH2 JMP2r                        ( ; no, is xhi > yhi? )
    } LTH2 #00 EQU JMP2r                  ( ; yes, is xhi >= yhi? )

@x32-lt ( x/** y/** -> bool^ )
    x32-prepare-cmp NEQk ?{ POP2 !u32-lt } LTH STH POP8 STHr JMP2r

@x32-gt ( x/** y/** -> bool^ )
    x32-prepare-cmp NEQk ?{ POP2 !u32-gt } GTH STH POP8 STHr JMP2r

@x32-lteq ( x/** y/** -> bool^ )
    x32-prepare-cmp NEQk ?{ POP2 !u32-lteq } LTH STH POP8 STHr JMP2r

@x32-gteq ( x/** y/** -> bool^ )
    x32-prepare-cmp NEQk ?{ POP2 !u32-gteq } GTH STH POP8 STHr JMP2r

( TODO: support saturation at +/- infinity )
( TODO: support signed operations )

@x32-add ( x/** y/** -> z/** )
    !u32-add

@x32-sub ( x/** y/** -> z/** )
    !u32-sub

@x32-negate ( x/** y/** -> z/** )
    !u32-negate

( multiply a fixed point number by an unsigned integer )
@x32-scaled-mul32 ( x/** y** -> z/** )
    !u32-mul

( multiply a fixed point number by an unsigned integer )
@x32-scaled-mul16 ( x/** y* -> z/** )
    !u32-mul16

@x32-scaled-div32 ( x/** y** -> z/** )
    !u32-div

@x32-mul ( x/** y/** -> z/** )
    ;x32-mul-unsigned !x32-signed-op

( [x * y]/1000 = floor[x/1000] + [[x%1000]*y]/1000 )
@x32-mul-unsigned ( x/** y/** -> z/** )
    STH2 STH2 DENOM32           ( x** 1000** [ylo* yhi*] )
    u32-divmod                  ( q=x/1000** r=x%1000** [ylo* yhi*] )
    STH2kr OVR2r STH2r u32-mul  ( q** ry** [ylo* yhi*] )
    DENOM32 u32-divmod          ( q** rq=ry/1000** rr=ry%1000** [ylo* yhi*] )
    NIP2 ,&r1 STR2              ( q** rq** [ylo* yhi*] ; <-rr1 )
    ROT2 STH2 ROT2 STH2r        ( ry/1000** q** [ylo* yhi*] )
    STH2r STH2r u32-mul         ( ry/1000** qy** )
    u32-add                     ( z=qy+ry/1000** )
    DUP2 #0001 AND2 STH2        ( z** [odd*] )
    #0000 LIT2 [ &r1 $2 ]       ( z** rr** [odd*] )
    STH2r ADD2 #01f3 ADD2       ( z** rr+odd+499** )
    DENOM32 u32-div             ( z** b=rr+odd+499/1000** )
    !u32-add                    ( z+b** )

@x32-div ( x/** y/** -> z/** )
    ;x32-div-unsigned !x32-signed-op

( [x * 1000]/y = floor[x/y]*1000 + [[x%y]*1000]/y )
@x32-div-unsigned ( x/** y/** -> z/** )
    STH2k OVR2 STH2                 ( x/** y/** [ylo* yhi*] )
    u32-divmod                      ( q=x/y** r=x%y** [ylo* yhi*] )
    DENOM32 u32-mul                 ( q** r1000** [ylo* yhi*] )
    STH2kr OVR2r STH2r u32-divmod   ( q** rq** rr** [ylo* yhi*] )
    ,&r1 STR2 ,&r0 STR2             ( q** rq** ; <-rr0 <-rr1 [ylo* yhi*] )
    ROT2 STH2 ROT2 STH2r            ( rq** q** [ylo* yhi*] )
    DENOM32 u32-mul                 ( rq** q1000** [ylo* yhi*] )
    u32-add                         ( z=rq+q1000** [ylo* yhi*] )
    DUP ,&e STR                     ( z** ; e<-z3^ [ylo* yhi*] )
    LIT2 [ &r0 $2 ] LIT2 [ &r1 $2 ] ( z** rr** [ylo* yhi*] )
    LIT [ &e $1 ] #01 AND           ( z** rr** e^ )
    #00 SWP #0000 SWP2              ( z** rr** e** [ylo* yhi*] )
    u32-add                         ( z** w=rr+e** [ylo* yhi*] )
    STH2kr OVR2r STH2r              ( z** w** y** [ylo* yhi*] )
    #0000 #0001 u32-sub             ( z** w** y-1** [ylo* yhi*] )
    #01 u32-rshift u32-add          ( z** v=w+y-1/2** [ylo* yhi*] )
    STH2r STH2r u32-div !u32-add    ( z+v/y** )

( print an x32 number to stdout )
@x32-emit ( x/** -> )
    ;x32-emit/draw-ch !x32-draw
    &draw-ch ( c^ -> ) #18 DEO JMP2r

( draw an x32 number using the given character-drawing subroutine )
@x32-draw ( x/** draw-char* -> )
    ,&f STR2 LITr 00             ( x** [0^] )
    &loop                        ( x1** [... count^] )
        #0000 #000a u32-divmod   ( q** r** )
        NIP2 NIP INCr            ( q** r^ [... count+1^] )
        LIT "0 ADD STH SWPr      ( q** [... c^ count+1^] )
        STHkr #03 NEQ ?&next     ( q** [... c^ count+1^] )
        INCr LITr ". SWPr        ( q** [... c^ dot^ count+2^] )
    &next                        ( q** [... count+n^ )
        OVR2 OVR2                ( q** q** [... count+n^] )
        u32-non-zero ?&loop      ( q** [... count+n^] )
        POP2 POP2                ( [... count+n^] )
    &pad                         ( [... count+n^] )
        STHkr #04 GTH ?&unroll   ( [... count+n^] )
        STHkr #03 NEQ ?{ INCr LITr ". SWPr }
        INCr LITr "0 SWPr !&pad  ( [... 0^ count+n+1^] )
    &unroll                      ( [... x0^] )
        STHr                     ( x0^ [...] )
    &uloop                       ( x^ [... z^] )
        STHr LIT2 [ &f $2 ] JSR2 ( x^ [...] ; call f[z] )
        #01 SUB DUP ?&uloop      ( x-1^ [...] )
    POP JMP2r                    ( )

~math32.tal