dmath.f (2807B) - raw
1 \ mostly taken from: 2 \ https://web.archive.org/web/20181118215700/http://excamera.com/files/j1demo/docforth/nuc.fs.html 3 4 : d= ( a b c d -- f ) 5 >r \ a b c 6 rot xor \ b a^c 7 swap r> xor \ a^c b^d 8 or 0= ; 9 : d+ ( augend . addend . -- sum . ) 10 rot + >r ( augend addend) 11 over + ( augend sum) 12 dup rot ( sum sum augend) 13 u< if ( sum) 14 r> 1+ 15 else 16 r> 17 then ; ( sum . ) 18 : s>d dup 0< if -1 else 0 then ; 19 : dnegate 20 invert swap invert swap 21 1 0 d+ ; 22 : dabs ( d -- ud ) dup 0< if dnegate then ; 23 : d- dnegate d+ ; 24 : d< \ ( al ah bl bh -- flag ) 25 rot \ al bl bh ah 26 2dup = 27 if 28 2drop u< 29 else 30 2nip > 31 then ; 32 : d0= or 0= ; 33 : d0< 0 0 d< ; 34 : d2* 2dup d+ ; 35 : d2/ dup 31 lshift >r 2/ swap 2/ r> or swap ; 36 : dmax 2over 2over d< if 2swap then 2drop ; 37 : dmin 2over 2over d< 0= if 2swap then 2drop ; 38 : tf if -1 else 0 then ; 39 40 variable scratch 41 : um* ( u1 u2 -- ud ) 42 scratch ! 43 0 0 44 16 0 do 45 2dup d+ 46 rot dup 0< if 47 2* -rot 48 scratch @ 0 d+ 49 else 50 2* -rot 51 then 52 loop 53 rot drop ; 54 : abssgn ( a b -- |a| |b| negf ) 55 2dup xor 0< tf >r abs swap abs swap r> ; 56 : m* abssgn >r um* r> if dnegate then ; 57 : divstep 58 ( divisor dq hi ) 59 2* 60 over 0< if 1+ then 61 swap 2* swap 62 rot ( dq hi divisor ) 63 2dup >= if 64 tuck ( dq divisor hi divisor ) 65 - 66 swap ( dq hi divisor ) 67 rot 1+ ( hi divisor dq ) 68 rot ( divisor dq hi ) 69 else 70 -rot 71 then ; 72 73 : um/mod ( ud u1 -- u2 u3 ) 74 -rot 16 0 do divstep loop 75 rot drop swap ; 76 : sm/rem ( d n -- r q ) ( symmetric ) 77 over >r >r dabs r@ abs um/mod 78 r> r@ xor 0< if negate then r> 0< if >r negate r> then ; 79 : */mod >r m* r> sm/rem ; 80 : */ */mod nip ; 81 : t2* over >r >r d2* r> 2* r> 0< tf 1 and + ; 82 83 variable divisor 84 : m*/mod 85 divisor ! 86 tuck um* 2swap um* ( hi. lo. ) 87 ( m0 h l m1 ) 88 swap >r 0 d+ r> ( m h l ) 89 -rot ( l m h ) 90 32 0 do 91 t2* 92 dup divisor @ >= if 93 divisor @ - 94 rot 1+ -rot 95 then 96 loop ; 97 : m*/ ( d1 n1 +n2 -- d2 ) m*/mod drop ; 98 99 \ double printing 100 : (digit) ( u -- c ) 9 over < 7 and + [char] 0 + ; 101 : (d#) ( d1 -- d2 ) 102 0 base @ um/mod >r base @ um/mod swap (digit) hold r> ; 103 : d#s ( d1 -- d2 ) begin (d#) 2dup or 0= until ; 104 : d#> ( d -- a u ) drop #> ; 105 : (d.) ( d -- a n ) 2dup dabs <# d#s 2swap nip sign d#> ; 106 : d. ( n -- ) (d.) type space ;