From dd81163fe8ff6611261475f97c08f8ef688dd4d1 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 26 Sep 2018 09:18:09 +0000 Subject: [PATCH] [Ada] Minor reformattings 2018-09-26 Hristian Kirtchev gcc/ada/ * contracts.adb, exp_unst.adb, exp_util.adb, gnat1drv.adb, opt.ads, par-prag.adb, sem_ch3.adb, sem_ch5.adb, sem_prag.adb, sinfo.ads, snames.ads-tmpl: Minor reformatting. From-SVN: r264621 --- gcc/ada/ChangeLog | 6 + gcc/ada/contracts.adb | 30 +-- gcc/ada/exp_unst.adb | 30 +-- gcc/ada/exp_util.adb | 8 +- gcc/ada/gnat1drv.adb | 2 +- gcc/ada/opt.ads | 15 +- gcc/ada/par-prag.adb | 12 +- gcc/ada/sem_ch3.adb | 8 +- gcc/ada/sem_ch5.adb | 3 +- gcc/ada/sem_prag.adb | 392 ++++++++++++++++++++++++++-------------- gcc/ada/sinfo.ads | 4 +- gcc/ada/snames.ads-tmpl | 10 +- 12 files changed, 318 insertions(+), 202 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 92009ff9d6b..ba3c363367e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-09-26 Hristian Kirtchev + + * contracts.adb, exp_unst.adb, exp_util.adb, gnat1drv.adb, + opt.ads, par-prag.adb, sem_ch3.adb, sem_ch5.adb, sem_prag.adb, + sinfo.ads, snames.ads-tmpl: Minor reformatting. + 2018-09-26 Hristian Kirtchev * gcc-interface/Make-lang.in: Add unit GNAT.Sets to the list of diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 8b18c398cc4..760c06b1114 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -2858,13 +2858,11 @@ package body Contracts is ------------------------------- procedure Process_Preconditions_For (Subp_Id : Entity_Id) is - Items : constant Node_Id := Contract (Subp_Id); - - Bod : constant Node_Id := Unit_Declaration_Node (Body_Id); + Items : constant Node_Id := Contract (Subp_Id); + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); Decl : Node_Id; Freeze_T : Boolean; Prag : Node_Id; - Subp_Decl : Node_Id; begin -- Process the contract. If the body is an expression function @@ -2873,12 +2871,13 @@ package body Contracts is -- its completion by an expression function appear in distinct -- declarative lists of the same unit (visible and private). - Freeze_T := Was_Expression_Function (Bod) - and then Sloc (Body_Id) /= Sloc (Subp_Id) - and then In_Same_Source_Unit (Body_Id, Subp_Id) - and then List_Containing (Bod) /= - List_Containing (Unit_Declaration_Node (Subp_Id)) - and then not In_Instance; + Freeze_T := + Was_Expression_Function (Body_Decl) + and then Sloc (Body_Id) /= Sloc (Subp_Id) + and then In_Same_Source_Unit (Body_Id, Subp_Id) + and then List_Containing (Body_Decl) /= + List_Containing (Subp_Decl) + and then not In_Instance; if Present (Items) then Prag := Pre_Post_Conditions (Items); @@ -2887,10 +2886,13 @@ package body Contracts is and then Is_Checked (Prag) then if Freeze_T - and then Present (Corresponding_Aspect (Prag)) + and then Present (Corresponding_Aspect (Prag)) then - Freeze_Expr_Types (Subp_Id, Standard_Boolean, - Expression (Corresponding_Aspect (Prag)), Bod); + Freeze_Expr_Types + (Def_Id => Subp_Id, + Typ => Standard_Boolean, + Expr => Expression (Corresponding_Aspect (Prag)), + N => Body_Decl); end if; Prepend_To_Decls_Or_Save (Prag); @@ -2905,8 +2907,6 @@ package body Contracts is -- it must be taken into account. The pragma appears after the -- stub. - Subp_Decl := Unit_Declaration_Node (Subp_Id); - if Nkind (Subp_Decl) = N_Subprogram_Body_Stub then -- Inspect the declarations following the body stub diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index e31d84acb0e..de4ea1a26ce 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -260,8 +260,8 @@ package body Exp_Unst is E := Ultimate_Alias (E); -- The body of a protected operation has a different name and - -- has been scanned at this point, and thus has an entry in - -- the subprogram table. + -- has been scanned at this point, and thus has an entry in the + -- subprogram table. if E = Sub and then Convention (E) = Convention_Protected then E := Protected_Body_Subprogram (E); @@ -541,19 +541,17 @@ package body Exp_Unst is if Nkind (N) = N_Attribute_Reference then declare Attr : constant Attribute_Id := - Get_Attribute_Id (Attribute_Name (N)); + Get_Attribute_Id (Attribute_Name (N)); + DT : Boolean := False; + begin if (Attr = Attribute_First or else Attr = Attribute_Last or else Attr = Attribute_Length) and then Is_Constrained (Etype (Prefix (N))) then - declare - DT : Boolean := False; - begin - Check_Static_Type - (Etype (Prefix (N)), Empty, DT); - end; + Check_Static_Type + (Etype (Prefix (N)), Empty, DT); end if; end; end if; @@ -2022,21 +2020,23 @@ package body Exp_Unst is -- N_Loop_Parameter_Specification or to -- an N_Iterator_Specification. - if Nkind_In (Ins, N_Iterator_Specification, - N_Loop_Parameter_Specification) + if Nkind_In + (Ins, N_Iterator_Specification, + N_Loop_Parameter_Specification) then - -- Quantified expression are rewrittne - -- as loops during expansion. + -- Quantified expression are rewritten as + -- loops during expansion. if Nkind (Parent (Ins)) = - N_Quantified_Expression + N_Quantified_Expression then null; else Ins := First - (Statements (Parent (Parent (Ins)))); + (Statements + (Parent (Parent (Ins)))); Insert_Before (Ins, Asn); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 183797cd9f9..ec681af91db 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9151,10 +9151,10 @@ package body Exp_Util is Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc)))); - Set_Reverse_Storage_Order (Equiv_Type, - Reverse_Storage_Order (Base_Type (Root_Utyp))); - Set_Reverse_Bit_Order (Equiv_Type, - Reverse_Bit_Order (Base_Type (Root_Utyp))); + Set_Reverse_Storage_Order + (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp))); + Set_Reverse_Bit_Order + (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp))); end if; Append_To (Comp_List, diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index a3d905bac3b..eab2fda1a00 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -161,7 +161,7 @@ procedure Gnat1drv is Modify_Tree_For_C := True; end if; - -- -gnatd_A disables generation of ALI files. + -- -gnatd_A disables generation of ALI files if Debug_Flag_Underscore_AA then Disable_ALI_File := True; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index ca5dc6162d0..26143030da1 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1216,6 +1216,11 @@ package Opt is -- cannot be simultaneous compilations with the object files in the same -- object directory, if project files are used. + OpenAcc_Enabled : Boolean := False; + -- GNAT + -- Indicates whether OpenAcc pragmas should be taken into account. Set to + -- True by the use of -fopenacc. + type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code); pragma Ordered (Operating_Mode_Type); Operating_Mode : Operating_Mode_Type := Generate_Code; @@ -2335,21 +2340,11 @@ package Opt is -- The only special comment sequence allowed is --! - ------------- - -- OpenAcc -- - ------------- - - OpenAcc_Enabled : Boolean := False; - -- GNAT - -- Indicates whether OpenAcc pragmas should be taken into account. - -- Set True by use of -fopenacc. - -------------------------- -- Private Declarations -- -------------------------- private - -- The following type is used to save and restore settings of switches in -- Opt that represent the configuration (i.e. result of config pragmas). diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index f51a838728a..a8b399711e5 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1295,11 +1295,15 @@ begin -- All Other Pragmas -- ----------------------- - -- For all other pragmas, checking and processing is handled - -- entirely in Sem_Prag, and no further checking is done by Par. + -- For all other pragmas, checking and processing is handled entirely in + -- Sem_Prag, and no further checking is done by Par. when Pragma_Abort_Defer | Pragma_Abstract_State + | Pragma_Acc_Data + | Pragma_Acc_Kernels + | Pragma_Acc_Loop + | Pragma_Acc_Parallel | Pragma_Async_Readers | Pragma_Async_Writers | Pragma_Assertion_Policy @@ -1516,10 +1520,6 @@ begin | Pragma_Warning_As_Error | Pragma_Weak_External | Pragma_Validity_Checks - | Pragma_Acc_Data - | Pragma_Acc_Kernels - | Pragma_Acc_Loop - | Pragma_Acc_Parallel => null; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cf45ccc2959..32797d88f9e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1919,8 +1919,8 @@ package body Sem_Ch3 is if Is_Limited_Record (Typ) then return True; - -- If the root type is limited (and not a limited interface) - -- so is the current type + -- If the root type is limited (and not a limited interface) so is + -- the current type. elsif Is_Limited_Record (R) and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) @@ -1931,8 +1931,8 @@ package body Sem_Ch3 is -- limited record parent that is not an interface. elsif R /= P - and then Is_Limited_Record (P) - and then not Is_Interface (P) + and then Is_Limited_Record (P) + and then not Is_Interface (P) then return True; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 6f002f42824..95b56601d81 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2210,8 +2210,7 @@ package body Sem_Ch5 is if Nkind (Iter_Name) = N_Function_Call and then Is_Entity_Name (Name (Iter_Name)) and then Full_Analysis - and then (In_Assertion_Expr = 0 - or else Assertions_Enabled) + and then (In_Assertion_Expr = 0 or else Assertions_Enabled) then Freeze_Before (N, Entity (Name (Iter_Name))); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c409b85ecb9..bc914119afa 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3686,10 +3686,10 @@ package body Sem_Prag is ----------------------- function Acc_First (N : Node_Id) return Node_Id; - -- Helper function to iterate over arguments given to OpenAcc pragmas. + -- Helper function to iterate over arguments given to OpenAcc pragmas function Acc_Next (N : Node_Id) return Node_Id; - -- Helper function to iterate over arguments given to OpenAcc pragmas. + -- Helper function to iterate over arguments given to OpenAcc pragmas procedure Acquire_Warning_Match_String (Arg : Node_Id); -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to @@ -4241,14 +4241,14 @@ package body Sem_Prag is -- profile. procedure Validate_Acc_Condition_Clause (Clause : Node_Id); - -- Make sure the argument of a given Acc_If clause is a boolean. + -- Make sure the argument of a given Acc_If clause is a Boolean procedure Validate_Acc_Data_Clause (Clause : Node_Id); -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin, -- Copyout...) is an identifier or an aggregate of identifiers. procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id); - -- Make sure the argument of an OpenAcc clause is an Integer expression. + -- Make sure the argument of an OpenAcc clause is an Integer expression procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id); -- Make sure the argument of an OpenAcc clause is an Integer expression @@ -4266,8 +4266,8 @@ package body Sem_Prag is procedure Validate_Acc_Loop_Vector (Clause : Node_Id); -- When this procedure is called in a construct offloaded by an -- Acc_Kernels pragma, makes sure that a Vector_Length clause does - -- not exist on said pragma. - -- In all cases, make sure the argument is an integer expression. + -- not exist on said pragma. In all cases, make sure the argument + -- is an Integer expression. procedure Validate_Acc_Loop_Worker (Clause : Node_Id); -- When this procedure is called in a construct offloaded by an @@ -4297,10 +4297,12 @@ package body Sem_Prag is if Nkind (N) = N_Aggregate then if Present (Expressions (N)) then return First (Expressions (N)); + elsif Present (Component_Associations (N)) then return Expression (First (Component_Associations (N))); end if; end if; + return N; end Acc_First; @@ -4312,8 +4314,10 @@ package body Sem_Prag is begin if Nkind (Parent (N)) = N_Component_Association then return Expression (Next (Parent (N))); + elsif Nkind (Parent (N)) = N_Aggregate then return Next (N); + else return Empty; end if; @@ -11174,8 +11178,9 @@ package body Sem_Prag is procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is begin Analyze_And_Resolve (Clause); + if not Is_Boolean_Type (Etype (Clause)) then - Error_Pragma ("Expected a boolean"); + Error_Pragma ("expected a boolean"); end if; end Validate_Acc_Condition_Clause; @@ -11185,13 +11190,16 @@ package body Sem_Prag is procedure Validate_Acc_Data_Clause (Clause : Node_Id) is Expr : Node_Id; + begin Expr := Acc_First (Clause); while Present (Expr) loop if Nkind (Expr) /= N_Identifier then - Error_Pragma ("Expected an Identifer"); + Error_Pragma ("expected an identifer"); end if; + Analyze_And_Resolve (Expr); + Expr := Acc_Next (Expr); end loop; end Validate_Acc_Data_Clause; @@ -11203,8 +11211,9 @@ package body Sem_Prag is procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is begin Analyze_And_Resolve (Clause); + if not Is_Integer_Type (Etype (Clause)) then - Error_Pragma_Arg ("Expected an integer", Clause); + Error_Pragma_Arg ("expected an integer", Clause); end if; end Validate_Acc_Int_Expr_Clause; @@ -11214,13 +11223,16 @@ package body Sem_Prag is procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is Expr : Node_Id; + begin Expr := Acc_First (Clause); while Present (Expr) loop Analyze_And_Resolve (Expr); + if not Is_Integer_Type (Etype (Expr)) then - Error_Pragma ("Expected an Integer"); + Error_Pragma ("expected an integer"); end if; + Expr := Acc_Next (Expr); end loop; end Validate_Acc_Int_Expr_List_Clause; @@ -11230,41 +11242,45 @@ package body Sem_Prag is -------------------------------- procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is - Count : Uint; - Parent_Loop : Node_Id; - Current_Statement : Node_Id; + Count : Uint; + Par_Loop : Node_Id; + Stmt : Node_Id; + begin - -- Make sure the argument is a positive integer. + -- Make sure the argument is a positive integer + Analyze_And_Resolve (Clause); + Count := Static_Integer (Clause); if Count = No_Uint or else Count < 1 then - Error_Pragma_Arg ("Expected a positive integer", Clause); + Error_Pragma_Arg ("expected a positive integer", Clause); end if; -- Then, make sure we have at least Count-1 tightly-nested loops -- (i.e. loops with no statements in between). - Parent_Loop := Parent (Parent (Parent (Clause))); - Current_Statement := First (Statements (Parent_Loop)); + Par_Loop := Parent (Parent (Parent (Clause))); + Stmt := First (Statements (Par_Loop)); + -- Skip first pragmas in the parent loop - while Present (Current_Statement) - and then Nkind (Current_Statement) = N_Pragma loop - Current_Statement := Next (Current_Statement); + + while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop + Next (Stmt); end loop; - if not Present (Next (Current_Statement)) then - While_Loop : - while Nkind (Current_Statement) = N_Loop_Statement - and Count > 1 loop - Current_Statement := First (Statements (Current_Statement)); - exit While_Loop when Present (Next (Current_Statement)); + if not Present (Next (Stmt)) then + while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop + Stmt := First (Statements (Stmt)); + exit when Present (Next (Stmt)); + Count := Count - 1; - end loop While_Loop; + end loop; end if; if Count > 1 then - Error_Pragma_Arg ("Collapse argument too high or loops not " & - "tightly nested.", Clause); + Error_Pragma_Arg + ("Collapse argument too high or loops not tightly nested", + Clause); end if; end Validate_Acc_Loop_Collapse; @@ -11300,83 +11316,119 @@ package body Sem_Prag is --------------------------------- procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is + -- ??? On top of the following operations, the OpenAcc spec adds the -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and -- ".neqv" for Fortran. Can we, should we and how do we support them -- in Ada? - type Reduction_Op is (Add_Op, Mul_Op, Max_Op, - Min_Op, And_Op, Or_Op); + + type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op); + function To_Reduction_Op (Op : String) return Reduction_Op; + -- Convert operator Op described by a String into its corresponding + -- enumeration value. + + --------------------- + -- To_Reduction_Op -- + --------------------- + function To_Reduction_Op (Op : String) return Reduction_Op is begin if Op = "+" then return Add_Op; + elsif Op = "*" then return Mul_Op; + elsif Op = "max" then return Max_Op; + elsif Op = "min" then return Min_Op; + elsif Op = "and" then return And_Op; + elsif Op = "or" then return Or_Op; + else - Error_Pragma ("Unsuported reduction operation"); + Error_Pragma ("unsuported reduction operation"); end if; end To_Reduction_Op; - Expr : Node_Id; - Reduc_Op : Node_Id; + + -- Local variables + + Seen : constant Elist_Id := New_Elmt_List; + + Expr : Node_Id; + Reduc_Op : Node_Id; Reduc_Var : Node_Id; - Seen_Entities : Elist_Id; + + -- Start of processing for Validate_Acc_Name_Reduction + begin - -- Reduction operations look like this: - -- ("+" => (a, b), "*" => c) - Seen_Entities := New_Elmt_List; + -- Reduction operations appear in the following form: + -- ("+" => (a, b), "*" => c) + Expr := First (Component_Associations (Clause)); while Present (Expr) loop Reduc_Op := First (Choices (Expr)); String_To_Name_Buffer (Strval (Reduc_Op)); - case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is - when Add_Op | Mul_Op | Max_Op | Min_Op => + case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is + when Add_Op + | Mul_Op + | Max_Op + | Min_Op + => Reduc_Var := Acc_First (Expression (Expr)); while Present (Reduc_Var) loop Analyze_And_Resolve (Reduc_Var); - if Contains (Seen_Entities, Entity (Reduc_Var)) then - Error_Pragma ("Variable used in multiple reductions"); + + if Contains (Seen, Entity (Reduc_Var)) then + Error_Pragma ("variable used in multiple reductions"); + else - if (Nkind (Reduc_Var) /= N_Identifier) - or not Is_Numeric_Type (Etype (Reduc_Var)) + if Nkind (Reduc_Var) /= N_Identifier + or not Is_Numeric_Type (Etype (Reduc_Var)) then Error_Pragma - ("Expected an identifier for a Numeric"); + ("expected an identifier for a Numeric"); end if; - Append_Elmt (Entity (Reduc_Var), Seen_Entities); + + Append_Elmt (Entity (Reduc_Var), Seen); end if; + Reduc_Var := Acc_Next (Reduc_Var); end loop; - when And_Op | Or_Op => + when And_Op + | Or_Op + => Reduc_Var := Acc_First (Expression (Expr)); while Present (Reduc_Var) loop Analyze_And_Resolve (Reduc_Var); - if Contains (Seen_Entities, Entity (Reduc_Var)) then - Error_Pragma ("Variable used in multiple " & - "reductions"); + + if Contains (Seen, Entity (Reduc_Var)) then + Error_Pragma ("variable used in multiple reductions"); + else - if Nkind (Reduc_Var) /= N_Identifier or not - Is_Boolean_Type (Etype (Reduc_Var)) + if Nkind (Reduc_Var) /= N_Identifier + or not Is_Boolean_Type (Etype (Reduc_Var)) then - Error_Pragma ("Expected a variable of type " & - "Boolean"); + Error_Pragma + ("expected a variable of type boolean"); end if; - Append_Elmt (Entity (Reduc_Var), Seen_Entities); + + Append_Elmt (Entity (Reduc_Var), Seen); end if; + Reduc_Var := Acc_Next (Reduc_Var); end loop; end case; - Expr := Next (Expr); + + Next (Expr); end loop; end Validate_Acc_Name_Reduction; @@ -11385,26 +11437,38 @@ package body Sem_Prag is ----------------------------------- procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is - - -- A size expr is either an integer expression or "*" function Validate_Size_Expr (Expr : Node_Id) return Boolean; + -- A size expr is either an integer expression or "*" + + ------------------------ + -- Validate_Size_Expr -- + ------------------------ + function Validate_Size_Expr (Expr : Node_Id) return Boolean is begin if Nkind (Expr) = N_Operator_Symbol then return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*'); end if; + Analyze_And_Resolve (Expr); + return Is_Integer_Type (Etype (Expr)); end Validate_Size_Expr; + -- Local variables + Expr : Node_Id; + + -- Start of processing for Validate_Acc_Size_Expressions + begin Expr := Acc_First (Clause); while Present (Expr) loop if not Validate_Size_Expr (Expr) then - Error_Pragma ("Size expressions should be either integers " & - "or '*'"); + Error_Pragma + ("Size expressions should be either integers or '*'"); end if; + Expr := Acc_Next (Expr); end loop; end Validate_Acc_Size_Expressions; @@ -12357,8 +12421,8 @@ package body Sem_Prag is -------------- when Pragma_Acc_Data => Acc_Data : declare - Clause_Names : constant Name_List := ( - Name_Attach, + Clause_Names : constant Name_List := + (Name_Attach, Name_Copy, Name_Copy_In, Name_Copy_Out, @@ -12367,24 +12431,29 @@ package body Sem_Prag is Name_Detach, Name_Device_Ptr, Name_No_Create, - Name_Present - ); + Name_Present); + + Clause : Node_Id; Clauses : Args_List (Clause_Names'Range); - Clause : Node_Id; begin if not OpenAcc_Enabled then return; end if; + GNAT_Pragma; - if Nkind (Parent (N)) /= N_Loop_Statement - then - Error_Pragma ("Acc_Data pragma should be placed in loop or " - & "block statements."); + + if Nkind (Parent (N)) /= N_Loop_Statement then + Error_Pragma + ("Acc_Data pragma should be placed in loop or block " + & "statements"); end if; + Gather_Associations (Clause_Names, Clauses); + for Id in Clause_Names'First .. Clause_Names'Last loop Clause := Clauses (Id); + if Present (Clause) then case Clause_Names (Id) is when Name_Copy @@ -12392,20 +12461,24 @@ package body Sem_Prag is | Name_Copy_Out | Name_Create | Name_Device_Ptr - | Name_Present => + | Name_Present + => Validate_Acc_Data_Clause (Clause); + when Name_Attach | Name_Detach | Name_Delete - | Name_No_Create => - Error_Pragma ("Unsupported pragma clause."); - when others => raise Program_Error; + | Name_No_Create + => + Error_Pragma ("unsupported pragma clause"); + + when others => + raise Program_Error; end case; end if; end loop; Set_Is_OpenAcc_Environment (Parent (N)); - end Acc_Data; -------------- @@ -12413,9 +12486,8 @@ package body Sem_Prag is -------------- when Pragma_Acc_Loop => Acc_Loop : declare - - Clause_Names : constant Name_List := ( - Name_Auto, + Clause_Names : constant Name_List := + (Name_Auto, Name_Collapse, Name_Gang, Name_Independent, @@ -12424,51 +12496,77 @@ package body Sem_Prag is Name_Seq, Name_Tile, Name_Vector, - Name_Worker - ); + Name_Worker); + + Clause : Node_Id; Clauses : Args_List (Clause_Names'Range); - Clause : Node_Id; - Parent_Node : Node_Id; + Par : Node_Id; begin if not OpenAcc_Enabled then return; end if; + GNAT_Pragma; -- Make sure the pragma is in an openacc construct + Check_Loop_Pragma_Placement; - Parent_Node := Parent (N); - while Present (Parent_Node) and then - (Nkind (Parent_Node) /= N_Loop_Statement or else - not Is_OpenAcc_Environment (Parent_Node)) loop - Parent_Node := Parent (Parent_Node); + + Par := Parent (N); + while Present (Par) + and then (Nkind (Par) /= N_Loop_Statement + or else not Is_OpenAcc_Environment (Par)) + loop + Par := Parent (Par); end loop; - if not Is_OpenAcc_Environment (Parent_Node) then - Error_Pragma ("Acc_Loop directive must be associated with an " & - "OpenAcc construct region"); + + if not Is_OpenAcc_Environment (Par) then + Error_Pragma + ("Acc_Loop directive must be associated with an OpenAcc " + & "construct region"); end if; Gather_Associations (Clause_Names, Clauses); + for Id in Clause_Names'First .. Clause_Names'Last loop Clause := Clauses (Id); + if Present (Clause) then case Clause_Names (Id) is - when Name_Auto | Name_Independent | Name_Seq => null; + when Name_Auto + | Name_Independent + | Name_Seq + => + null; + when Name_Collapse => Validate_Acc_Loop_Collapse (Clause); - when Name_Gang => Validate_Acc_Loop_Gang (Clause); + + when Name_Gang => + Validate_Acc_Loop_Gang (Clause); + when Name_Acc_Private => Validate_Acc_Data_Clause (Clause); + when Name_Reduction => Validate_Acc_Name_Reduction (Clause); - when Name_Tile => Validate_Acc_Size_Expressions (Clause); - when Name_Vector => Validate_Acc_Loop_Vector (Clause); - when Name_Worker => Validate_Acc_Loop_Worker (Clause); - when others => raise Program_Error; + + when Name_Tile => + Validate_Acc_Size_Expressions (Clause); + + when Name_Vector => + Validate_Acc_Loop_Vector (Clause); + + when Name_Worker => + Validate_Acc_Loop_Worker (Clause); + + when others => + raise Program_Error; end case; end if; end loop; + Set_Is_OpenAcc_Loop (Parent (N)); end Acc_Loop; @@ -12476,12 +12574,12 @@ package body Sem_Prag is -- Acc_Parallel and Acc_Kernels -- ---------------------------------- - when Pragma_Acc_Parallel | Pragma_Acc_Kernels => - Acc_Kernels_Or_Parallel : - declare - - Clause_Names : constant Name_List := ( - Name_Acc_If, + when Pragma_Acc_Parallel + | Pragma_Acc_Kernels + => + Acc_Kernels_Or_Parallel : declare + Clause_Names : constant Name_List := + (Name_Acc_If, Name_Async, Name_Copy, Name_Copy_In, @@ -12495,68 +12593,81 @@ package body Sem_Prag is Name_Present, Name_Vector_Length, Name_Wait, + -- Parallel only + Name_Acc_Private, Name_First_Private, Name_Reduction, + -- Kernels only + Name_Attach, - Name_No_Create - ); + Name_No_Create); + + Clause : Node_Id; Clauses : Args_List (Clause_Names'Range); - Clause : Node_Id; begin if not OpenAcc_Enabled then return; end if; + GNAT_Pragma; Check_Loop_Pragma_Placement; if Nkind (Parent (N)) /= N_Loop_Statement then - Error_Pragma ("Pragma should be placed in loop or block " - & "statements."); + Error_Pragma + ("pragma should be placed in loop or block statements"); end if; Gather_Associations (Clause_Names, Clauses); + for Id in Clause_Names'First .. Clause_Names'Last loop Clause := Clauses (Id); + if Present (Clause) then if Chars (Parent (Clause)) = No_Name then - Error_Pragma ("All arguments should be associations"); + Error_Pragma ("all arguments should be associations"); else case Clause_Names (Id) is - -- Note: According to the OpenAcc Standard v2.6, - -- Async's argument should be optional. Because - -- this complicates parsing the clause, the - -- argument is made mandatory. The standard defines - -- two negative values, acc_async_noval and - -- acc_async_sync. When given acc_async_noval as - -- value, the clause should behave as if no - -- argument was given. According to the standard, - -- acc_async_noval is defined in header files for C - -- and Fortran, thus this value should probably be - -- defined in the OpenAcc Ada library once it is - -- implemented. + + -- Note: According to the OpenAcc Standard v2.6, + -- Async's argument should be optional. Because this + -- complicates parsing the clause, the argument is + -- made mandatory. The standard defines two negative + -- values, acc_async_noval and acc_async_sync. When + -- given acc_async_noval as value, the clause should + -- behave as if no argument was given. According to + -- the standard, acc_async_noval is defined in header + -- files for C and Fortran, thus this value should + -- probably be defined in the OpenAcc Ada library once + -- it is implemented. + when Name_Async | Name_Num_Gangs | Name_Num_Workers - | Name_Vector_Length => + | Name_Vector_Length + => Validate_Acc_Int_Expr_Clause (Clause); when Name_Acc_If => Validate_Acc_Condition_Clause (Clause); - -- Unsupported by GCC + -- Unsupported by GCC + when Name_Attach - | Name_No_Create => - Error_Pragma ("Unsupported clause."); + | Name_No_Create + => + Error_Pragma ("unsupported clause"); - when Name_First_Private - | Name_Acc_Private => + when Name_Acc_Private + | Name_First_Private + => if Prag_Id /= Pragma_Acc_Parallel then - Error_Pragma ("Argument is only available for" & - " 'Parallel' construct."); + Error_Pragma + ("argument is only available for 'Parallel' " + & "construct"); else Validate_Acc_Data_Clause (Clause); end if; @@ -12564,42 +12675,45 @@ package body Sem_Prag is when Name_Copy | Name_Copy_In | Name_Copy_Out - | Name_Present | Name_Create - | Name_Device_Ptr => + | Name_Device_Ptr + | Name_Present + => Validate_Acc_Data_Clause (Clause); when Name_Reduction => if Prag_Id /= Pragma_Acc_Parallel then - Error_Pragma ("Argument is only available for" & - " 'Parallel' construct."); + Error_Pragma + ("argument is only available for 'Parallel' " + & "construct"); else Validate_Acc_Name_Reduction (Clause); end if; when Name_Default => if Chars (Clause) /= Name_None then - Error_Pragma ("Expected None"); + Error_Pragma ("expected none"); end if; when Name_Device_Type => - Error_Pragma ("Unsupported pragma clause"); + Error_Pragma ("unsupported pragma clause"); + + -- Similar to Name_Async, Name_Wait's arguments should + -- be optional. However, this can be simulated using + -- acc_async_noval, hence, we do not bother making the + -- argument optional for now. - -- Same as for Name_Async, Name_Wait's arguments - -- should be optional. However, this can be - -- simulated using acc_async_noval, hence, we do - -- not bother making the argument optional for now. when Name_Wait => Validate_Acc_Int_Expr_List_Clause (Clause); - when others => raise Program_Error; + when others => + raise Program_Error; end case; end if; end if; end loop; Set_Is_OpenAcc_Environment (Parent (N)); - end Acc_Kernels_Or_Parallel; ------------ diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index bed8b32455b..fcf99a8132b 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -5134,11 +5134,11 @@ package Sinfo is -- Iteration_Scheme (Node2) (set to Empty if no iteration scheme) -- Statements (List3) -- End_Label (Node4) + -- Is_OpenAcc_Environment (Flag13-Sem) + -- Is_OpenAcc_Loop (Flag14-Sem) -- Has_Created_Identifier (Flag15) -- Is_Null_Loop (Flag16) -- Suppress_Loop_Warnings (Flag17) - -- Is_OpenAcc_Environment (Flag13-Sem) - -- Is_OpenAcc_Loop (Flag14-Sem) -- Note: the parser fills in the Identifier field if there is an -- explicit loop identifier. Otherwise the parser leaves this field diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 0b9e531b089..21cc0f41182 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -864,8 +864,8 @@ package Snames is Name_Warn : constant Name_Id := N + $; Name_Working_Storage : constant Name_Id := N + $; - -- OpenAcc-specific clause names - -- Parallel, Kernels, Data + -- OpenAcc-specific clause names for Parallel, Kernels, Data + Name_Acc_If : constant Name_Id := N + $; Name_Acc_Private : constant Name_Id := N + $; Name_Attach : constant Name_Id := N + $; @@ -884,13 +884,15 @@ package Snames is Name_Reduction : constant Name_Id := N + $; Name_Vector_Length : constant Name_Id := N + $; Name_Wait : constant Name_Id := N + $; + -- Loop + + Name_Auto : constant Name_Id := N + $; Name_Collapse : constant Name_Id := N + $; Name_Gang : constant Name_Id := N + $; - Name_Worker : constant Name_Id := N + $; Name_Seq : constant Name_Id := N + $; - Name_Auto : constant Name_Id := N + $; Name_Tile : constant Name_Id := N + $; + Name_Worker : constant Name_Id := N + $; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These -- 2.30.2