+ implements TExtended80Rec, TDoubleRec, TSingleRec

+ test

git-svn-id: trunk@29084 -

.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

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}

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}

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) }

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.
+