Patchwork [Ada] Extension aggregate with ancestor that is a constrained private extension

login
register
mail settings
Submitter Arnaud Charlet
Date June 17, 2010, 3:24 p.m.
Message ID <20100617152422.GA14120@adacore.com>
Download mbox | patch
Permalink /patch/56059/
State New
Headers show

Comments

Arnaud Charlet - June 17, 2010, 3:24 p.m.
This patch fixes the handling of extension aggregates when the parent type is
a private extension that constrains a discriminant of the parent.

The following must compile quietly:

with P; use P;
package X is

   type Base_I is interface;
   type Interface_And_Child is new Child_1_3 and Base_I with null record;

   function Copy_No_Clone
     (Object : Interface_And_Child) return access Interface_And_Child;

   type Interface_And_Child_Acc is access all Interface_And_Child'Class;
end X;
---
package body X is

   function Copy_No_Clone
     (Object : Interface_And_Child) return access Interface_And_Child
   is
      Res : Interface_And_Child_Acc :=
        new Interface_And_Child'(Child_1_3 with others => <>);
   begin
      return Res;
   end Copy_No_Clone;
end X;
---
package P is
   type Root_1 (V : Integer) is tagged null 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-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Valid_Ancestor_Type): handle properly the case of a
	constrained discriminated parent that is a private type.
	(Analyze_Record_Aggregate): when collecting inherited discriminants,
	handle properly an ancestor type that is a constrained private type.

Patch

Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb	(revision 160919)
+++ sem_aggr.adb	(working copy)
@@ -2288,6 +2288,18 @@  package body Sem_Aggr is
             then
                A_Type := Etype (Imm_Type);
                return True;
+
+            --  The parent type may be a private extension. The aggregate is
+            --  legal if the type of the aggregate is an extension of it that
+            --  is not a private extension.
+
+            elsif Is_Private_Type (A_Type)
+              and then not Is_Private_Type (Imm_Type)
+              and then Present (Full_View (A_Type))
+              and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type)
+            then
+               return True;
+
             else
                Imm_Type := Etype (Base_Type (Imm_Type));
             end if;
@@ -2502,11 +2514,9 @@  package body Sem_Aggr is
          From                   : List_Id;
          Consider_Others_Choice : Boolean := False)
          return                   Node_Id;
-      --  Given a record component stored in parameter Compon, the following
-      --  function returns its value as it appears in the list From, which is
-      --  a list of N_Component_Association nodes.
-      --  What is this referring to??? There is no "following function" in
-      --  sight???
+      --  Given a record component stored in parameter Compon, this function
+      --  returns its value as it appears in the list From, which is a list
+      --  of N_Component_Association nodes.
       --
       --  If no component association has a choice for the searched component,
       --  the value provided by the others choice is returned, if there is one,
@@ -3241,12 +3251,11 @@  package body Sem_Aggr is
 
                Dnode := Declaration_Node (Base_Type (Root_Typ));
 
-               --  If we don't get a full declaration, then we have some
-               --  error which will get signalled later so skip this part.
-               --  Otherwise, gather components of root that apply to the
-               --  aggregate type. We use the base type in case there is an
-               --  applicable stored constraint that renames the discriminants
-               --  of the root.
+               --  If we don't get a full declaration, then we have some error
+               --  which will get signalled later so skip this part. Otherwise
+               --  gather components of root that apply to the aggregate type.
+               --  We use the base type in case there is an applicable stored
+               --  constraint that renames the discriminants of the root.
 
                if Nkind (Dnode) = N_Full_Type_Declaration then
                   Record_Def := Type_Definition (Dnode);
@@ -3281,6 +3290,15 @@  package body Sem_Aggr is
                          Ancestor_Part (N), Parent_Typ);
                      return;
                   end if;
+
+               --  The current view of ancestor part may be a private type,
+               --  while the context type is always non-private.
+
+               elsif Is_Private_Type (Root_Typ)
+                 and then Present (Full_View (Root_Typ))
+                 and then Nkind (N) = N_Extension_Aggregate
+               then
+                  exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ;
                end if;
             end loop;