===================================================================
@@ -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;
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); begin return Res2; end Create; end X; --- package P is type Root_1 (V : Integer) is tagged record null; end record; type Child_1_3 is new Root_1 (1) with private; 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.