[Ada] AI12-0226 Make objects more consistent

Message ID 20200608080043.GA90295@adacore.com
State New
Headers show
Series
  • [Ada] AI12-0226 Make objects more consistent
Related show

Commit Message

Pierre-Marie de Rodat June 8, 2020, 8 a.m.
Clean up Analyze_Object_Renaming and Is_Object_Reference while
implementing this new AI and recognize value conversion of objects as an
object reference.

Tested on x86_64-pc-linux-gnu, committed on trunk

2020-06-08  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	* sem_ch8.adb (Analyze_Object_Renaming): Simplify code by moving
	many special cases to Is_Object_Reference and removing others by
	only checking renamings coming from sources.
	* sem_util.adb (Is_Object_Reference): Update for AI12-0226 and
	add more regular handling of 'Priority. Remove special cases no
	longer needed now that we are only checking renamings coming
	from sources.

Patch

--- gcc/ada/sem_ch8.adb
+++ gcc/ada/sem_ch8.adb
@@ -759,12 +759,13 @@  package body Sem_Ch8 is
    -----------------------------
 
    procedure Analyze_Object_Renaming (N : Node_Id) is
-      Id  : constant Entity_Id  := Defining_Identifier (N);
-      Loc : constant Source_Ptr := Sloc (N);
-      Nam : constant Node_Id    := Name (N);
-      Dec : Node_Id;
-      T   : Entity_Id;
-      T2  : Entity_Id;
+      Id            : constant Entity_Id  := Defining_Identifier (N);
+      Loc           : constant Source_Ptr := Sloc (N);
+      Nam           : constant Node_Id    := Name (N);
+      Is_Object_Ref : Boolean := False;
+      Dec           : Node_Id;
+      T             : Entity_Id;
+      T2            : Entity_Id;
 
       procedure Check_Constrained_Object;
       --  If the nominal type is unconstrained but the renamed object is
@@ -1016,18 +1017,6 @@  package body Sem_Ch8 is
             Mark_Ghost_Renaming (N, Entity (Nam));
          end if;
 
-         --  Reject renamings of conversions unless the type is tagged, or
-         --  the conversion is implicit (which can occur for cases of anonymous
-         --  access types in Ada 2012).
-
-         if Nkind (Nam) = N_Type_Conversion
-           and then Comes_From_Source (Nam)
-           and then not Is_Tagged_Type (T)
-         then
-            Error_Msg_N
-              ("renaming of conversion only allowed for tagged types", Nam);
-         end if;
-
          Resolve (Nam, T);
 
          --  If the renamed object is a function call of a limited type,
@@ -1268,15 +1257,7 @@  package body Sem_Ch8 is
          return;
       end if;
 
-      --  Ada 2005 (AI-327)
-
-      if Ada_Version >= Ada_2005
-        and then Nkind (Nam) = N_Attribute_Reference
-        and then Attribute_Name (Nam) = Name_Priority
-      then
-         null;
-
-      elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
+      if Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
          declare
             Nam_Ent  : constant Entity_Id := Entity (Get_Object_Name (Nam));
             Nam_Decl : constant Node_Id   := Declaration_Node (Nam_Ent);
@@ -1375,13 +1356,33 @@  package body Sem_Ch8 is
 
       Init_Object_Size_Align (Id);
 
+      --  If N comes from source then check that the original node is an
+      --  object reference since there may have been several rewritting and
+      --  folding. Do not do this for N_Function_Call or N_Explicit_Dereference
+      --  which might correspond to rewrites of e.g. N_Selected_Component
+      --  (for example Object.Method rewriting).
+      --  If N does not come from source then assume the tree is properly
+      --  formed and accept any object reference. In such cases we do support
+      --  more cases of renamings anyway, so the actual check on which renaming
+      --  is valid is better left to the code generator as a last sanity
+      --  check.
+
+      if Comes_From_Source (N) then
+         if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) then
+            Is_Object_Ref := Is_Object_Reference (Nam);
+         else
+            Is_Object_Ref := Is_Object_Reference (Original_Node (Nam));
+         end if;
+      else
+         Is_Object_Ref := True;
+      end if;
+
       if T = Any_Type or else Etype (Nam) = Any_Type then
          return;
 
-      --  Verify that the renamed entity is an object or a function call. It
-      --  may have been rewritten in several ways.
+      --  Verify that the renamed entity is an object or function call.
 
-      elsif Is_Object_Reference (Nam) then
+      elsif Is_Object_Ref then
          if Comes_From_Source (N) then
             if Is_Dependent_Component_Of_Mutable_Object (Nam) then
                Error_Msg_N
@@ -1400,49 +1401,15 @@  package body Sem_Ch8 is
             end if;
          end if;
 
-      --  A static function call may have been folded into a literal
+      --  Weird but legal, equivalent to renaming a function call. Illegal
+      --  if the literal is the result of constant-folding an attribute
+      --  reference that is not a function.
 
-      elsif Nkind (Original_Node (Nam)) = N_Function_Call
-
-        --  When expansion is disabled, attribute reference is not rewritten
-        --  as function call. Otherwise it may be rewritten as a conversion,
-        --  so check original node.
-
-        or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference
-                  and then Is_Function_Attribute_Name
-                             (Attribute_Name (Original_Node (Nam))))
-
-        --  Weird but legal, equivalent to renaming a function call. Illegal
-        --  if the literal is the result of constant-folding an attribute
-        --  reference that is not a function.
-
-        or else (Is_Entity_Name (Nam)
-                  and then Ekind (Entity (Nam)) = E_Enumeration_Literal
-                  and then
-                    Nkind (Original_Node (Nam)) /= N_Attribute_Reference)
-
-        or else (Nkind (Nam) = N_Type_Conversion
-                  and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
-      then
-         null;
-
-      elsif Nkind (Nam) = N_Type_Conversion then
-         Error_Msg_N
-           ("renaming of conversion only allowed for tagged types", Nam);
-
-      --  Ada 2005 (AI-327)
-
-      elsif Ada_Version >= Ada_2005
-        and then Nkind (Nam) = N_Attribute_Reference
-        and then Attribute_Name (Nam) = Name_Priority
+      elsif Is_Entity_Name (Nam)
+        and then Ekind (Entity (Nam)) = E_Enumeration_Literal
+        and then Nkind (Original_Node (Nam)) /= N_Attribute_Reference
       then
          null;
-
-      --  Allow internally generated x'Ref resulting in N_Reference node
-
-      elsif Nkind (Nam) = N_Reference then
-         null;
-
       else
          Error_Msg_N ("expect object name in renaming", Nam);
       end if;

--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -16420,33 +16420,6 @@  package body Sem_Util is
    -------------------------
 
    function Is_Object_Reference (N : Node_Id) return Boolean is
-      function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
-      --  Determine whether N is the name of an internally-generated renaming
-
-      --------------------------------------
-      -- Is_Internally_Generated_Renaming --
-      --------------------------------------
-
-      function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
-         P : Node_Id;
-
-      begin
-         P := N;
-         while Present (P) loop
-            if Nkind (P) = N_Object_Renaming_Declaration then
-               return not Comes_From_Source (P);
-            elsif Is_List_Member (P) then
-               return False;
-            end if;
-
-            P := Parent (P);
-         end loop;
-
-         return False;
-      end Is_Internally_Generated_Renaming;
-
-   --  Start of processing for Is_Object_Reference
-
    begin
       if Is_Entity_Name (N) then
          return Present (Entity (N)) and then Is_Object (Entity (N));
@@ -16472,13 +16445,14 @@  package body Sem_Util is
             =>
                return Etype (N) /= Standard_Void_Type;
 
-            --  Attributes references 'Loop_Entry, 'Old, and 'Result yield
-            --  objects, even though they are not functions.
+            --  Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
+            --  yield objects, even though they are not functions.
 
             when N_Attribute_Reference =>
                return
                  Nam_In (Attribute_Name (N), Name_Loop_Entry,
                                              Name_Old,
+                                             Name_Priority,
                                              Name_Result)
                    or else Is_Function_Attribute_Name (Attribute_Name (N));
 
@@ -16501,9 +16475,19 @@  package body Sem_Util is
             --  A view conversion of a tagged object is an object reference
 
             when N_Type_Conversion =>
-               return Is_Tagged_Type (Etype (Subtype_Mark (N)))
-                 and then Is_Tagged_Type (Etype (Expression (N)))
-                 and then Is_Object_Reference (Expression (N));
+               if Ada_Version <= Ada_2012 then
+                  --  A view conversion of a tagged object is an object
+                  --  reference.
+                  return Is_Tagged_Type (Etype (Subtype_Mark (N)))
+                    and then Is_Tagged_Type (Etype (Expression (N)))
+                    and then Is_Object_Reference (Expression (N));
+
+               else
+                  --  AI12-0226: In Ada 202x a value conversion of an object is
+                  --  an object.
+
+                  return Is_Object_Reference (Expression (N));
+               end if;
 
             --  An unchecked type conversion is considered to be an object if
             --  the operand is an object (this construction arises only as a
@@ -16512,14 +16496,6 @@  package body Sem_Util is
             when N_Unchecked_Type_Conversion =>
                return True;
 
-            --  Allow string literals to act as objects as long as they appear
-            --  in internally-generated renamings. The expansion of iterators
-            --  may generate such renamings when the range involves a string
-            --  literal.
-
-            when N_String_Literal =>
-               return Is_Internally_Generated_Renaming (Parent (N));
-
             --  AI05-0003: In Ada 2012 a qualified expression is a name.
             --  This allows disambiguation of function calls and the use
             --  of aggregates in more contexts.