From patchwork Thu Aug 4 13:15:59 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 108452 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id C5458B6F57 for ; Thu, 4 Aug 2011 23:16:19 +1000 (EST) Received: (qmail 32403 invoked by alias); 4 Aug 2011 13:16:17 -0000 Received: (qmail 32387 invoked by uid 22791); 4 Aug 2011 13:16:15 -0000 X-SWARE-Spam-Status: No, hits=-1.5 required=5.0 tests=AWL, BAYES_00, KAM_ADVERT2 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 04 Aug 2011 13:16:00 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 331AB2BB3AB; Thu, 4 Aug 2011 09:15:59 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id nbEqGmMqL3Ko; Thu, 4 Aug 2011 09:15:59 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 1FDF12BB3A9; Thu, 4 Aug 2011 09:15:59 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 1F4523FEE8; Thu, 4 Aug 2011 09:15:59 -0400 (EDT) Date: Thu, 4 Aug 2011 09:15:59 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] AI05-0115: aggregates with invisible components. Message-ID: <20110804131558.GA29247@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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. 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);