From d44202ba07e54a1d61bebb53abc6133139e75e7d Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 30 Jul 2008 17:53:21 +0200 Subject: [PATCH] einfo.adb: Flag245 is now used. 2008-07-30 Hristian Kirtchev * einfo.adb: Flag245 is now used. (Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Relax the assertion check to include functions. (Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms. (Wrapped_Entity, Set_Wrapped_Entity): Relax the assertion check to include functions. (Write_Entity_Flags): Move flag Is_Primitive, add Is_Private_Primitive to the list of displayed flags. * einfo.ads: Update comment on the usage of Is_Primitive_Wrapper and Wrapped_Entity. These two flags are now present in functions. New flag Is_Private_Primitive. (Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms. * exp_ch9.adb: (Build_Wrapper_Bodies): New subprogram. (Build_Wrapper_Body): The spec and body have been moved to in Build_Wrapper_ Bodies. Code cleanup. (Build_Wrapper_Spec): Moved to the spec of Exp_Ch9. Code cleanup. Wrappers are now generated for primitives declared between the private and full view of a concurrent type that implements an interface. (Build_Wrapper_Specs): New subprogram. (Expand_N_Protected_Body): Code reformatting. Replace the wrapper body creation mechanism with a call to Build_Wrapper_Bodies. (Expand_N_Protected_Type_Declaration): Code reformatting. Replace the wrapper spec creation mechanism with a call to Build_Wrapper_Specs. (Expand_N_Task_Body): Replace the wrapper body creation mechanism with a call to Build_Wrapper_Bodies. (Expand_N_Task_Type_Declaration): Replace the wrapper spec creation mechanism with a call to Build_Wrapper_Specs. (Is_Private_Primitive_Subprogram): New subprogram. (Overriding_Possible): Code cleanup. (Replicate_Entry_Formals): Renamed to Replicate_Formals, code cleanup. * exp_ch9.ads (Build_Wrapper_Spec): Moved from the body of Exp_Ch9. * sem_ch3.adb: Add with and use clause for Exp_Ch9. (Process_Full_View): Build wrapper specs for all primitives that belong to a private view completed by a concurrent type implementing an interface. * sem_ch6.adb (Analyze_Subprogram_Body): When the current subprogram is a primitive of a concurrent type with a private view that implements an interface, try to find the proper spec. (Analyze_Subprogram_Declaration): Mark a subprogram as a private primitive if the type of its first parameter is a non-generic tagged private type. (Analyze_Subprogram_Specification): Code reformatting. (Disambiguate_Spec): New routine. (Find_Corresponding_Spec): Add a flag to controll the output of errors. (Is_Private_Concurrent_Primitive): New routine. * sem_ch6.ads: (Find_Corresponding_Spec): Add a formal to control the output of errors. From-SVN: r138324 --- gcc/ada/einfo.adb | 36 +- gcc/ada/einfo.ads | 22 +- gcc/ada/exp_ch9.adb | 1020 +++++++++++++++++++++++++-------------------------- gcc/ada/exp_ch9.ads | 12 + gcc/ada/sem_ch3.adb | 129 +++++-- gcc/ada/sem_ch6.adb | 215 +++++++++-- gcc/ada/sem_ch6.ads | 8 +- 7 files changed, 849 insertions(+), 593 deletions(-) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 49dffae..01d384e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -504,9 +504,8 @@ package body Einfo is -- Optimize_Alignment_Time Flag242 -- Overlays_Constant Flag243 -- Is_RACW_Stub_Type Flag244 + -- Is_Private_Primitive Flag245 - -- (unused) Flag169 - -- (unused) Flag245 -- (unused) Flag246 -- (unused) Flag247 @@ -1929,7 +1928,8 @@ package body Einfo is function Is_Primitive_Wrapper (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Procedure); + pragma Assert (Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); return Flag195 (Id); end Is_Primitive_Wrapper; @@ -1944,6 +1944,13 @@ package body Einfo is return Flag53 (Id); end Is_Private_Descendant; + function Is_Private_Primitive (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); + return Flag245 (Id); + end Is_Private_Primitive; + function Is_Protected_Interface (Id : E) return B is begin pragma Assert (Is_Interface (Id)); @@ -2702,8 +2709,9 @@ package body Einfo is function Wrapped_Entity (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Procedure - and then Is_Primitive_Wrapper (Id)); + pragma Assert ((Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure) + and then Is_Primitive_Wrapper (Id)); return Node27 (Id); end Wrapped_Entity; @@ -4372,7 +4380,8 @@ package body Einfo is procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Procedure); + pragma Assert (Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); Set_Flag195 (Id, V); end Set_Is_Primitive_Wrapper; @@ -4387,6 +4396,13 @@ package body Einfo is Set_Flag53 (Id, V); end Set_Is_Private_Descendant; + procedure Set_Is_Private_Primitive (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); + Set_Flag245 (Id, V); + end Set_Is_Private_Primitive; + procedure Set_Is_Protected_Interface (Id : E; V : B := True) is begin pragma Assert (Is_Interface (Id)); @@ -5168,8 +5184,9 @@ package body Einfo is procedure Set_Wrapped_Entity (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Procedure - and then Is_Primitive_Wrapper (Id)); + pragma Assert ((Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure) + and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; @@ -7597,9 +7614,11 @@ package body Einfo is W ("Is_Packed_Array_Type", Flag138 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id)); W ("Is_Preelaborated", Flag59 (Id)); + W ("Is_Primitive", Flag218 (Id)); W ("Is_Primitive_Wrapper", Flag195 (Id)); W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); + W ("Is_Private_Primitive", Flag245 (Id)); W ("Is_Protected_Interface", Flag198 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); @@ -7666,7 +7685,6 @@ package body Einfo is W ("Suppress_Init_Proc", Flag105 (Id)); W ("Suppress_Style_Checks", Flag165 (Id)); W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); - W ("Is_Primitive", Flag218 (Id)); W ("Treat_As_Volatile", Flag41 (Id)); W ("Universal_Aliasing", Flag216 (Id)); W ("Used_As_Generic_Actual", Flag222 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 43e0e17..8316a68 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2513,9 +2513,9 @@ package Einfo is -- indicators in bodies. -- Is_Primitive_Wrapper (Flag195) --- Present in all entities. Set for procedure entries that are used as --- primitive wrappers. which are generated by the expander to wrap --- entries of protected or task types implementing a limited interface. +-- Present in functions and procedures created by the expander to serve +-- as an indirection mechanism to overriding primitives of concurrent +-- types, entries and protected procedures. -- Is_Prival (synthesized) -- Applies to all entities, true for renamings of private protected @@ -2533,6 +2533,10 @@ package Einfo is -- functions, procedures). Set if the library unit is itself a private -- child unit, or if it is the descendent of a private child unit. +-- Is_Private_Primitive (Flag245) +-- Present in subprograms. Set if the first parameter of the subprogram +-- is of concurrent tagged type with a private view. + -- Is_Private_Type (synthesized) -- Applies to all entities, true for private types and subtypes, -- as well as for record with private types as subtypes @@ -3723,8 +3727,8 @@ package Einfo is -- attribute when the limited-view is installed (Ada 2005: AI-217). -- Wrapped_Entity (Node27) --- Present in an E_Procedure classified as an Is_Primitive_Wrapper. Set --- to the entity that is being wrapped. +-- Present in functions and procedures which have been classified as +-- Is_Primitive_Wrapper. Set to the entity being wrapper. ------------------ -- Access Kinds -- @@ -5013,6 +5017,7 @@ package Einfo is -- Protection_Object (Node23) (for concurrent kind) -- Interface_Alias (Node25) -- Overridden_Operation (Node26) + -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) -- Body_Needed_For_SAL (Flag40) -- Elaboration_Entity_Required (Flag174) @@ -5039,7 +5044,9 @@ package Einfo is -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Overriding_Operation (Flag39) (non-generic case only) -- Is_Primitive (Flag218) + -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) + -- Is_Private_Primitive (Flag245) (non-generic case only) -- Is_Pure (Flag44) -- Is_Thunk (Flag225) -- Is_Visible_Child_Unit (Flag116) @@ -5305,6 +5312,7 @@ package Einfo is -- Is_Primitive (Flag218) -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) + -- Is_Private_Primitive (Flag245) (non-generic case only) -- Is_Pure (Flag44) -- Is_Thunk (Flag225) -- Is_Valued_Procedure (Flag127) @@ -5974,6 +5982,7 @@ package Einfo is function Is_Primitive_Wrapper (Id : E) return B; function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; + function Is_Private_Primitive (Id : E) return B; function Is_Protected_Interface (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; @@ -6538,6 +6547,7 @@ package Einfo is procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); + procedure Set_Is_Private_Primitive (Id : E; V : B := True); procedure Set_Is_Protected_Interface (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); @@ -7216,6 +7226,7 @@ package Einfo is pragma Inline (Is_Primitive_Wrapper); pragma Inline (Is_Private_Composite); pragma Inline (Is_Private_Descendant); + pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Type); pragma Inline (Is_Protected_Interface); pragma Inline (Is_Protected_Type); @@ -7609,6 +7620,7 @@ package Einfo is pragma Inline (Set_Is_Primitive_Wrapper); pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); + pragma Inline (Set_Is_Private_Primitive); pragma Inline (Set_Is_Protected_Interface); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 572dae0..d040f00 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -152,29 +152,25 @@ package body Exp_Ch9 is -- : AnnN; -- end record; - function Build_Wrapper_Body - (Loc : Source_Ptr; - Proc_Nam : Entity_Id; - Obj_Typ : Entity_Id; - Formals : List_Id) return Node_Id; - -- Ada 2005 (AI-345): Build the body that wraps a primitive operation - -- associated with a protected or task type. This is required to implement - -- dispatching calls through interfaces. Proc_Nam is the entry name to be - -- wrapped, Obj_Typ is the type of the newly added formal parameter to - -- handle object notation, Formals are the original entry formals that will - -- be explicitly replicated. - - function Build_Wrapper_Spec - (Loc : Source_Ptr; - Proc_Nam : Entity_Id; - Obj_Typ : Entity_Id; - Formals : List_Id) return Node_Id; - -- Ada 2005 (AI-345): Build the specification of a primitive operation - -- associated with a protected or task type. This is required implement - -- dispatching calls through interfaces. Proc_Nam is the entry name to be - -- wrapped, Obj_Typ is the type of the newly added formal parameter to - -- handle object notation, Formals are the original entry formals that will - -- be explicitly replicated. + procedure Build_Wrapper_Bodies + (Loc : Source_Ptr; + Typ : Entity_Id; + N : Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all bodies + -- will be placed. This routine builds the bodies of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new body is analyzed. + + procedure Build_Wrapper_Specs + (Loc : Source_Ptr; + Typ : Entity_Id; + N : in out Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all specs + -- will be placed. This routine builds the specs of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new spec is analyzed. function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; -- Build the function that translates the entry index in the call @@ -359,6 +355,10 @@ package body Exp_Ch9 is Lo : Node_Id; Hi : Node_Id) return Boolean; + function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; + -- Determine whether Id is a function or a procedure and is marked as a + -- private primitive. + function Null_Statements (Stats : List_Id) return Boolean; -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. -- Allows labels, and pragma Warnings/Unreferenced in the sequence as @@ -1541,144 +1541,241 @@ package body Exp_Ch9 is return Rec_Nam; end Build_Parameter_Block; - ------------------------ - -- Build_Wrapper_Body -- - ------------------------ + -------------------------- + -- Build_Wrapper_Bodies -- + -------------------------- - function Build_Wrapper_Body - (Loc : Source_Ptr; - Proc_Nam : Entity_Id; - Obj_Typ : Entity_Id; - Formals : List_Id) return Node_Id + procedure Build_Wrapper_Bodies + (Loc : Source_Ptr; + Typ : Entity_Id; + N : Node_Id) is - Actuals : List_Id := No_List; - Body_Spec : Node_Id; - Conv_Id : Node_Id; - First_Formal : Node_Id; - Formal : Node_Id; - - begin - Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals); + Rec_Typ : Entity_Id; - -- If we did not generate the specification do have nothing else to do + function Build_Wrapper_Body + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the body that wraps a primitive operation + -- associated with a protected or task type. Subp_Id is the subprogram + -- name which will be wrapped. Obj_Typ is the type of the new formal + -- parameter which handles dispatching and object notation. Formals are + -- the original formals of Subp_Id which will be explicitly replicated. + + ------------------------ + -- Build_Wrapper_Body -- + ------------------------ + + function Build_Wrapper_Body + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id + is + Body_Spec : Node_Id; - if Body_Spec = Empty then - return Empty; - end if; + begin + Body_Spec := Build_Wrapper_Spec (Loc, Subp_Id, Obj_Typ, Formals); - -- Map formals to actuals. Use the list built for the wrapper spec, - -- skipping the object notation parameter. + -- The subprogram is not overriding or is not a primitive declared + -- between two views. - First_Formal := First (Parameter_Specifications (Body_Spec)); + if No (Body_Spec) then + return Empty; + end if; - Formal := First_Formal; - Next (Formal); + declare + Actuals : List_Id := No_List; + Conv_Id : Node_Id; + First_Formal : Node_Id; + Formal : Node_Id; + Nam : Node_Id; - if Present (Formal) then - Actuals := New_List; + begin + -- Map formals to actuals. Use the list built for the wrapper + -- spec, skipping the object notation parameter. - while Present (Formal) loop - Append_To (Actuals, - Make_Identifier (Loc, Chars => - Chars (Defining_Identifier (Formal)))); + First_Formal := First (Parameter_Specifications (Body_Spec)); + Formal := First_Formal; Next (Formal); - end loop; - end if; - -- An access-to-variable first parameter will require an explicit - -- dereference in the unchecked conversion. This case occurs when - -- a protected entry wrapper must override an interface-level - -- procedure with interface access as first parameter. + if Present (Formal) then + Actuals := New_List; - -- SubprgName (O.all).Proc_Nam (Formal_1 .. Formal_N) + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars => + Chars (Defining_Identifier (Formal)))); - if Nkind (Parameter_Type (First_Formal)) = N_Access_Definition then - Conv_Id := - Make_Explicit_Dereference (Loc, - Prefix => - Make_Identifier (Loc, Chars => Name_uO)); + Next (Formal); + end loop; + end if; + + -- Special processing for primitives declared between a private + -- type and its completion. + + if Is_Private_Primitive_Subprogram (Subp_Id) then + if No (Actuals) then + Actuals := New_List; + end if; + + Prepend_To (Actuals, + Unchecked_Convert_To ( + Corresponding_Concurrent_Type (Obj_Typ), + Make_Identifier (Loc, Name_uO))); + + Nam := New_Reference_To (Subp_Id, Loc); + + else + -- An access-to-variable object parameter requires an explicit + -- dereference in the unchecked conversion. This case occurs + -- when a protected entry wrapper must override an interface + -- level procedure with interface access as first parameter. + + -- O.all.Subp_Id (Formal_1 .. Formal_N) + + if Nkind (Parameter_Type (First_Formal)) = + N_Access_Definition + then + Conv_Id := + Make_Explicit_Dereference (Loc, + Prefix => Make_Identifier (Loc, Name_uO)); + else + Conv_Id := Make_Identifier (Loc, Name_uO); + end if; + + Nam := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + Corresponding_Concurrent_Type (Obj_Typ), + Conv_Id), + Selector_Name => + New_Reference_To (Subp_Id, Loc)); + end if; + + -- Create the subprogram body + + if Ekind (Subp_Id) = E_Function then + return + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Make_Function_Call (Loc, + Name => Nam, + Parameter_Associations => Actuals))))); + + else + return + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => Actuals)))); + end if; + end; + end Build_Wrapper_Body; + + -- Start of processing for Build_Wrapper_Bodies + + begin + if Is_Concurrent_Type (Typ) then + Rec_Typ := Corresponding_Record_Type (Typ); else - Conv_Id := - Make_Identifier (Loc, Chars => Name_uO); + Rec_Typ := Typ; end if; - if Ekind (Proc_Nam) = E_Function then - return - Make_Subprogram_Body (Loc, - Specification => Body_Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => - New_List ( - Make_Simple_Return_Statement (Loc, - Make_Function_Call (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - Corresponding_Concurrent_Type (Obj_Typ), - Conv_Id), - Selector_Name => - New_Reference_To (Proc_Nam, Loc)), - Parameter_Associations => Actuals))))); - else - return - Make_Subprogram_Body (Loc, - Specification => Body_Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To ( - Corresponding_Concurrent_Type (Obj_Typ), - Conv_Id), - Selector_Name => - New_Reference_To (Proc_Nam, Loc)), - Parameter_Associations => Actuals)))); + -- Generate wrapper bodies for a concurrent type which implements an + -- interface. + + if Present (Interfaces (Rec_Typ)) then + declare + Insert_Nod : Node_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Decl : Node_Id; + Subp : Entity_Id; + Wrap_Body : Node_Id; + Wrap_Id : Entity_Id; + + begin + Insert_Nod := N; + + -- Examine all primitive operations of the corresponding record + -- type, looking for wrapper specs. Generate bodies in order to + -- complete them. + + Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if (Ekind (Prim) = E_Function + or else Ekind (Prim) = E_Procedure) + and then Is_Primitive_Wrapper (Prim) + then + Subp := Wrapped_Entity (Prim); + Prim_Decl := Parent (Parent (Prim)); + + Wrap_Body := + Build_Wrapper_Body (Loc, + Subp_Id => Subp, + Obj_Typ => Rec_Typ, + Formals => Parameter_Specifications (Parent (Subp))); + Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); + + Set_Corresponding_Spec (Wrap_Body, Prim); + Set_Corresponding_Body (Prim_Decl, Wrap_Id); + + Insert_After (Insert_Nod, Wrap_Body); + Insert_Nod := Wrap_Body; + + Analyze (Wrap_Body); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; end if; - end Build_Wrapper_Body; + end Build_Wrapper_Bodies; ------------------------ -- Build_Wrapper_Spec -- ------------------------ function Build_Wrapper_Spec - (Loc : Source_Ptr; - Proc_Nam : Entity_Id; - Obj_Typ : Entity_Id; - Formals : List_Id) return Node_Id + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id is - New_Name_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars (Proc_Nam)); - - First_Param : Node_Id := Empty; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id := No_Elmt; - New_Formals : List_Id; - Obj_Param : Node_Id; - Obj_Param_Typ : Node_Id; - Iface_Prim_Op : Entity_Id; - Iface_Prim_Op_Elmt : Elmt_Id; + First_Param : Node_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Op : Entity_Id; + Iface_Op_Elmt : Elmt_Id; function Overriding_Possible - (Iface_Prim_Op : Entity_Id; - Proc_Nam : Entity_Id) return Boolean; - -- Determine whether a primitive operation can be overridden by the - -- wrapper. Iface_Prim_Op is the candidate primitive operation of an - -- abstract interface type, Proc_Nam is the generated entry wrapper. + (Iface_Op : Entity_Id; + Wrapper : Entity_Id) return Boolean; + -- Determine whether a primitive operation can be overridden by Wrapper. + -- Iface_Op is the candidate primitive operation of an interface type, + -- Wrapper is the generated entry wrapper. - function Replicate_Entry_Formals + function Replicate_Formals (Loc : Source_Ptr; Formals : List_Id) return List_Id; - -- An explicit parameter replication is required due to the - -- Is_Entry_Formal flag being set for all the formals. The explicit + -- An explicit parameter replication is required due to the Is_Entry_ + -- Formal flag being set for all the formals of an entry. The explicit -- replication removes the flag that would otherwise cause a different -- path of analysis. @@ -1687,18 +1784,15 @@ package body Exp_Ch9 is ------------------------- function Overriding_Possible - (Iface_Prim_Op : Entity_Id; - Proc_Nam : Entity_Id) return Boolean + (Iface_Op : Entity_Id; + Wrapper : Entity_Id) return Boolean is - Prim_Op_Spec : constant Node_Id := Parent (Iface_Prim_Op); - Proc_Spec : constant Node_Id := Parent (Proc_Nam); - - Is_Access_To_Variable : Boolean; - Is_Out_Present : Boolean; + Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); + Wrapper_Spec : constant Node_Id := Parent (Wrapper); function Type_Conformant_Parameters - (Prim_Op_Param_Specs : List_Id; - Proc_Param_Specs : List_Id) return Boolean; + (Iface_Op_Params : List_Id; + Wrapper_Params : List_Id) return Boolean; -- Determine whether the parameters of the generated entry wrapper -- and those of a primitive operation are type conformant. During -- this check, the first parameter of the primitive operation is @@ -1709,40 +1803,40 @@ package body Exp_Ch9 is -------------------------------- function Type_Conformant_Parameters - (Prim_Op_Param_Specs : List_Id; - Proc_Param_Specs : List_Id) return Boolean + (Iface_Op_Params : List_Id; + Wrapper_Params : List_Id) return Boolean is - Prim_Op_Param : Node_Id; - Prim_Op_Typ : Entity_Id; - Proc_Param : Node_Id; - Proc_Typ : Entity_Id; + Iface_Op_Param : Node_Id; + Iface_Op_Typ : Entity_Id; + Wrapper_Param : Node_Id; + Wrapper_Typ : Entity_Id; begin -- Skip the first parameter of the primitive operation - Prim_Op_Param := Next (First (Prim_Op_Param_Specs)); - Proc_Param := First (Proc_Param_Specs); - while Present (Prim_Op_Param) - and then Present (Proc_Param) + Iface_Op_Param := Next (First (Iface_Op_Params)); + Wrapper_Param := First (Wrapper_Params); + while Present (Iface_Op_Param) + and then Present (Wrapper_Param) loop - Prim_Op_Typ := Find_Parameter_Type (Prim_Op_Param); - Proc_Typ := Find_Parameter_Type (Proc_Param); + Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); + Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); -- The two parameters must be mode conformant if not Conforming_Types - (Prim_Op_Typ, Proc_Typ, Mode_Conformant) + (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) then return False; end if; - Next (Prim_Op_Param); - Next (Proc_Param); + Next (Iface_Op_Param); + Next (Wrapper_Param); end loop; -- One of the lists is longer than the other - if Present (Prim_Op_Param) or else Present (Proc_Param) then + if Present (Iface_Op_Param) or else Present (Wrapper_Param) then return False; end if; @@ -1752,47 +1846,42 @@ package body Exp_Ch9 is -- Start of processing for Overriding_Possible begin - if Chars (Iface_Prim_Op) /= Chars (Proc_Nam) then + if Chars (Iface_Op) /= Chars (Wrapper) then return False; end if; - -- Special check for protected procedures: If an inherited subprogram - -- is implemented by a protected procedure or an entry, then the - -- first parameter of the inherited subprogram shall be of mode OUT - -- or IN OUT, or an access-to-variable parameter. - - if Ekind (Iface_Prim_Op) = E_Procedure then + -- If an inherited subprogram is implemented by a protected procedure + -- or an entry, then the first parameter of the inherited subprogram + -- shall be of mode OUT or IN OUT, or access-to-variable parameter. - Is_Out_Present := - Present (Parameter_Specifications (Prim_Op_Spec)) - and then - Out_Present (First (Parameter_Specifications (Prim_Op_Spec))); - - Is_Access_To_Variable := - Present (Parameter_Specifications (Prim_Op_Spec)) - and then - Nkind (Parameter_Type - (First - (Parameter_Specifications (Prim_Op_Spec)))) = - N_Access_Definition; + if Ekind (Iface_Op) = E_Procedure + and then Present (Parameter_Specifications (Iface_Op_Spec)) + then + declare + Obj_Param : constant Node_Id := + First (Parameter_Specifications (Iface_Op_Spec)); - if not Is_Out_Present - and then not Is_Access_To_Variable - then - return False; - end if; + begin + if not Out_Present (Obj_Param) + and then Nkind (Parameter_Type (Obj_Param)) /= + N_Access_Definition + then + return False; + end if; + end; end if; - return Type_Conformant_Parameters ( - Parameter_Specifications (Prim_Op_Spec), - Parameter_Specifications (Proc_Spec)); + return + Type_Conformant_Parameters ( + Parameter_Specifications (Iface_Op_Spec), + Parameter_Specifications (Wrapper_Spec)); end Overriding_Possible; - ----------------------------- - -- Replicate_Entry_Formals -- - ----------------------------- + ----------------------- + -- Replicate_Formals -- + ----------------------- - function Replicate_Entry_Formals + function Replicate_Formals (Loc : Source_Ptr; Formals : List_Id) return List_Id is @@ -1802,6 +1891,14 @@ package body Exp_Ch9 is begin Formal := First (Formals); + + -- Skip the object parameter when dealing with primitives declared + -- between two views. + + if Is_Private_Primitive_Subprogram (Subp_Id) then + Formal := Next (Formal); + end if; + while Present (Formal) loop -- Create an explicit copy of the entry parameter @@ -1835,166 +1932,228 @@ package body Exp_Ch9 is end loop; return New_Formals; - end Replicate_Entry_Formals; + end Replicate_Formals; -- Start of processing for Build_Wrapper_Spec begin - -- The mode is determined by the first parameter of the interface-level - -- procedure that the current entry is trying to override. - - pragma Assert (Is_Non_Empty_List (Abstract_Interface_List (Obj_Typ))); - - -- We must examine all the protected operations of the implemented - -- interfaces in order to discover a possible overriding candidate. - - Iface := Etype (First (Abstract_Interface_List (Obj_Typ))); - - Examine_Parents : loop - if Present (Primitive_Operations (Iface)) then - Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Iface_Prim_Op_Elmt) loop - Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); + -- There is no point in building wrappers for non-tagged concurrent + -- types. - if not Is_Predefined_Dispatching_Operation (Iface_Prim_Op) then - while Present (Alias (Iface_Prim_Op)) loop - Iface_Prim_Op := Alias (Iface_Prim_Op); - end loop; + pragma Assert (Is_Tagged_Type (Obj_Typ)); - -- The current primitive operation can be overridden by the - -- generated entry wrapper. + -- An entry or a protected procedure can override a routine where the + -- controlling formal is either IN OUT, OUT or is of access-to-variable + -- type. Since the wrapper must have the exact same signature as that of + -- the overridden subprogram, we try to find the overriding candidate + -- and use its controlling formal. - if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then - First_Param := First (Parameter_Specifications - (Parent (Iface_Prim_Op))); + First_Param := Empty; - goto Found; - end if; - end if; + -- Check every implemented interface - Next_Elmt (Iface_Prim_Op_Elmt); - end loop; - end if; - - exit Examine_Parents when Etype (Iface) = Iface; - - Iface := Etype (Iface); - end loop Examine_Parents; - - if Present (Interfaces - (Corresponding_Record_Type (Scope (Proc_Nam)))) - then - Iface_Elmt := First_Elmt - (Interfaces - (Corresponding_Record_Type (Scope (Proc_Nam)))); - Examine_Interfaces : while Present (Iface_Elmt) loop + if Present (Interfaces (Obj_Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); + Search : while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); + -- Check every interface primitive + if Present (Primitive_Operations (Iface)) then - Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Iface_Prim_Op_Elmt) loop - Iface_Prim_Op := Node (Iface_Prim_Op_Elmt); + Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Iface_Op_Elmt) loop + Iface_Op := Node (Iface_Op_Elmt); - if not Is_Predefined_Dispatching_Operation - (Iface_Prim_Op) - then - while Present (Alias (Iface_Prim_Op)) loop - Iface_Prim_Op := Alias (Iface_Prim_Op); - end loop; + -- Ignore predefined primitives + + if not Is_Predefined_Dispatching_Operation (Iface_Op) then + Iface_Op := Ultimate_Alias (Iface_Op); -- The current primitive operation can be overridden by -- the generated entry wrapper. - if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then - First_Param := First (Parameter_Specifications - (Parent (Iface_Prim_Op))); + if Overriding_Possible (Iface_Op, Subp_Id) then + First_Param := + First (Parameter_Specifications (Parent (Iface_Op))); - goto Found; + exit Search; end if; end if; - Next_Elmt (Iface_Prim_Op_Elmt); + Next_Elmt (Iface_Op_Elmt); end loop; end if; Next_Elmt (Iface_Elmt); - end loop Examine_Interfaces; + end loop Search; + end if; + + -- If the subprogram to be wrapped is not overriding anything or is not + -- a primitive declared between two views, do not produce anything. This + -- avoids spurious errors involving overriding. + + if No (First_Param) + and then not Is_Private_Primitive_Subprogram (Subp_Id) + then + return Empty; end if; - -- Return if no interface primitive can be overridden + declare + Wrapper_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Subp_Id)); + New_Formals : List_Id; + Obj_Param : Node_Id; + Obj_Param_Typ : Entity_Id; + + begin + -- Minimum decoration is needed to catch the entity in + -- Sem_Ch6.Override_Dispatching_Operation. - return Empty; + if Ekind (Subp_Id) = E_Function then + Set_Ekind (Wrapper_Id, E_Function); + else + Set_Ekind (Wrapper_Id, E_Procedure); + end if; - <> + Set_Is_Primitive_Wrapper (Wrapper_Id); + Set_Wrapped_Entity (Wrapper_Id, Subp_Id); + Set_Is_Private_Primitive (Wrapper_Id, + Is_Private_Primitive_Subprogram (Subp_Id)); - New_Formals := Replicate_Entry_Formals (Loc, Formals); + -- Process the formals - -- ??? Certain source packages contain protected or task types that do - -- not implement any interfaces and are compiled with the -gnat05 - -- switch. In this case, a default first parameter is created. + New_Formals := Replicate_Formals (Loc, Formals); - -- If the interface operation has an access parameter, create a copy - -- of it, with the same null exclusion indicator if present. + -- Routine Subp_Id has been found to override an interface primitive. + -- If the interface operation has an access parameter, create a copy + -- of it, with the same null exclusion indicator if present. - if Present (First_Param) then - if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then - Obj_Param_Typ := - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To (Obj_Typ, Loc)); - Set_Null_Exclusion_Present (Obj_Param_Typ, - Null_Exclusion_Present (Parameter_Type (First_Param))); + if Present (First_Param) then + if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then + Obj_Param_Typ := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To (Obj_Typ, Loc)); + Set_Null_Exclusion_Present (Obj_Param_Typ, + Null_Exclusion_Present (Parameter_Type (First_Param))); + else + Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); + end if; + + Obj_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => In_Present (First_Param), + Out_Present => Out_Present (First_Param), + Parameter_Type => Obj_Param_Typ); + + -- If we are dealing with a primitive declared between two views, + -- create a default parameter. + + else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); + Obj_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Out_Present => Ekind (Subp_Id) /= E_Function, + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + end if; + + Prepend_To (New_Formals, Obj_Param); + + -- Build the final spec + + if Ekind (Subp_Id) = E_Function then + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => New_Formals, + Result_Definition => + New_Copy (Result_Definition (Parent (Subp_Id)))); else - Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc); + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => New_Formals); end if; + end; + end Build_Wrapper_Spec; - Obj_Param := - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uO), - In_Present => In_Present (First_Param), - Out_Present => Out_Present (First_Param), - Parameter_Type => Obj_Param_Typ); + ------------------------- + -- Build_Wrapper_Specs -- + ------------------------- - else - Obj_Param := - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uO), - In_Present => True, - Out_Present => True, - Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + procedure Build_Wrapper_Specs + (Loc : Source_Ptr; + Typ : Entity_Id; + N : in out Node_Id) + is + Def : Node_Id; + Rec_Typ : Entity_Id; + + begin + if Is_Protected_Type (Typ) then + Def := Protected_Definition (Parent (Typ)); + else pragma Assert (Is_Task_Type (Typ)); + Def := Task_Definition (Parent (Typ)); end if; - Prepend_To (New_Formals, Obj_Param); + Rec_Typ := Corresponding_Record_Type (Typ); - -- Minimum decoration needed to catch the entity in - -- Sem_Ch6.Override_Dispatching_Operation + -- Generate wrapper specs for a concurrent type which implements an + -- interface and has visible entries and/or protected procedures. - if Ekind (Proc_Nam) = E_Procedure - or else Ekind (Proc_Nam) = E_Entry + if Present (Interfaces (Rec_Typ)) + and then Present (Def) + and then Present (Visible_Declarations (Def)) then - Set_Ekind (New_Name_Id, E_Procedure); - Set_Is_Primitive_Wrapper (New_Name_Id); - Set_Wrapped_Entity (New_Name_Id, Proc_Nam); + declare + Decl : Node_Id; + Wrap_Decl : Node_Id; + Wrap_Spec : Node_Id; - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => New_Name_Id, - Parameter_Specifications => New_Formals); + begin + Decl := First (Visible_Declarations (Def)); + while Present (Decl) loop + Wrap_Spec := Empty; - else pragma Assert (Ekind (Proc_Nam) = E_Function); - Set_Ekind (New_Name_Id, E_Function); + if Nkind (Decl) = N_Entry_Declaration + and then Ekind (Defining_Identifier (Decl)) = E_Entry + then + Wrap_Spec := + Build_Wrapper_Spec (Loc, + Subp_Id => Defining_Identifier (Decl), + Obj_Typ => Rec_Typ, + Formals => Parameter_Specifications (Decl)); - return - Make_Function_Specification (Loc, - Defining_Unit_Name => New_Name_Id, - Parameter_Specifications => New_Formals, - Result_Definition => - New_Copy (Result_Definition (Parent (Proc_Nam)))); + elsif Nkind (Decl) = N_Subprogram_Declaration then + Wrap_Spec := + Build_Wrapper_Spec (Loc, + Subp_Id => Defining_Unit_Name (Specification (Decl)), + Obj_Typ => Rec_Typ, + Formals => + Parameter_Specifications (Specification (Decl))); + end if; + + if Present (Wrap_Spec) then + Wrap_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Wrap_Spec); + + Insert_After (N, Wrap_Decl); + N := Wrap_Decl; + + Analyze (Wrap_Decl); + end if; + + Next (Decl); + end loop; + end; end if; - end Build_Wrapper_Spec; + end Build_Wrapper_Specs; --------------------------- -- Build_Find_Body_Index -- @@ -6903,13 +7062,13 @@ package body Exp_Ch9 is procedure Expand_N_Protected_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); - Op_Body : Node_Id; - Op_Decl : Node_Id; - Op_Id : Entity_Id; + Current_Node : Node_Id; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; - Current_Node : Node_Id; Num_Entries : Natural := 0; + Op_Body : Node_Id; + Op_Decl : Node_Id; + Op_Id : Entity_Id; function Build_Dispatching_Subprogram_Body (N : Node_Id; @@ -7002,14 +7161,12 @@ package body Exp_Ch9 is return; end if; - if Nkind (Parent (N)) = N_Subunit then - - -- This is the proper body corresponding to a stub. The declarations - -- must be inserted at the point of the stub, which is in the decla- - -- rative part of the parent unit. + -- This is the proper body corresponding to a stub. The declarations + -- must be inserted at the point of the stub, which in turn is in the + -- declarative part of the parent unit. + if Nkind (Parent (N)) = N_Subunit then Current_Node := Corresponding_Stub (Parent (N)); - else Current_Node := N; end if; @@ -7171,63 +7328,12 @@ package body Exp_Ch9 is Analyze (New_Op_Body); end if; - -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after - -- the protected body. At this point the entry specs have been created, + -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the + -- protected body. At this point all wrapper specs have been created, -- frozen and included in the dispatch table for the protected type. - pragma Assert (Present (Corresponding_Record_Type (Pid))); - - if Ada_Version >= Ada_05 - and then Present (Protected_Definition (Parent (Pid))) - and then Present (Interfaces (Corresponding_Record_Type (Pid))) - then - declare - Vis_Decl : Node_Id := - First (Visible_Declarations - (Protected_Definition (Parent (Pid)))); - Wrap_Body : Node_Id; - - begin - -- Examine the visible declarations of the protected type, looking - -- for an entry declaration. We do not consider entry families - -- since they cannot have dispatching operations, thus they do not - -- need entry wrappers. - - while Present (Vis_Decl) loop - if Nkind (Vis_Decl) = N_Entry_Declaration then - Wrap_Body := - Build_Wrapper_Body (Loc, - Proc_Nam => Defining_Identifier (Vis_Decl), - Obj_Typ => Corresponding_Record_Type (Pid), - Formals => Parameter_Specifications (Vis_Decl)); - - if Wrap_Body /= Empty then - Insert_After (Current_Node, Wrap_Body); - Current_Node := Wrap_Body; - - Analyze (Wrap_Body); - end if; - - elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then - Wrap_Body := - Build_Wrapper_Body (Loc, - Proc_Nam => Defining_Unit_Name - (Specification (Vis_Decl)), - Obj_Typ => Corresponding_Record_Type (Pid), - Formals => Parameter_Specifications - (Specification (Vis_Decl))); - - if Wrap_Body /= Empty then - Insert_After (Current_Node, Wrap_Body); - Current_Node := Wrap_Body; - - Analyze (Wrap_Body); - end if; - end if; - - Next (Vis_Decl); - end loop; - end; + if Ada_Version >= Ada_05 then + Build_Wrapper_Bodies (Loc, Pid, Current_Node); end if; end Expand_N_Protected_Body; @@ -7625,67 +7731,11 @@ package body Exp_Ch9 is Analyze (Rec_Decl, Suppress => All_Checks); -- Ada 2005 (AI-345): Construct the primitive entry wrappers before - -- the corresponding record is frozen - - if Ada_Version >= Ada_05 - and then Present (Visible_Declarations (Pdef)) - and then Present (Corresponding_Record_Type - (Defining_Identifier (Parent (Pdef)))) - and then Present (Interfaces - (Corresponding_Record_Type - (Defining_Identifier (Parent (Pdef))))) - then - declare - Current_Node : Node_Id := Rec_Decl; - Vis_Decl : Node_Id; - Wrap_Spec : Node_Id; - New_N : Node_Id; - - begin - -- Examine the visible declarations of the protected type, looking - -- for declarations of entries, and subprograms. We do not - -- consider entry families since they cannot have dispatching - -- operations, thus they do not need entry wrappers. - - Vis_Decl := First (Visible_Declarations (Pdef)); - - while Present (Vis_Decl) loop - - Wrap_Spec := Empty; - - if Nkind (Vis_Decl) = N_Entry_Declaration - and then No (Discrete_Subtype_Definition (Vis_Decl)) - then - Wrap_Spec := - Build_Wrapper_Spec (Loc, - Proc_Nam => Defining_Identifier (Vis_Decl), - Obj_Typ => Defining_Identifier (Rec_Decl), - Formals => Parameter_Specifications (Vis_Decl)); - - elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then - Wrap_Spec := - Build_Wrapper_Spec (Loc, - Proc_Nam => Defining_Unit_Name - (Specification (Vis_Decl)), - Obj_Typ => Defining_Identifier (Rec_Decl), - Formals => Parameter_Specifications - (Specification (Vis_Decl))); - - end if; - - if Wrap_Spec /= Empty then - New_N := Make_Subprogram_Declaration (Loc, - Specification => Wrap_Spec); - - Insert_After (Current_Node, New_N); - Current_Node := New_N; - - Analyze (New_N); - end if; + -- the corresponding record is frozen. If any wrappers are generated, + -- Current_Node is updated accordingly. - Next (Vis_Decl); - end loop; - end; + if Ada_Version >= Ada_05 then + Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); end if; -- Collect pointers to entry bodies and their barriers, to be placed @@ -7694,9 +7744,7 @@ package body Exp_Ch9 is -- this array. The array is declared after all protected subprograms. if Has_Entries (Prot_Typ) then - Entries_Aggr := - Make_Aggregate (Loc, Expressions => New_List); - + Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); else Entries_Aggr := Empty; end if; @@ -9461,6 +9509,9 @@ package body Exp_Ch9 is Call : Node_Id; New_N : Node_Id; + Insert_Nod : Node_Id; + -- Used to determine the proper location of wrapper body insertions + begin -- Add renaming declarations for discriminals and a declaration for the -- entry family index (if applicable). @@ -9527,56 +9578,17 @@ package body Exp_Ch9 is end if; -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after - -- the task body. At this point the entry specs have been created, + -- the task body. At this point all wrapper specs have been created, -- frozen and included in the dispatch table for the task type. - pragma Assert (Present (Corresponding_Record_Type (Ttyp))); - - if Ada_Version >= Ada_05 - and then Present (Task_Definition (Parent (Ttyp))) - and then Present (Interfaces (Corresponding_Record_Type (Ttyp))) - then - declare - Current_Node : Node_Id; - Vis_Decl : Node_Id := - First (Visible_Declarations (Task_Definition (Parent (Ttyp)))); - Wrap_Body : Node_Id; - - begin - if Nkind (Parent (N)) = N_Subunit then - Current_Node := Corresponding_Stub (Parent (N)); - else - Current_Node := N; - end if; - - -- Examine the visible declarations of the task type, looking for - -- an entry declaration. We do not consider entry families since - -- they cannot have dispatching operations, thus they do not need - -- entry wrappers. - - while Present (Vis_Decl) loop - if Nkind (Vis_Decl) = N_Entry_Declaration - and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry - then - -- Create the specification of the wrapper - - Wrap_Body := - Build_Wrapper_Body (Loc, - Proc_Nam => Defining_Identifier (Vis_Decl), - Obj_Typ => Corresponding_Record_Type (Ttyp), - Formals => Parameter_Specifications (Vis_Decl)); - - if Wrap_Body /= Empty then - Insert_After (Current_Node, Wrap_Body); - Current_Node := Wrap_Body; - - Analyze (Wrap_Body); - end if; - end if; + if Ada_Version >= Ada_05 then + if Nkind (Parent (N)) = N_Subunit then + Insert_Nod := Corresponding_Stub (Parent (N)); + else + Insert_Nod := N; + end if; - Next (Vis_Decl); - end loop; - end; + Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); end if; end Expand_N_Task_Body; @@ -10025,51 +10037,8 @@ package body Exp_Ch9 is -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before -- the corresponding record has been frozen. - if Ada_Version >= Ada_05 - and then Present (Taskdef) - and then Present (Corresponding_Record_Type - (Defining_Identifier (Parent (Taskdef)))) - and then Present (Interfaces - (Corresponding_Record_Type - (Defining_Identifier (Parent (Taskdef))))) - then - declare - Current_Node : Node_Id := Rec_Decl; - Vis_Decl : Node_Id := First (Visible_Declarations (Taskdef)); - Wrap_Spec : Node_Id; - New_N : Node_Id; - - begin - -- Examine the visible declarations of the task type, looking for - -- an entry declaration. We do not consider entry families since - -- they cannot have dispatching operations, thus they do not need - -- entry wrappers. - - while Present (Vis_Decl) loop - if Nkind (Vis_Decl) = N_Entry_Declaration - and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry - then - Wrap_Spec := - Build_Wrapper_Spec (Loc, - Proc_Nam => Defining_Identifier (Vis_Decl), - Obj_Typ => Etype (Rec_Ent), - Formals => Parameter_Specifications (Vis_Decl)); - - if Wrap_Spec /= Empty then - New_N := - Make_Subprogram_Declaration (Loc, - Specification => Wrap_Spec); - - Insert_After (Current_Node, New_N); - Current_Node := New_N; - - Analyze (New_N); - end if; - end if; - - Next (Vis_Decl); - end loop; - end; + if Ada_Version >= Ada_05 then + Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); end if; -- Ada 2005 (AI-345): We must defer freezing to allow further @@ -11408,6 +11377,17 @@ package body Exp_Ch9 is or else Denotes_Discriminant (Hi, True)); end Is_Potentially_Large_Family; + ------------------------------------- + -- Is_Private_Primitive_Subprogram -- + ------------------------------------- + + function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is + begin + return + (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) + and then Is_Private_Primitive (Id); + end Is_Private_Primitive_Subprogram; + ------------------ -- Index_Object -- ------------------ diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index a4c618a..1cfa74d 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -153,6 +153,18 @@ package Exp_Ch9 is -- aggregate. It replaces the call to Init (Args) done by -- Build_Task_Allocate_Block. + function Build_Wrapper_Spec + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Obj_Typ : Entity_Id; + Formals : List_Id) return Node_Id; + -- Ada 2005 (AI-345): Build the specification of a primitive operation + -- associated with a protected or task type. This is required to implement + -- dispatching calls through interfaces. Subp_Id is the primitive to be + -- wrapped, Obj_Typ is the type of the newly added formal parameter to + -- handle object notation, Formals are the original entry formals that + -- will be explicitly replicated. + function Concurrent_Ref (N : Node_Id) return Node_Id; -- Given the name of a concurrent object (task or protected object), or -- the name of an access to a concurrent object, this function returns an diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b6ccb60..f67d34d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -31,6 +31,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Ch3; use Exp_Ch3; +with Exp_Ch9; use Exp_Ch9; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; @@ -15811,48 +15812,117 @@ package body Sem_Ch3 is -- If the private view was tagged, copy the new primitive operations -- from the private view to the full view. - -- Note: Subprograms covering interface primitives were previously - -- propagated to the full view by Derive_Progenitor_Primitives - - if Is_Tagged_Type (Full_T) - and then not Is_Concurrent_Type (Full_T) - then + if Is_Tagged_Type (Full_T) then declare - Priv_List : Elist_Id; - Full_List : constant Elist_Id := Primitive_Operations (Full_T); - P1, P2 : Elmt_Id; + Disp_Typ : Entity_Id; + Full_List : Elist_Id; Prim : Entity_Id; - D_Type : Entity_Id; + Prim_Elmt : Elmt_Id; + Priv_List : Elist_Id; + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean; + -- Determine whether list L contains element E + + -------------- + -- Contains -- + -------------- + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean + is + List_Elmt : Elmt_Id; + + begin + List_Elmt := First_Elmt (L); + while Present (List_Elmt) loop + if Node (List_Elmt) = E then + return True; + end if; + + Next_Elmt (List_Elmt); + end loop; + + return False; + end Contains; + + -- Start of processing begin if Is_Tagged_Type (Priv_T) then Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); + + -- In the case of a concurrent type completing a private tagged + -- type, primivies may have been declared in between the two + -- views. These subprograms need to be wrapped the same way + -- entries and protected procedures are handled because they + -- cannot be directly shared by the two views. + + if Is_Concurrent_Type (Full_T) then + declare + Conc_Typ : constant Entity_Id := + Corresponding_Record_Type (Full_T); + Loc : constant Source_Ptr := Sloc (Conc_Typ); + Curr_Nod : Node_Id := Parent (Conc_Typ); + Wrap_Spec : Node_Id; - P1 := First_Elmt (Priv_List); - while Present (P1) loop - Prim := Node (P1); + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - -- Transfer explicit primitives, not those inherited from - -- parent of partial view, which will be re-inherited on - -- the full view. + if Comes_From_Source (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Wrap_Spec := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Wrapper_Spec (Loc, + Subp_Id => Prim, + Obj_Typ => Conc_Typ, + Formals => + Parameter_Specifications ( + Parent (Prim)))); + + Insert_After (Curr_Nod, Wrap_Spec); + Curr_Nod := Wrap_Spec; + + Analyze (Wrap_Spec); + end if; - if Comes_From_Source (Prim) then - P2 := First_Elmt (Full_List); - while Present (P2) and then Node (P2) /= Prim loop - Next_Elmt (P2); + Next_Elmt (Prim_Elmt); end loop; - -- If not found, that is a new one + return; + end; + + -- For non-concurrent types, transfer explicit primitives, but + -- omit those inherited from the parent of the private view + -- since they will be re-inherited later on. + + else + Full_List := Primitive_Operations (Full_T); + + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - if No (P2) then + if Comes_From_Source (Prim) + and then not Contains (Prim, Full_List) + then Append_Elmt (Prim, Full_List); end if; - end if; - Next_Elmt (P1); - end loop; + Next_Elmt (Prim_Elmt); + end loop; + end if; + + -- Untagged private view else + Full_List := Primitive_Operations (Full_T); + -- In this case the partial view is untagged, so here we locate -- all of the earlier primitives that need to be treated as -- dispatching (those that appear between the two views). Note @@ -15871,10 +15941,9 @@ package body Sem_Ch3 is or else Ekind (Prim) = E_Function then + Disp_Typ := Find_Dispatching_Type (Prim); - D_Type := Find_Dispatching_Type (Prim); - - if D_Type = Full_T + if Disp_Typ = Full_T and then (Chars (Prim) /= Name_Op_Ne or else Comes_From_Source (Prim)) then @@ -15887,13 +15956,13 @@ package body Sem_Ch3 is end if; elsif Is_Dispatching_Operation (Prim) - and then D_Type /= Full_T + and then Disp_Typ /= Full_T then -- Verify that it is not otherwise controlled by a -- formal or a return value of type T. - Check_Controlling_Formals (D_Type, Prim); + Check_Controlling_Formals (Disp_Typ, Prim); end if; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 0116a83..04413a1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1306,6 +1306,17 @@ package body Sem_Ch6 is -- If pragma does not appear after the body, check whether there is -- an inline pragma before any local declarations. + function Disambiguate_Spec return Entity_Id; + -- When a primitive is declared between the private view and the full + -- view of a concurrent type which implements an interface, a special + -- mechanism is used to find the corresponding spec of the primitive + -- body. + + function Is_Private_Concurrent_Primitive + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a primitive of a concurrent + -- type that implements an interface and has a private view. + procedure Set_Trivial_Subprogram (N : Node_Id); -- Sets the Is_Trivial_Subprogram flag in both spec and body of the -- subprogram whose body is being analyzed. N is the statement node @@ -1457,6 +1468,128 @@ package body Sem_Ch6 is end if; end Check_Inline_Pragma; + ----------------------- + -- Disambiguate_Spec -- + ----------------------- + + function Disambiguate_Spec return Entity_Id is + Priv_Spec : Entity_Id; + Spec_N : Entity_Id; + + procedure Replace_Types (To_Corresponding : Boolean); + -- Depending on the flag, replace the type of formal parameters of + -- Body_Id if it is a concurrent type implementing interfaces with + -- the corresponding record type or the other way around. + + procedure Replace_Types (To_Corresponding : Boolean) is + Formal : Entity_Id; + Formal_Typ : Entity_Id; + + begin + Formal := First_Formal (Body_Id); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + -- From concurrent type to corresponding record + + if To_Corresponding then + if Is_Concurrent_Type (Formal_Typ) + and then Present (Corresponding_Record_Type (Formal_Typ)) + and then Present (Interfaces ( + Corresponding_Record_Type (Formal_Typ))) + then + Set_Etype (Formal, + Corresponding_Record_Type (Formal_Typ)); + end if; + + -- From corresponding record to concurrent type + + else + if Is_Concurrent_Record_Type (Formal_Typ) + and then Present (Interfaces (Formal_Typ)) + then + Set_Etype (Formal, + Corresponding_Concurrent_Type (Formal_Typ)); + end if; + end if; + + Next_Formal (Formal); + end loop; + end Replace_Types; + + -- Start of processing for Disambiguate_Spec + + begin + -- Try to retrieve the specification of the body as is. All error + -- messages are suppressed because the body may not have a spec in + -- its current state. + + Spec_N := Find_Corresponding_Spec (N, False); + + -- It is possible that this is the body of a primitive declared + -- between a private and a full view of a concurrent type. The + -- controlling parameter of the spec carries the concurrent type, + -- not the corresponding record type as transformed by Analyze_ + -- Subprogram_Specification. In such cases, we undo the change + -- made by the analysis of the specification and try to find the + -- spec again. + + if No (Spec_N) then + + -- Restore all references of corresponding record types to the + -- original concurrent types. + + Replace_Types (To_Corresponding => False); + Priv_Spec := Find_Corresponding_Spec (N, False); + + -- The current body truly belongs to a primitive declared between + -- a private and a full view. We leave the modified body as is, + -- and return the true spec. + + if Present (Priv_Spec) + and then Is_Private_Primitive (Priv_Spec) + then + return Priv_Spec; + end if; + + -- In case that this is some sort of error, restore the original + -- state of the body. + + Replace_Types (To_Corresponding => True); + end if; + + return Spec_N; + end Disambiguate_Spec; + + ------------------------------------- + -- Is_Private_Concurrent_Primitive -- + ------------------------------------- + + function Is_Private_Concurrent_Primitive + (Subp_Id : Entity_Id) return Boolean + is + Formal_Typ : Entity_Id; + + begin + if Present (First_Formal (Subp_Id)) then + Formal_Typ := Etype (First_Formal (Subp_Id)); + + if Is_Concurrent_Record_Type (Formal_Typ) then + Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ); + end if; + + -- The type of the first formal is a concurrent tagged type with + -- a private view. + + return + Is_Concurrent_Type (Formal_Typ) + and then Is_Tagged_Type (Formal_Typ) + and then Has_Private_Declaration (Formal_Typ); + end if; + + return False; + end Is_Private_Concurrent_Primitive; + ---------------------------- -- Set_Trivial_Subprogram -- ---------------------------- @@ -1581,7 +1714,11 @@ package body Sem_Ch6 is if Nkind (N) = N_Subprogram_Body_Stub or else No (Corresponding_Spec (N)) then - Spec_Id := Find_Corresponding_Spec (N); + if Is_Private_Concurrent_Primitive (Body_Id) then + Spec_Id := Disambiguate_Spec; + else + Spec_Id := Find_Corresponding_Spec (N); + end if; -- If this is a duplicate body, no point in analyzing it @@ -2322,6 +2459,22 @@ package body Sem_Ch6 is New_Overloaded_Entity (Designator); Check_Delayed_Subprogram (Designator); + -- If the type of the first formal of the current subprogram is a non + -- generic tagged private type , mark the subprogram as being a private + -- primitive. + + if Present (First_Formal (Designator)) then + declare + Formal_Typ : constant Entity_Id := + Etype (First_Formal (Designator)); + begin + Set_Is_Private_Primitive (Designator, + Is_Tagged_Type (Formal_Typ) + and then Is_Private_Type (Formal_Typ) + and then not Is_Generic_Actual_Type (Formal_Typ)); + end; + end if; + -- Ada 2005 (AI-251): Abstract interface primitives must be abstract -- or null. @@ -2435,8 +2588,6 @@ package body Sem_Ch6 is function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is Designator : constant Entity_Id := Defining_Entity (N); Formals : constant List_Id := Parameter_Specifications (N); - Formal : Entity_Id; - Formal_Typ : Entity_Id; -- Start of processing for Analyze_Subprogram_Specification @@ -2466,21 +2617,29 @@ package body Sem_Ch6 is -- record, to match the proper signature of an overriding operation. if Ada_Version >= Ada_05 then - Formal := First_Formal (Designator); - while Present (Formal) loop - Formal_Typ := Etype (Formal); + declare + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Rec_Typ : Entity_Id; - if Is_Concurrent_Type (Formal_Typ) - and then Present (Corresponding_Record_Type (Formal_Typ)) - and then Present (Interfaces - (Corresponding_Record_Type (Formal_Typ))) - then - Set_Etype (Formal, - Corresponding_Record_Type (Formal_Typ)); - end if; + begin + Formal := First_Formal (Designator); + while Present (Formal) loop + Formal_Typ := Etype (Formal); - Formal := Next_Formal (Formal); - end loop; + if Is_Concurrent_Type (Formal_Typ) + and then Present (Corresponding_Record_Type (Formal_Typ)) + then + Rec_Typ := Corresponding_Record_Type (Formal_Typ); + + if Present (Interfaces (Rec_Typ)) then + Set_Etype (Formal, Rec_Typ); + end if; + end if; + + Next_Formal (Formal); + end loop; + end; end if; End_Scope; @@ -5161,7 +5320,10 @@ package body Sem_Ch6 is -- Find_Corresponding_Spec -- ----------------------------- - function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is + function Find_Corresponding_Spec + (N : Node_Id; + Post_Error : Boolean := True) return Entity_Id + is Spec : constant Node_Id := Specification (N); Designator : constant Entity_Id := Defining_Entity (Spec); @@ -5205,7 +5367,6 @@ package body Sem_Ch6 is end if; if not Has_Completion (E) then - if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); end if; @@ -5250,14 +5411,15 @@ package body Sem_Ch6 is return Empty; end if; - -- If body already exists, this is an error unless the - -- previous declaration is the implicit declaration of - -- a derived subprogram, or this is a spurious overloading - -- in an instance. + -- If the body already exists, then this is an error unless + -- the previous declaration is the implicit declaration of a + -- derived subprogram, or this is a spurious overloading in an + -- instance. elsif No (Alias (E)) and then not Is_Intrinsic_Subprogram (E) and then not In_Instance + and then Post_Error then Error_Msg_Sloc := Sloc (E); if Is_Imported (E) then @@ -5269,16 +5431,17 @@ package body Sem_Ch6 is end if; end if; + -- Child units cannot be overloaded, so a conformance mismatch + -- between body and a previous spec is an error. + elsif Is_Child_Unit (E) and then Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body and then Nkind (Parent (Unit_Declaration_Node (Designator))) = - N_Compilation_Unit + N_Compilation_Unit + and then Post_Error then - -- Child units cannot be overloaded, so a conformance mismatch - -- between body and a previous spec is an error. - Error_Msg_N ("body of child unit does not match previous declaration", N); end if; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 689ac8b..e54c1e1 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -136,8 +136,8 @@ package Sem_Ch6 is Get_Inst : Boolean := False) return Boolean; -- Check that the types of two formal parameters are conforming. In most -- cases this is just a name comparison, but within an instance it involves - -- generic actual types, and in the presence of anonymous access types - -- it must examine the designated types. + -- generic actual types, and in the presence of anonymous access types it + -- must examine the designated types. procedure Create_Extra_Formals (E : Entity_Id); -- For each parameter of a subprogram or entry that requires an additional @@ -147,7 +147,9 @@ package Sem_Ch6 is -- the end of Subp's parameter list (with each subsequent extra formal -- being attached to the preceding extra formal). - function Find_Corresponding_Spec (N : Node_Id) return Entity_Id; + function Find_Corresponding_Spec + (N : Node_Id; + Post_Error : Boolean := True) return Entity_Id; -- Use the subprogram specification in the body to retrieve the previous -- subprogram declaration, if any. -- 2.7.4