[Ada] Cleanup analysis of concurrent types that implement interfaces

Message ID	20100622164815.GA29191@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-265984-incoming=patchwork.ozlabs.org@gcc.gnu.org> Date: Tue, 22 Jun 2010 18:48:15 +0200 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Javier Miranda <miranda@adacore.com> Subject: [Ada] Cleanup analysis of concurrent types that implement interfaces Message-ID: <20100622164815.GA29191@adacore.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="CE+1k2dSO48ffgeK" Content-Disposition: inline User-Agent: Mutt/1.5.9i Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk Sender: gcc-patches-owner@gcc.gnu.org

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;

[Ada] Cleanup analysis of concurrent types that implement interfaces

Commit Message

Patch