\ double numbers in noForth
\ 5-8-2019  Frans van der Markt/Albert Nijhof

\ endianess of double numbers
hex
DN 12345678
.S
\ the high part is on the lowest address, top of stack ( lo hi )
\ remember: the stack grows downward!
\ in memory it is ( hi lo )
2drop
decimal

\ create a double variable, name in flash, value in ram
: 2variable ( 'name' -- )
  create 2 cells allot \ reserve 2 cells for value
  does> @  \ get ram-address
;

\ store value in double variable
\ lo = low word, hi = high word
: 2!  ( lo hi adr -- )
  dup >r           \ S: lo hi adr     R: adr
  !                \ S: lo            R: adr
  r> 1 cells + !
;

\ fetch value from double variable
: 2@ ( adr -- lo hi )
  dup              \ adr adr
  @                \ adr hi
  swap 1 cells +   \ hi adr+2
  @ swap           \ lo hi
;

2variable dubbel
dn 12345678 dubbel 2! .s
dubbel 2@ d.


: D-  ( D1 D2 -- D3 ) \ D3 = D1 - D2 
  DNEGATE D+ 
;

: D>S  ( lo hi -- lo )  
\ double d to 16-bits number
\ only possible if d fits in a single number
\ if hi=0  then drop it
\ if hi=-1 and the highest bit of lo=1 then
\ drop the hi part
\ for all other cases give an overflow message 
: D>S  ( lo hi -- lo )  
  dup 0= if 
            drop ( lo )
         else dup -1 =  ( lo hi )
            if  
               swap dup hx 8000 and
               if  swap drop then  ( lo )
            else  2drop ." D>S overflow " cr abort 
            then
         then
;
 
: M/ ( d n1 -- n2 ) \ rounded division 
  dup >r 2/ s>d d+ r> fm/mod nip ( n2 = quot )  
;

noForth words handy for double numbers:
======================================
 D = double
 U = unsigned
 DU = unsigned double
 S = single
 M = mixed ( double and single)

D.  DU.  D.STR  DU.STR
*/  */MOD   FM/MOD  M*
UM/MOD  UM*
D+  DABS
?DNEGATE  DNEGATE
DU2/  D2/  D2*
2SWAP 2OVER 2NIP 2DUP 2DROP
2R@ 2R> 2>R
DU/S DU*S
========================================

\ Albert Nijhof <><> --->

Scale with double numbers:
==========================
: D*/ ( dn1 +x +y -- dn2 )
    >r >r           \ LO HI
    tuck            \ teken bewaren
    dabs            \ +LO +HI
    swap r@ um*     \ +HI lo mi
    rot  r> um*     \ lo mi mi hi
    rot 0 d+        \ lo mi hi -- 48bits tussenresultaat
    r@ um/mod       \ lo rest +HI
    r> 2>r          \ lo rest
    r> um/mod       \ Rest +LO
    nip r>          \ +LO +HI
    rot ?dnegate ;  \ LO HI -- teken terugzetten

(*
    dn1 maal x/y levert dn2 op.
    dn1 mag negatief zijn, x en y moeten positief zijn.
    Voorbeeld:
    -100000. 3000 4000 d*/ d. <rtn> -75000  OK
    Geen afrondingscorrectie.
*)

\ een variant van d*/ , waarin ook x negatief mag zijn
: D*/s ( dn1 x +y -- dn2)     
     swap dup >r abs swap D*/ 
     r> ?dnegate 
;

Store en fetch dubbele getallen
================================
\ colon definitions store en fetch
\ : 2!    ( lo hi a -- )  tuck ! cell+ ! ;
\ : 2@    ( a -- lo hi )  dup cell+ @ swap @ ;

\ code definitions
\ code 2! ( lo hi a -- )  sp )+ tos ) mov
\    sp )+ 2 tos x) mov   sp )+ tos mov   next end-code
\ code 2@ ( a -- lo hi )  tos w mov
\    w )+ tos mov   w ) sp -) mov   next end-code

hex \ comma code
code 2! ( lo hi a -- )  44B7 ,  0 ,
    44B7 ,  2 ,  4437 ,  next  end-code
code 2@ ( a -- lo hi )  4706 ,  4637 ,
    8324 ,  46A4 ,  0 ,  next  end-code

Met a op stack wordt een adres bedoeld.

Arrays om ruimte te besparen t.o.v. losse values
================================================
: ARRAY ( n ccc -- )
create cells allot immediate
does> @ char 1- hx 0F and 2* + postpone literal ;

9 array DIGP
3 array DIGT
6 arry  DIGH

\ schrijven:
decimal
 18374 digp 1 !
 -5271 digp 8 !
    25 digt 3 !

\ uitlezen:
digp 3 @ .
digt 2 @ .
digh 5 @ .

Schuiven van dubbele getallen
=============================
\ DSHIFTS -- dlshift drshift darshift
\ an -- 24jul2019

code DLSHIFT ( d1 n -- d2 )
    tos w mov   sp )+ tos mov
    #0 w .b cmp
    <>? if,
        begin,
            sp ) sp ) add   tos tos addc
            #1 w .b sub
        =? until,
    then,
next end-code

code DRSHIFT  ( d1 n -- d2 )    \ logical shift right
    tos w mov   sp )+ tos mov
    #0 w .b cmp
    <>? if,
        begin,
            #1 sr bic       \ clrc
            tos rrc   sp ) rrc
            #1 w .b sub
        =? until,
    then,
next end-code

code DARSHIFT ( d1 n -- d2 )    \ arithmical shift right
    tos w mov   sp )+ tos mov
    #0 w .b cmp
    <>? if,
        begin,
            tos rra   sp ) rrc
            #1 w .b sub
        =? until,
    then,
next end-code


\  alle shifts ( d1 n -- d2 )
hex

code DLSHIFT   4706 ,
4437 ,  9346 ,  2405 ,  54A4 ,
   0 ,  6707 ,  8356 ,  23FB ,   next  end-code

code DRSHIFT   4706 ,
4437 ,  9346 ,  2405 ,  C312 ,
1007 ,  1024 ,  8356 ,  23FB ,   next  end-code

code DARSHIFT   4706 ,
4437 ,  9346 ,  2404 ,  1107 ,
1024 ,  8356 ,  23FC ,   next  end-code

decimal

schaalroutines
==============
: scale ( x num den -- result ) \ x, num, den  >0
   >r m*
   r@ 2/ s>d d+ \ x*num + den/2
   r> fm/mod nip
   dup 32767 u> if ." Overflow! " dup . cr then
;

: USCALE ( x teller noemer -- y ) \ unsigned */ met afronding
  \ alleen gebruiken als alle stackparameters positief zijn !
  >r um* 
  r@ 0 d2/ d+  \ heft van deler erbij
  r>  2dup u< 0= if ." Overflow!" dup . cr then 
  um/mod nip 
; 
\ <----  <><> Albert Nijhof