fl { flaotmath Tranlated FloatMath.spin to PropForth Translation do Not Completed yet. Maybe,there are bugs. floating point Sign bit31 (1bi) Exponent bit30 - bit23 (8bits) Mantissa Bit22 - bit0 (23bits) PropForth5.2 13/09/2012 13:25:54 } hex \ rashift ( n1 n2 -- n3) \ n3 = n1 shifted right arithmetically n2 bits : rashift _xasm2>1 h077 _cnip ; : bit_enc 80000000 20 0 do 2dup and if i 20 seti else 1 rshift then loop rot2 2drop 20 swap - ; \ Pack floating-point from (sign, exponent, mantissa) \ ( n1 n2 n3 -- n4 ) n1:sign n2:exponent n3:mantissa \ n4:floating-point(Long) sign:1bit exponent:8bits mantissa:23bits : pack dup if dup bit_enc 21 swap - \ determine magnitude of mantissa dup >r lshift \ msb-justify mantissa without leading 1 swap 3 r> - + \ adjust exponent \ (sign mantissa exp) swap 100 + \ push mantissa and round up mantissa by 1/2 lsb dup >r FFFFFF00 and 0= \ if rounding overflow if 1+ then \ increment exponent \ bias and limit exponent 7F + dup FF > if drop FF else dup FFFFFFE9 < \ dup -17 < if drop FFFFFFE9 \ drop -17 then then r> swap \ pop mantissa dup 1 < \ if exponent < 1 if swap 1 rshift 80000000 + \ replace leading 1 swap negate rshift \ shift mantissa down by exponent 0 \ exponent is now 0 then \ (sign mantissa exp) 17 lshift \ exponent swap 9 rshift \ mantissa or swap 1F lshift \ sign or then ; \ Unpack floating-point into (sign, exponent, mantissa) \ ( n1 -- n2 n3 n4 ) n1:floating-point(Long) sign:1bit exponent:8bits mantissa:23bits \ n2:sign n3:exponent n3:mantissa : unpack dup 1F rshift \ unpack sign over 1 lshift 18 rshift \ unpack exponent rot 7FFFFF and \ unpack mantissa swap dup 0> if \ if exponent > 0 swap 6 lshift 20000000 or \ bit29-justify mantissa with leading 1 \ (sign exponent msntissa) else over bit_enc 17 - swap drop dup 7 swap - rot swap lshift \ bit29-justify mantissa \ (sign exponent msntissa) then swap 7F - swap \ (sign exponent msntissa) ; \ Convert integer to float \ ( n1 -- n2 ) n1:integer n2:float : ffloat dup \ if 0, nothing do if dup abs \ Get absolute value swap 1F rshift \ Get sign swap dup bit_enc 1- \ Get exponent dup rot swap 1F swap - lshift \ msb-justify mantissa 2 rshift \ bit29-justify mantissa \ ( n1 n2 n3 ) n1:sign n2:exponent n3:mantissa pack then ; \ Convert float to rounded/truncated integer \ ( n1 n2 -- n3 ) n1:float n2:round(1) trancate(0) n3:integer : integer swap unpack \ ( n1 n2 n3 ) n1:sign n2:exponent n3:mantissa over -1 1E between \ if exponent not -1..30, result 0 if 2 lshift \ msb-justify mantissa swap 1E swap - rshift \ shift down to 1/2-lsb rot + \ round (1) or truncate (0) 1 rshift \ shift down to lsb swap 1 = if negate then \ handle negation else 2drop 2drop 0 then ; \ Convert float to rounded integer \ ( n1 -- n2) n1:float n2:integer : fround 1 integer ; \ Convert float to truncated integer \ ( n1 -- n2) n1:float n2:integer : ftrunc 0 integer ; \ Negate \ ( n1 -- n2 ) n1:float n2: -float : fneg 80000000 xor ; \ Absolute float \ ( n1 -- n2 ) n1:float n2: abs(float) : fabs 7FFFFFFF and ; \ variable work variable m \ Divide flaot1 by float2 \ (n1 n2 -- n3 ) n1:float1 n2:float2 n3:result \ ( n1 n2 -- n2 ) : fdiv unpack \ unpack float2 (sign exponent mantissa) >r >r >r \ push unpacked value unpack \ unpack float1 (sign exponent mantissa) rot r> xor \ float1(sign) xor float2(sign) rot r> - \ float1(exponent) - float2(exponent) \ rot r> work L! rot r> m L! 0 \ initial result 1E 0 do \ divide mantissa 1 lshift swap m L@ 2dup >= if - swap 1+ swap else drop then 1 lshift swap loop nip pack ; \ Multiply float1 and float2 \ ( n1 n2 -- n2 ) n1:float1 n2:float2 n3:multiply float1 and float2 : fmult unpack \ unpack float2 (sign exponent mantissa) >r >r >r \ push unpacked value unpack \ unpack float1 (sign exponent mantissa) rot r> xor \ Get sign float1(sign) xor float2(sign) rot r> + \ Get exponent float1(exponent) + float2(exponent) rot r> um* 3 lshift \ Get mantissa nip pack ; wvariable e \ Add float1 and float2 \ ( n1 n2 -- n2 ) n1:float1 n2:float2 n3:sum : fadd unpack \ unpack float2 (sign exponent mantissa) m L! \ mantissa(float2) e W! \ exponent(float2) >r unpack \ unpack float1 (sign exponent mantissa) r> \ sign(float2) 1 = if m L@ negate m L! then \ if sign=1, negate mantissa(float2) rot 1 = if negate then \ if sign=1, negate mantissa(float1) swap e W@ 2dup - abs 1F min >r \ push result swap dup rot > if m L@ r> rashift else e W@ nip swap r> rashift swap m L@ then rot + dup 0< if 1 else 0 then \ Get sign rot2 abs \ abs mantissa pack ; \ Subtract float2 from float1 \ ( n1 n2 -- n2 ) n1:float1 n2:float2 n3:diff : fsub fneg fadd ; { \ Compute square root of float \ ( n1 -- n2 ) n1:float n2: root of float : fsqr ; decimal : 1usec clkfreq 1000000 u/ ; \ swap-time d1712ticks : swap-time 1 cnt COG@ swap cnt COG@ nip swap - . ; \ >r time d1808-d1712=d96ticks : >r-time 1 cnt COG@ swap >r cnt COG@ swap - . r> drop ; \ rot2-time d1808-d96=d1712ticks : rot2-time 1 2 3 cnt COG@ >r rot cnt COG@ r> - . 2drop drop ; \ ffloat's executing time \ ( n -- ) n:integer : ffloat-time dup . cnt COG@ swap ffloat cnt COG@ rot - 1712 - 1usec u/ swap ." ffloat " hex . decimal . ." usec" cr ; \ fneg's executing time \ ( n1 -- ) n1:integer : fneg-time dup . ffloat cnt COG@ swap fneg cnt COG@ rot - 1712 - 1usec u/ swap ." fneg " hex . decimal . ." usec" cr ; \ fabs's executing time \ ( n1 -- ) n1:integer : fabs-time dup . ffloat cnt COG@ swap fabs cnt COG@ rot - 1712 - 1usec u/ swap ." fabs " hex . decimal . ." usec" cr ; \ fadd's executing time \ ( n1 n2 -- ) n1:integer n2:integer n2+n1 : fadd-time 2dup . . ffloat swap ffloat cnt COG@ rot2 fadd cnt COG@ rot - 1712 - 1usec u/ \ Get time swap ." fadd " hex . decimal . ." usec" cr ; \ fsub's executing time \ ( n1 n2 -- ) n1:integer n2:integer n2-n1 : fsub-time 2dup . . ffloat swap ffloat cnt COG@ rot2 fsub cnt COG@ rot - 1712 - 1usec u/ \ Get time swap ." fadd " hex . decimal . ." usec" cr ; \ fdiv's executing time \ ( n1 n2 -- ) n1:integer n2:integer n2/n1 : fdiv-time 2dup . . ffloat swap ffloat cnt COG@ rot2 fdiv cnt COG@ rot - 1712 - 1usec u/ \ Get time swap ." fdiv " hex . decimal . ." usec" cr ; \ fmul's executing time \ ( n1 n2 -- ) n1:integer n2:integer n2 x n1 : fmult-time 2dup . . ffloat swap ffloat cnt COG@ rot2 fmult cnt COG@ rot - 1712 - 1usec u/ \ Get time swap ." fmult " hex . decimal . ." usec" cr ; wvariable s variable frac \ ( n1 n2 -- n3 ) n1:fraction n2:decimal-point position n3:float : ffraction dup 0= if ffloat else 0 frac W! dup rot2 \ save decimal-point 2dup 1 swap 1- 0 do 1 lshift 1+ loop and \ fraction part rot2 over 1F rshift s W! \ Get sign rshift \ integer part \ ( decimal-point fraction integer ) \ integer dup abs \ Get absolute value bit_enc 1- e W! \ Get exponent ." 1" st? \ fraction rot2 \ ( integer decimal-point fraction ) swap dup rot2 dup st? 0 do over 1 lshift swap i - >m and if 1 else 0 then frac W@ ." frac:" dup . 1 lshift + frac W! over ." 2" st? loop 2drop st? lshift frac W@ or \ Combine integer and fraction \ dup rot swap \ 1F swap - lshift \ msb-justify mantissa \ 2 rshift \ bit29-justify mantissa \ ( n1 n2 n3 ) n1:sign n2:exponent n3:mantissa \ pack then ; } decimal