diff --git a/.gitattributes b/.gitattributes index 9ff3399ed4..485b0d53f7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -12480,6 +12480,7 @@ tests/test/units/system/testpc.txt svneol=native#text/plain tests/test/units/system/teststk.pp svneol=native#text/plain tests/test/units/system/testux.txt svneol=native#text/plain tests/test/units/system/tfiledir.pp svneol=native#text/plain +tests/test/units/system/tfloatrecs.pp svneol=native#text/pascal tests/test/units/system/tgenstr.pp svneol=native#text/pascal tests/test/units/system/tincdec.pp svneol=native#text/plain tests/test/units/system/tint.pp svneol=native#text/plain diff --git a/rtl/inc/genmath.inc b/rtl/inc/genmath.inc index 40d1d4df83..d1cf222a65 100644 --- a/rtl/inc/genmath.inc +++ b/rtl/inc/genmath.inc @@ -1927,3 +1927,310 @@ function FPower10(val: Extended; Power: Longint): Extended; end; end; {$endif SUPPORT_EXTENDED} + +{$ifdef SUPPORT_EXTENDED} +function TExtended80Rec.Mantissa : QWord; + begin + Result:=Frac and $7fffffffffffffff; + end; + + +function TExtended80Rec.Fraction : Extended; + begin + Result:=system.frac(Value); + end; + + +function TExtended80Rec.Exponent : Longint; + begin + Result:=Exp-16383; + end; + + +function TExtended80Rec.GetExp : QWord; + begin + Result:=_Exp and $7fff; + end; + + +procedure TExtended80Rec.SetExp(e : QWord); + begin + _Exp:=(_Exp and $8000) or (e and $7fff); + end; + + +function TExtended80Rec.GetSign : Boolean; + begin + Result:=(_Exp and $8000)<>0; + end; + + +procedure TExtended80Rec.SetSign(s : Boolean); + begin + _Exp:=(_Exp and $7ffff) or (ord(s) shl 15); + end; + +{ + Based on information taken from http://en.wikipedia.org/wiki/Extended_precision#x86_Extended_Precision_Format +} +function TExtended80Rec.SpecialType : TFloatSpecial; + const + Denormal : array[boolean] of TFloatSpecial = (fsDenormal,fsNDenormal); + begin + case Exp of + 0: + begin + if Mantissa=0 then + begin + if Sign then + Result:=fsNZero + else + Result:=fsZero + end + else + Result:=Denormal[Sign]; + end; + $7fff: + case (Frac shr 62) and 3 of + 0,1: + Result:=fsInvalidOp; + 2: + begin + if (Frac and $3fffffffffffffff)=0 then + begin + if Sign then + Result:=fsNInf + else + Result:=fsInf; + end + else + Result:=fsNaN; + end; + 3: + Result:=fsNaN; + end + else + begin + if (Frac and $8000000000000000)=0 then + Result:=fsInvalidOp + else + begin + if Sign then + Result:=fsNegative + else + Result:=fsPositive; + end; + end; + end; + end; + +{ +procedure TExtended80Rec.BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint); + begin + end; +} +{$endif SUPPORT_EXTENDED} + + +{$ifdef SUPPORT_DOUBLE} +function TDoubleRec.Mantissa : QWord; + begin + Result:=Data and $fffffffffffff; + end; + + +function TDoubleRec.Fraction : ValReal; + begin + Result:=system.frac(Value); + end; + + +function TDoubleRec.Exponent : Longint; + begin + Result:=Exp-1023; + end; + + +function TDoubleRec.GetExp : QWord; + begin + Result:=(Data and $7ff0000000000000) shr 52; + end; + + +procedure TDoubleRec.SetExp(e : QWord); + begin + Data:=(Data and $800fffffffffffff) or ((e and $7ff) shl 52); + end; + + +function TDoubleRec.GetSign : Boolean; + begin + Result:=(Data and $8000000000000000)<>0; + end; + + +procedure TDoubleRec.SetSign(s : Boolean); + begin + Data:=(Data and $7fffffffffffffff) or (QWord(ord(s)) shl 63); + end; + + +function TDoubleRec.GetFrac : QWord; + begin + Result:=$10000000000000 or Mantissa; + end; + + +procedure TDoubleRec.SetFrac(e : QWord); + begin + Data:=(Data and $7ff0000000000000) or (e and $fffffffffffff); + end; + +{ + Based on information taken from http://en.wikipedia.org/wiki/Double_precision#x86_Extended_Precision_Format +} +function TDoubleRec.SpecialType : TFloatSpecial; + const + Denormal : array[boolean] of TFloatSpecial = (fsDenormal,fsNDenormal); + begin + case Exp of + 0: + begin + if Mantissa=0 then + begin + if Sign then + Result:=fsNZero + else + Result:=fsZero + end + else + Result:=Denormal[Sign]; + end; + $7ff: + if Mantissa=0 then + begin + if Sign then + Result:=fsNInf + else + Result:=fsInf; + end + else + Result:=fsNaN; + else + begin + if Sign then + Result:=fsNegative + else + Result:=fsPositive; + end; + end; + end; + +{ +procedure TDoubleRec.BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint); + begin + end; +} +{$endif SUPPORT_DOUBLE} + + +{$ifdef SUPPORT_SINGLE} +function TSingleRec.Mantissa : QWord; + begin + Result:=Data and $7fffff; + end; + + +function TSingleRec.Fraction : ValReal; + begin + Result:=system.frac(Value); + end; + + +function TSingleRec.Exponent : Longint; + begin + Result:=Exp-127; + end; + + +function TSingleRec.GetExp : QWord; + begin + Result:=(Data and $7f800000) shr 23; + end; + + +procedure TSingleRec.SetExp(e : QWord); + begin + Data:=(Data and $807fffff) or ((e and $ff) shl 23); + end; + + +function TSingleRec.GetSign : Boolean; + begin + Result:=(Data and $80000000)<>0; + end; + + +procedure TSingleRec.SetSign(s : Boolean); + begin + Data:=(Data and $7fffffff) or (ord(s) shl 31); + end; + + +function TSingleRec.GetFrac : QWord; + begin + Result:=$8000000 or Mantissa; + end; + + +procedure TSingleRec.SetFrac(e : QWord); + begin + Data:=(Data and $ff800000) or (e and $7fffff); + end; + +{ + Based on information taken from http://en.wikipedia.org/wiki/Single_precision#x86_Extended_Precision_Format +} +function TSingleRec.SpecialType : TFloatSpecial; + const + Denormal : array[boolean] of TFloatSpecial = (fsDenormal,fsNDenormal); + begin + case Exp of + 0: + begin + if Mantissa=0 then + begin + if Sign then + Result:=fsNZero + else + Result:=fsZero + end + else + Result:=Denormal[Sign]; + end; + $ff: + if Mantissa=0 then + begin + if Sign then + Result:=fsNInf + else + Result:=fsInf; + end + else + Result:=fsNaN; + else + begin + if Sign then + Result:=fsNegative + else + Result:=fsPositive; + end; + end; + end; + +{ +procedure TSingleRec.BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint); + begin + end; +} +{$endif SUPPORT_SINGLE} diff --git a/rtl/inc/mathh.inc b/rtl/inc/mathh.inc index bb079d9982..88f9a20242 100644 --- a/rtl/inc/mathh.inc +++ b/rtl/inc/mathh.inc @@ -115,6 +115,86 @@ procedure float_raise(i: TFPUExceptionMask); operator := (b:real48) e:extended; {$endif SUPPORT_EXTENDED} + type + TFloatSpecial = (fsZero,fsNZero,fsDenormal,fsNDenormal,fsPositive,fsNegative, + fsInf,fsNInf,fsNaN,fsInvalidOp); + +{$ifdef SUPPORT_EXTENDED} + TExtended80Rec = packed record + private + function GetExp : QWord; + procedure SetExp(e : QWord); + function GetSign : Boolean; + procedure SetSign(s : Boolean); + public + function Mantissa : QWord; + function Fraction : Extended; + function Exponent : Longint; + property Sign : Boolean read GetSign write SetSign; + property Exp : QWord read GetExp write SetExp; + function SpecialType : TFloatSpecial; + // procedure BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint); + case byte of + 0: (Bytes : array[0..9] of Byte); + 1: (Words : array[0..4] of Word); +{$ifdef ENDIAN_LITTLE} + 2: (Frac : QWord; _Exp: Word); +{$else ENDIAN_LITTLE} + 2: (_Exp: Word; Frac : QWord); +{$endif ENDIAN_LITTLE} + 3: (Value: Extended); + end; +{$endif SUPPORT_EXTENDED} + +{$ifdef SUPPORT_DOUBLE} + TDoubleRec = packed record + private + function GetExp : QWord; + procedure SetExp(e : QWord); + function GetSign : Boolean; + procedure SetSign(s : Boolean); + function GetFrac : QWord; + procedure SetFrac(e : QWord); + public + function Mantissa : QWord; + function Fraction : ValReal; + function Exponent : Longint; + property Sign : Boolean read GetSign write SetSign; + property Exp : QWord read GetExp write SetExp; + property Frac : QWord read Getfrac write SetFrac; + function SpecialType : TFloatSpecial; + case byte of + 0: (Bytes : array[0..7] of Byte); + 1: (Words : array[0..3] of Word); + 2: (Data : QWord); + 3: (Value: Double); + end; +{$endif SUPPORT_DOUBLE} + +{$ifdef SUPPORT_SINGLE} + TSingleRec = packed record + private + function GetExp : QWord; + procedure SetExp(e : QWord); + function GetSign : Boolean; + procedure SetSign(s : Boolean); + function GetFrac : QWord; + procedure SetFrac(e : QWord); + public + function Mantissa : QWord; + function Fraction : ValReal; + function Exponent : Longint; + property Sign : Boolean read GetSign write SetSign; + property Exp : QWord read GetExp write SetExp; + property Frac : QWord read Getfrac write SetFrac; + function SpecialType : TFloatSpecial; + case byte of + 0: (Bytes : array[0..3] of Byte); + 1: (Words : array[0..1] of Word); + 2: (Data : DWord); + 3: (Value: Single); + end; +{$endif SUPPORT_SINGLE} function FMASingle(s1,s2,s3 : single) : single;[internproc:fpc_in_fma_single]; {$ifdef SUPPORT_DOUBLE} diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index d61d849d05..b23eb1230b 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -20,6 +20,7 @@ {$I-,Q-,H-,R-,V-} {$mode objfpc} +{$modeswitch advancedrecords} { At least 2.4.0 is required } {$if defined(VER1) or defined(VER2_0) or defined(VER2_2) } diff --git a/tests/test/units/system/tfloatrecs.pp b/tests/test/units/system/tfloatrecs.pp new file mode 100644 index 0000000000..776ba361b8 --- /dev/null +++ b/tests/test/units/system/tfloatrecs.pp @@ -0,0 +1,273 @@ +uses + Math; + +procedure do_error(i : longint); + begin + writeln('Error near ',i); + halt(1); + end; + +var +{$ifdef FPC_HAS_TYPE_EXTENDED} + extended_NaN,extended_Inf,extended_NInf,extended_NDenormal,extended_Denormal,extended_Zero,extended_NZero, + extended_Positive,extended_Negative,extended_InvalidOp : extended; +{$endif FPC_HAS_TYPE_EXTENDED} +{$ifdef FPC_HAS_TYPE_DOUBLE} + double_NaN,double_Inf,double_NInf,double_NDenormal,double_Denormal,double_Zero,double_NZero, + double_Positive,double_Negative : double; +{$endif FPC_HAS_TYPE_DOUBLE} +{$ifdef FPC_HAS_TYPE_SINGLE} + single_NaN,single_Inf,single_NInf,single_NDenormal,single_Denormal,single_Zero,single_NZero, + single_Positive,single_Negative : single; +{$endif FPC_HAS_TYPE_SINGLE} + +begin +{$ifdef FPC_HAS_TYPE_EXTENDED} + extended_NaN:=NaN; + + extended_Inf:=Infinity; + + extended_NInf:=-Infinity; + + extended_Denormal:=1234.0; + TExtended80Rec(extended_Denormal).Exp:=0; + + extended_NDenormal:=-1234.0; + TExtended80Rec(extended_NDenormal).Exp:=0; + + extended_Zero:=0.0; + + extended_NZero:=0.0; + TExtended80Rec(extended_NZero).Sign:=true; + + extended_Positive:=Pi*10; + + extended_Negative:=-Pi*10; + + extended_InvalidOp:=0; + TExtended80Rec(extended_InvalidOp).Exp:=$7fff; + + if TExtended80Rec(extended_NaN).SpecialType<>fsNaN then + do_error(1); + + if TExtended80Rec(extended_Inf).SpecialType<>fsInf then + do_error(2); + + if TExtended80Rec(extended_NInf).SpecialType<>fsNInf then + do_error(3); + + if TExtended80Rec(extended_Denormal).SpecialType<>fsDenormal then + do_error(4); + + if TExtended80Rec(extended_NDenormal).SpecialType<>fsNDenormal then + do_error(5); + + if TExtended80Rec(extended_Zero).SpecialType<>fsZero then + do_error(6); + + if TExtended80Rec(extended_NZero).SpecialType<>fsNZero then + do_error(7); + + if TExtended80Rec(extended_Positive).SpecialType<>fsPositive then + do_error(8); + + if TExtended80Rec(extended_Negative).SpecialType<>fsNegative then + do_error(9); + + if TExtended80Rec(extended_InvalidOp).SpecialType<>fsInvalidOp then + do_error(10); + + if TExtended80Rec(extended_Positive).Mantissa<>$7B53D14AA9C2F2C2 then + do_error(11); + + if TExtended80Rec(extended_Positive).Fraction<>4.15926535897932384694E-0001 then + do_error(12); + + if TExtended80Rec(extended_Positive).Exponent<>4 then + do_error(13); + + if TExtended80Rec(extended_Positive).Sign then + do_error(14); + + if TExtended80Rec(extended_Positive).Exp<>$4003 then + do_error(15); + + if TExtended80Rec(extended_Negative).Mantissa<>$7B53D14AA9C2F2C2 then + do_error(16); + + if TExtended80Rec(extended_Negative).Fraction<>-4.15926535897932384694E-0001 then + do_error(17); + + if TExtended80Rec(extended_Negative).Exponent<>4 then + do_error(18); + + if not(TExtended80Rec(extended_Negative).Sign) then + do_error(19); + + if TExtended80Rec(extended_Negative).Exp<>$4003 then + do_error(20); +{$endif FPC_HAS_TYPE_EXTENDED} + +{$ifdef FPC_HAS_TYPE_DOUBLE} + double_NaN:=NaN; + + double_Inf:=Infinity; + + double_NInf:=-Infinity; + + double_Denormal:=1234.0; + TDoubleRec(double_Denormal).Exp:=0; + + double_NDenormal:=-1234.0; + TDoubleRec(double_NDenormal).Exp:=0; + + double_Zero:=0.0; + + double_NZero:=0.0; + TDoubleRec(double_NZero).Sign:=true; + + double_Positive:=Pi*10; + + double_Negative:=-Pi*10; + + if TDoubleRec(double_NaN).SpecialType<>fsNaN then + do_error(101); + + if TDoubleRec(double_Inf).SpecialType<>fsInf then + do_error(102); + + if TDoubleRec(double_NInf).SpecialType<>fsNInf then + do_error(103); + + if TDoubleRec(double_Denormal).SpecialType<>fsDenormal then + do_error(104); + + if TDoubleRec(double_NDenormal).SpecialType<>fsNDenormal then + do_error(105); + + if TDoubleRec(double_Zero).SpecialType<>fsZero then + do_error(106); + + if TDoubleRec(double_NZero).SpecialType<>fsNZero then + do_error(107); + + if TDoubleRec(double_Positive).SpecialType<>fsPositive then + do_error(108); + + if TDoubleRec(double_Negative).SpecialType<>fsNegative then + do_error(109); + + if TDoubleRec(double_Positive).Mantissa<>$000F6A7A2955385E then + do_error(111); + + if TDoubleRec(double_Positive).Fraction<>4.15926535897931159980E-0001 then + do_error(112); + + if TDoubleRec(double_Positive).Exponent<>4 then + do_error(113); + + if TDoubleRec(double_Positive).Sign then + do_error(114); + + if TDoubleRec(double_Positive).Exp<>$403 then + do_error(115); + + if TDoubleRec(double_Negative).Mantissa<>$000F6A7A2955385E then + do_error(116); + + if TDoubleRec(double_Negative).Fraction<>-4.15926535897931159980E-0001 then + do_error(117); + + if TDoubleRec(double_Negative).Exponent<>4 then + do_error(118); + + if not(TDoubleRec(double_Negative).Sign) then + do_error(119); + + if TDoubleRec(double_Negative).Exp<>$403 then + do_error(120); +{$endif FPC_HAS_TYPE_DOUBLE} + +{$ifdef FPC_HAS_TYPE_DOUBLE} + single_NaN:=NaN; + + single_Inf:=Infinity; + + single_NInf:=-Infinity; + + single_Denormal:=1234.0; + TSingleRec(single_Denormal).Exp:=0; + + single_NDenormal:=-1234.0; + TSingleRec(single_NDenormal).Exp:=0; + + single_Zero:=0.0; + + single_NZero:=0.0; + TSingleRec(single_NZero).Sign:=true; + + single_Positive:=Pi*10; + + single_Negative:=-Pi*10; + + if TSingleRec(single_NaN).SpecialType<>fsNaN then + do_error(201); + + if TSingleRec(single_Inf).SpecialType<>fsInf then + do_error(202); + + if TSingleRec(single_NInf).SpecialType<>fsNInf then + do_error(203); + + if TSingleRec(single_Denormal).SpecialType<>fsDenormal then + do_error(204); + + if TSingleRec(single_NDenormal).SpecialType<>fsNDenormal then + do_error(205); + + if TSingleRec(single_Zero).SpecialType<>fsZero then + do_error(206); + + if TSingleRec(single_NZero).SpecialType<>fsNZero then + do_error(207); + + if TSingleRec(single_Positive).SpecialType<>fsPositive then + do_error(208); + + if TSingleRec(single_Negative).SpecialType<>fsNegative then + do_error(209); + + if TSingleRec(single_Positive).Mantissa<>$7b53d1 then + do_error(211); + + if TSingleRec(single_Positive).Fraction<>4.15925979614257812500E-0001 then + do_error(212); + + if TSingleRec(single_Positive).Exponent<>4 then + do_error(213); + + if TSingleRec(single_Positive).Sign then + do_error(214); + + if TSingleRec(single_Positive).Exp<>$83 then + do_error(215); + + if TSingleRec(single_Negative).Mantissa<>$7b53d1 then + do_error(216); + + if TSingleRec(single_Negative).Fraction<>-4.15925979614257812500E-0001 then + do_error(217); + + if TSingleRec(single_Negative).Exponent<>4 then + do_error(218); + + if not(TSingleRec(single_Negative).Sign) then + do_error(219); + + if TSingleRec(single_Negative).Exp<>$83 then + do_error(220); +{$endif FPC_HAS_TYPE_DOUBLE} + + writeln('ok'); +end. +