fl { floatmath 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 10/09/2012 09:03:58 } 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