From: Arnaud Charlet Date: Tue, 24 Mar 2020 08:40:18 +0000 (-0400) Subject: [Ada] Fix handling of subprograms declared in a protected body X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=842d28d2acba14a4ebe53f80a35bf1096a1c223e;p=gcc.git [Ada] Fix handling of subprograms declared in a protected body 2020-06-12 Arnaud Charlet gcc/ada/ * exp_ch6.adb (Expand_N_Subprogram_Declaration): Do nothing for a subprogram declared in a protected body. * exp_ch9.ads, exp_ch9.adb (Build_Private_Protected_Declaration): Moved to sem_ch6.adb. (Expand_N_Protected_Body): Do nothing for a subprogram declared in a protected body. * sem_ch6.adb (Build_Internal_Protected_Declaration): Moved from exp_ch9.adb and renamed and fixed to ensure in particular that such subprograms have convention Intrinsic and have no protected version. (Analyze_Subprogram_Body_Helper): Call Build_Internal_Protected_Declaration. (Move_Pragmas): Moved up and merged with the more general version from Build_Private_Protected_Declaration. We only want to copy selected pragmas, most pragmas are not suitable for a copy on the spec. --- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 11b6983c030..f4369336e2c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6346,19 +6346,6 @@ package body Exp_Ch6 is Analyze (Prot_Decl); Freeze_Before (N, Prot_Id); Set_Protected_Body_Subprogram (Subp, Prot_Id); - - -- Create protected operation as well. Even though the operation - -- is only accessible within the body, it is possible to make it - -- available outside of the protected object by using 'Access to - -- provide a callback, so build protected version in all cases. - - Prot_Decl := - Make_Subprogram_Declaration (Loc, - Specification => - Build_Protected_Sub_Specification (N, Scop, Protected_Mode)); - Insert_Before (Prot_Bod, Prot_Decl); - Analyze (Prot_Decl); - Pop_Scope; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 8d4bf233cf1..83717115ee8 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; @@ -56,7 +55,6 @@ with Sem_Ch11; use Sem_Ch11; with Sem_Ch13; use Sem_Ch13; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; -with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -3491,177 +3489,6 @@ package body Exp_Ch9 is Set_Master_Id (Ptr_Typ, Master_Id); end Build_Master_Renaming; - ----------------------------------------- - -- Build_Private_Protected_Declaration -- - ----------------------------------------- - - function Build_Private_Protected_Declaration - (N : Node_Id) return Entity_Id - is - procedure Analyze_Pragmas (From : Node_Id); - -- Analyze all pragmas which follow arbitrary node From - - procedure Move_Pragmas (From : Node_Id; To : Node_Id); - -- Find all suitable source pragmas at the top of subprogram body From's - -- declarations and insert them after arbitrary node To. - -- - -- Very similar to Move_Pragmas in sem_ch6 ??? - - --------------------- - -- Analyze_Pragmas -- - --------------------- - - procedure Analyze_Pragmas (From : Node_Id) is - Decl : Node_Id; - - begin - Decl := Next (From); - while Present (Decl) loop - if Nkind (Decl) = N_Pragma then - Analyze_Pragma (Decl); - - -- No candidate pragmas are available for analysis - - else - exit; - end if; - - Next (Decl); - end loop; - end Analyze_Pragmas; - - ------------------ - -- Move_Pragmas -- - ------------------ - - procedure Move_Pragmas (From : Node_Id; To : Node_Id) is - Decl : Node_Id; - Insert_Nod : Node_Id; - Next_Decl : Node_Id; - - begin - pragma Assert (Nkind (From) = N_Subprogram_Body); - - -- The pragmas are moved in an order-preserving fashion - - Insert_Nod := To; - - -- Inspect the declarations of the subprogram body and relocate all - -- candidate pragmas. - - Decl := First (Declarations (From)); - while Present (Decl) loop - - -- Preserve the following declaration for iteration purposes, due - -- to possible relocation of a pragma. - - Next_Decl := Next (Decl); - - -- We add an exception here for Unreferenced pragmas since the - -- internally generated spec gets analyzed within - -- Build_Private_Protected_Declaration and will lead to spurious - -- warnings due to the way references are checked. - - if Nkind (Decl) = N_Pragma - and then Pragma_Name_Unmapped (Decl) /= Name_Unreferenced - then - Remove (Decl); - Insert_After (Insert_Nod, Decl); - Insert_Nod := Decl; - - -- Skip internally generated code - - elsif not Comes_From_Source (Decl) then - null; - - -- No candidate pragmas are available for relocation - - else - exit; - end if; - - Decl := Next_Decl; - end loop; - end Move_Pragmas; - - -- Local variables - - Body_Id : constant Entity_Id := Defining_Entity (N); - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; - Formal : Entity_Id; - Formals : List_Id; - Spec : Node_Id; - Spec_Id : Entity_Id; - - -- Start of processing for Build_Private_Protected_Declaration - - begin - Formal := First_Formal (Body_Id); - - -- The protected operation always has at least one formal, namely the - -- object itself, but it is only placed in the parameter list if - -- expansion is enabled. - - if Present (Formal) or else Expander_Active then - Formals := Copy_Parameter_List (Body_Id); - else - Formals := No_List; - end if; - - Spec_Id := - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)); - - -- Indicate that the entity comes from source, to ensure that cross- - -- reference information is properly generated. The body itself is - -- rewritten during expansion, and the body entity will not appear in - -- calls to the operation. - - Set_Comes_From_Source (Spec_Id, True); - - if Nkind (Specification (N)) = N_Procedure_Specification then - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Spec_Id, - Parameter_Specifications => Formals); - else - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => Spec_Id, - Parameter_Specifications => Formals, - Result_Definition => - New_Occurrence_Of (Etype (Body_Id), Loc)); - end if; - - Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); - Set_Corresponding_Body (Decl, Body_Id); - Set_Corresponding_Spec (N, Spec_Id); - - Insert_Before (N, Decl); - - -- Associate all aspects and pragmas of the body with the spec. This - -- ensures that these annotations apply to the initial declaration of - -- the subprogram body. - - Move_Aspects (From => N, To => Decl); - Move_Pragmas (From => N, To => Decl); - - Analyze (Decl); - - -- The analysis of the spec may generate pragmas which require manual - -- analysis. Since the generation of the spec and the relocation of the - -- annotations is driven by the expansion of the stand-alone body, the - -- pragmas will not be analyzed in a timely manner. Do this now. - - Analyze_Pragmas (Decl); - - Set_Convention (Spec_Id, Convention_Protected); - Set_Has_Completion (Spec_Id); - - return Spec_Id; - end Build_Private_Protected_Declaration; - --------------------------- -- Build_Protected_Entry -- --------------------------- @@ -8630,6 +8457,7 @@ package body Exp_Ch9 is Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; Op_Body : Node_Id; + Op_Decl : Node_Id; Op_Id : Entity_Id; function Build_Dispatching_Subprogram_Body @@ -8766,51 +8594,46 @@ package body Exp_Ch9 is Current_Node := New_Op_Body; Analyze (New_Op_Body); - -- Build the corresponding protected operation. It may - -- appear that this is needed only if this is a visible - -- operation of the type, or if it is an interrupt handler, - -- and this was the strategy used previously in GNAT. - - -- However, the operation may be exported through a 'Access - -- to an external caller. This is the common idiom in code - -- that uses the Ada 2005 Timing_Events package. As a result - -- we need to produce the protected body for both visible - -- and private operations, as well as operations that only - -- have a body in the source, and for which we create a - -- declaration in the protected body itself. + -- Build the corresponding protected operation. This is + -- needed only if this is a public or private operation of + -- the type. if Present (Corresponding_Spec (Op_Body)) then - if Lock_Free_Active then - New_Op_Body := - Build_Lock_Free_Protected_Subprogram_Body - (Op_Body, Pid, Specification (New_Op_Body)); - else - New_Op_Body := - Build_Protected_Subprogram_Body - (Op_Body, Pid, Specification (New_Op_Body)); - end if; - - Insert_After (Current_Node, New_Op_Body); - Analyze (New_Op_Body); - - Current_Node := New_Op_Body; - - -- Generate an overriding primitive operation body for - -- this subprogram if the protected type implements an - -- interface. - - if Ada_Version >= Ada_2005 - and then - Present (Interfaces (Corresponding_Record_Type (Pid))) - then - Disp_Op_Body := - Build_Dispatching_Subprogram_Body - (Op_Body, Pid, New_Op_Body); - - Insert_After (Current_Node, Disp_Op_Body); - Analyze (Disp_Op_Body); - - Current_Node := Disp_Op_Body; + Op_Decl := + Unit_Declaration_Node (Corresponding_Spec (Op_Body)); + + if Nkind (Parent (Op_Decl)) = N_Protected_Definition then + if Lock_Free_Active then + New_Op_Body := + Build_Lock_Free_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + else + New_Op_Body := + Build_Protected_Subprogram_Body ( + Op_Body, Pid, Specification (New_Op_Body)); + end if; + + Insert_After (Current_Node, New_Op_Body); + Analyze (New_Op_Body); + Current_Node := New_Op_Body; + + -- Generate an overriding primitive operation body for + -- this subprogram if the protected type implements + -- an interface. + + if Ada_Version >= Ada_2005 + and then Present (Interfaces ( + Corresponding_Record_Type (Pid))) + then + Disp_Op_Body := + Build_Dispatching_Subprogram_Body ( + Op_Body, Pid, New_Op_Body); + + Insert_After (Current_Node, Disp_Op_Body); + Analyze (Disp_Op_Body); + + Current_Node := Disp_Op_Body; + end if; end if; end if; end if; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 0867d4a07db..5ba5b9fdd07 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -72,17 +72,6 @@ package Exp_Ch9 is -- where _master denotes the task master of the enclosing context. Ins_Nod -- is used to provide a specific insertion node for the renaming. - function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id; - -- A subprogram body without a previous spec that appears in a protected - -- body must be expanded separately to create a subprogram declaration - -- for it, in order to resolve internal calls to it from other protected - -- operations. It would seem that no locking version of the operation is - -- needed, but in fact, in Ada 2005 the subprogram may be used in a call- - -- back, and therefore a protected version of the operation must be - -- generated as well. - -- - -- Possibly factor this with Exp_Dist.Copy_Specification ??? - function Build_Protected_Sub_Specification (N : Node_Id; Prot_Typ : Entity_Id; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5062f57b7ea..51724ff0ea3 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2504,6 +2504,15 @@ package body Sem_Ch6 is -- because it is specified directly on the body, or because it is -- inherited from the enclosing subprogram or package. + function Build_Internal_Protected_Declaration + (N : Node_Id) return Entity_Id; + -- A subprogram body without a previous spec that appears in a protected + -- body must be expanded separately to create a subprogram declaration + -- for it, in order to resolve internal calls to it from other protected + -- operations. + -- + -- Possibly factor this with Exp_Dist.Copy_Specification ??? + procedure Build_Subprogram_Declaration; -- Create a matching subprogram declaration for subprogram body N @@ -2552,6 +2561,12 @@ package body Sem_Ch6 is -- the not-yet-frozen types referenced by the simple return statement -- of the function as formally frozen. + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Find all suitable source pragmas at the top of subprogram body + -- From's declarations and move them after arbitrary node To. + -- One exception is pragma SPARK_Mode which is copied rather than moved, + -- as it applies to the body too. + procedure Restore_Limited_Views (Restore_List : Elist_Id); -- Undo the transformation done by Exchange_Limited_Views. @@ -2664,68 +2679,129 @@ package body Sem_Ch6 is return SPARK_Mode = On; end Body_Has_SPARK_Mode_On; - ---------------------------------- - -- Build_Subprogram_Declaration -- - ---------------------------------- + ------------------------------------------ + -- Build_Internal_Protected_Declaration -- + ------------------------------------------ - procedure Build_Subprogram_Declaration is - procedure Move_Pragmas (From : Node_Id; To : Node_Id); - -- Relocate certain categorization pragmas from the declarative list - -- of subprogram body From and insert them after node To. The pragmas - -- in question are: - -- Ghost - -- Volatile_Function - -- Also copy pragma SPARK_Mode if present in the declarative list - -- of subprogram body From and insert it after node To. This pragma - -- should not be moved, as it applies to the body too. + function Build_Internal_Protected_Declaration + (N : Node_Id) return Entity_Id + is + procedure Analyze_Pragmas (From : Node_Id); + -- Analyze all pragmas which follow arbitrary node From - ------------------ - -- Move_Pragmas -- - ------------------ + --------------------- + -- Analyze_Pragmas -- + --------------------- - procedure Move_Pragmas (From : Node_Id; To : Node_Id) is - Decl : Node_Id; - Next_Decl : Node_Id; + procedure Analyze_Pragmas (From : Node_Id) is + Decl : Node_Id; begin - pragma Assert (Nkind (From) = N_Subprogram_Body); - - -- The destination node must be part of a list, as the pragmas are - -- inserted after it. - - pragma Assert (Is_List_Member (To)); - - -- Inspect the declarations of the subprogram body looking for - -- specific pragmas. - - Decl := First (Declarations (N)); + Decl := Next (From); while Present (Decl) loop - Next_Decl := Next (Decl); - if Nkind (Decl) = N_Pragma then - if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then - Insert_After (To, New_Copy_Tree (Decl)); + Analyze_Pragma (Decl); - elsif Nam_In (Pragma_Name_Unmapped (Decl), - Name_Ghost, - Name_Volatile_Function) - then - Remove (Decl); - Insert_After (To, Decl); - end if; + -- No candidate pragmas are available for analysis + + else + exit; end if; - Decl := Next_Decl; + Next (Decl); end loop; - end Move_Pragmas; + end Analyze_Pragmas; -- Local variables + Body_Id : constant Entity_Id := Defining_Entity (N); + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Formal : Entity_Id; + Formals : List_Id; + Spec : Node_Id; + Spec_Id : Entity_Id; + + -- Start of processing for Build_Internal_Protected_Declaration + + begin + Formal := First_Formal (Body_Id); + + -- The protected operation always has at least one formal, namely the + -- object itself, but it is only placed in the parameter list if + -- expansion is enabled. + + if Present (Formal) or else Expander_Active then + Formals := Copy_Parameter_List (Body_Id); + else + Formals := No_List; + end if; + + Spec_Id := + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)); + + -- Indicate that the entity comes from source, to ensure that cross- + -- reference information is properly generated. The body itself is + -- rewritten during expansion, and the body entity will not appear in + -- calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + + if Nkind (Specification (N)) = N_Procedure_Specification then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals, + Result_Definition => + New_Occurrence_Of (Etype (Body_Id), Loc)); + end if; + + Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); + Set_Corresponding_Body (Decl, Body_Id); + Set_Corresponding_Spec (N, Spec_Id); + + Insert_Before (N, Decl); + + -- Associate all aspects and pragmas of the body with the spec. This + -- ensures that these annotations apply to the initial declaration of + -- the subprogram body. + + Move_Aspects (From => N, To => Decl); + Move_Pragmas (From => N, To => Decl); + + Analyze (Decl); + + -- The analysis of the spec may generate pragmas which require manual + -- analysis. Since the generation of the spec and the relocation of + -- the annotations is driven by the expansion of the stand-alone + -- body, the pragmas will not be analyzed in a timely manner. Do this + -- now. + + Analyze_Pragmas (Decl); + + -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2) + -- ensuring in particular that 'Access is illegal. + + Set_Convention (Spec_Id, Convention_Intrinsic); + Set_Has_Completion (Spec_Id); + + return Spec_Id; + end Build_Internal_Protected_Declaration; + + ---------------------------------- + -- Build_Subprogram_Declaration -- + ---------------------------------- + + procedure Build_Subprogram_Declaration is Decl : Node_Id; Subp_Decl : Node_Id; - -- Start of processing for Build_Subprogram_Declaration - begin -- Create a matching subprogram spec using the profile of the body. -- The structure of the tree is identical, but has new entities for @@ -3376,6 +3452,77 @@ package body Sem_Ch6 is return Result; end Mask_Unfrozen_Types; + ------------------ + -- Move_Pragmas -- + ------------------ + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Insert_Nod : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The pragmas are moved in an order-preserving fashion + + Insert_Nod := To; + + -- Inspect the declarations of the subprogram body and relocate all + -- candidate pragmas. + + Decl := First (Declarations (From)); + while Present (Decl) loop + + -- Preserve the following declaration for iteration purposes, due + -- to possible relocation of a pragma. + + Next_Decl := Next (Decl); + + if Nkind (Decl) = N_Pragma then + -- Copy pragma SPARK_Mode if present in the declarative list + -- of subprogram body From and insert it after node To. This + -- pragma should not be moved, as it applies to the body too. + + if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then + Insert_After (Insert_Nod, New_Copy_Tree (Decl)); + + -- Move relevant pragmas to the spec + + elsif Nam_In (Pragma_Name_Unmapped (Decl), + Name_Depends, + Name_Ghost, + Name_Global, + Name_Pre, + Name_Precondition, + Name_Post, + Name_Refined_Depends, + Name_Refined_Global, + Name_Refined_Post, + Name_Inline, + Name_Pure_Function, + Name_Volatile_Function) + then + Remove (Decl); + Insert_After (Insert_Nod, Decl); + Insert_Nod := Decl; + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- No candidate pragmas are available for relocation + + else + exit; + end if; + + Decl := Next_Decl; + end loop; + end Move_Pragmas; + --------------------------- -- Restore_Limited_Views -- --------------------------- @@ -3668,6 +3815,8 @@ package body Sem_Ch6 is -- are legal and can be processed ahead of the body. -- We make two copies of the given spec, one for the new -- declaration, and one for the body. + -- ??? This should be conditioned on front-end inlining rather + -- than GNATprove_Mode. if No (Spec_Id) and then GNATprove_Mode @@ -3708,7 +3857,7 @@ package body Sem_Ch6 is Build_Subprogram_Declaration; -- If this is a function that returns a constrained array, and - -- we are generating SPARK_For_C, create subprogram declaration + -- we are generating C code, create subprogram declaration -- to simplify subsequent C generation. elsif No (Spec_Id) @@ -3795,15 +3944,15 @@ package body Sem_Ch6 is -- Deal with special case of a fully private operation in the body of -- the protected type. We must create a declaration for the subprogram, - -- in order to attach the protected subprogram that will be used in - -- internal calls. We exclude compiler generated bodies from the - -- expander since the issue does not arise for those cases. + -- in order to attach the subprogram that will be used in internal + -- calls. We exclude compiler generated bodies from the expander since + -- the issue does not arise for those cases. if No (Spec_Id) and then Comes_From_Source (N) and then Is_Protected_Type (Current_Scope) then - Spec_Id := Build_Private_Protected_Declaration (N); + Spec_Id := Build_Internal_Protected_Declaration (N); end if; -- If we are generating C and this is a function returning a constrained