Patchwork [Ada] Implementation of Ada 2012 AI05-0026: Missing rules for Unchecked_Union

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 7, 2010, 9:27 a.m.
Message ID <20101007092700.GA31414@adacore.com>
Download mbox | patch
Permalink /patch/67021/
State New
Headers show

Comments

Arnaud Charlet - Oct. 7, 2010, 9:27 a.m.
This patch integrates the new semantic rules as defined in AI05-0026 version
1.6 concerning Unchecked_Union types. The following test program illustrates
the major points of the AI.

procedure Main is
begin
   declare
      type UU (Discr : Boolean := False) is record
         Comp1 : Integer;
         case Discr is
            when True =>
               Comp2 : Float;
            when others =>
               Comp3 : Integer;
         end case;
      end record;
      pragma Unchecked_Union (UU);

      for UU use record
         Discr at 0 range 0 .. 8;  --  ERROR
      end record;
   begin
      null;
   end;

   declare
      type Root is tagged null record;

      generic
         type Priv_Formal_Typ is private;
         type Priv_Formal_Ext is new Root with private;
      package Solitary_Gen is
         type Spec_UU (Discr : Boolean := False) is record
            Comp1 : Priv_Formal_Typ;  --  OK
            case Discr is
               when True =>
                  Comp2 : Priv_Formal_Typ;  --  OK
               when False =>
                  Comp3 : Priv_Formal_Ext;  --  OK
            end case;
         end record;
         pragma Unchecked_Union (Spec_UU);
         procedure Dummy;
      end Solitary_Gen;

      package body Solitary_Gen is
         type Body_UU (Discr : Boolean := False) is record
            Comp1 : Priv_Formal_Typ;  --  OK
            case Discr is
               when True =>
                  Comp2 : Priv_Formal_Typ;  --  ERROR
               when False =>
                  Comp3 : Priv_Formal_Ext;  --  ERROR
            end case;
         end record;
         pragma Unchecked_Union (Body_UU);
         procedure Dummy is
         begin
            null;
         end Dummy;
      end Solitary_Gen;
   begin
      null;
   end;
end Main;

-----------------
-- Compilation --
-----------------

gnatmake -gnat12 main.adb

---------------------
-- Expected output --
---------------------

main.adb:16:10: cannot reference discriminant of Unchecked_Union
main.adb:47:19: component of Unchecked_Union cannot be of generic type
main.adb:49:19: component of Unchecked_Union cannot be of generic type

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

2010-10-07  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch13.adb (Analyze_Record_Representation_Clause): Alphabetize all
	local variables. Remove the general restriction which prohibits the
	application of record rep clauses to Unchecked_Union types. Add Ada
	2012 check to detect improper naming of an Unchecked_Union
	discriminant in record rep clause.
	* sem_prag.adb: Add with and use clause for Exp_Ch7.
	(Analyze_Pragma): Unchecked_Union case: Propagate the Unchecked_Union
	type to all invocations of Check_Component and Check_Variant.
	(Check_Component): Add formal parameters UU_Typ and In_Variant_Part.
	Rewritten.  Add Ada 2012 check to detect improper use of formal
	private types and private extensions as component types of an
	Unchecked_Union declared inside a generic body.
	(Check_Variant): Add formal parameter UU_Typ. Propagate the
	Unchecked_Union type to all calls of Check_Component. Signal that the
	current component comes from the variant part of an Unchecked_Union
	type.
	(Inside_Generic_Body): New routine.

Patch

Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165082)
+++ sem_prag.adb	(working copy)
@@ -37,6 +37,7 @@  with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Exp_Ch7;  use Exp_Ch7;
 with Exp_Dist; use Exp_Dist;
 with Lib;      use Lib;
 with Lib.Writ; use Lib.Writ;
@@ -392,9 +393,14 @@  package body Sem_Prag is
       procedure Check_At_Most_N_Arguments (N : Nat);
       --  Check there are no more than N arguments present
 
-      procedure Check_Component (Comp : Node_Id);
-      --  Examine Unchecked_Union component for correct use of per-object
+      procedure Check_Component
+        (Comp            : Node_Id;
+         UU_Typ          : Entity_Id;
+         In_Variant_Part : Boolean := False);
+      --  Examine an Unchecked_Union component for correct use of per-object
       --  constrained subtypes, and for restrictions on finalizable components.
+      --  UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
+      --  should be set when Comp comes from a record variant.
 
       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
       --  Nam is an N_String_Literal node containing the external name set by
@@ -483,9 +489,10 @@  package body Sem_Prag is
       --  and to library level instantiations), and they are simply ignored,
       --  which is implemented by rewriting them as null statements.
 
-      procedure Check_Variant (Variant : Node_Id);
-      --  Check Unchecked_Union variant for lack of nested variants and
-      --  presence of at least one component.
+      procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
+      --  Check an Unchecked_Union variant for lack of nested variants and
+      --  presence of at least one component. UU_Typ is the related Unchecked_
+      --  Union type.
 
       procedure Error_Pragma (Msg : String);
       pragma No_Return (Error_Pragma);
@@ -1094,39 +1101,80 @@  package body Sem_Prag is
       -- Check_Component --
       ---------------------
 
-      procedure Check_Component (Comp : Node_Id) is
-      begin
-         if Nkind (Comp) = N_Component_Declaration then
-            declare
-               Sindic : constant Node_Id :=
-                          Subtype_Indication (Component_Definition (Comp));
-               Typ    : constant Entity_Id :=
-                          Etype (Defining_Identifier (Comp));
-            begin
-               if Nkind (Sindic) = N_Subtype_Indication then
+      procedure Check_Component
+        (Comp            : Node_Id;
+         UU_Typ          : Entity_Id;
+         In_Variant_Part : Boolean := False)
+      is
+         Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
+         Sindic  : constant Node_Id :=
+                     Subtype_Indication (Component_Definition (Comp));
+         Typ     : constant Entity_Id := Etype (Comp_Id);
 
-                  --  Ada 2005 (AI-216): If a component subtype is subject to
-                  --  a per-object constraint, then the component type shall
-                  --  be an Unchecked_Union.
+         function Inside_Generic_Body (Id : Entity_Id) return Boolean;
+         --  Determine whether entity Id appears inside a generic body
 
-                  if Has_Per_Object_Constraint (Defining_Identifier (Comp))
-                    and then
-                      not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
-                  then
-                     Error_Msg_N ("component subtype subject to per-object" &
-                       " constraint must be an Unchecked_Union", Comp);
-                  end if;
-               end if;
+         -------------------------
+         -- Inside_Generic_Body --
+         -------------------------
 
-               if Is_Controlled (Typ) then
-                  Error_Msg_N
-                   ("component of unchecked union cannot be controlled", Comp);
+         function Inside_Generic_Body (Id : Entity_Id) return Boolean is
+            S : Entity_Id := Id;
 
-               elsif Has_Task (Typ) then
-                  Error_Msg_N
-                   ("component of unchecked union cannot have tasks", Comp);
+         begin
+            while Present (S)
+              and then S /= Standard_Standard
+            loop
+               if Ekind (S) = E_Generic_Package
+                 and then In_Package_Body (S)
+               then
+                  return True;
                end if;
-            end;
+
+               S := Scope (S);
+            end loop;
+
+            return False;
+         end Inside_Generic_Body;
+
+      --  Start of processing for Check_Component
+
+      begin
+         --  Ada 2005 (AI-216): If a component subtype is subject to a per-
+         --  object constraint, then the component type shall be an Unchecked_
+         --  Union.
+
+         if Nkind (Sindic) = N_Subtype_Indication
+           and then Has_Per_Object_Constraint (Comp_Id)
+           and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+         then
+            Error_Msg_N
+              ("component subtype subject to per-object constraint " &
+               "must be an Unchecked_Union", Comp);
+
+         --  Ada 2012 (AI05-0026): For an unchecked union type declared within
+         --  the body of a generic unit, or within the body of any of its
+         --  descendant library units, no part of the type of a component
+         --  declared in a variant_part of the unchecked union type shall be of
+         --  a formal private type or formal private extension declared within
+         --  the formal part of the generic unit.
+
+         elsif Ada_Version >= Ada_2012
+           and then Inside_Generic_Body (UU_Typ)
+           and then In_Variant_Part
+           and then Is_Private_Type (Typ)
+           and then Is_Generic_Type (Typ)
+         then
+            Error_Msg_N
+              ("component of Unchecked_Union cannot be of generic type", Comp);
+
+         elsif Needs_Finalization (Typ) then
+            Error_Msg_N
+              ("component of Unchecked_Union cannot be controlled", Comp);
+
+         elsif Has_Task (Typ) then
+            Error_Msg_N
+              ("component of Unchecked_Union cannot have tasks", Comp);
          end if;
       end Check_Component;
 
@@ -1698,7 +1746,7 @@  package body Sem_Prag is
       -- Check_Variant --
       -------------------
 
-      procedure Check_Variant (Variant : Node_Id) is
+      procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
          Clist : constant Node_Id := Component_List (Variant);
          Comp  : Node_Id;
 
@@ -1712,7 +1760,7 @@  package body Sem_Prag is
 
          Comp := First (Component_Items (Clist));
          while Present (Comp) loop
-            Check_Component (Comp);
+            Check_Component (Comp, UU_Typ, In_Variant_Part => True);
             Next (Comp);
          end loop;
       end Check_Variant;
@@ -11971,7 +12019,7 @@  package body Sem_Prag is
 
                Comp := First (Component_Items (Clist));
                while Present (Comp) loop
-                  Check_Component (Comp);
+                  Check_Component (Comp, Typ);
                   Next (Comp);
                end loop;
 
@@ -11986,7 +12034,7 @@  package body Sem_Prag is
 
                Variant := First (Variants (Vpart));
                while Present (Variant) loop
-                  Check_Variant (Variant);
+                  Check_Variant (Variant, Typ);
                   Next (Variant);
                end loop;
             end if;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165080)
+++ sem_ch13.adb	(working copy)
@@ -2506,16 +2506,16 @@  package body Sem_Ch13 is
    --  for the remainder of this processing.
 
    procedure Analyze_Record_Representation_Clause (N : Node_Id) is
-      Ident   : constant Node_Id    := Identifier (N);
-      Rectype : Entity_Id;
+      Ident   : constant Node_Id := Identifier (N);
+      Biased  : Boolean;
       CC      : Node_Id;
-      Posit   : Uint;
+      Comp    : Entity_Id;
       Fbit    : Uint;
-      Lbit    : Uint;
       Hbit    : Uint := Uint_0;
-      Comp    : Entity_Id;
+      Lbit    : Uint;
       Ocomp   : Entity_Id;
-      Biased  : Boolean;
+      Posit   : Uint;
+      Rectype : Entity_Id;
 
       CR_Pragma : Node_Id := Empty;
       --  Points to N_Pragma node if Complete_Representation pragma present
@@ -2543,10 +2543,6 @@  package body Sem_Ch13 is
            ("record type required, found}", Ident, First_Subtype (Rectype));
          return;
 
-      elsif Is_Unchecked_Union (Rectype) then
-         Error_Msg_N
-           ("record rep clause not allowed for Unchecked_Union", N);
-
       elsif Scope (Rectype) /= Current_Scope then
          Error_Msg_N ("type must be declared in this scope", N);
          return;
@@ -2722,6 +2718,24 @@  package body Sem_Ch13 is
                      Error_Msg_N
                        ("component clause is for non-existent field", CC);
 
+                  --  Ada 2012 (AI05-0026): Any name that denotes a
+                  --  discriminant of an object of an unchecked union type
+                  --  shall not occur within a record_representation_clause.
+
+                  --  The general restriction of using record rep clauses on
+                  --  Unchecked_Union types has now been lifted. Since it is
+                  --  possible to introduce a record rep clause which mentions
+                  --  the discriminant of an Unchecked_Union in non-Ada 2012
+                  --  code, this check is applied to all versions of the
+                  --  language.
+
+                  elsif Ekind (Comp) = E_Discriminant
+                    and then Is_Unchecked_Union (Rectype)
+                  then
+                     Error_Msg_N
+                       ("cannot reference discriminant of Unchecked_Union",
+                        Component_Name (CC));
+
                   elsif Present (Component_Clause (Comp)) then
 
                      --  Diagnose duplicate rep clause, or check consistency