[Ada] Implement AI12-0109 (prohibit some "early" derivations)

Message ID 20191213095501.GA13983@adacore.com
State New
Headers show
Series
  • [Ada] Implement AI12-0109 (prohibit some "early" derivations)
Related show

Commit Message

Pierre-Marie de Rodat Dec. 13, 2019, 9:55 a.m.
If a by-reference untagged type has primitive subprograms, then the
representations of that type and any type derived from it need to match.
This is because passing in a reference to a "change of representation"
copy doesn't work for a by-reference type.  AI12-0109 is a binding
interpretation that plugs a hole that could otherwise be used to violate
this design principle. AI12-0109 ensures that all representation aspects
of the parent are inherited by the derived type; this is achieved by
prohibiting the case where the derivation precedes the specification of
a type-related representation aspect of the parent type.

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

2019-12-13  Steve Baird  <baird@adacore.com>

gcc/ada/

	* einfo.ads: Correct comment for Derived_Type_Link to reflect
	that fact that this function is now used for more than just
	generation of warnings.
	* sem_ch3.adb (Build_Derived_Type): Do not call
	Set_Derived_Type_Link if the derived type and the parent type
	are in different compilation units. Such a derivation cannot be
	a problematic "early" derivation (identifying these is what the
	Derived_Type_Link attribute is used for) and we don't like
	inter-unit references that go in the opposite direction of
	semantic dependencies.
	* sem_ch13.adb (Is_Type_Related_Rep_Item): A new function,
	analogous to the existing function Is_Operational_Item.
	(Rep_Item_Too_Late): Generate a hard error (with same text as
	the warning that was previously being generated) if the
	AI12-0109 legality rule is violated.

Patch

--- gcc/ada/einfo.ads
+++ gcc/ada/einfo.ads
@@ -929,12 +929,12 @@  package Einfo is
 --
 --       In this case, if primitive operations have been declared for R, at
 --       the point of declaration of G, then the Derived_Type_Link of R is set
---       to point to the entity for G. This is used to generate warnings for
---       rep clauses that appear later on for R, which might result in an
---       unexpected implicit conversion operation.
+--       to point to the entity for G. This is used to generate warnings and
+--       errors for rep clauses that appear later on for R, which might result
+--       in an unexpected (or illegal) implicit conversion operation.
 --
 --       Note: if there is more than one such derived type, the link will point
---       to the last one (this is only used in generating warning messages).
+--       to the last one.
 
 --    Designated_Type (synthesized)
 --       Applies to access types. Returns the designated type. Differs from

--- gcc/ada/sem_ch13.adb
+++ gcc/ada/sem_ch13.adb
@@ -154,6 +154,10 @@  package body Sem_Ch13 is
    --  that do not specify a representation characteristic are operational
    --  attributes.
 
+   function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean;
+   --  Returns True for a representation clause/pragma that specifies a
+   --  type-related representation (as opposed to operational) aspect.
+
    function Is_Predicate_Static
      (Expr : Node_Id;
       Nam  : Name_Id) return Boolean;
@@ -12282,6 +12286,59 @@  package body Sem_Ch13 is
       end if;
    end Is_Predicate_Static;
 
+   ------------------------------
+   -- Is_Type_Related_Rep_Item --
+   ------------------------------
+
+   function Is_Type_Related_Rep_Item (N : Node_Id) return Boolean is
+   begin
+      case Nkind (N) is
+         when N_Attribute_Definition_Clause =>
+            declare
+               Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
+               --  See AARM 13.1(8.f-8.x) list items that end in "clause"
+               --  ???: include any GNAT-defined attributes here?
+            begin
+               return    Id = Attribute_Component_Size
+                 or else Id = Attribute_Bit_Order
+                 or else Id = Attribute_Storage_Pool
+                 or else Id = Attribute_Stream_Size
+                 or else Id = Attribute_Machine_Radix;
+            end;
+
+         when N_Pragma =>
+            case Get_Pragma_Id (N) is
+               --  See AARM 13.1(8.f-8.x) list items that start with "pragma"
+               --  ???: include any GNAT-defined pragmas here?
+               when Pragma_Pack
+                  | Pragma_Import
+                  | Pragma_Export
+                  | Pragma_Convention
+                  | Pragma_Atomic
+                  | Pragma_Independent
+                  | Pragma_Volatile
+                  | Pragma_Atomic_Components
+                  | Pragma_Independent_Components
+                  | Pragma_Volatile_Components
+                  | Pragma_Discard_Names
+               =>
+                  return True;
+               when others =>
+                  null;
+            end case;
+
+         when N_Enumeration_Representation_Clause
+            | N_Record_Representation_Clause
+         =>
+            return True;
+
+         when others =>
+            null;
+      end case;
+
+      return False;
+   end Is_Type_Related_Rep_Item;
+
    ---------------------
    -- Kill_Rep_Clause --
    ---------------------
@@ -12964,7 +13021,7 @@  package body Sem_Ch13 is
       end if;
 
       --  No error, but one more warning to consider. The RM (surprisingly)
-      --  allows this pattern:
+      --  allows this pattern in some cases:
 
       --    type S is ...
       --    primitive operations for S
@@ -12973,7 +13030,7 @@  package body Sem_Ch13 is
 
       --  Meaning that calls on the primitive operations of S for values of
       --  type R may require possibly expensive implicit conversion operations.
-      --  This is not an error, but is worth a warning.
+      --  So even when this is not an error, it is still worth a warning.
 
       if not Relaxed_RM_Semantics and then Is_Type (T) then
          declare
@@ -12981,26 +13038,47 @@  package body Sem_Ch13 is
 
          begin
             if Present (DTL)
-              and then Has_Primitive_Operations (Base_Type (T))
 
-              --  For now, do not generate this warning for the case of aspect
-              --  specification using Ada 2012 syntax, since we get wrong
-              --  messages we do not understand. The whole business of derived
-              --  types and rep items seems a bit confused when aspects are
-              --  used, since the aspects are not evaluated till freeze time.
+              --  For now, do not generate this warning for the case of
+              --  aspect specification using Ada 2012 syntax, since we get
+              --  wrong messages we do not understand. The whole business
+              --  of derived types and rep items seems a bit confused when
+              --  aspects are used, since the aspects are not evaluated
+              --  till freeze time. However, AI12-0109 confirms (in an AARM
+              --  ramification) that inheritance in this case is required
+              --  to work.
 
               and then not From_Aspect_Specification (N)
             then
-               Error_Msg_Sloc := Sloc (DTL);
-               Error_Msg_N
-                 ("representation item for& appears after derived type "
-                  & "declaration#??", N);
-               Error_Msg_NE
-                 ("\may result in implicit conversions for primitive "
-                  & "operations of&??", N, T);
-               Error_Msg_NE
-                 ("\to change representations when called with arguments "
-                  & "of type&??", N, DTL);
+               if Is_By_Reference_Type (T)
+                 and then not Is_Tagged_Type (T)
+                 and then Is_Type_Related_Rep_Item (N)
+                 and then (Ada_Version >= Ada_2012
+                            or else Has_Primitive_Operations (Base_Type (T)))
+               then
+                  --  Treat as hard error (AI12-0109, binding interpretation).
+                  --  Implementing a change of representation is not really
+                  --  an option in the case of a by-reference type, so we
+                  --  take this path for all Ada dialects if primitive
+                  --  operations are present.
+                  Error_Msg_Sloc := Sloc (DTL);
+                  Error_Msg_N
+                    ("representation item for& appears after derived type "
+                     & "declaration#", N);
+
+               elsif Has_Primitive_Operations (Base_Type (T)) then
+                  Error_Msg_Sloc := Sloc (DTL);
+
+                  Error_Msg_N
+                    ("representation item for& appears after derived type "
+                     & "declaration#??", N);
+                  Error_Msg_NE
+                    ("\may result in implicit conversions for primitive "
+                     & "operations of&??", N, T);
+                  Error_Msg_NE
+                    ("\to change representations when called with arguments "
+                     & "of type&??", N, DTL);
+               end if;
             end if;
          end;
       end if;

--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -9741,9 +9741,17 @@  package body Sem_Ch3 is
            (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
       end if;
 
-      --  If the parent has primitive routines, set the derived type link
-
-      if Has_Primitive_Operations (Parent_Type) then
+      --  If the parent has primitive routines and may have not-seen-yet aspect
+      --  specifications (e.g., a Pack pragma), then set the derived type link
+      --  in order to later diagnose "early derivation" issues. If in different
+      --  compilation units, then "early derivation" cannot be an issue (and we
+      --  don't like interunit references that go in the opposite direction of
+      --  semantic dependencies).
+
+      if Has_Primitive_Operations (Parent_Type)
+         and then Enclosing_Comp_Unit_Node (Parent_Type) =
+           Enclosing_Comp_Unit_Node (Derived_Type)
+      then
          Set_Derived_Type_Link (Parent_Base, Derived_Type);
       end if;