Patchwork [Ada] AI05-0115: aggregates with invisible components.

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 4, 2011, 1:15 p.m.
Message ID <20110804131558.GA29247@adacore.com>
Download mbox | patch
Permalink /patch/108452/
State New
Headers show

Comments

Arnaud Charlet - Aug. 4, 2011, 1:15 p.m.
If a type has an ancestor derived from a private view of its parent, the
type may have invisible components and aggregates cannot be written for it.
This is an Ada2012 binding interpretation.

Compilation of pak1-pak3.adb below must yield:

   predicatek1-pak3.adb:6:15:
         no selector "C1" for type "T3" defined at pak1-pak3.ads:3
   pak1-pak3.adb:7:14: type of aggregate has private ancestor "T1"
   pak1-pak3.adb:7:14: must use extension aggregate
   pak1-pak3.adb:8:14: type of aggregate has private ancestor "T1"
   pak1-pak3.adb:8:14: must use extension aggregate
   pak1-pak3.adb:9:14: type of aggregate has private ancestor "T1"
   pak1-pak3.adb:9:14: must use extension aggregate

---
package Pak1 is
    type T1 is tagged private;
private
    type T1 is tagged record
        C1 : Integer;
    end record;
end Pak1;
---
with Pak1;
package Pak2 is
    type T2 is new Pak1.T1 with record
        C2 : Integer;
    end record;
end Pak2;
---
with Pak2;
package Pak1.Pak3 is
    type T3 is new Pak2.T2 with record
        C3 : Integer;
    end record;
    procedure Foo;
end Pak1.Pak3;
---
package body Pak1.Pak3 is
    procedure Foo is
        R : T3;
        N : Integer;
    begin
        N := R.C1;                            -- (A: Error.)
        R := (C1 => 1, C2 => 2, C3 => 3);     -- (B: Legal? No.)
        R := (C2 => 2, C3 => 3, others => 1); -- (C: Legal? No.)
        R := (others => 4);                   -- (D: Legal? No.)
    end Foo;
end Pak1.Pak3;

----
date: 2011/03/21 11:29:58;  author: quinot;
TN is J701-202

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

2011-08-04  Ed Schonberg  <schonberg@adacore.com>

	* einfo.ads, einfo.adb (Has_Private_Ancestor): now a flag on types.
	Remove previous procedure with that name.
	* sem_ch3.adb (Build_Derived_Record_Type): set Has_Private_Ancestor
	when appropriate.
	* sem_aggr.adb (Resolve_Extension_Aggregate): if the ancestor part is a
	subtype mark, the ancestor cannot have unknown discriminants.
	(Resolve_Record_Aggregate): if the type has invisible components
	because of a private ancestor, the aggregate is illegal.

Patch

Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb	(revision 177344)
+++ sem_aggr.adb	(working copy)
@@ -45,6 +45,7 @@ 
 with Sem_Aux;  use Sem_Aux;
 with Sem_Cat;  use Sem_Cat;
 with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch13; use Sem_Ch13;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
@@ -2573,6 +2574,15 @@ 
         and then Is_Type (Entity (A))
       then
          Check_SPARK_Restriction ("ancestor part cannot be a type mark", A);
+
+         --  AI05-0115: if the ancestor part is a subtype mark, the ancestor
+         --  must not have unknown discriminants.
+
+         if Has_Unknown_Discriminants (Root_Type (Typ)) then
+            Error_Msg_NE
+              ("aggregate not available for type& whose ancestor "
+                 & "has unknown discriminants", N, Typ);
+         end if;
       end if;
 
       if not Is_Tagged_Type (Typ) then
@@ -3405,6 +3415,18 @@ 
             Positional_Expr := Empty;
          end if;
 
+         --  AI05-0115: if the ancestor part is a subtype mark, the ancestor
+         --  must npt have unknown discriminants.
+
+         if Is_Derived_Type (Typ)
+           and then Has_Unknown_Discriminants (Root_Type (Typ))
+           and then Nkind (N) /= N_Extension_Aggregate
+         then
+            Error_Msg_NE
+              ("aggregate not available for type& whose ancestor "
+                 & "has unknown discriminants ", N, Typ);
+         end if;
+
          if Has_Unknown_Discriminants (Typ)
            and then Present (Underlying_Record_View (Typ))
          then
@@ -3558,6 +3580,35 @@ 
          Errors_Found    : Boolean := False;
          Dnode           : Node_Id;
 
+         function Find_Private_Ancestor return Entity_Id;
+         --  AI05-0115: Find earlier ancestor in the derivation chain that is
+         --  derived from a private view. Whether the aggregate is legal
+         --  depends on the current visibility of the type as well as that
+         --  of the parent of the ancestor.
+
+         ---------------------------
+         -- Find_Private_Ancestor --
+         ---------------------------
+
+         function Find_Private_Ancestor return Entity_Id is
+            Par : Entity_Id;
+         begin
+            Par := Typ;
+            loop
+               if Has_Private_Ancestor (Par)
+                 and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+               then
+                  return Par;
+
+               elsif not Is_Derived_Type (Par) then
+                  return Empty;
+
+               else
+                  Par := Etype (Base_Type (Par));
+               end if;
+            end loop;
+         end Find_Private_Ancestor;
+
       begin
          if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
             Parent_Typ_List := New_Elmt_List;
@@ -3571,16 +3622,45 @@ 
                Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
 
             else
+               --  AI05-0115:  check legality of aggregate for type with
+               --  aa private ancestor.
+
                Root_Typ := Root_Type (Typ);
+               if Has_Private_Ancestor (Typ) then
+                  declare
+                     Ancestor      : constant Entity_Id :=
+                       Find_Private_Ancestor;
+                     Ancestor_Unit : constant Entity_Id :=
+                       Cunit_Entity (Get_Source_Unit (Ancestor));
+                     Parent_Unit   : constant Entity_Id :=
+                       Cunit_Entity
+                         (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+                  begin
 
-               if Nkind (Parent (Base_Type (Root_Typ))) =
-                                               N_Private_Type_Declaration
-               then
-                  Error_Msg_NE
-                    ("type of aggregate has private ancestor&!",
-                     N, Root_Typ);
-                  Error_Msg_N ("must use extension aggregate!", N);
-                  return;
+                     --  check whether we are in a scope that has full view
+                     --  over the private ancestor and its parent. This can
+                     --  only happen if the derivation takes place in a child
+                     --  unit of the unit that declares the parent, and we are
+                     --  in the private part or body of that child unit, else
+                     --  the aggregate is illegal.
+
+                     if Is_Child_Unit (Ancestor_Unit)
+                       and then Scope (Ancestor_Unit) = Parent_Unit
+                       and then In_Open_Scopes (Scope (Ancestor))
+                       and then
+                        (In_Private_Part (Scope (Ancestor))
+                           or else In_Package_Body (Scope (Ancestor)))
+                     then
+                        null;
+
+                     else
+                        Error_Msg_NE
+                          ("type of aggregate has private ancestor&!",
+                              N, Root_Typ);
+                        Error_Msg_N ("must use extension aggregate!", N);
+                        return;
+                     end if;
+                  end;
                end if;
 
                Dnode := Declaration_Node (Base_Type (Root_Typ));
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 177353)
+++ sem_ch3.adb	(working copy)
@@ -7006,6 +7006,28 @@ 
          Parent_Base := Base_Type (Parent_Type);
       end if;
 
+      --  AI05-0115 : if this is a derivation from a private type in some
+      --  other scope that may lead to invisible components for the derived
+      --  type, mark it accordingly.
+
+      if Is_Private_Type (Parent_Type) then
+         if Scope (Parent_Type) = Scope (Derived_Type) then
+            null;
+
+         elsif In_Open_Scopes (Scope (Parent_Type))
+           and then In_Private_Part (Scope (Parent_Type))
+         then
+            null;
+
+         else
+            Set_Has_Private_Ancestor (Derived_Type);
+         end if;
+
+      else
+         Set_Has_Private_Ancestor
+           (Derived_Type, Has_Private_Ancestor (Parent_Type));
+      end if;
+
       --  Before we start the previously documented transformations, here is
       --  little fix for size and alignment of tagged types. Normally when we
       --  derive type D from type P, we copy the size and alignment of P as the
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 177356)
+++ einfo.adb	(working copy)
@@ -409,6 +409,7 @@ 
    --    Is_Compilation_Unit             Flag149
    --    Has_Pragma_Elaborate_Body       Flag150
 
+   --    Has_Private_Ancestor            Flag151
    --    Entry_Accepted                  Flag152
    --    Is_Obsolescent                  Flag153
    --    Has_Per_Object_Constraint       Flag154
@@ -1312,7 +1313,9 @@ 
 
    function Has_Invariants (Id : E) return B is
    begin
-      pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+      pragma Assert (Is_Type (Id)
+        or else Ekind (Id) = E_Procedure
+        or else Ekind (Id) = E_Generic_Procedure);
       return Flag232 (Id);
    end Has_Invariants;
 
@@ -1445,6 +1448,11 @@ 
       return Flag120 (Base_Type (Id));
    end Has_Primitive_Operations;
 
+   function Has_Private_Ancestor (Id : E) return B is
+   begin
+      return Flag151 (Id);
+   end Has_Private_Ancestor;
+
    function Has_Private_Declaration (Id : E) return B is
    begin
       return Flag155 (Id);
@@ -3936,6 +3944,12 @@ 
       Set_Flag120 (Id, V);
    end Set_Has_Primitive_Operations;
 
+   procedure Set_Has_Private_Ancestor (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Type (Id));
+      Set_Flag151 (Id, V);
+   end Set_Has_Private_Ancestor;
+
    procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
    begin
       Set_Flag155 (Id, V);
@@ -6100,25 +6114,6 @@ 
       return False;
    end Has_Interrupt_Handler;
 
-   --------------------------
-   -- Has_Private_Ancestor --
-   --------------------------
-
-   function Has_Private_Ancestor (Id : E) return B is
-      R  : constant Entity_Id := Root_Type (Id);
-      T1 : Entity_Id := Id;
-   begin
-      loop
-         if Is_Private_Type (T1) then
-            return True;
-         elsif T1 = R then
-            return False;
-         else
-            T1 := Etype (T1);
-         end if;
-      end loop;
-   end Has_Private_Ancestor;
-
    --------------------
    -- Has_Rep_Pragma --
    --------------------
@@ -7461,6 +7456,7 @@ 
       W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
       W ("Has_Predicates",                  Flag250 (Id));
       W ("Has_Primitive_Operations",        Flag120 (Id));
+      W ("Has_Private_Ancestor",            Flag151 (Id));
       W ("Has_Private_Declaration",         Flag155 (Id));
       W ("Has_Qualified_Name",              Flag161 (Id));
       W ("Has_RACW",                        Flag214 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 177353)
+++ einfo.ads	(working copy)
@@ -1690,10 +1690,13 @@ 
 --       Present in all type entities. Set if at least one primitive operation
 --       is defined for the type.
 
---    Has_Private_Ancestor (synthesized)
---       Applies to all type and subtype entities. Returns True if at least
---       one ancestor is private, and otherwise False if there are no private
---       ancestors.
+--    Has_Private_Ancestor (Flag151)
+--       Applies to type extensions. True if some ancestor is derived from a
+--       private type, making some components invisible and aggregates illegal.
+--       This flag is set at the point of derivation. The legality of the
+--       aggregate must be rechecked because it also depends on the visibility
+--       at the point the aggregate is resolved. See sem_aggr.adb.
+--       This is part of AI05-0115.
 
 --    Has_Private_Declaration (Flag155)
 --       Present in all entities. Returns True if it is the defining entity
@@ -4909,7 +4912,6 @@ 
 
    --    Alignment_Clause                    (synth)
    --    Base_Type                           (synth)
-   --    Has_Private_Ancestor                (synth)
    --    Implementation_Base_Type            (synth)
    --    Invariant_Procedure                 (synth)
    --    Is_Access_Protected_Subprogram_Type (synth)
@@ -5581,6 +5583,7 @@ 
    --    Has_Dispatch_Table                  (Flag220)  (base tagged type only)
    --    Has_External_Tag_Rep_Clause         (Flag110)
    --    Has_Pragma_Pack                     (Flag121)  (impl base type only)
+   --    Has_Private_Ancestor                (Flag151)
    --    Has_Record_Rep_Clause               (Flag65)   (base type only)
    --    Has_Static_Discriminants            (Flag211)  (subtype only)
    --    Is_Class_Wide_Equivalent_Type       (Flag35)
@@ -5607,6 +5610,7 @@ 
    --    Stored_Constraint                   (Elist23)
    --    Interfaces                          (Elist25)
    --    Has_Completion                      (Flag26)
+   --    Has_Private_Ancestor                (Flag151)
    --    Has_Record_Rep_Clause               (Flag65)   (base type only)
    --    Has_External_Tag_Rep_Clause         (Flag110)
    --    Is_Concurrent_Record_Type           (Flag20)
@@ -6119,6 +6123,7 @@ 
    function Has_Pragma_Unreferenced_Objects     (Id : E) return B;
    function Has_Predicates                      (Id : E) return B;
    function Has_Primitive_Operations            (Id : E) return B;
+   function Has_Private_Ancestor                (Id : E) return B;
    function Has_Qualified_Name                  (Id : E) return B;
    function Has_RACW                            (Id : E) return B;
    function Has_Record_Rep_Clause               (Id : E) return B;
@@ -6436,7 +6441,6 @@ 
    function Has_Attach_Handler                  (Id : E) return B;
    function Has_Entries                         (Id : E) return B;
    function Has_Foreign_Convention              (Id : E) return B;
-   function Has_Private_Ancestor                (Id : E) return B;
    function Has_Private_Declaration             (Id : E) return B;
    function Implementation_Base_Type            (Id : E) return E;
    function Is_Base_Type                        (Id : E) return B;
@@ -6705,6 +6709,7 @@ 
    procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
    procedure Set_Has_Predicates                  (Id : E; V : B := True);
    procedure Set_Has_Primitive_Operations        (Id : E; V : B := True);
+   procedure Set_Has_Private_Ancestor            (Id : E; V : B := True);
    procedure Set_Has_Private_Declaration         (Id : E; V : B := True);
    procedure Set_Has_Qualified_Name              (Id : E; V : B := True);
    procedure Set_Has_RACW                        (Id : E; V : B := True);
@@ -7400,6 +7405,7 @@ 
    pragma Inline (Has_Pragma_Unreferenced_Objects);
    pragma Inline (Has_Predicates);
    pragma Inline (Has_Primitive_Operations);
+   pragma Inline (Has_Private_Ancestor);
    pragma Inline (Has_Private_Declaration);
    pragma Inline (Has_Qualified_Name);
    pragma Inline (Has_RACW);
@@ -7842,6 +7848,7 @@ 
    pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
    pragma Inline (Set_Has_Predicates);
    pragma Inline (Set_Has_Primitive_Operations);
+   pragma Inline (Set_Has_Private_Ancestor);
    pragma Inline (Set_Has_Private_Declaration);
    pragma Inline (Set_Has_Qualified_Name);
    pragma Inline (Set_Has_RACW);