From patchwork Fri Oct 8 13:08:20 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 67194 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 241E6B6F10 for ; Sat, 9 Oct 2010 00:08:37 +1100 (EST) Received: (qmail 1229 invoked by alias); 8 Oct 2010 13:08:35 -0000 Received: (qmail 896 invoked by uid 22791); 8 Oct 2010 13:08:32 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, TW_TM, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 08 Oct 2010 13:08:25 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id B4B64CB027C; Fri, 8 Oct 2010 15:08:22 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id FdygnGRcebD9; Fri, 8 Oct 2010 15:08:22 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 9E399CB01F7; Fri, 8 Oct 2010 15:08:22 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id AC587D9BB4; Fri, 8 Oct 2010 15:08:20 +0200 (CEST) Date: Fri, 8 Oct 2010 15:08:20 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Immutably limited types Message-ID: <20101008130820.GA30368@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes 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 In Ada2012, a type that is a descendant of a formal limited private type is not immutably limited within a generic body. This affects the legality of access discriminants on types that are descended from such a type. The following must be rejected with the message : gen.adb:3:25: access discriminants allowed only for limited types package Gen is pragma Elaborate_Body; type Disc is tagged null record; generic type FP (DD: access Disc) is limited private; -- OK package Gen1 is type DFP (D: access Disc) is new FP(D); -- OK end Gen1; end Gen; --- package body Gen is package body Gen1 is type DFP2 (D: access Disc) is new FP(D); -- ERROR end Gen1; end Gen; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-08 Ed Schonberg * exp_ch5.adb, sem_ch3.adb, exp_ch7.adb, exp_util.adb, sem_aux.adb, sem_aux.ads, exp_ch4.adb, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb, exp_ch3.adb: Change Is_Inherently_Limited_Type to Is_Immutably_Limited_Type to accord with new RM terminology. * sem_aux.adb (Is_Immutably_Limited_Type): A type that is a descendant of a formal limited private type is not immutably limited in a generic body. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 165100) +++ exp_ch5.adb (working copy) @@ -3896,7 +3896,7 @@ package body Exp_Ch5 is -- the type of the expression may be. if not Comes_From_Extended_Return_Statement (N) - and then Is_Inherently_Limited_Type (Etype (Expression (N))) + and then Is_Immutably_Limited_Type (Etype (Expression (N))) and then Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L then @@ -3967,7 +3967,7 @@ package body Exp_Ch5 is -- type that requires special processing (indicated by the fact that -- it requires a cleanup scope for the secondary stack case). - if Is_Inherently_Limited_Type (Exptyp) + if Is_Immutably_Limited_Type (Exptyp) or else Is_Limited_Interface (Exptyp) then null; @@ -4252,7 +4252,7 @@ package body Exp_Ch5 is elsif Ekind (R_Type) = E_Anonymous_Access_Type and then Has_Controlling_Result (Scope_Id) - and then Ada_Version >= Ada_12 + and then (Ada_Version >= Ada_12 or else True) then Insert_Action (Exp, Make_Raise_Constraint_Error (Loc, Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165157) +++ sem_ch3.adb (working copy) @@ -8794,12 +8794,11 @@ package body Sem_Ch3 is -- only in the declaration for a task or protected type, or for a type -- with the reserved word 'limited' in its definition or in one of its -- ancestors. (RM 3.7(10)) + -- AI-0063 : the proper condition is that type must be immutably + -- limited. if Nkind (Discriminant_Type (D)) = N_Access_Definition - and then not Is_Concurrent_Type (Current_Scope) - and then not Is_Concurrent_Record_Type (Current_Scope) - and then not Is_Limited_Record (Current_Scope) - and then Ekind (Current_Scope) /= E_Limited_Private_Type + and then not Is_Immutably_Limited_Type (Current_Scope) then Error_Msg_N ("access discriminants allowed only for limited types", Loc); Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 165080) +++ exp_ch7.adb (working copy) @@ -392,7 +392,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); - if not Is_Inherently_Limited_Type (Typ) then + if not Is_Immutably_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc ( Prim => Adjust_Case, @@ -502,7 +502,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - if not Is_Inherently_Limited_Type (Typ) then + if not Is_Immutably_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc ( Prim => Adjust_Case, @@ -2725,7 +2725,7 @@ package body Exp_Ch7 is Res : constant List_Id := New_List; begin - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Controller_Typ := RTE (RE_Limited_Record_Controller); else Controller_Typ := RTE (RE_Record_Controller); Index: exp_util.adb =================================================================== --- exp_util.adb (revision 165103) +++ exp_util.adb (working copy) @@ -5028,7 +5028,7 @@ package body Exp_Util is -- to accommodate functions returning limited objects by reference. if Nkind (Exp) = N_Function_Call - and then Is_Inherently_Limited_Type (Etype (Exp)) + and then Is_Immutably_Limited_Type (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration and then Ada_Version >= Ada_05 then Index: sem_aux.adb =================================================================== --- sem_aux.adb (revision 165080) +++ sem_aux.adb (working copy) @@ -570,24 +570,49 @@ package body Sem_Aux is end if; end Is_Indefinite_Subtype; - -------------------------------- - -- Is_Inherently_Limited_Type -- - -------------------------------- + ------------------------------- + -- Is_Immutably_Limited_Type -- + ------------------------------- - function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Base_Type (Ent); begin - if Is_Private_Type (Btype) then - declare - Utyp : constant Entity_Id := Underlying_Type (Btype); - begin - if No (Utyp) then + if Ekind (Btype) = E_Limited_Private_Type then + if Nkind (Parent (Btype)) = N_Formal_Type_Declaration then + return not In_Package_Body (Scope ((Btype))); + else + return True; + end if; + + elsif Is_Private_Type (Btype) then + -- AI05-0063 : a type derived from a limited private formal type + -- is not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then return False; + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Etype (Btype))); + else - return Is_Inherently_Limited_Type (Utyp); + return False; end if; - end; + + else + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Immutably_Limited_Type (Utyp); + end if; + end; + end if; elsif Is_Concurrent_Type (Btype) then return True; @@ -605,7 +630,7 @@ package body Sem_Aux is return True; elsif Is_Class_Wide_Type (Btype) then - return Is_Inherently_Limited_Type (Root_Type (Btype)); + return Is_Immutably_Limited_Type (Root_Type (Btype)); else declare @@ -622,7 +647,7 @@ package body Sem_Aux is -- limited intefaces. if not Is_Interface (Etype (C)) - and then Is_Inherently_Limited_Type (Etype (C)) + and then Is_Immutably_Limited_Type (Etype (C)) then return True; end if; @@ -635,12 +660,12 @@ package body Sem_Aux is end if; elsif Is_Array_Type (Btype) then - return Is_Inherently_Limited_Type (Component_Type (Btype)); + return Is_Immutably_Limited_Type (Component_Type (Btype)); else return False; end if; - end Is_Inherently_Limited_Type; + end Is_Immutably_Limited_Type; --------------------- -- Is_Limited_Type -- Index: sem_aux.ads =================================================================== --- sem_aux.ads (revision 165080) +++ sem_aux.ads (working copy) @@ -165,7 +165,7 @@ package Sem_Aux is -- discriminant values or a class wide type or subtype and returns True if -- so. False for other type entities, or any entities that are not types. - function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean; + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 165158) +++ exp_ch4.adb (working copy) @@ -947,7 +947,7 @@ package body Exp_Ch4 is -- want to Adjust. if not Aggr_In_Place - and then not Is_Inherently_Limited_Type (T) + and then not Is_Immutably_Limited_Type (T) then Insert_Actions (N, Make_Adjust_Call ( Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 165154) +++ exp_ch6.adb (working copy) @@ -3106,7 +3106,7 @@ package body Exp_Ch6 is -- not a rewriting of a protected function call. if Needs_Finalization (Etype (Subp)) then - if not Is_Inherently_Limited_Type (Etype (Subp)) + if not Is_Immutably_Limited_Type (Etype (Subp)) and then (No (First_Formal (Subp)) or else @@ -4405,7 +4405,7 @@ package body Exp_Ch6 is then null; - elsif Is_Inherently_Limited_Type (Typ) then + elsif Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Spec_Id); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then @@ -4810,7 +4810,7 @@ package body Exp_Ch6 is -- may return objects of nonlimited descendants. else - return Is_Inherently_Limited_Type (Etype (E)) + return Is_Immutably_Limited_Type (Etype (E)) and then Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L; end if; @@ -5025,7 +5025,7 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Etype (Subp); Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Subp); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 165162) +++ sem_ch6.adb (working copy) @@ -483,7 +483,7 @@ package body Sem_Ch6 is Error_Msg_N ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); - if Is_Inherently_Limited_Type (R_Type) then + if Is_Immutably_Limited_Type (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; @@ -495,7 +495,7 @@ package body Sem_Ch6 is -- evilly turned off. Otherwise it is a real error. elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then - if Is_Inherently_Limited_Type (R_Type) then + if Is_Immutably_Limited_Type (R_Type) then Error_Msg_N ("return by reference not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?", Expr); @@ -759,7 +759,7 @@ package body Sem_Ch6 is -- check the static cases. if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L) - and then Is_Inherently_Limited_Type (Etype (Scope_Id)) + and then Is_Immutably_Limited_Type (Etype (Scope_Id)) and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then @@ -4256,7 +4256,7 @@ package body Sem_Ch6 is Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Index: exp_aggr.adb =================================================================== --- exp_aggr.adb (revision 165160) +++ exp_aggr.adb (working copy) @@ -596,7 +596,7 @@ package body Exp_Aggr is -- If component is limited, aggregate must be expanded because each -- component assignment must be built in place. - if Is_Inherently_Limited_Type (Component_Type (Typ)) then + if Is_Immutably_Limited_Type (Component_Type (Typ)) then return False; end if; @@ -2120,7 +2120,7 @@ package body Exp_Aggr is then RC := RE_Limited_Record_Controller; - elsif Is_Inherently_Limited_Type (Target_Type) then + elsif Is_Immutably_Limited_Type (Target_Type) then RC := RE_Limited_Record_Controller; else @@ -3648,7 +3648,7 @@ package body Exp_Aggr is -- in place within the caller's scope). or else - (Is_Inherently_Limited_Type (Typ) + (Is_Immutably_Limited_Type (Typ) and then (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement or else Nkind (Parent_Node) = N_Simple_Return_Statement)) @@ -5598,7 +5598,7 @@ package body Exp_Aggr is -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. - if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then + if Ada_Version >= Ada_05 and then Is_Immutably_Limited_Type (Typ) then if not Nkind_In (Parent (N), N_Object_Declaration, N_Component_Association) then Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 165166) +++ exp_ch3.adb (working copy) @@ -1661,7 +1661,7 @@ package body Exp_Ch3 is and then Has_New_Controlled_Component (Enclos_Type) and then Has_Controlled_Component (Typ) then - if Is_Inherently_Limited_Type (Typ) then + if Is_Immutably_Limited_Type (Typ) then Controller_Typ := RTE (RE_Limited_Record_Controller); else Controller_Typ := RTE (RE_Record_Controller); @@ -1930,7 +1930,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) - and then not Is_Inherently_Limited_Type (Typ) + and then not Is_Immutably_Limited_Type (Typ) then declare Ref : constant Node_Id := @@ -4800,7 +4800,7 @@ package body Exp_Ch3 is -- creating the object (via allocator) and initializing it. if Is_Return_Object (Def_Id) - and then Is_Inherently_Limited_Type (Typ) + and then Is_Immutably_Limited_Type (Typ) then null; @@ -5014,7 +5014,7 @@ package body Exp_Ch3 is -- renaming declaration. if Needs_Finalization (Typ) - and then not Is_Inherently_Limited_Type (Typ) + and then not Is_Immutably_Limited_Type (Typ) and then not Rewrite_As_Renaming then Insert_Actions_After (Init_After, @@ -5291,7 +5291,7 @@ package body Exp_Ch3 is Loc := Sloc (First (Component_Items (Comp_List))); end if; - if Is_Inherently_Limited_Type (T) then + if Is_Immutably_Limited_Type (T) then Controller_Type := RTE (RE_Limited_Record_Controller); else Controller_Type := RTE (RE_Record_Controller); @@ -6099,7 +6099,11 @@ package body Exp_Ch3 is end if; Set_Is_Frozen (Def_Id); - Set_All_DT_Position (Def_Id); + if not Is_Derived_Type (Def_Id) + or else Is_Tagged_Type (Etype (Def_Id)) + then + Set_All_DT_Position (Def_Id); + end if; -- Add the controlled component before the freezing actions -- referenced in those actions. @@ -6194,9 +6198,16 @@ package body Exp_Ch3 is end if; end; - elsif Ada_Version >= Ada_12 - and then Comes_From_Source (Def_Id) + -- Otherwise create primitive equality operation (AI05-0123) + -- This is done unconditionally to ensure that tools can be linked + -- properly with user programs compiled with older language versions. + -- It might be worth including a switch to revert to a non-composable + -- equality for untagged records, even though no program depending on + -- non-composability has surfaced ??? + + elsif Comes_From_Source (Def_Id) and then Convention (Def_Id) = Convention_Ada + and then not Is_Limited_Type (Def_Id) then Build_Untagged_Equality (Def_Id); end if;