From 4039e17351e557c4f9cb781d36e4247572ce3232 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 26 Oct 2015 16:44:32 +0100 Subject: [PATCH] [multiple changes] 2015-10-26 Hristian Kirtchev * sem_prag.adb (Add_Item_To_Name_Buffer): Update the comment on usage. Add an output string for loop parameters. (Analyze_Global_Items): Loop parameters are now a valid global item. The share the legality checks of constants. (Analyze_Input_Output): Loop parameters are now a valid dependency item. (Find_Role): Loop parameters share the role of constants. 2015-10-26 Ed Schonberg * sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, preserve the Generalized_ indexing link if the context is not a spec expression that will be analyzed anew. 2015-10-26 Javier Miranda * exp_ch6.ads, exp_ch6.adb (Build_Procedure_Body_Form): Promote it to library level (to invoke this routine from the semantic analyzer). * sem_ch6.adb (Analyze_Subprogram_Body_Helper): When generating C code, invoke Build_Procedure_Body_Form to transform a function that returns a constrained array type into a procedure with an out parameter that carries the return value. 2015-10-26 Arnaud Charlet * a-reatim.ads: Add "Clock_Time with Synchronous" contract in package Ada.Real_Time. * a-taside.ads: Add "Tasking_State with Synchronous" contract in package Ada.Task_Identification. * sem_ch12.adb: minor typo in comment From-SVN: r229377 --- gcc/ada/ChangeLog | 32 ++++++ gcc/ada/a-reatim.ads | 3 +- gcc/ada/a-taside.ads | 5 +- gcc/ada/exp_ch6.adb | 261 +++++++++++++++++++++---------------------- gcc/ada/exp_ch6.ads | 7 ++ gcc/ada/sem_ch12.adb | 2 +- gcc/ada/sem_ch6.adb | 28 ++++- gcc/ada/sem_prag.adb | 86 +++++++++----- gcc/ada/sem_res.adb | 10 +- 9 files changed, 264 insertions(+), 170 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7cafbd88c89..ce4195eac36 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2015-10-26 Hristian Kirtchev + + * sem_prag.adb (Add_Item_To_Name_Buffer): Update the comment on usage. + Add an output string for loop parameters. + (Analyze_Global_Items): Loop parameters are now a + valid global item. The share the legality checks of constants. + (Analyze_Input_Output): Loop parameters are now a valid dependency item. + (Find_Role): Loop parameters share the role of constants. + +2015-10-26 Ed Schonberg + + * sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, + preserve the Generalized_ indexing link if the context is not + a spec expression that will be analyzed anew. + +2015-10-26 Javier Miranda + + * exp_ch6.ads, exp_ch6.adb (Build_Procedure_Body_Form): Promote it to + library level (to invoke this routine from the semantic analyzer). + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): When generating + C code, invoke Build_Procedure_Body_Form to transform a function + that returns a constrained array type into a procedure with an + out parameter that carries the return value. + +2015-10-26 Arnaud Charlet + + * a-reatim.ads: Add "Clock_Time with Synchronous" contract in package + Ada.Real_Time. + * a-taside.ads: Add "Tasking_State with Synchronous" contract in + package Ada.Task_Identification. + * sem_ch12.adb: minor typo in comment + 2015-10-26 Hristian Kirtchev * contracts.adb (Analyze_Object_Contract): Set and restore diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads index 98d97156a02..8b341c0b58d 100644 --- a/gcc/ada/a-reatim.ads +++ b/gcc/ada/a-reatim.ads @@ -38,7 +38,8 @@ pragma Elaborate_All (System.Task_Primitives.Operations); package Ada.Real_Time with SPARK_Mode, - Abstract_State => (Clock_Time with External => (Async_Readers, + Abstract_State => (Clock_Time with Synchronous, + External => (Async_Readers, Async_Writers)) is diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads index 353475ea146..ee39ec3e5a9 100644 --- a/gcc/ada/a-taside.ads +++ b/gcc/ada/a-taside.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -38,7 +38,8 @@ with System.Tasking; package Ada.Task_Identification with SPARK_Mode, - Abstract_State => (Tasking_State with External => (Async_Readers, + Abstract_State => (Tasking_State with Synchronous, + External => (Async_Readers, Async_Writers)) is pragma Preelaborate; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f95841e9f68..fb919248a8b 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -674,6 +674,131 @@ package body Exp_Ch6 is return Extra_Formal; end Build_In_Place_Formal; + ------------------------------- + -- Build_Procedure_Body_Form -- + ------------------------------- + + function Build_Procedure_Body_Form + (Func_Id : Entity_Id; + Func_Body : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Func_Body); + + Proc_Decl : constant Node_Id := + Next (Unit_Declaration_Node (Func_Id)); + -- It is assumed that the next node following the declaration of the + -- corresponding subprogram spec is the declaration of the procedure + -- form. + + Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl); + + procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id); + -- Replace each return statement found in the list Stmts with an + -- assignment of the return expression to parameter Param_Id. + + --------------------- + -- Replace_Returns -- + --------------------- + + procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is + Stmt : Node_Id; + + begin + Stmt := First (Stmts); + while Present (Stmt) loop + if Nkind (Stmt) = N_Block_Statement then + Replace_Returns (Param_Id, Statements (Stmt)); + + elsif Nkind (Stmt) = N_Case_Statement then + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (Stmt)); + while Present (Alt) loop + Replace_Returns (Param_Id, Statements (Alt)); + Next (Alt); + end loop; + end; + + elsif Nkind (Stmt) = N_If_Statement then + Replace_Returns (Param_Id, Then_Statements (Stmt)); + Replace_Returns (Param_Id, Else_Statements (Stmt)); + + declare + Part : Node_Id; + begin + Part := First (Elsif_Parts (Stmt)); + while Present (Part) loop + Replace_Returns (Part, Then_Statements (Part)); + Next (Part); + end loop; + end; + + elsif Nkind (Stmt) = N_Loop_Statement then + Replace_Returns (Param_Id, Statements (Stmt)); + + elsif Nkind (Stmt) = N_Simple_Return_Statement then + + -- Generate: + -- Param := Expr; + -- return; + + Rewrite (Stmt, + Make_Assignment_Statement (Sloc (Stmt), + Name => New_Occurrence_Of (Param_Id, Loc), + Expression => Relocate_Node (Expression (Stmt)))); + + Insert_After (Stmt, Make_Simple_Return_Statement (Loc)); + + -- Skip the added return + + Next (Stmt); + end if; + + Next (Stmt); + end loop; + end Replace_Returns; + + -- Local variables + + Stmts : List_Id; + New_Body : Node_Id; + + -- Start of processing for Build_Procedure_Body_Form + + begin + -- This routine replaces the original function body: + + -- function F (...) return Array_Typ is + -- begin + -- ... + -- return Something; + -- end F; + + -- with the following: + + -- procedure P (..., Result : out Array_Typ) is + -- begin + -- ... + -- Result := Something; + -- end P; + + Stmts := + Statements (Handled_Statement_Sequence (Func_Body)); + Replace_Returns (Last_Entity (Proc_Id), Stmts); + + New_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Specification (Proc_Decl)), + Declarations => Declarations (Func_Body), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + return New_Body; + end Build_Procedure_Body_Form; + -------------------------------- -- Check_Overriding_Operation -- -------------------------------- @@ -4959,11 +5084,6 @@ package body Exp_Ch6 is -- returns, since they get eliminated anyway later on. Spec_Id denotes -- the corresponding spec of the subprogram body. - procedure Build_Procedure_Body_Form (Func_Id : Entity_Id); - -- Create a procedure body which emulates the behavior of function - -- Func_Id. This body replaces the original function body, which is - -- not needed for the C program. - ---------------- -- Add_Return -- ---------------- @@ -5036,125 +5156,7 @@ package body Exp_Ch6 is end if; end Add_Return; - ------------------------------- - -- Build_Procedure_Body_Form -- - ------------------------------- - - procedure Build_Procedure_Body_Form (Func_Id : Entity_Id) is - Proc_Decl : constant Node_Id := - Next (Unit_Declaration_Node (Func_Id)); - -- It is assumed that the next node following the declaration of the - -- corresponding subprogram spec is the declaration of the procedure - -- form. - - Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl); - - procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id); - -- Replace each return statement found in the list Stmts with an - -- assignment of the return expression to parameter Param_Id. - - --------------------- - -- Replace_Returns -- - --------------------- - - procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is - Stmt : Node_Id; - - begin - Stmt := First (Stmts); - while Present (Stmt) loop - if Nkind (Stmt) = N_Block_Statement then - Replace_Returns (Param_Id, Statements (Stmt)); - - elsif Nkind (Stmt) = N_Case_Statement then - declare - Alt : Node_Id; - begin - Alt := First (Alternatives (Stmt)); - while Present (Alt) loop - Replace_Returns (Param_Id, Statements (Alt)); - Next (Alt); - end loop; - end; - - elsif Nkind (Stmt) = N_If_Statement then - Replace_Returns (Param_Id, Then_Statements (Stmt)); - Replace_Returns (Param_Id, Else_Statements (Stmt)); - - declare - Part : Node_Id; - begin - Part := First (Elsif_Parts (Stmt)); - while Present (Part) loop - Replace_Returns (Part, Then_Statements (Part)); - Next (Part); - end loop; - end; - - elsif Nkind (Stmt) = N_Loop_Statement then - Replace_Returns (Param_Id, Statements (Stmt)); - - elsif Nkind (Stmt) = N_Simple_Return_Statement then - - -- Generate: - -- Param := Expr; - -- return; - - Rewrite (Stmt, - Make_Assignment_Statement (Sloc (Stmt), - Name => New_Occurrence_Of (Param_Id, Loc), - Expression => Relocate_Node (Expression (Stmt)))); - - Insert_After (Stmt, Make_Simple_Return_Statement (Loc)); - - -- Skip the added return - - Next (Stmt); - end if; - - Next (Stmt); - end loop; - end Replace_Returns; - - -- Local variables - - Stmts : List_Id; - - -- Start of processing for Build_Procedure_Body_Form - - begin - -- This routine replaces the original function body: - - -- function F (...) return Array_Typ is - -- begin - -- ... - -- return Something; - -- end F; - - -- with the following: - - -- procedure P (..., Result : out Array_Typ) is - -- begin - -- ... - -- Result := Something; - -- end P; - - Stmts := Statements (HSS); - Replace_Returns (Last_Entity (Proc_Id), Stmts); - - Replace (N, - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Specification (Proc_Decl)), - Declarations => Declarations (N), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts))); - - Analyze (N); - end Build_Procedure_Body_Form; - - -- Local varaibles + -- Local variables Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; @@ -5452,17 +5454,6 @@ package body Exp_Ch6 is Unest_Bodies.Append ((Spec_Id, N)); end if; - -- When generating C code, transform a function that returns a - -- constrained array type into a procedure with an out parameter - -- that carries the return value. - - if Modify_Tree_For_C - and then Ekind (Spec_Id) = E_Function - and then Rewritten_For_C (Spec_Id) - then - Build_Procedure_Body_Form (Spec_Id); - end if; - Ghost_Mode := Save_Ghost_Mode; end Expand_N_Subprogram_Body; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 2184d5863ab..7ae19de6377 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -110,6 +110,13 @@ package Exp_Ch6 is -- function Func, and returns its Entity_Id. It is a bug if not found; the -- caller should ensure this is called only when the extra formal exists. + function Build_Procedure_Body_Form + (Func_Id : Entity_Id; Func_Body : Node_Id) return Node_Id; + -- Create a procedure body which emulates the behavior of function Func_Id. + -- Func_Body is the root of the body of the function before its analysis. + -- The returned node is the root of the procedure body which will replace + -- the original function body, which is not needed for the C program. + procedure Initialize; -- Initialize internal tables diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e7d076ae6bb..eece74ff3d9 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3569,7 +3569,7 @@ package body Sem_Ch12 is begin Check_SPARK_05_Restriction ("generic is not allowed", N); - -- Very first thing: check for Text_IO sp[ecial unit in case we are + -- Very first thing: check for Text_IO special unit in case we are -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Check_Text_IO_Special_Unit (Name (N)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index f6ecdcf5790..519d7caffb2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3003,7 +3003,8 @@ package body Sem_Ch6 is -- Local variables - Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Cloned_Body_For_C : Node_Id := Empty; -- Start of processing for Analyze_Subprogram_Body_Helper @@ -3584,6 +3585,21 @@ package body Sem_Ch6 is return; end if; + -- If we are generating C and this is a function returning a constrained + -- array type for which we must create a procedure with an extra out + -- parameter then clone the body before it is analyzed. Needed to ensure + -- that the body of the built procedure does not have any reference to + -- the body of the function. + + if Expander_Active + and then Modify_Tree_For_C + and then Present (Spec_Id) + and then Ekind (Spec_Id) = E_Function + and then Rewritten_For_C (Spec_Id) + then + Cloned_Body_For_C := Copy_Separate_Tree (N); + end if; + -- Handle frontend inlining -- Note: Normally we don't do any inlining if expansion is off, since @@ -4041,6 +4057,16 @@ package body Sem_Ch6 is end if; end; + -- When generating C code, transform a function that returns a + -- constrained array type into a procedure with an out parameter + -- that carries the return value. + + if Present (Cloned_Body_For_C) then + Replace (N, + Build_Procedure_Body_Form (Spec_Id, Cloned_Body_For_C)); + Analyze (N); + end if; + Ghost_Mode := Save_Ghost_Mode; end Analyze_Subprogram_Body_Helper; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 17544f0cb81..96f508f641e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -530,6 +530,7 @@ package body Sem_Prag is -- E_Generic_Out_Parameter - "generic parameter" -- E_In_Parameter - "parameter" -- E_In_Out_Parameter - "parameter" + -- E_Loop_Parameter - "loop parameter" -- E_Out_Parameter - "parameter" -- E_Protected_Type - "current instance of protected type" -- E_Task_Type - "current instance of task type" @@ -590,6 +591,9 @@ package body Sem_Prag is elsif Is_Formal (Item_Id) then Add_Str_To_Name_Buffer ("parameter"); + elsif Ekind (Item_Id) = E_Loop_Parameter then + Add_Str_To_Name_Buffer ("loop parameter"); + elsif Ekind (Item_Id) = E_Protected_Type then Add_Str_To_Name_Buffer ("current instance of protected type"); @@ -826,17 +830,31 @@ package body Sem_Prag is Item_Id := Entity_Of (Item); if Present (Item_Id) then - if Ekind_In (Item_Id, E_Abstract_State, - E_Constant, + + -- Constants + + if Ekind_In (Item_Id, E_Constant, E_Discriminant, - E_Generic_In_Out_Parameter, - E_Generic_In_Parameter, - E_In_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Protected_Type, - E_Task_Type, - E_Variable) + E_Loop_Parameter) + or else + + -- Current instances of concurrent types + + Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) + or else + + -- Formal parameters + + Ekind_In (Item_Id, E_Generic_In_Out_Parameter, + E_Generic_In_Parameter, + E_In_Parameter, + E_In_Out_Parameter, + E_Out_Parameter) + or else + + -- States, variables + + Ekind_In (Item_Id, E_Abstract_State, E_Variable) then -- The item denotes a concurrent type, but it is not the -- current instance of an enclosing concurrent type. @@ -1063,7 +1081,7 @@ package body Sem_Prag is Item_Is_Input := False; Item_Is_Output := False; - -- Abstract state cases + -- Abstract states if Ekind (Item_Id) = E_Abstract_State then @@ -1086,29 +1104,24 @@ package body Sem_Prag is Item_Is_Output := True; end if; - -- Constant case - - elsif Ekind (Item_Id) = E_Constant then - Item_Is_Input := True; - - elsif Ekind (Item_Id) = E_Discriminant then - Item_Is_Input := True; - - -- Generic parameter cases + -- Constants - elsif Ekind (Item_Id) = E_Generic_In_Parameter then + elsif Ekind_In (Item_Id, E_Constant, + E_Discriminant, + E_Loop_Parameter) + then Item_Is_Input := True; - elsif Ekind (Item_Id) = E_Generic_In_Out_Parameter then - Item_Is_Input := True; - Item_Is_Output := True; - - -- Parameter cases + -- Parameters - elsif Ekind (Item_Id) = E_In_Parameter then + elsif Ekind_In (Item_Id, E_Generic_In_Parameter, + E_In_Parameter) + then Item_Is_Input := True; - elsif Ekind (Item_Id) = E_In_Out_Parameter then + elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, + E_In_Out_Parameter) + then Item_Is_Input := True; Item_Is_Output := True; @@ -2021,11 +2034,12 @@ package body Sem_Prag is null; -- The only legal references are those to abstract states, - -- discriminants and objects (SPARK RM 6.1.4(4)). + -- objects and various kinds of constants (SPARK RM 6.1.4(4)). elsif not Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Discriminant, + E_Loop_Parameter, E_Variable) then SPARK_Msg_N @@ -2108,6 +2122,20 @@ package body Sem_Prag is return; end if; + -- Loop parameter related checks + + elsif Ekind (Item_Id) = E_Loop_Parameter then + + -- A loop parameter is a read-only item, therefore it cannot + -- act as an output. + + if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + SPARK_Msg_NE + ("loop parameter & cannot act as output", + Item, Item_Id); + return; + end if; + -- Variable related checks. These are only relevant when -- SPARK_Mode is on as they are not standard Ada legality -- rules. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index d3312e2d84c..689e1cbca16 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8174,7 +8174,15 @@ package body Sem_Res is Indexes := Parameter_Associations (Call); Pref := Remove_Head (Indexes); Set_Expressions (N, Indexes); - Set_Generalized_Indexing (N, Empty); + + -- If expression is to be reanalyzed, reset Generalized_Indexing + -- to recreate call node, as is the case when the expression is + -- part of an expression function. + + if In_Spec_Expression then + Set_Generalized_Indexing (N, Empty); + end if; + Set_Prefix (N, Pref); end if; -- 2.30.2