===================================================================
@@ -9584,7 +9584,14 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Full_Base) then
Set_Is_Tagged_Type (Full);
Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
- Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
+
+ -- Inherit class_wide type of full_base in case the partial view was
+ -- not tagged. Otherwise it has already been created when the private
+ -- subtype was analyzed.
+
+ if No (Class_Wide_Type (Full)) then
+ Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
+ end if;
-- If this is a subtype of a protected or task type, constrain its
-- corresponding record, unless this is a subtype without constraints,
There is a separate class_wide type for each subtype of a discriminated type. When the parent type is a private type, the completion of the subtype (which is created at the time the full view of the parent is analyzed) must have the same class_wide type. Prior to this patch the completion inherited the class_wide type of the parent type. The following must compile quietly: --- package P is type Kinds is (A, C); type T (K : Kinds) is abstract tagged limited private; subtype TA is T (A); procedure B (S : not null access TA'Class); private type T (K : Kinds) is abstract tagged limited null record; end P; --- package body P is procedure B (S : not null access TA'Class) is begin null; end B; end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-16 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Complete_Private_Subtype): Inherit class_wide type from base type only if it was not previously created for the partial view.