+ support of NaN and Inf in the compiler as values of real constants

compiler/aggas.pas

@@ -35,9 +35,7 @@ interface
       assemble;
 
 
-
     type
-
       {# This is a derived class which is used to write
          GAS styled assembler.
 
@@ -828,7 +826,10 @@ var
 end.
 {
   $Log$
-  Revision 1.33  2003-09-04 00:15:29  florian
+  Revision 1.34  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.33  2003/09/04 00:15:29  florian
     * first bunch of adaptions of arm compiler for new register type
 
   Revision 1.32  2003/09/03 19:35:24  peter

compiler/fpcdefs.inc

@@ -48,6 +48,7 @@
   {$define x86}
   {$define cpu64bit}
   {$define cpuextended}
+  {$define cpufloat128}
 {$endif x86_64}
 
 {$ifdef alpha}
@@ -81,7 +82,10 @@
 
 {
   $Log$
-  Revision 1.24  2003-09-03 15:55:00  peter
+  Revision 1.25  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.24  2003/09/03 15:55:00  peter
     * NEWRA branch merged
 
   Revision 1.23  2003/09/03 11:18:36  florian
@@ -97,7 +101,6 @@
   Revision 1.22.2.1  2003/08/27 20:11:29  peter
     * newra default
 
->>>>>>> 1.22.2.2
   Revision 1.22  2003/08/11 21:18:20  peter
     * start of sparc support for newra
 

compiler/globals.pas

@@ -84,7 +84,17 @@ interface
 
        treelogfilename = 'tree.log';
 
+       { I don't know if this endian dependend }
+       MathQNaN : array[0..7] of byte = (0,0,0,0,0,0,252,255);
+       MathInf : array[0..7] of byte = (0,0,0,0,0,0,240,127);
+       MathNegInf : array[0..7] of byte = (0,0,0,0,0,0,240,255);
+
+
     type
+       TFPUException = (exInvalidOp, exDenormalized, exZeroDivide,
+                        exOverflow, exUnderflow, exPrecision);
+       TFPUExceptionMask = set of TFPUException;
+
        pfileposinfo = ^tfileposinfo;
        tfileposinfo = record
          line      : longint;
@@ -285,6 +295,9 @@ interface
     function  GetEnvPChar(const envname:string):pchar;
     procedure FreeEnvPChar(p:pchar);
 
+    function SetFPUExceptionMask(const Mask : TFPUExceptionMask) : TFPUExceptionMask;
+    function is_number_float(d : double) : boolean;
+
     Function SetCompileMode(const s:string; changeInit: boolean):boolean;
     function SetAktProcCall(const s:string; changeInit: boolean):boolean;
 
@@ -1215,7 +1228,57 @@ implementation
       {$endif}
 
 
-    Function SetCompileMode(const s:string; changeInit: boolean):boolean;
+{$ifdef CPUI386}
+      { later, this should be replaced by the math unit }
+      const
+        Default8087CW : word = $1332;
+
+      procedure Set8087CW(cw:word);assembler;
+        asm
+          movw cw,%ax
+          movw %ax,default8087cw
+          fnclex
+          fldcw default8087cw
+        end;
+
+
+      function Get8087CW:word;assembler;
+        asm
+          pushl $0
+          fnstcw (%esp)
+          popl %eax
+        end;
+
+
+      function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
+        var
+          CtlWord: Word;
+        begin
+          CtlWord:=Get8087CW;
+          Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
+          Result:=TFPUExceptionMask(CtlWord and $3F);
+        end;
+{$else CPUI386}
+      function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
+        begin
+        end;
+{$endif CPUI386}
+
+      function is_number_float(d : double) : boolean;
+        var
+           bytearray : array[0..7] of byte;
+        begin
+          move(d,bytearray,8);
+          { only 1.1 save, 1.0.x will use always little endian }
+{$ifdef FPC_BIG_ENDIAN}
+          result:=((bytearray[0] and $7f)<>$7f) or ((bytearray[1] and $f0)<>$f0);
+{$else FPC_BIG_ENDIAN}
+          result:=((bytearray[7] and $7f)<>$7f) or ((bytearray[6] and $f0)<>$f0);
+{$endif FPC_BIG_ENDIAN}
+        end;
+
+
+      Function SetCompileMode(const s:string; changeInit: boolean):boolean;
       var
         b : boolean;
       begin
@@ -1611,7 +1674,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.95  2003-09-05 17:41:12  florian
+  Revision 1.96  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.95  2003/09/05 17:41:12  florian
     * merged Wiktor's Watcom patches in 1.1
 
   Revision 1.94  2003/09/04 21:37:29  olle

compiler/i386/n386con.pas

@@ -38,7 +38,7 @@ interface
 implementation
 
     uses
-      systems,globtype,
+      systems,globtype,globals,
       cpubase,
       cga,cginfo,cgbase,rgobj,rgcpu;
 
@@ -49,7 +49,7 @@ implementation
     function ti386realconstnode.pass_1 : tnode;
       begin
          result:=nil;
-         if (value_real=1.0) or (value_real=0.0) then
+         if is_number_float(value_real) and (value_real=1.0) or (value_real=0.0) then
            begin
               expectloc:=LOC_FPUREGISTER;
               registersfpu:=1;
@@ -61,19 +61,24 @@ implementation
     procedure ti386realconstnode.pass_2;
 
       begin
-         if (value_real=1.0) then
+         if is_number_float(value_real) then
            begin
-              emit_none(A_FLD1,S_NO);
-              location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
-              location.register:=NR_ST;
-              inc(trgcpu(rg).fpuvaroffset);
-           end
-         else if (value_real=0.0) then
-           begin
-              emit_none(A_FLDZ,S_NO);
-              location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
-              location.register:=NR_ST;
-              inc(trgcpu(rg).fpuvaroffset);
+             if (value_real=1.0) then
+               begin
+                  emit_none(A_FLD1,S_NO);
+                  location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
+                  location.register:=NR_ST;
+                  inc(trgcpu(rg).fpuvaroffset);
+               end
+             else if (value_real=0.0) then
+               begin
+                  emit_none(A_FLDZ,S_NO);
+                  location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
+                  location.register:=NR_ST;
+                  inc(trgcpu(rg).fpuvaroffset);
+               end
+            else
+              inherited pass_2;
            end
          else
            inherited pass_2;
@@ -85,7 +90,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.20  2003-09-03 15:55:01  peter
+  Revision 1.21  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.20  2003/09/03 15:55:01  peter
     * NEWRA branch merged
 
   Revision 1.19.2.1  2003/08/29 17:29:00  peter

compiler/nadd.pas

@@ -234,13 +234,13 @@ implementation
            ((rt = realconstn) and
             (trealconstnode(right).value_real = 0.0))) then
          begin
-           Message(parser_e_division_by_zero);
-           case rt of
-             ordconstn:
-                tordconstnode(right).value := 1;
-             realconstn:
-                trealconstnode(right).value_real := 1.0;
-           end;
+           if (cs_check_range in aktlocalswitches) or
+              (cs_check_overflow in aktlocalswitches) then
+              begin
+                result:=crealconstnode.create(1,pbestrealtype^);
+                Message(parser_e_division_by_zero);
+                exit;
+              end;
          end;
 
 
@@ -1873,7 +1873,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.94  2003-09-03 15:55:00  peter
+  Revision 1.95  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.94  2003/09/03 15:55:00  peter
     * NEWRA branch merged
 
   Revision 1.93.2.1  2003/08/31 21:07:44  daniel

compiler/ncgcon.pas

@@ -106,11 +106,15 @@ implementation
                     begin
                        if (hp1.typ=realait) and (lastlabel<>nil) then
                          begin
-                            if(
-                               ((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real)) or
-                               ((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real)) or
-                               ((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real)) or
-                               ((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real))
+                            if is_number_float(value_real) and
+                              (
+                               ((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real) and is_number_float(tai_real_32bit(hp1).value)) or
+                               ((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real) and is_number_float(tai_real_64bit(hp1).value)) or
+                               ((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real) and is_number_float(tai_real_80bit(hp1).value)) or
+{$ifdef cpufloat128}
+                               ((realait=ait_real_128bit) and (tai_real_128bit(hp1).value=value_real) and is_number_float(tai_real_128bit(hp1).value)) or
+{$endif cpufloat128}
+                               ((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real) and is_number_float(tai_comp_64bit(hp1).value))
                               ) then
                               begin
                                  { found! }
@@ -138,6 +142,11 @@ implementation
                       Consts.concat(Tai_real_64bit.Create(ts64real(value_real)));
                     ait_real_80bit :
                       Consts.concat(Tai_real_80bit.Create(value_real));
+{$ifdef cpufloat128}
+                    ait_real_128bit :
+                      Consts.concat(Tai_real_128bit.Create(value_real));
+{$endif cpufloat128}
+
 {$ifdef ver1_0}
                     ait_comp_64bit :
                       Consts.concat(Tai_comp_64bit.Create(value_real));
@@ -545,7 +554,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.29  2003-09-03 15:55:00  peter
+  Revision 1.30  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.29  2003/09/03 15:55:00  peter
     * NEWRA branch merged
 
   Revision 1.28  2003/05/01 12:24:22  jonas

compiler/ncon.pas

@@ -397,7 +397,10 @@ implementation
       begin
         docompare :=
           inherited docompare(p) and
-          (value_real = trealconstnode(p).value_real);
+          (value_real = trealconstnode(p).value_real) and
+          { floating point compares for non-numbers give strange results usually }
+          is_number_float(value_real) and
+          is_number_float(trealconstnode(p).value_real);
       end;
 
 
@@ -902,7 +905,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.50  2003-09-03 15:55:01  peter
+  Revision 1.51  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.50  2003/09/03 15:55:01  peter
     * NEWRA branch merged
 
   Revision 1.49  2003/04/25 20:59:33  peter

compiler/ninl.pas

@@ -1110,6 +1110,44 @@ implementation
            result:=crealconstnode.create(r,pbestrealtype^);
         end;
 
+
+        function handle_ln_const(r : bestreal) : tnode;
+          begin
+            if r<=0.0 then
+              if (cs_check_range in aktlocalswitches) or
+                 (cs_check_overflow in aktlocalswitches) then
+                 begin
+                   result:=crealconstnode.create(0,pbestrealtype^);
+                   CGMessage(type_e_wrong_math_argument)
+                 end
+              else
+                begin
+                  if r=0.0 then
+                    result:=crealconstnode.create(double(MathQNaN),pbestrealtype^)
+                  else
+                    result:=crealconstnode.create(double(MathNegInf),pbestrealtype^)
+                end
+            else
+              result:=crealconstnode.create(ln(r),pbestrealtype^)
+          end;
+
+
+        function handle_sqrt_const(r : bestreal) : tnode;
+          begin
+            if r<0.0 then
+              if (cs_check_range in aktlocalswitches) or
+                 (cs_check_overflow in aktlocalswitches) then
+                 begin
+                   result:=crealconstnode.create(0,pbestrealtype^);
+                   CGMessage(type_e_wrong_math_argument)
+                 end
+              else
+                result:=crealconstnode.create(double(MathQNaN),pbestrealtype^)
+            else
+              result:=crealconstnode.create(sqrt(r),pbestrealtype^)
+          end;
+
+
       var
          vl,vl2    : TConstExprInt;
          vr        : bestreal;
@@ -1265,19 +1303,9 @@ implementation
                  in_const_sqrt :
                    begin
                      if isreal then
-                       begin
-                          if vr<0.0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=crealconstnode.create(sqrt(vr),pbestrealtype^)
-                       end
+                       hp:=handle_sqrt_const(vr)
                      else
-                       begin
-                          if vl<0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=crealconstnode.create(sqrt(vl),pbestrealtype^);
-                       end;
+                       hp:=handle_sqrt_const(vl)
                    end;
                  in_const_arctan :
                    begin
@@ -1310,19 +1338,9 @@ implementation
                  in_const_ln :
                    begin
                      if isreal then
-                       begin
-                          if vr<=0.0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=crealconstnode.create(ln(vr),pbestrealtype^)
-                       end
+                       hp:=handle_ln_const(vr)
                      else
-                       begin
-                          if vl<=0 then
-                           CGMessage(type_e_wrong_math_argument)
-                          else
-                           hp:=crealconstnode.create(ln(vl),pbestrealtype^);
-                       end;
+                       hp:=handle_ln_const(vl)
                    end;
                  else
                    internalerror(88);
@@ -1902,11 +1920,8 @@ implementation
                    begin
                      vr:=getconstrealvalue;
                      if vr<0.0 then
-                       begin
-                         CGMessage(type_e_wrong_math_argument);
-                         setconstrealvalue(0);
-                       end
-                      else
+                       result:=handle_sqrt_const(vr)
+                     else
                        setconstrealvalue(sqrt(vr));
                    end
                   else
@@ -1923,11 +1938,8 @@ implementation
                    begin
                      vr:=getconstrealvalue;
                      if vr<=0.0 then
-                       begin
-                         CGMessage(type_e_wrong_math_argument);
-                         setconstrealvalue(0);
-                       end
-                      else
+                       result:=handle_ln_const(vr)
+                     else
                        setconstrealvalue(ln(vr));
                    end
                   else
@@ -2351,7 +2363,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.114  2003-06-13 21:19:30  peter
+  Revision 1.115  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.114  2003/06/13 21:19:30  peter
     * current_procdef removed, use current_procinfo.procdef instead
 
   Revision 1.113  2003/05/31 21:29:04  jonas

compiler/pp.pas

@@ -193,13 +193,17 @@ end;
 begin
   oldexit:=exitproc;
   exitproc:=@myexit;
-
+  SetFPUExceptionMask([exInvalidOp, exDenormalized, exZeroDivide,
+                        exOverflow, exUnderflow, exPrecision]);
 { Call the compiler with empty command, so it will take the parameters }
   Halt(compiler.Compile(''));
 end.
 {
   $Log$
-  Revision 1.26  2003-09-05 17:41:12  florian
+  Revision 1.27  2003-09-06 16:47:24  florian
+    + support of NaN and Inf in the compiler as values of real constants
+
+  Revision 1.26  2003/09/05 17:41:12  florian
     * merged Wiktor's Watcom patches in 1.1
 
   Revision 1.25  2003/09/03 11:18:37  florian