[Ada] Class-wide types of private extensions of constrained types

Message ID 20100618090707.GA1015@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet June 18, 2010, 9:07 a.m.
The class-wide type of private extension is created when the partial view is
analyzed. This class-wide type is shared with the full view. If the full view
is a subtype, as is the case when the parent is a constrained discriminated
subtype, the type of the private extension must be the base type of the full
view, to prevent spurious semantic errors when the classwide equivalent type
is constructed. This expansion involves dispatching calls to Size and to
Deep_Adjust, and these are best expressed on the full view.

   x.adb must compile quietly:  
with P; use P;
package X is

   function Create return access Child_1_3'Class;

   type Child_Acc is access all Child_1_3'Class;

end X;
package body X is
   function Create return access Child_1_3'Class is
      Res : Child_Acc := new Child_1_3;
      Res2 : Child_Acc := new Child_1_3'Class'(Res.all);

      return Res2;
   end Create;
end X;
package P is
   type Root_1 (V : Integer) is tagged record
   end record;

   type Child_1_3 is new Root_1 (1) with private;

   type Child_1_3 is new Root_1 (1) with null record;
end P;

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

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is
	the class-wide type for a private extension, and the completion is a
	subtype, set the type of the class-wide type to the base type of the
	full view.


Index: exp_util.adb
--- exp_util.adb	(revision 160962)
+++ exp_util.adb	(working copy)
@@ -4052,6 +4052,20 @@  package body Exp_Util is
             --  additional intermediate type to handle the assignment).
             if Expander_Active and then Tagged_Type_Expansion then
+               --  If this is the class_wide type of a completion that is
+               --  a record subtype, set the type of the class_wide type
+               --  to be the full base type, for use in the expanded code
+               --  for the equivalent type. Should this be done earlier when
+               --  the completion is analyzed ???
+               if Is_Private_Type (Etype (Unc_Typ))
+                 and then
+                   Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
+               then
+                  Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
+               end if;
                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
             end if;