From patchwork Fri Dec 2 14:46:18 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 128878 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 1708B1007D4 for ; Sat, 3 Dec 2011 01:46:48 +1100 (EST) Received: (qmail 17941 invoked by alias); 2 Dec 2011 14:46:38 -0000 Received: (qmail 17600 invoked by uid 22791); 2 Dec 2011 14:46:36 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 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; Fri, 02 Dec 2011 14:46:19 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id CDCE82BAF6A; Fri, 2 Dec 2011 09:46:18 -0500 (EST) 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 M1VOyGLncIkX; Fri, 2 Dec 2011 09:46:18 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id A8B6B2BAF65; Fri, 2 Dec 2011 09:46:18 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id A7C383FEE8; Fri, 2 Dec 2011 09:46:18 -0500 (EST) Date: Fri, 2 Dec 2011 09:46:18 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Ada 2012: Derived types and partial views Message-ID: <20111202144618.GA23298@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 This patch incorporates the support for AI95-0041. For the purposes of the rules for allowing allocated unconstrained objects, any ancestor that has a constrained partial view causes the rules to apply. In addition, in a generic body, 3.10.2(27.2/2) is checked assuming that any untagged formal private or derived type has a constrained partial view. The following test now compiles with an error: procedure AI95_041 is subtype Index is Integer range 0 .. 255; Smaller_Index : constant Index := 10; Larger_Index : constant Index := 20; generic type T1 (D : Index) is private; package G is type Ref is access all T1; Smaller : aliased T1 (Smaller_Index); Ptr_1 : Ref := Smaller'Access; -- Legal? (Yes.) Ptr : Ref; end G; package body G is begin Ptr := Smaller'Access; -- Legal? (No.) end G; begin null; end; Command: gcc -c -gnat05 ai95_041.adb Output: ai95_041.adb:17:15: object subtype must statically match designated subtype Tested on x86_64-pc-linux-gnu, committed on trunk 2011-12-02 Javier Miranda * sem_ch3.adb (Constrain_Access): Enable on Ada 2005 mode the static check of the rule of general access types whose designated type has discriminants. * sem_util.ads, sem_util.adb (Effectively_Has_Constrained_Partial_View): New subprogram. (In_Generic_Body): New subprogram. * einfo.ads (Has_Constrained_Partial_View): Adding documentation. * sem_prag.adb (Inside_Generic_Body): Removed. Replaced by new subprogram In_Generic_Body. * exp_attr.adb, checks.adb, sem_attr.adb, exp_ch4.adb, sem_ch4.adb: In addition, this patch replaces the occurrences of Has_Constrained_Partial_View by Effectively_Has_Constrained_Partial_View. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 181910) +++ sem_ch3.adb (working copy) @@ -10674,8 +10674,7 @@ return; end if; - if (Ekind (T) = E_General_Access_Type - or else Ada_Version >= Ada_2005) + if Ekind (T) = E_General_Access_Type and then Has_Private_Declaration (Desig_Type) and then In_Open_Scopes (Scope (Desig_Type)) and then Has_Discriminants (Desig_Type) @@ -10687,11 +10686,6 @@ -- (Defect Report 8652/0008, Technical Corrigendum 1, checked -- by ACATS B371001). - -- Rule updated for Ada 2005: the private type is said to have - -- a constrained partial view, given that objects of the type - -- can be declared. Furthermore, the rule applies to all access - -- types, unlike the rule concerning default discriminants. - declare Pack : constant Node_Id := Unit_Declaration_Node (Scope (Desig_Type)); Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 181910) +++ exp_attr.adb (working copy) @@ -1559,10 +1559,11 @@ return Is_Aliased_View (Obj) and then (Is_Constrained (Etype (Obj)) - or else (Nkind (Obj) = N_Explicit_Dereference - and then - not Has_Constrained_Partial_View - (Base_Type (Etype (Obj))))); + or else + (Nkind (Obj) = N_Explicit_Dereference + and then + not Effectively_Has_Constrained_Partial_View + (Base_Type (Etype (Obj))))); end if; end Is_Constrained_Aliased_View; @@ -1684,7 +1685,8 @@ or else (Nkind (Pref) = N_Explicit_Dereference and then - not Has_Constrained_Partial_View (Base_Type (Ptyp))) + not Effectively_Has_Constrained_Partial_View + (Base_Type (Ptyp))) or else Is_Constrained (Underlying_Type (Ptyp)) or else (Ada_Version >= Ada_2012 and then Is_Tagged_Type (Underlying_Type (Ptyp)) Index: einfo.ads =================================================================== --- einfo.ads (revision 181910) +++ einfo.ads (working copy) @@ -1420,6 +1420,8 @@ -- type has no discriminants and the full view has discriminants with -- defaults. In Ada 2005 heap-allocated objects of such types are not -- constrained, and can change their discriminants with full assignment. +-- Sem_Util.Effectively_Has_Constrained_Partial_View should be always +-- used by callers, rather than reading this attribute directly. -- Has_Contiguous_Rep (Flag181) -- Present in enumeration types. True if the type as a representation Index: checks.adb =================================================================== --- checks.adb (revision 181910) +++ checks.adb (working copy) @@ -1240,7 +1240,7 @@ -- partial view that is constrained. elsif Ada_Version >= Ada_2005 - and then Has_Constrained_Partial_View (Base_Type (T_Typ)) + and then Effectively_Has_Constrained_Partial_View (Base_Type (T_Typ)) then return; end if; Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 181910) +++ sem_prag.adb (working copy) @@ -1314,34 +1314,6 @@ Subtype_Indication (Component_Definition (Comp)); Typ : constant Entity_Id := Etype (Comp_Id); - function Inside_Generic_Body (Id : Entity_Id) return Boolean; - -- Determine whether entity Id appears inside a generic body. - -- Shouldn't this be in a more general place ??? - - ------------------------- - -- Inside_Generic_Body -- - ------------------------- - - function Inside_Generic_Body (Id : Entity_Id) return Boolean is - S : Entity_Id; - - begin - S := Id; - while Present (S) and then S /= Standard_Standard loop - if Ekind (S) = E_Generic_Package - and then In_Package_Body (S) - then - return True; - end if; - - S := Scope (S); - end loop; - - return False; - end Inside_Generic_Body; - - -- Start of processing for Check_Component - begin -- Ada 2005 (AI-216): If a component subtype is subject to a per- -- object constraint, then the component type shall be an Unchecked_ @@ -1363,7 +1335,7 @@ -- the formal part of the generic unit. elsif Ada_Version >= Ada_2012 - and then Inside_Generic_Body (UU_Typ) + and then In_Generic_Body (UU_Typ) and then In_Variant_Part and then Is_Private_Type (Typ) and then Is_Generic_Type (Typ) Index: sem_util.adb =================================================================== --- sem_util.adb (revision 181910) +++ sem_util.adb (working copy) @@ -3039,6 +3039,24 @@ return Extra_Accessibility (Id); end Effective_Extra_Accessibility; + ---------------------------------------------- + -- Effectively_Has_Constrained_Partial_View -- + ---------------------------------------------- + + function Effectively_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id := Current_Scope) return Boolean is + begin + return Has_Constrained_Partial_View (Typ) + or else (In_Generic_Body (Scop) + and then Is_Generic_Type (Base_Type (Typ)) + and then Is_Private_Type (Base_Type (Typ)) + and then not Is_Tagged_Type (Typ) + and then not (Is_Array_Type (Typ) + and then not Is_Constrained (Typ)) + and then Has_Discriminants (Typ)); + end Effectively_Has_Constrained_Partial_View; + -------------------------- -- Enclosing_CPP_Parent -- -------------------------- @@ -6088,6 +6106,38 @@ return False; end Implements_Interface; + --------------------- + -- In_Generic_Body -- + --------------------- + + function In_Generic_Body (Id : Entity_Id) return Boolean is + S : Entity_Id := Id; + + begin + while Present (S) and then S /= Standard_Standard loop + + -- Generic package body + + if Ekind (S) = E_Generic_Package + and then In_Package_Body (S) + then + return True; + + -- Generic subprogram body + + elsif Is_Subprogram (S) + and then Nkind (Unit_Declaration_Node (S)) + = N_Generic_Subprogram_Declaration + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end In_Generic_Body; + ----------------- -- In_Instance -- ----------------- @@ -6945,7 +6995,7 @@ -- designated object is known to be constrained. if Ekind (Prefix_Type) = E_Access_Type - and then not Has_Constrained_Partial_View + and then not Effectively_Has_Constrained_Partial_View (Designated_Type (Prefix_Type)) then return False; Index: sem_util.ads =================================================================== --- sem_util.ads (revision 181910) +++ sem_util.ads (working copy) @@ -368,6 +368,14 @@ -- Same as Einfo.Extra_Accessibility except thtat object renames -- are looked through. + function Effectively_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id := Current_Scope) return Boolean; + -- Return True if Typ has attribute Has_Constrained_Partial_View set to + -- True; in addition, within a generic body, return True if a subtype is + -- a descendant of an untagged generic formal private or derived type, and + -- the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)). + function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id; -- Returns the closest ancestor of Typ that is a CPP type. @@ -717,6 +725,9 @@ Exclude_Parents : Boolean := False) return Boolean; -- Returns true if the Typ_Ent implements interface Iface_Ent + function In_Generic_Body (Id : Entity_Id) return Boolean; + -- Determine whether entity Id appears inside a generic body + function In_Instance return Boolean; -- Returns True if the current scope is within a generic instance Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 181910) +++ sem_attr.adb (working copy) @@ -8632,7 +8632,7 @@ and then (Ada_Version < Ada_2005 or else - not Has_Constrained_Partial_View + not Effectively_Has_Constrained_Partial_View (Designated_Type (Base_Type (Typ)))) then null; Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 181910) +++ exp_ch4.adb (working copy) @@ -3903,8 +3903,9 @@ and then Present (Discriminant_Default_Value (First_Discriminant (Typ))) and then (Ada_Version < Ada_2005 - or else - not Has_Constrained_Partial_View (Typ)) + or else not + Effectively_Has_Constrained_Partial_View + (Typ)) then Typ := Build_Default_Subtype (Typ, N); Set_Expression (N, New_Reference_To (Typ, Loc)); Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 181910) +++ sem_ch4.adb (working copy) @@ -576,10 +576,10 @@ -- and the allocated object is unconstrained. elsif Ada_Version >= Ada_2005 - and then Has_Constrained_Partial_View (Base_Typ) + and then Effectively_Has_Constrained_Partial_View (Base_Typ) then Error_Msg_N - ("constraint no allowed when type " & + ("constraint not allowed when type " & "has a constrained partial view", Constraint (E)); end if;