Patchwork [Ada] Initialize hidden discriminants in extension aggregates

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 3, 2011, 8:26 a.m.
Message ID <20110803082635.GA27225@adacore.com>
Download mbox | patch
Permalink /patch/108044/
State New
Headers show

Comments

Arnaud Charlet - Aug. 3, 2011, 8:26 a.m.
If the type of the aggregate is derived, and constrains discriminants
of the parent type, these discriminants are not components of the
aggregate, and must be initialized by the code generated by the
compiler. They are not visible components of the object, but can
become visible with a view conversion to the ancestor.

This patch adds the missing support to the frontend to generate
assignments initializing hidden discriminants in extension
aggregates. The following test must compile and execute
without errors.

package Pkg is
   type ROOT is tagged null record;

   type NT_B1 (D2 : Natural) is new Root with record
      S2 : String(1..D2);
   end record;

   type NT_B2 (D3 : Natural) is new NT_B1 (D2 => 10) with null record;
end;

with Pkg; use Pkg;
procedure Do_Test is
   String10 : String(1..10) := "1234567890";
   G : NT_B2 := (ROOT with D3 => 5, S2   => String10);
   N : Natural;
begin
   N := NT_B1(G).D2;
   if N /= 10 then
     raise Program_Error;
   end if;
end;

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

2011-08-03  Javier Miranda  <miranda@adacore.com>

	* exp_aggr.adb (Init_Hidden_Discriminants): New subprogram of
	Build_Record_Aggr_Code.
	(Build_Record_Aggr_Code): Add missing support to initialize hidden
	discriminants in extension aggregates.

Patch

Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb	(revision 177237)
+++ exp_aggr.adb	(working copy)
@@ -1854,6 +1854,11 @@ 
       --  to finalization list F. Init_Pr conditions the call to the init proc
       --  since it may already be done due to ancestor initialization.
 
+      procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
+      --  If Typ is derived, and constrains discriminants of the parent type,
+      --  these discriminants are not components of the aggregate, and must be
+      --  initialized. The assignments are appended to List.
+
       function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
       --  Check whether Bounds is a range node and its lower and higher bounds
       --  are integers literals.
@@ -2156,6 +2161,56 @@ 
          return L;
       end Init_Controller;
 
+      -------------------------------
+      -- Init_Hidden_Discriminants --
+      -------------------------------
+
+      procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is
+         Btype       : Entity_Id;
+         Parent_Type : Entity_Id;
+         Disc        : Entity_Id;
+         Discr_Val   : Elmt_Id;
+
+      begin
+         Btype := Base_Type (Typ);
+         while Is_Derived_Type (Btype)
+            and then Present (Stored_Constraint (Btype))
+         loop
+            Parent_Type := Etype (Btype);
+
+            Disc := First_Discriminant (Parent_Type);
+            Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ)));
+            while Present (Discr_Val) loop
+
+               --  Only those discriminants of the parent that are not
+               --  renamed by discriminants of the derived type need to
+               --  be added explicitly.
+
+               if not Is_Entity_Name (Node (Discr_Val))
+                 or else Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
+               then
+                  Comp_Expr :=
+                    Make_Selected_Component (Loc,
+                      Prefix        => New_Copy_Tree (Target),
+                      Selector_Name => New_Occurrence_Of (Disc, Loc));
+
+                  Instr :=
+                    Make_OK_Assignment_Statement (Loc,
+                      Name       => Comp_Expr,
+                      Expression => New_Copy_Tree (Node (Discr_Val)));
+
+                  Set_No_Ctrl_Actions (Instr);
+                  Append_To (List, Instr);
+               end if;
+
+               Next_Discriminant (Disc);
+               Next_Elmt (Discr_Val);
+            end loop;
+
+            Btype := Base_Type (Parent_Type);
+         end loop;
+      end Init_Hidden_Discriminants;
+
       -------------------------
       -- Is_Int_Range_Bounds --
       -------------------------
@@ -2741,6 +2796,17 @@ 
             end if;
          end;
 
+         --  Generate assignments of hidden assignments. If the base type is an
+         --  unchecked union, the discriminants are unknown to the back-end and
+         --  absent from a value of the type, so assignments for them are not
+         --  emitted.
+
+         if Has_Discriminants (Typ)
+           and then not Is_Unchecked_Union (Base_Type (Typ))
+         then
+            Init_Hidden_Discriminants (Typ, L);
+         end if;
+
       --  Normal case (not an extension aggregate)
 
       else
@@ -2752,60 +2818,8 @@ 
          if Has_Discriminants (Typ)
            and then not Is_Unchecked_Union (Base_Type (Typ))
          then
-            --  If the type is derived, and constrains discriminants of the
-            --  parent type, these discriminants are not components of the
-            --  aggregate, and must be initialized explicitly. They are not
-            --  visible components of the object, but can become visible with
-            --  a view conversion to the ancestor.
+            Init_Hidden_Discriminants (Typ, L);
 
-            declare
-               Btype      : Entity_Id;
-               Parent_Type : Entity_Id;
-               Disc        : Entity_Id;
-               Discr_Val   : Elmt_Id;
-
-            begin
-               Btype := Base_Type (Typ);
-               while Is_Derived_Type (Btype)
-                  and then Present (Stored_Constraint (Btype))
-               loop
-                  Parent_Type := Etype (Btype);
-
-                  Disc := First_Discriminant (Parent_Type);
-                  Discr_Val :=
-                    First_Elmt (Stored_Constraint (Base_Type (Typ)));
-                  while Present (Discr_Val) loop
-
-                     --  Only those discriminants of the parent that are not
-                     --  renamed by discriminants of the derived type need to
-                     --  be added explicitly.
-
-                     if not Is_Entity_Name (Node (Discr_Val))
-                       or else
-                         Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
-                     then
-                        Comp_Expr :=
-                          Make_Selected_Component (Loc,
-                            Prefix        => New_Copy_Tree (Target),
-                            Selector_Name => New_Occurrence_Of (Disc, Loc));
-
-                        Instr :=
-                          Make_OK_Assignment_Statement (Loc,
-                            Name       => Comp_Expr,
-                            Expression => New_Copy_Tree (Node (Discr_Val)));
-
-                        Set_No_Ctrl_Actions (Instr);
-                        Append_To (L, Instr);
-                     end if;
-
-                     Next_Discriminant (Disc);
-                     Next_Elmt (Discr_Val);
-                  end loop;
-
-                  Btype := Base_Type (Parent_Type);
-               end loop;
-            end;
-
             --  Generate discriminant init values for the visible discriminants
 
             declare