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