From patchwork Tue Jun 22 16:48:15 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56529 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 7FB78B6F0C for ; Wed, 23 Jun 2010 02:48:24 +1000 (EST) Received: (qmail 5810 invoked by alias); 22 Jun 2010 16:48:22 -0000 Received: (qmail 5785 invoked by uid 22791); 22 Jun 2010 16:48:20 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, 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; Tue, 22 Jun 2010 16:48:13 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 47E15CB0202; Tue, 22 Jun 2010 18:48:15 +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 jGJRmQ+r0KCT; Tue, 22 Jun 2010 18:48:15 +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 29C29CB01DB; Tue, 22 Jun 2010 18:48:15 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 207B6D9BB4; Tue, 22 Jun 2010 18:48:15 +0200 (CEST) Date: Tue, 22 Jun 2010 18:48:15 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Cleanup analysis of concurrent types that implement interfaces Message-ID: <20100622164815.GA29191@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 The analysis of a generic unit containing a concurrent type that covers interfaces previously required building the corresponding record type. This patch avoids such requirement, which leaves the frontend more clean because the corresponding record type is only required for code generation. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-22 Javier Miranda * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles generic subprogram declarations to ensure proper context. Add missing support for generic actuals. (Try_Primitive_Operation): Add missing support for concurrent types that have no Corresponding_Record_Type. Required to diagnose errors compiling generics or when compiling with no code generation (-gnatc). * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build the corresponding record type. * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete documentation. Do minimum decoration when processing a primitive of a concurrent tagged type that covers interfaces. Required to diagnose errors in the Object.Operation notation compiling generics or under -gnatc. * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing propagation of attribute Interface_List to the corresponding record. (Expand_N_Task_Type_Declaration): Code cleanup. (Expand_N_Protected_Type_Declaration): Code cleanup. Index: exp_ch9.ads =================================================================== --- exp_ch9.ads (revision 161073) +++ exp_ch9.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -50,14 +50,6 @@ package Exp_Ch9 is -- Task_Id of the associated task as the parameter. The caller is -- responsible for analyzing and resolving the resulting tree. - function Build_Corresponding_Record - (N : Node_Id; - Ctyp : Node_Id; - Loc : Source_Ptr) return Node_Id; - -- Common to tasks and protected types. Copy discriminant specifications, - -- build record declaration. N is the type declaration, Ctyp is the - -- concurrent entity (task type or protected type). - function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; -- Create the statements which populate the entry names array of a task or -- protected type. The statements are wrapped inside a block due to a local Index: exp_ch9.adb =================================================================== --- exp_ch9.adb (revision 161073) +++ exp_ch9.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -128,6 +128,14 @@ package body Exp_Ch9 is -- Build a specification for a function implementing the protected entry -- barrier of the specified entry body. + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Node_Id; + Loc : Source_Ptr) return Node_Id; + -- Common to tasks and protected types. Copy discriminant specifications, + -- build record declaration. N is the type declaration, Ctyp is the + -- concurrent entity (task type or protected type). + function Build_Entry_Count_Expression (Concurrent_Type : Node_Id; Component_List : List_Id; @@ -1037,8 +1045,9 @@ package body Exp_Ch9 is -- record is "limited tagged". It is "limited" to reflect the underlying -- limitedness of the task or protected object that it represents, and -- ensuring for example that it is properly passed by reference. It is - -- "tagged" to give support to dispatching calls through interfaces (Ada - -- 2005: AI-345) + -- "tagged" to give support to dispatching calls through interfaces. We + -- propagate here the list of interfaces covered by the concurrent type + -- (Ada 2005: AI-345). return Make_Full_Type_Declaration (Loc, @@ -1051,6 +1060,7 @@ package body Exp_Ch9 is Component_Items => Cdecls), Tagged_Present => Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp), + Interface_List => Interface_List (N), Limited_Present => True)); end Build_Corresponding_Record; @@ -7682,11 +7692,6 @@ package body Exp_Ch9 is Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Qualify_Entity_Names (N); -- If the type has discriminants, their occurrences in the declaration @@ -9946,11 +9951,6 @@ package body Exp_Ch9 is Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Rec_Ent := Defining_Identifier (Rec_Decl); Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 161076) +++ sem_ch9.adb (working copy) @@ -1176,16 +1176,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of protected type while inside a generic. - -- The corresponding record is needed for various semantic checks. - - if Ada_Version >= Ada_05 - and then Inside_A_Generic - then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the @@ -1976,15 +1966,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of the task type while inside a generic - -- context. The corresponding record is needed for various semantic - -- checks. - - if Inside_A_Generic then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 161148) +++ sem_ch4.adb (working copy) @@ -6880,23 +6880,26 @@ package body Sem_Ch4 is -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. - declare - Decl : Node_Id; - - begin - Decl := - First (Generic_Formal_Declarations - (Unit_Declaration_Node (Scope (T)))); - while Present (Decl) loop - if Nkind (Decl) in N_Formal_Subprogram_Declaration then - Subp := Defining_Entity (Decl); - Check_Candidate; - end if; - - Next (Decl); - end loop; - end; + if Nkind (Unit_Declaration_Node (Scope (T))) + = N_Generic_Subprogram_Declaration + then + declare + Decl : Node_Id; + begin + Decl := + First (Generic_Formal_Declarations + (Unit_Declaration_Node (Scope (T)))); + while Present (Decl) loop + if Nkind (Decl) in N_Formal_Subprogram_Declaration then + Subp := Defining_Entity (Decl); + Check_Candidate; + end if; + + Next (Decl); + end loop; + end; + end if; return Candidates; else @@ -6906,7 +6909,15 @@ package body Sem_Ch4 is -- declaration or body (either the one that declares T, or a -- child unit). - Subp := First_Entity (Scope (T)); + -- For a subtype representing a generic actual type, go to the + -- base type. + + if Is_Generic_Actual_Type (T) then + Subp := First_Entity (Scope (Base_Type (T))); + else + Subp := First_Entity (Scope (T)); + end if; + while Present (Subp) loop if Is_Overloadable (Subp) then Check_Candidate; @@ -6979,13 +6990,14 @@ package body Sem_Ch4 is -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then - if not Present (Corresponding_Record_Type (Obj_Type)) then - return False; + if Present (Corresponding_Record_Type (Obj_Type)) then + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); + Elmt := First_Elmt (Primitive_Operations (Corr_Type)); + else + Corr_Type := Obj_Type; + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; - Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); - Elmt := First_Elmt (Primitive_Operations (Corr_Type)); - elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; Elmt := First_Elmt (Primitive_Operations (Obj_Type)); Index: sem_disp.adb =================================================================== --- sem_disp.adb (revision 161141) +++ sem_disp.adb (working copy) @@ -677,18 +677,15 @@ package body Sem_Disp is Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); - -- Ada 2005 (AI-345) + -- Ada 2005 (AI-345): Use the corresponding record (if available). + -- Required because primitives of concurrent types are be attached + -- to the corresponding record (not to the concurrent type). if Ada_Version >= Ada_05 and then Present (Tagged_Type) and then Is_Concurrent_Type (Tagged_Type) + and then Present (Corresponding_Record_Type (Tagged_Type)) then - -- Protect the frontend against previously detected errors - - if No (Corresponding_Record_Type (Tagged_Type)) then - return; - end if; - Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; @@ -1068,6 +1065,18 @@ package body Sem_Disp is end if; end if; + -- If the tagged type is a concurrent type then we must be compiling + -- with no code generation (we are either compiling a generic unit or + -- compiling under -gnatc mode) because we have previously tested that + -- no serious errors has been reported. In this case we do not add the + -- primitive to the list of primitives of Tagged_Type but we leave the + -- primitive decorated as a dispatching operation to be able to analyze + -- and report errors associated with the Object.Operation notation. + + elsif Is_Concurrent_Type (Tagged_Type) then + pragma Assert (not Expander_Active); + null; + -- If no old subprogram, then we add this as a dispatching operation, -- but we avoid doing this if an error was posted, to prevent annoying -- cascaded errors. Index: sem_disp.ads =================================================================== --- sem_disp.ads (revision 161073) +++ sem_disp.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,12 @@ package Sem_Disp is -- if it has a parameter of this type and is defined at a proper place for -- primitive operations (new primitives are only defined in package spec, -- overridden operation can be defined in any scope). If Old_Subp is not - -- Empty we are in the overriding case. + -- Empty we are in the overriding case. If the tagged type associated with + -- Subp is a concurrent type (case that occurs when the type is declared in + -- a generic because the analysis of generics disables generation of the + -- corresponding record) then this routine does does not add "Subp" to the + -- list of primitive operations but leaves Subp decorated as dispatching + -- operation to enable checks associated with the Object.Operation notation procedure Check_Operation_From_Incomplete_Type (Subp : Entity_Id;