sem_res.adb (Resolve_Real_Literal): Generate warning if static fixed-point expression has value that is not a...

2005-03-29  Robert Dewar  <dewar@adacore.com>

	* sem_res.adb (Resolve_Real_Literal): Generate warning if static
	fixed-point expression has value that is not a multiple of the Small
	value.

	* opt.ads (Warn_On_Bad_Fixed_Value): New flag

	* s-taprop-tru64.adb (RT_Resolution): Return an integer number of
	nanoseconds.

	* ug_words: Add entry for [NO_]BAD_FIXED_VALUES for -gnatwb/-gnatwB

From-SVN: r97165

4 files changed, 109 insertions, 22 deletions

diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 52f1522..29acc92 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -1025,6 +1025,11 @@ package Opt is
    --  Set to True to get verbose mode (full error message text and location
    --  information sent to standard output, also header, copyright and summary)
 
+   Warn_On_Bad_Fixed_Value : Boolean := False;
+   --  GNAT
+   --  Set to True to generate warnings for static fixed-point expression
+   --  values that are not an exact multiple of the small value of the type.
+
    Warn_On_Constant : Boolean := False;
    --  GNAT
    --  Set to True to generate warnings for variables that could be declared
diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb
index 6667899f..9a0bba9 100644
--- a/gcc/ada/s-taprop-tru64.adb
+++ b/gcc/ada/s-taprop-tru64.adb
@@ -612,7 +612,11 @@ package body System.Task_Primitives.Operations is
 
    function RT_Resolution return Duration is
    begin
-      return 1.0 / 1024.0; --  Clock on DEC Alpha ticks at 1024 Hz
+      --  Returned value must be an integral multiple of Duration'Small (1 ns)
+      --  The following is the best approximation of 1/1024. The clock on the
+      --  DEC Alpha ticks at 1024 Hz.
+
+      return 0.000_976_563;
    end RT_Resolution;
 
    ------------
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 90ee6f5..cc55d26 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -168,7 +168,9 @@ package body Sem_Res is
    --  by other node rewriting procedures.
 
    procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-   --  Resolve actuals of call, and add default expressions for missing ones
+   --  Resolve actuals of call, and add default expressions for missing ones.
+   --  N is the Node_Id for the subprogram call, and Nam is the entity of the
+   --  called subprogram.
 
    procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
    --  Called from Resolve_Call, when the prefix denotes an entry or element
@@ -626,7 +628,6 @@ package body Sem_Res is
 
          F := First_Formal (Subp);
          A := First_Actual (N);
-
          while Present (F) and then Present (A) loop
             if not Is_Entity_Name (A)
               or else Entity (A) /= F
@@ -787,6 +788,42 @@ package body Sem_Res is
    procedure Check_Parameterless_Call (N : Node_Id) is
       Nam : Node_Id;
 
+      function Prefix_Is_Access_Subp return Boolean;
+      --  If the prefix is of an access_to_subprogram type, the node must be
+      --  rewritten as a call. Ditto if the prefix is overloaded and all its
+      --  interpretations are access to subprograms.
+
+      ---------------------------
+      -- Prefix_Is_Access_Subp --
+      ---------------------------
+
+      function Prefix_Is_Access_Subp return Boolean is
+         I   : Interp_Index;
+         It  : Interp;
+
+      begin
+         if not Is_Overloaded (N) then
+            return
+              Ekind (Etype (N)) = E_Subprogram_Type
+                and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
+         else
+            Get_First_Interp (N, I, It);
+            while Present (It.Typ) loop
+               if Ekind (It.Typ) /= E_Subprogram_Type
+                 or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
+               then
+                  return False;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            return True;
+         end if;
+      end Prefix_Is_Access_Subp;
+
+   --  Start of processing for Check_Parameterless_Call
+
    begin
       --  Defend against junk stuff if errors already detected
 
@@ -832,9 +869,7 @@ package body Sem_Res is
       --  procedure or entry.
 
       or else
-        (Nkind (N) = N_Explicit_Dereference
-          and then Ekind (Etype (N)) = E_Subprogram_Type
-          and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
+        (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
 
       --  Rewrite as call if it is a selected component which is a function,
       --  this is the case of a call to a protected function (which may be
@@ -858,7 +893,7 @@ package body Sem_Res is
          then
             Nam := New_Copy (N);
 
-            --  If overloaded, overload set belongs to new copy.
+            --  If overloaded, overload set belongs to new copy
 
             Save_Interps (N, Nam);
 
@@ -2515,7 +2550,6 @@ package body Sem_Res is
    begin
       A := First_Actual (N);
       F := First_Formal (Nam);
-
       while Present (F) loop
          if No (A) and then Needs_No_Actuals (Nam) then
             null;
@@ -4796,9 +4830,11 @@ package body Sem_Res is
    ----------------------------------
 
    procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
-      P  : constant Node_Id := Prefix (N);
-      I  : Interp_Index;
-      It : Interp;
+      Loc   : constant Source_Ptr := Sloc (N);
+      New_N : Node_Id;
+      P     : constant Node_Id := Prefix (N);
+      I     : Interp_Index;
+      It    : Interp;
 
    begin
       --  Now that we know the type, check that this is not a
@@ -4824,7 +4860,39 @@ package body Sem_Res is
             Get_Next_Interp (I, It);
          end loop;
 
-         Resolve (P, It.Typ);
+         if Present (It.Typ) then
+            Resolve (P, It.Typ);
+         else
+            --  If no interpretation covers the designated type of the
+            --  prefix, this is the pathological case where not all
+            --  implementations of the prefix allow the interpretation
+            --  of the node as a call. Now that the expected type is known,
+            --  Remove other interpretations from prefix, rewrite it as
+            --  a call, and resolve again, so that the proper call node
+            --  is generated.
+
+            Get_First_Interp (P, I, It);
+            while Present (It.Typ) loop
+               if Ekind (It.Typ) /= E_Access_Subprogram_Type then
+                  Remove_Interp (I);
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+
+            New_N :=
+              Make_Function_Call (Loc,
+                Name =>
+                  Make_Explicit_Dereference (Loc,
+                    Prefix => P),
+                Parameter_Associations => New_List);
+
+            Save_Interps (N, New_N);
+            Rewrite (N, New_N);
+            Analyze_And_Resolve (N, Typ);
+            return;
+         end if;
+
          Set_Etype (N, Designated_Type (It.Typ));
 
       else
@@ -5667,6 +5735,16 @@ package body Sem_Res is
                   Error_Msg_N ("value has extraneous low order digits", N);
                end if;
 
+               --  Generate a warning if literal from source
+
+               if Is_Static_Expression (N)
+                 and then Warn_On_Bad_Fixed_Value
+               then
+                  Error_Msg_N
+                    ("static fixed-point value is not a multiple of Small?",
+                     N);
+               end if;
+
                --  Replace literal by a value that is the exact representation
                --  of a value of the type, i.e. a multiple of the small value,
                --  by truncation, since Machine_Rounds is false for all GNAT
@@ -5678,6 +5756,8 @@ package body Sem_Res is
                    Realval => Small_Value (Typ) * Cint));
 
                Set_Is_Static_Expression (N, Stat);
+
+
             end if;
 
             --  In all cases, set the corresponding integer field
@@ -6351,8 +6431,7 @@ package body Sem_Res is
                Set_Etype (Operand, Standard_Duration);
             end if;
 
-            --  Resolve the real operand with largest available precision.
-
+            --  Resolve the real operand with largest available precision
             if Etype (Right_Opnd (Operand)) = Universal_Real then
                Rop := New_Copy_Tree (Right_Opnd (Operand));
             else
@@ -6787,7 +6866,7 @@ package body Sem_Res is
 
       T1 := Standard_Duration;
 
-      --  Look for fixed-point types in enclosing scopes.
+      --  Look for fixed-point types in enclosing scopes
 
       Scop := Current_Scope;
       while Scop /= Standard_Standard loop
@@ -7219,19 +7298,16 @@ package body Sem_Res is
       elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
                or else
              Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
+        and then No (Corresponding_Remote_Type (Opnd_Type))
         and then Conversion_Check
                    (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
                     "illegal operand for access subprogram conversion")
       then
          --  Check that the designated types are subtype conformant
 
-         if not Subtype_Conformant (Designated_Type (Opnd_Type),
-                                    Designated_Type (Target_Type))
-         then
-            Error_Msg_N
-              ("operand type is not subtype conformant with target type",
-               Operand);
-         end if;
+         Check_Subtype_Conformant (New_Id  => Designated_Type (Target_Type),
+                                   Old_Id  => Designated_Type (Opnd_Type),
+                                   Err_Loc => N);
 
          --  Check the static accessibility rule of 4.6(20)
 
diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words
index 21ccc3f..03e4325 100644
--- a/gcc/ada/ug_words
+++ b/gcc/ada/ug_words
@@ -105,6 +105,8 @@ gcc -c          ^ GNAT COMPILE
 -gnatw          ^ /WARNINGS
 -gnatwa         ^ /WARNINGS=OPTIONAL
 -gnatwA         ^ /WARNINGS=NOOPTIONAL
+-gnatwb         ^ /WARNINGS=BAD_FIXED_VALUES
+-gnatwB         ^ /WARNINGS=NO_BAD_FIXED_VALUES
 -gnatwc         ^ /WARNINGS=CONDITIONALS
 -gnatwC         ^ /WARNINGS=NOCONDITIONALS
 -gnatwd         ^ /WARNINGS=IMPLICIT_DEREFERENCE