Patchwork [Ada] Class_wide type of a private subtype

login
register
mail settings
Submitter Arnaud Charlet
Date June 16, 2010, 3:48 p.m.
Message ID <20100616154806.GA24661@adacore.com>
Download mbox | patch
Permalink /patch/55900/
State New
Headers show

Comments

Arnaud Charlet - June 16, 2010, 3:48 p.m.
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.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 160834)
+++ sem_ch3.adb	(working copy)
@@ -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,