checks.adb, [...]: Improve warnings for address overlays.

2007-09-26  Robert Dewar  <dewar@adacore.com>

	* checks.adb, gnat1drv.adb, sem_util.ads: Improve warnings for address
	overlays.

	* sem_ch13.ads, sem_ch13.adb: Improve warnings for address overlays
	(Analyze_Record_Representation_Clause): Suppress junk warning for
	missing component clause.
	(Analyze_Attribute_Definition_Clause, case Address): Apply the special
	tests for controlled type overlay to composites with controlled
	components.
	(Analyze_Record_Representation_Clause): Add reference for component name

From-SVN: r128785

gcc/ada/checks.adb

@@ -543,6 +543,7 @@ package body Checks is
             Error_Msg_FE
               ("\?program execution may be erroneous (RM 13.3(27))",
                Aexp, E);
+            Set_Address_Warning_Posted (AC);
          end if;
       end Compile_Time_Bad_Alignment;
 
@@ -626,6 +627,7 @@ package body Checks is
                   Error_Msg_FE
                     ("\?program execution may be erroneous", Aexp, E);
                   Size_Warning_Output := True;
+                  Set_Address_Warning_Posted (AC);
                end if;
             end if;
          end;

gcc/ada/gnat1drv.adb

@@ -442,6 +442,7 @@ begin
       if Compilation_Errors then
          Treepr.Tree_Dump;
          Sem_Ch13.Validate_Unchecked_Conversions;
+         Sem_Ch13.Validate_Address_Clauses;
          Errout.Output_Messages;
          Namet.Finalize;
 
@@ -622,6 +623,7 @@ begin
          Write_Eol;
 
          Sem_Ch13.Validate_Unchecked_Conversions;
+         Sem_Ch13.Validate_Address_Clauses;
          Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Treepr.Tree_Dump;
@@ -654,6 +656,7 @@ begin
                    or else Targparm.VM_Target /= No_VM)
       then
          Sem_Ch13.Validate_Unchecked_Conversions;
+         Sem_Ch13.Validate_Address_Clauses;
          Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Write_ALI (Object => False);
@@ -704,6 +707,11 @@ begin
 
       Sem_Ch13.Validate_Unchecked_Conversions;
 
+      --  Validate address clauses (again using alignment values annotated
+      --  by the backend where possible).
+
+      Sem_Ch13.Validate_Address_Clauses;
+
       --  Now we complete output of errors, rep info and the tree info. These
       --  are delayed till now, since it is perfectly possible for gigi to
       --  generate errors, modify the tree (in particular by setting flags

gcc/ada/sem_ch13.adb

@@ -30,6 +30,7 @@ with Errout;   use Errout;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
@@ -88,11 +89,6 @@ package body Sem_Ch13 is
    function Address_Aliased_Entity (N : Node_Id) return Entity_Id;
    --  If expression N is of the form E'Address, return E
 
-   procedure Mark_Aliased_Address_As_Volatile (N : Node_Id);
-   --  This is used for processing of an address representation clause. If
-   --  the expression N is of the form of K'Address, then the entity that
-   --  is associated with K is marked as volatile.
-
    procedure New_Stream_Subprogram
      (N    : Node_Id;
       Ent  : Entity_Id;
@@ -138,6 +134,41 @@ package body Sem_Ch13 is
      Table_Increment      => 200,
      Table_Name           => "Unchecked_Conversions");
 
+   ----------------------------------------
+   -- Table for Validate_Address_Clauses --
+   ----------------------------------------
+
+   --  If an address clause has the form
+
+   --    for X'Address use Expr
+
+   --  where Expr is of the form Y'Address or recursively is a reference
+   --  to a constant of either of these forms, and X and Y are entities of
+   --  objects, then if Y has a smaller alignment than X, that merits a
+   --  warning about possible bad alignment. The following table collects
+   --  address clauses of this kind. We put these in a table so that they
+   --  can be checked after the back end has completed annotation of the
+   --  alignments of objects, since we can catch more cases that way.
+
+   type Address_Clause_Check_Record is record
+      N : Node_Id;
+      --  The address clause
+
+      X : Entity_Id;
+      --  The entity of the object overlaying Y
+
+      Y : Entity_Id;
+      --  The entity of the object being overlaid
+   end record;
+
+   package Address_Clause_Checks is new Table.Table (
+     Table_Component_Type => Address_Clause_Check_Record,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 20,
+     Table_Increment      => 200,
+     Table_Name           => "Address_Clause_Checks");
+
    ----------------------------
    -- Address_Aliased_Entity --
    ----------------------------
@@ -259,7 +290,7 @@ package body Sem_Ch13 is
       end loop;
 
       --  We need to sort the component clauses on the basis of the Position
-      --  values in the clause, so we can group clauses with the same Position
+      --  values in the clause, so we can group clauses with the same Position.
       --  together to determine the relevant machine scalar size.
 
       declare
@@ -601,7 +632,6 @@ package body Sem_Ch13 is
 
             else
                Get_First_Interp (Expr, I, It);
-
                while Present (It.Nam) loop
                   if Has_Good_Profile (It.Nam) then
                      Subp := It.Nam;
@@ -720,11 +750,12 @@ package body Sem_Ch13 is
                     ("address clause cannot be given " &
                      "for overloaded subprogram",
                      Nam);
+                  return;
                end if;
 
-               --  For subprograms, all address clauses are permitted,
-               --  and we mark the subprogram as having a deferred freeze
-               --  so that Gigi will not elaborate it too soon.
+               --  For subprograms, all address clauses are permitted, and we
+               --  mark the subprogram as having a deferred freeze so that Gigi
+               --  will not elaborate it too soon.
 
                --  Above needs more comments, what is too soon about???
 
@@ -736,12 +767,15 @@ package body Sem_Ch13 is
                if Nkind (Parent (N)) = N_Task_Body then
                   Error_Msg_N
                     ("entry address must be specified in task spec", Nam);
+                  return;
                end if;
 
                --  For entries, we require a constant address
 
                Check_Constant_Address_Clause (Expr, U_Ent);
 
+               --  Special checks for task types
+
                if Is_Task_Type (Scope (U_Ent))
                  and then Comes_From_Source (Scope (U_Ent))
                then
@@ -751,6 +785,8 @@ package body Sem_Ch13 is
                     ("\?only one task can be declared of this type", N);
                end if;
 
+               --  Entry address clauses are obsolescent
+
                Check_Restriction (No_Obsolescent_Features, N);
 
                if Warn_On_Obsolescent_Feature then
@@ -761,10 +797,12 @@ package body Sem_Ch13 is
                     ("\use interrupt procedure instead?", N);
                end if;
 
-            --  Case of an address clause for a controlled object:
-            --  erroneous execution.
+            --  Case of an address clause for a controlled object which we
+            --  consider to be erroneous.
 
-            elsif Is_Controlled (Etype (U_Ent)) then
+            elsif Is_Controlled (Etype (U_Ent))
+              or else Has_Controlled_Component (Etype (U_Ent))
+            then
                Error_Msg_NE
                  ("?controlled object& must not be overlaid", Nam, U_Ent);
                Error_Msg_N
@@ -772,6 +810,7 @@ package body Sem_Ch13 is
                Insert_Action (Declaration_Node (U_Ent),
                  Make_Raise_Program_Error (Loc,
                    Reason => PE_Overlaid_Controlled_Object));
+               return;
 
             --  Case of address clause for a (non-controlled) object
 
@@ -781,8 +820,9 @@ package body Sem_Ch13 is
               Ekind (U_Ent) = E_Constant
             then
                declare
-                  Expr : constant Node_Id   := Expression (N);
-                  Aent : constant Entity_Id := Address_Aliased_Entity (Expr);
+                  Expr  : constant Node_Id   := Expression (N);
+                  Aent  : constant Entity_Id := Address_Aliased_Entity (Expr);
+                  Ent_Y : constant Entity_Id := Find_Overlaid_Object (N);
 
                begin
                   --  Exported variables cannot have an address clause,
@@ -791,19 +831,22 @@ package body Sem_Ch13 is
                   if Is_Exported (U_Ent) then
                      Error_Msg_N
                        ("cannot export object with address clause", Nam);
+                     return;
 
                   --  Overlaying controlled objects is erroneous
 
                   elsif Present (Aent)
-                    and then Is_Controlled (Etype (Aent))
+                    and then (Has_Controlled_Component (Etype (Aent))
+                                or else Is_Controlled (Etype (Aent)))
                   then
                      Error_Msg_N
-                       ("?controlled object must not be overlaid", Expr);
+                       ("?cannot overlay with controlled object", Expr);
                      Error_Msg_N
                        ("\?Program_Error will be raised at run time", Expr);
                      Insert_Action (Declaration_Node (U_Ent),
                        Make_Raise_Program_Error (Loc,
                          Reason => PE_Overlaid_Controlled_Object));
+                     return;
 
                   elsif Present (Aent)
                     and then Ekind (U_Ent) = E_Constant
@@ -815,6 +858,7 @@ package body Sem_Ch13 is
                      Error_Msg_N
                        ("address clause not allowed"
                           & " for a renaming declaration (RM 13.1(6))", Nam);
+                     return;
 
                   --  Imported variables can have an address clause, but then
                   --  the import is pretty meaningless except to suppress
@@ -831,41 +875,13 @@ package body Sem_Ch13 is
 
                   Note_Possible_Modification (Nam);
 
-                  --  Here we are checking for explicit overlap of one
-                  --  variable by another, and if we find this, then we
-                  --  mark the overlapped variable as also being aliased.
-
-                  --  First case is where we have an explicit
-
-                  --    for J'Address use K'Address;
+                  --  Here we are checking for explicit overlap of one variable
+                  --  by another, and if we find this then mark the overlapped
+                  --  variable as also being volatile to prevent unwanted
+                  --  optimizations.
 
-                  --  In this case, we mark K as volatile
-
-                  Mark_Aliased_Address_As_Volatile (Expr);
-
-                  --  Second case is where we have a constant whose
-                  --  definition is of the form of an address as in:
-
-                  --     A : constant Address := K'Address;
-                  --     ...
-                  --     for B'Address use A;
-
-                  --  In this case we also mark K as volatile
-
-                  if Is_Entity_Name (Expr) then
-                     declare
-                        Ent  : constant Entity_Id := Entity (Expr);
-                        Decl : constant Node_Id   := Declaration_Node (Ent);
-
-                     begin
-                        if Ekind (Ent) = E_Constant
-                          and then Nkind (Decl) = N_Object_Declaration
-                          and then Present (Expression (Decl))
-                        then
-                           Mark_Aliased_Address_As_Volatile
-                             (Expression (Decl));
-                        end if;
-                     end;
+                  if Present (Ent_Y) then
+                     Set_Treat_As_Volatile (Ent_Y);
                   end if;
 
                   --  Legality checks on the address clause for initialized
@@ -900,6 +916,38 @@ package body Sem_Ch13 is
                   Kill_Size_Check_Code (U_Ent);
                end;
 
+               --  If the address clause is of the form:
+
+               --    for X'Address use Y'Address
+
+               --  or
+
+               --    Const : constant Address := Y'Address;
+               --    ...
+               --    for X'Address use Const;
+
+               --  then we make an entry in the table for checking the size and
+               --  alignment of the overlaying variable. We defer this check
+               --  till after code generation to take full advantage of the
+               --  annotation done by the back end. This entry is only made if
+               --  we have not already posted a warning about size/alignment
+               --  (some warnings of this type are posted in Checks).
+
+               if Address_Clause_Overlay_Warnings then
+                  declare
+                     Ent_X : Entity_Id := Empty;
+                     Ent_Y : Entity_Id := Empty;
+
+                  begin
+                     Ent_Y := Find_Overlaid_Object (N);
+
+                     if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then
+                        Ent_X := Entity (Name (N));
+                           Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
+                     end if;
+                  end;
+               end if;
+
             --  Not a valid entity for an address clause
 
             else
@@ -2137,7 +2185,7 @@ package body Sem_Ch13 is
       end if;
 
       --  Clear any existing component clauses for the type (this happens with
-      --  derived types, where we are now overriding the original)
+      --  derived types, where we are now overriding the original).
 
       Comp := First_Component_Or_Discriminant (Rectype);
       while Present (Comp) loop
@@ -2274,6 +2322,13 @@ package body Sem_Ch13 is
                        ("component clause previously given#", CC);
 
                   else
+                     --  Make reference for field in record rep clause and set
+                     --  appropriate entity field in the field identifier.
+
+                     Generate_Reference
+                       (Comp, Component_Name (CC), Set_Ref => False);
+                     Set_Entity (Component_Name (CC), Comp);
+
                      --  Update Fbit and Lbit to the actual bit number
 
                      Fbit := Fbit + UI_From_Int (SSU) * Posit;
@@ -2641,7 +2696,11 @@ package body Sem_Ch13 is
             then
                Comp := First_Component_Or_Discriminant (Rectype);
                while Present (Comp) loop
-                  if No (Component_Clause (Comp)) then
+                  if No (Component_Clause (Comp))
+                    and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
+                                or else Size_Known_At_Compile_Time
+                                             (Underlying_Type (Etype (Comp))))
+                  then
                      Error_Msg_Sloc := Sloc (Comp);
                      Error_Msg_NE
                        ("?no component clause given for & declared #",
@@ -3236,19 +3295,6 @@ package body Sem_Ch13 is
       end if;
    end Is_Operational_Item;
 
-   --------------------------------------
-   -- Mark_Aliased_Address_As_Volatile --
-   --------------------------------------
-
-   procedure Mark_Aliased_Address_As_Volatile (N : Node_Id) is
-      Ent : constant Entity_Id := Address_Aliased_Entity (N);
-
-   begin
-      if Present (Ent) then
-         Set_Treat_As_Volatile (Ent);
-      end if;
-   end Mark_Aliased_Address_As_Volatile;
-
    ------------------
    -- Minimum_Size --
    ------------------
@@ -3965,12 +4011,110 @@ package body Sem_Ch13 is
         and then Esize (T) < Standard_Integer_Size
       then
          Init_Esize (T, Standard_Integer_Size);
-
       else
          Init_Esize (T, Sz);
       end if;
    end Set_Enum_Esize;
 
+   ------------------------------
+   -- Validate_Address_Clauses --
+   ------------------------------
+
+   procedure Validate_Address_Clauses is
+   begin
+      for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
+         declare
+            ACCR : Address_Clause_Check_Record
+                     renames Address_Clause_Checks.Table (J);
+
+            X_Alignment : Uint;
+            Y_Alignment : Uint;
+
+            X_Size : Uint;
+            Y_Size : Uint;
+
+         begin
+            --  Skip processing of this entry if warning already posted
+
+            if not Address_Warning_Posted (ACCR.N) then
+
+               --  Get alignments. Really we should always have the alignment
+               --  of the objects properly back annotated, but right now the
+               --  back end fails to back annotate for address clauses???
+
+               if Known_Alignment (ACCR.X) then
+                  X_Alignment := Alignment (ACCR.X);
+               else
+                  X_Alignment := Alignment (Etype (ACCR.X));
+               end if;
+
+               if Known_Alignment (ACCR.Y) then
+                  Y_Alignment := Alignment (ACCR.Y);
+               else
+                  Y_Alignment := Alignment (Etype (ACCR.Y));
+               end if;
+
+               --  Similarly obtain sizes
+
+               if Known_Esize (ACCR.X) then
+                  X_Size := Esize (ACCR.X);
+               else
+                  X_Size := Esize (Etype (ACCR.X));
+               end if;
+
+               if Known_Esize (ACCR.Y) then
+                  Y_Size := Esize (ACCR.Y);
+               else
+                  Y_Size := Esize (Etype (ACCR.Y));
+               end if;
+
+               --  Check for large object overlaying smaller one
+
+               if Y_Size > Uint_0
+                 and then X_Size > Uint_0
+                 and then X_Size > Y_Size
+               then
+                  Error_Msg_N
+                    ("?size for overlaid object is too small", ACCR.N);
+                  Error_Msg_Uint_1 := X_Size;
+                  Error_Msg_NE
+                    ("\?size of & is ^", ACCR.N, ACCR.X);
+                  Error_Msg_Uint_1 := Y_Size;
+                  Error_Msg_NE
+                    ("\?size of & is ^", ACCR.N, ACCR.Y);
+
+                  --  Check for inadequate alignment. Again the defensive check
+                  --  on Y_Alignment should not be needed, but because of the
+                  --  failure in back end annotation, we can have an alignment
+                  --  of 0 here???
+
+                  --  Note: we do not check alignments if we gave a size
+                  --  warning, since it would likely be redundant.
+
+               elsif Y_Alignment /= Uint_0
+                 and then Y_Alignment < X_Alignment
+               then
+                  Error_Msg_NE
+                    ("?specified address for& may be inconsistent "
+                       & "with alignment",
+                     ACCR.N, ACCR.X);
+                  Error_Msg_N
+                    ("\?program execution may be erroneous (RM 13.3(27))",
+                     ACCR.N);
+                  Error_Msg_Uint_1 := X_Alignment;
+                  Error_Msg_NE
+                    ("\?alignment of & is ^",
+                     ACCR.N, ACCR.X);
+                  Error_Msg_Uint_1 := Y_Alignment;
+                  Error_Msg_NE
+                    ("\?alignment of & is ^",
+                     ACCR.N, ACCR.Y);
+               end if;
+            end if;
+         end;
+      end loop;
+   end Validate_Address_Clauses;
+
    -----------------------------------
    -- Validate_Unchecked_Conversion --
    -----------------------------------

gcc/ada/sem_ch13.ads

@@ -161,4 +161,10 @@ package Sem_Ch13 is
    --  The reason it is called that late is to take advantage of any
    --  back-annotation of size and alignment performed by the backend.
 
+   procedure Validate_Address_Clauses;
+   --  This is called after the back end has been called (and thus after the
+   --  alignments of objects have been back annotated). It goes through the
+   --  table of saved address clauses checking for suspicious alignments and
+   --  if necessary issuing warnings.
+
 end Sem_Ch13;

gcc/ada/sem_util.ads

@@ -292,6 +292,13 @@ package Sem_Util is
    --  denotes when analyzed. Subsequent uses of this id on a different
    --  type denote the discriminant at the same position in this new type.
 
+   function Find_Overlaid_Object (N : Node_Id) return Entity_Id;
+   --  The node N should be an address representation clause. This function
+   --  checks if the target expression is the address of some stand alone
+   --  object (variable or constant), and if so, returns its entity. If N is
+   --  not an address representation clause, or if it is not possible to
+   --  determine that the address is of this form, then Empty is returned.
+
    function Find_Overridden_Synchronized_Primitive
      (Def_Id      : Entity_Id;
       First_Hom   : Entity_Id;
@@ -304,6 +311,11 @@ package Sem_Util is
    --  declared inside the scope of the synchronized type or after. Return
    --  the overridden entity or Empty.
 
+   function Find_Static_Alternative (N : Node_Id) return Node_Id;
+   --  N is a case statement whose expression is a compile-time value.
+   --  Determine the alternative chosen, so that the code of non-selected
+   --  alternatives, and the warnings that may apply to them, are removed.
+
    function First_Actual (Node : Node_Id) return Node_Id;
    --  Node is an N_Function_Call or N_Procedure_Call_Statement node. The
    --  result returned is the first actual parameter in declaration order
@@ -321,11 +333,6 @@ package Sem_Util is
    --  name in upper case. An ASCII.NUL is appended as the last character.
    --  The names in the string are generated by Namet.Get_Decoded_Name_String.
 
-   function Find_Static_Alternative (N : Node_Id) return Node_Id;
-   --  N is a case statement whose expression is a compile-time value.
-   --  Determine the alternative chosen, so that the code of non-selected
-   --  alternatives, and the warnings that may apply to them, are removed.
-
    procedure Gather_Components
      (Typ           : Entity_Id;
       Comp_List     : Node_Id;