diff options
Diffstat (limited to 'gcc/ada/sem_prag.adb')
| -rw-r--r-- | gcc/ada/sem_prag.adb | 578 |
1 files changed, 352 insertions, 226 deletions
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3ef5e82..0ff4e49 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,67 +29,71 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). -with Aspects; use Aspects; -with Atree; use Atree; -with Casing; use Casing; -with Checks; use Checks; -with Contracts; use Contracts; -with Csets; use Csets; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Dist; use Exp_Dist; -with Exp_Util; use Exp_Util; -with Expander; use Expander; -with Freeze; use Freeze; -with Ghost; use Ghost; -with GNAT_CUDA; use GNAT_CUDA; -with Gnatvsn; use Gnatvsn; -with Lib; use Lib; -with Lib.Writ; use Lib.Writ; -with Lib.Xref; use Lib.Xref; -with Namet.Sp; use Namet.Sp; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Output; use Output; -with Par_SCO; use Par_SCO; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elab; use Sem_Elab; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Intr; use Sem_Intr; -with Sem_Mech; use Sem_Mech; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Stylesw; use Stylesw; +with Aspects; use Aspects; +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Contracts; use Contracts; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Freeze; use Freeze; +with Ghost; use Ghost; +with GNAT_CUDA; use GNAT_CUDA; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elab; use Sem_Elab; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Stylesw; use Stylesw; with Table; -with Targparm; use Targparm; -with Tbuild; use Tbuild; +with Targparm; use Targparm; +with Tbuild; use Tbuild; with Ttypes; -with Uintp; use Uintp; -with Uname; use Uname; -with Urealp; use Urealp; -with Validsw; use Validsw; -with Warnsw; use Warnsw; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; +with Validsw; use Validsw; +with Warnsw; use Warnsw; with System.Case_Util; @@ -243,6 +247,7 @@ package body Sem_Prag is -- Constant_After_Elaboration -- Effective_Reads -- Effective_Writers + -- No_Caching -- Part_Of -- Find the first source declaration or statement found while traversing -- the previous node chain starting from pragma Prag. If flag Do_Checks is @@ -566,8 +571,8 @@ package body Sem_Prag is -- Check that the expression is a proper aggregate (no parentheses) if Paren_Count (CCases) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (CCases)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", CCases); end if; -- Ensure that the formal parameters are visible when analyzing all @@ -717,9 +722,7 @@ package body Sem_Prag is elsif Ekind (Item_Id) = E_Constant then Add_Str_To_Name_Buffer ("constant"); - elsif Ekind (Item_Id) in - E_Generic_In_Out_Parameter | E_Generic_In_Parameter - then + elsif Is_Formal_Object (Item_Id) then Add_Str_To_Name_Buffer ("generic parameter"); elsif Is_Formal (Item_Id) then @@ -1136,6 +1139,17 @@ package body Sem_Prag is (State_Id => Item_Id, Ref => Item); end if; + + elsif Ekind (Item_Id) in E_Constant | E_Variable + and then Present (Ultimate_Overlaid_Entity (Item_Id)) + then + SPARK_Msg_NE + ("overlaying object & cannot appear in Depends", + Item, Item_Id); + SPARK_Msg_NE + ("\use the overlaid object & instead", + Item, Ultimate_Overlaid_Entity (Item_Id)); + return; end if; -- When the item renames an entire object, replace the @@ -1282,17 +1296,22 @@ package body Sem_Prag is (Item_Is_Input : out Boolean; Item_Is_Output : out Boolean) is - -- A constant or IN parameter of access-to-variable type should be + -- A constant or an IN parameter of a procedure or a protected + -- entry, if it is of an access-to-variable type, should be -- handled like a variable, as the underlying memory pointed-to -- can be modified. Use Adjusted_Kind to do this adjustment. Adjusted_Kind : Entity_Kind := Ekind (Item_Id); begin - if Ekind (Item_Id) in E_Constant - | E_Generic_In_Parameter - | E_In_Parameter + if (Ekind (Item_Id) in E_Constant | E_Generic_In_Parameter + or else + (Ekind (Item_Id) = E_In_Parameter + and then Ekind (Scope (Item_Id)) + not in E_Function | E_Generic_Function)) and then Is_Access_Variable (Etype (Item_Id)) + and then Ekind (Spec_Id) not in E_Function + | E_Generic_Function then Adjusted_Kind := E_Variable; end if; @@ -1476,8 +1495,6 @@ package body Sem_Prag is (Item_Is_Input : Boolean; Item_Is_Output : Boolean) is - Error_Msg : Name_Id; - begin Name_Len := 0; @@ -1490,8 +1507,7 @@ package body Sem_Prag is Add_Str_To_Name_Buffer (" & cannot appear in dependence relation"); - Error_Msg := Name_Find; - SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); + SPARK_Msg_NE (To_String (Global_Name_Buffer), Item, Item_Id); Error_Msg_Name_1 := Chars (Spec_Id); SPARK_Msg_NE @@ -1520,8 +1536,8 @@ package body Sem_Prag is end if; Add_Str_To_Name_Buffer (" in dependence relation"); - Error_Msg := Name_Find; - SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); + + SPARK_Msg_NE (To_String (Global_Name_Buffer), Item, Item_Id); end if; end Role_Error; @@ -1573,8 +1589,6 @@ package body Sem_Prag is ----------------- procedure Usage_Error (Item_Id : Entity_Id) is - Error_Msg : Name_Id; - begin -- Input case @@ -1592,8 +1606,7 @@ package body Sem_Prag is Add_Str_To_Name_Buffer (" & is missing from input dependence list"); - Error_Msg := Name_Find; - SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); + SPARK_Msg_NE (To_String (Global_Name_Buffer), N, Item_Id); SPARK_Msg_NE ("\add `null ='> &` dependency to ignore this input", N, Item_Id); @@ -1608,8 +1621,7 @@ package body Sem_Prag is Add_Str_To_Name_Buffer (" & is missing from output dependence list"); - Error_Msg := Name_Find; - SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); + SPARK_Msg_NE (To_String (Global_Name_Buffer), N, Item_Id); end if; end Usage_Error; @@ -2386,6 +2398,17 @@ package body Sem_Prag is elsif Is_Formal_Object (Item_Id) then null; + elsif Ekind (Item_Id) in E_Constant | E_Variable + and then Present (Ultimate_Overlaid_Entity (Item_Id)) + then + SPARK_Msg_NE + ("overlaying object & cannot appear in Global", + Item, Item_Id); + SPARK_Msg_NE + ("\use the overlaid object & instead", + Item, Ultimate_Overlaid_Entity (Item_Id)); + return; + -- The only legal references are those to abstract states, -- objects and various kinds of constants (SPARK RM 6.1.4(4)). @@ -2432,10 +2455,13 @@ package body Sem_Prag is SPARK_Msg_N ("\use its constituents instead", Item); return; - -- An external state cannot appear as a global item of a - -- nonvolatile function (SPARK RM 7.1.3(8)). + -- An external state which has Async_Writers or + -- Effective_Reads enabled cannot appear as a global item + -- of a nonvolatile function (SPARK RM 7.1.3(8)). elsif Is_External_State (Item_Id) + and then (Async_Writers_Enabled (Item_Id) + or else Effective_Reads_Enabled (Item_Id)) and then Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Is_Volatile_Function (Spec_Id) then @@ -2456,17 +2482,31 @@ package body Sem_Prag is -- Constant related checks - elsif Ekind (Item_Id) = E_Constant - and then not Is_Access_Type (Etype (Item_Id)) - then + elsif Ekind (Item_Id) = E_Constant then - -- Unless it is of an access type, a constant is a read-only - -- item, therefore it cannot act as an output. + -- Constant is a read-only item, therefore it cannot act as + -- an output. if Global_Mode in Name_In_Out | Name_Output then - SPARK_Msg_NE - ("constant & cannot act as output", Item, Item_Id); - return; + + -- Constant of an access-to-variable type is a read-write + -- item in procedures, generic procedures, protected + -- entries and tasks. + + if Is_Access_Variable (Etype (Item_Id)) + and then (Ekind (Spec_Id) in E_Entry + | E_Entry_Family + | E_Procedure + | E_Generic_Procedure + | E_Task_Type + or else Is_Single_Task_Object (Spec_Id)) + then + null; + else + SPARK_Msg_NE + ("constant & cannot act as output", Item, Item_Id); + return; + end if; end if; -- Loop parameter related checks @@ -2633,13 +2673,9 @@ package body Sem_Prag is Context := Anonymous_Object (Context); end if; - if (Is_Subprogram (Context) - or else Ekind (Context) = E_Task_Type - or else Is_Single_Task_Object (Context)) - and then - (Present (Get_Pragma (Context, Pragma_Global)) - or else - Present (Get_Pragma (Context, Pragma_Refined_Global))) + if Is_Subprogram_Or_Entry (Context) + or else Ekind (Context) = E_Task_Type + or else Is_Single_Task_Object (Context) then Collect_Subprogram_Inputs_Outputs (Subp_Id => Context, @@ -2648,8 +2684,8 @@ package body Sem_Prag is Global_Seen => Dummy); -- The item is classified as In_Out or Output but appears as - -- an Input in an enclosing subprogram or task unit (SPARK - -- RM 6.1.4(12)). + -- an Input or a formal parameter of mode IN in an enclosing + -- subprogram or task unit (SPARK RM 6.1.4(13)). if Appears_In (Inputs, Item_Id) and then not Appears_In (Outputs, Item_Id) @@ -2658,7 +2694,7 @@ package body Sem_Prag is ("global item & cannot have mode In_Out or Output", Item, Item_Id); - if Is_Subprogram (Context) then + if Is_Subprogram_Or_Entry (Context) then SPARK_Msg_NE (Fix_Msg (Subp_Id, "\item already appears as input " & "of subprogram &"), Item, Context); @@ -2970,6 +3006,16 @@ package body Sem_Prag is if Item_Id = Any_Id then null; + elsif Ekind (Item_Id) in E_Constant | E_Variable + and then Present (Ultimate_Overlaid_Entity (Item_Id)) + then + SPARK_Msg_NE + ("overlaying object & cannot appear in Initializes", + Item, Item_Id); + SPARK_Msg_NE + ("\use the overlaid object & instead", + Item, Ultimate_Overlaid_Entity (Item_Id)); + -- The state or variable must be declared in the visible -- declarations of the package (SPARK RM 7.1.5(7)). @@ -3094,9 +3140,7 @@ package body Sem_Prag is -- it is allowed for an initialization item to depend -- on an input item. - if Ekind (Input_Id) in E_Generic_In_Out_Parameter - | E_Generic_In_Parameter - then + if Is_Formal_Object (Input_Id) then null; elsif Ekind (Input_Id) in E_Constant | E_Variable @@ -3114,6 +3158,18 @@ package body Sem_Prag is end if; end if; + if Ekind (Input_Id) in E_Constant | E_Variable + and then Present (Ultimate_Overlaid_Entity (Input_Id)) + then + SPARK_Msg_NE + ("overlaying object & cannot appear in Initializes", + Input, Input_Id); + SPARK_Msg_NE + ("\use the overlaid object & instead", + Input, Ultimate_Overlaid_Entity (Input_Id)); + return; + end if; + -- Detect a duplicate use of the same input item -- (SPARK RM 7.1.5(5)). @@ -4074,9 +4130,9 @@ package body Sem_Prag is procedure Check_Static_Constraint (Constr : Node_Id); -- Constr is a constraint from an N_Subtype_Indication node from a - -- component constraint in an Unchecked_Union type. This routine checks - -- that the constraint is static as required by the restrictions for - -- Unchecked_Union. + -- component constraint in an Unchecked_Union type, a range, or a + -- discriminant association. This routine checks that the constraint + -- is static as required by the restrictions for Unchecked_Union. procedure Check_Valid_Configuration_Pragma; -- Legality checks for placement of a configuration pragma @@ -4809,10 +4865,10 @@ package body Sem_Prag is then null; - -- For Ada 2020, pre/postconditions can appear on formal subprograms + -- For Ada 2022, pre/postconditions can appear on formal subprograms elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration - and then Ada_Version >= Ada_2020 + and then Ada_Version >= Ada_2022 then null; @@ -6449,11 +6505,6 @@ package body Sem_Prag is -- Check_Static_Constraint -- ----------------------------- - -- Note: for convenience in writing this procedure, in addition to - -- the officially (i.e. by spec) allowed argument which is always a - -- constraint, it also allows ranges and discriminant associations. - -- Above is not clear ??? - procedure Check_Static_Constraint (Constr : Node_Id) is procedure Require_Static (E : Node_Id); @@ -6884,7 +6935,7 @@ package body Sem_Prag is Proc : Entity_Id := Empty; begin - -- The body of this procedure needs some comments ??? + -- Perform sanity checks on Name if not Is_Entity_Name (Name) then Error_Pragma_Arg @@ -6900,6 +6951,9 @@ package body Sem_Prag is ("argument of pragma% must be parameterless procedure", Arg); end if; + -- Otherwise, search through interpretations looking for one which + -- has no parameters. + else declare Found : Boolean := False; @@ -6914,13 +6968,20 @@ package body Sem_Prag is if Ekind (Proc) = E_Procedure and then No (First_Formal (Proc)) then + -- We found an interpretation, note it and continue + -- looking looking to verify it is unique. + if not Found then Found := True; Set_Entity (Name, Proc); Set_Is_Overloaded (Name, False); + + -- Two procedures with the same name, log an error + -- since the name is ambiguous. + else Error_Pragma_Arg - ("ambiguous handler name for pragma% ", Arg); + ("ambiguous handler name for pragma%", Arg); end if; end if; @@ -6928,9 +6989,13 @@ package body Sem_Prag is end loop; if not Found then + -- Issue an error if we haven't found a suitable match for + -- Name. + Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); + else Proc := Entity (Name); end if; @@ -7249,7 +7314,7 @@ package body Sem_Prag is procedure Process_Atomic_Independent_Shared_Volatile is procedure Check_Full_Access_Only (Ent : Entity_Id); -- Apply legality checks to type or object Ent subject to the - -- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)). + -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)). procedure Mark_Component_Or_Object (Ent : Entity_Id); -- Appropriately set flags on the given entity, either an array or @@ -7421,7 +7486,7 @@ package body Sem_Prag is -- Attribute belongs on the base type. If the view of the type is -- currently private, it also belongs on the underlying type. - -- In Ada 2020, the pragma can apply to a formal type, for which + -- In Ada 2022, the pragma can apply to a formal type, for which -- there may be no underlying type. if Prag_Id = Pragma_Atomic @@ -7497,7 +7562,7 @@ package body Sem_Prag is end if; if not Has_Alignment_Clause (Ent) then - Set_Alignment (Ent, Uint_0); + Init_Alignment (Ent); end if; end Set_Atomic_VFA; @@ -7532,14 +7597,14 @@ package body Sem_Prag is Check_Duplicate_Pragma (E); - -- Check the constraints of Full_Access_Only in Ada 2020. Note that + -- Check the constraints of Full_Access_Only in Ada 2022. Note that -- they do not apply to GNAT's Volatile_Full_Access because 1) this -- aspect subsumes the Volatile aspect and 2) nesting is supported -- for this aspect and the outermost enclosing VFA object prevails. -- Note also that we used to forbid specifying both Atomic and VFA on -- the same type or object, but the restriction has been lifted in - -- light of the semantics of Full_Access_Only and Atomic in Ada 2020. + -- light of the semantics of Full_Access_Only and Atomic in Ada 2022. if Prag_Id = Pragma_Volatile_Full_Access and then From_Aspect_Specification (N) @@ -9118,7 +9183,10 @@ package body Sem_Prag is Def_Id := Entity (Def_Id); Kill_Size_Check_Code (Def_Id); - Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False); + if Ekind (Def_Id) /= E_Constant then + Note_Possible_Modification + (Get_Pragma_Arg (Arg1), Sure => False); + end if; else Process_Convention (C, Def_Id); @@ -9128,7 +9196,10 @@ package body Sem_Prag is Mark_Ghost_Pragma (N, Def_Id); Kill_Size_Check_Code (Def_Id); - Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); + if Ekind (Def_Id) /= E_Constant then + Note_Possible_Modification + (Get_Pragma_Arg (Arg2), Sure => False); + end if; end if; -- Various error checks @@ -9233,7 +9304,9 @@ package body Sem_Prag is -- just the same scope). If the pragma comes from an aspect -- specification we know that it is part of the declaration. - elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) + elsif (No (Unit_Declaration_Node (Def_Id)) + or else Parent (Unit_Declaration_Node (Def_Id)) /= + Parent (N)) and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux and then not From_Aspect_Specification (N) then @@ -9824,7 +9897,7 @@ package body Sem_Prag is -- inlineable either. elsif Is_Generic_Instance (Subp) - or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration + or else Parent_Kind (Parent (Subp)) = N_Subprogram_Declaration then null; @@ -9870,7 +9943,11 @@ package body Sem_Prag is if In_Same_Source_Unit (Subp, Inner_Subp) then Set_Inline_Flags (Inner_Subp); - Decl := Parent (Parent (Inner_Subp)); + if Present (Parent (Inner_Subp)) then + Decl := Parent (Parent (Inner_Subp)); + else + Decl := Empty; + end if; if Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) @@ -10453,6 +10530,41 @@ package body Sem_Prag is Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); end if; + -- Special processing for No_Dynamic_Accessibility_Checks to + -- disallow exclusive specification in a body or subunit. + + elsif R_Id = No_Dynamic_Accessibility_Checks + -- Check if the restriction is within configuration pragma + -- in a similar way to No_Elaboration_Code. + + and then not (Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N)) + + and then Nkind (Unit (Parent (N))) = N_Compilation_Unit + + and then (Nkind (Unit (Parent (N))) = N_Package_Body + or else Nkind (Unit (Parent (N))) = N_Subunit) + + and then not Restriction_Active + (No_Dynamic_Accessibility_Checks) + then + Error_Msg_N + ("invalid specification of " & + """No_Dynamic_Accessibility_Checks""", N); + + if Nkind (Unit (Parent (N))) = N_Package_Body then + Error_Msg_N + ("\restriction cannot be specified in a package " & + "body", N); + + elsif Nkind (Unit (Parent (N))) = N_Subunit then + Error_Msg_N + ("\restriction cannot be specified in a subunit", N); + end if; + + Error_Msg_N + ("\unless also specified in spec", N); + -- Special processing for No_Tasking restriction (not just a -- warning) when it appears as a configuration pragma. @@ -10860,8 +10972,8 @@ package body Sem_Prag is procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is pragma Unreferenced (N, E); begin - -- For GCC back ends the validation is done a priori - -- ??? This code is dead, might be useful in the future + -- For GCC back ends the validation is done a priori. This code is + -- dead, but might be useful in the future. -- if not AAMP_On_Target then -- return; @@ -10933,10 +11045,6 @@ package body Sem_Prag is end if; end if; - if Warn_On_Export_Import and then Is_Type (E) then - Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); - end if; - if Warn_On_Export_Import and Inside_A_Generic then Error_Msg_NE ("all instances of& will have the same external name?x?", @@ -11329,7 +11437,7 @@ package body Sem_Prag is Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); - -- Set the following restriction which was added to Ada 2020, + -- Set the following restriction which was added to Ada 2022, -- but as a binding interpretation: -- No_Dependence => Ada.Synchronous_Barriers -- for Ravenscar (and therefore for Ravenscar variants) but not @@ -11973,7 +12081,7 @@ package body Sem_Prag is Set_Comes_From_Source (State_Id, not Is_Null); Set_Parent (State_Id, State); - Set_Ekind (State_Id, E_Abstract_State); + Mutate_Ekind (State_Id, E_Abstract_State); Set_Etype (State_Id, Standard_Void_Type); Set_Encapsulating_State (State_Id, Empty); @@ -12524,26 +12632,65 @@ package body Sem_Prag is end; -------------- - -- Ada_2020 -- + -- Ada_2022 -- -------------- - -- pragma Ada_2020; + -- pragma Ada_2022; + -- pragma Ada_2022 (LOCAL_NAME): -- Note: this pragma also has some specific processing in Par.Prag - -- because we want to set the Ada 2020 version mode during parsing. + -- because we want to set the Ada 2022 version mode during parsing. + + -- The one argument form is used for managing the transition from Ada + -- 2012 to Ada 2022 in the run-time library. If an entity is marked + -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022 + -- mode will generate a warning;for calls to Ada_2022 only primitives + -- that require overriding an error will be reported. In addition, in + -- any pre-Ada_2022 mode, a preference rule is established which does + -- not choose such an entity unless it is unambiguously specified. + -- This avoids extra subprograms marked this way from generating + -- ambiguities in otherwise legal pre-Ada 2022 programs. The one + -- argument form is intended for exclusive use in the GNAT run-time + -- library. + + when Pragma_Ada_2022 => + declare + E_Id : Node_Id; - when Pragma_Ada_2020 => + begin GNAT_Pragma; - Check_Arg_Count (0); + if Arg_Count = 1 then + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); - Check_Valid_Configuration_Pragma; + if Etype (E_Id) = Any_Type then + return; + end if; + + Set_Is_Ada_2022_Only (Entity (E_Id)); + Record_Rep_Item (Entity (E_Id), N); + + else + Check_Arg_Count (0); - -- Now set appropriate Ada mode + -- For Ada_2022 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2022. That + -- would cause real difficulties for those cases where there + -- are incompatibilities between Ada 2012 and Ada 2022. We + -- could allow mixing of Ada 2012 and Ada 2022 but it's not + -- worth it. - Ada_Version := Ada_2020; - Ada_Version_Explicit := Ada_2020; - Ada_Version_Pragma := N; + Check_Valid_Configuration_Pragma; + + -- Now set appropriate Ada mode + + Ada_Version := Ada_2022; + Ada_Version_Explicit := Ada_2022; + Ada_Version_Pragma := N; + end if; + end; ------------------------------------- -- Aggregate_Individually_Assign -- @@ -12623,7 +12770,7 @@ package body Sem_Prag is -- external tool and a tool-specific function. These arguments are -- not analyzed. - when Pragma_Annotate => Annotate : declare + when Pragma_Annotate | Pragma_GNAT_Annotate => Annotate : declare Arg : Node_Id; Expr : Node_Id; Nam_Arg : Node_Id; @@ -13426,7 +13573,7 @@ package body Sem_Prag is Arg1); end if; - -- Only other possibility is Access-to-class-wide type + -- Only other possibility is access-to-class-wide type elsif Is_Access_Type (Nm) and then Is_Class_Wide_Type (Designated_Type (Nm)) @@ -13502,7 +13649,7 @@ package body Sem_Prag is and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) or else - (Ada_Version >= Ada_2020 + (Ada_Version >= Ada_2022 and then Nkind (D) = N_Formal_Type_Declaration) then -- The flag is set on the base type, or on the object @@ -14591,7 +14738,6 @@ package body Sem_Prag is -- [, [Link_Name =>] static_string_EXPRESSION ]); when Pragma_CPP_Constructor => CPP_Constructor : declare - Elmt : Elmt_Id; Id : Entity_Id; Def_Id : Entity_Id; Tag_Typ : Entity_Id; @@ -14658,12 +14804,7 @@ package body Sem_Prag is then Tag_Typ := Etype (Def_Id); - Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); - while Present (Elmt) and then Node (Elmt) /= Def_Id loop - Next_Elmt (Elmt); - end loop; - - Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Remove (Primitive_Operations (Tag_Typ), Def_Id); Set_Is_Dispatching_Operation (Def_Id, False); end if; @@ -14724,6 +14865,8 @@ package body Sem_Prag is end if; if Nkind (N) = N_Aggregate + and then not Null_Record_Present (N) + and then No (Component_Associations (N)) and then List_Length (Expressions (N)) = 3 then Expr := First (Expressions (N)); @@ -14745,7 +14888,7 @@ package body Sem_Prag is Shared_Memory : Node_Id; Stream : Node_Id; - -- Start of processing for CUDA_Execute + -- Start of processing for CUDA_Execute begin GNAT_Pragma; @@ -14754,7 +14897,7 @@ package body Sem_Prag is Analyze_And_Resolve (Kernel_Call); if Nkind (Kernel_Call) /= N_Function_Call - or else Etype (Kernel_Call) /= Standard_Void_Type + or else Etype (Kernel_Call) /= Standard_Void_Type then -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`, -- GNAT sees Kernel_Call as an N_Function_Call since @@ -14795,7 +14938,7 @@ package body Sem_Prag is -- CUDA_Global -- ----------------- - -- pragma CUDA_Global (IDENTIFIER); + -- pragma CUDA_Global ([Entity =>] IDENTIFIER); when Pragma_CUDA_Global => CUDA_Global : declare Arg_Node : Node_Id; @@ -14803,8 +14946,7 @@ package body Sem_Prag is Pack_Id : Entity_Id; begin GNAT_Pragma; - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (1); + Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); @@ -15041,9 +15183,8 @@ package body Sem_Prag is else -- All other cases: diagnose error - Error_Msg - ("argument of pragma ""Debug"" is not procedure call", - Sloc (Call)); + Error_Msg_N + ("argument of pragma ""Debug"" is not procedure call", Call); return; end if; @@ -16097,7 +16238,8 @@ package body Sem_Prag is begin Set_Is_Exported (Id2, Is_Exported (Def_Id)); Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); - Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); + Set_Interface_Name + (Id2, Einfo.Entities.Interface_Name (Def_Id)); end; end if; end Export; @@ -16274,25 +16416,6 @@ package body Sem_Prag is Arg_Mechanism => Mechanism); end Export_Procedure; - ------------------ - -- Export_Value -- - ------------------ - - -- pragma Export_Value ( - -- [Value =>] static_integer_EXPRESSION, - -- [Link_Name =>] static_string_EXPRESSION); - - when Pragma_Export_Value => - GNAT_Pragma; - Check_Arg_Order ((Name_Value, Name_Link_Name)); - Check_Arg_Count (2); - - Check_Optional_Identifier (Arg1, Name_Value); - Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); - - Check_Optional_Identifier (Arg2, Name_Link_Name); - Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); - ----------------------------- -- Export_Valued_Procedure -- ----------------------------- @@ -16402,11 +16525,8 @@ package body Sem_Prag is Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); if Chars (Get_Pragma_Arg (Arg1)) = Name_On then - Extensions_Allowed := True; - Ada_Version := Ada_Version_Type'Last; - + Ada_Version := Ada_With_Extensions; else - Extensions_Allowed := False; Ada_Version := Ada_Version_Explicit; Ada_Version_Pragma := Empty; end if; @@ -19787,7 +19907,7 @@ package body Sem_Prag is raise Pragma_Exit; end if; - -- Loop to find matching procedures or functions (Ada 2020) + -- Loop to find matching procedures or functions (Ada 2022) E := Entity (Id); @@ -19795,10 +19915,10 @@ package body Sem_Prag is while Present (E) and then Scope (E) = Current_Scope loop - -- Ada 2020 (AI12-0269): A function can be No_Return + -- Ada 2022 (AI12-0269): A function can be No_Return if Ekind (E) in E_Generic_Procedure | E_Procedure - or else (Ada_Version >= Ada_2020 + or else (Ada_Version >= Ada_2022 and then Ekind (E) in E_Generic_Function | E_Function) then @@ -19890,7 +20010,7 @@ package body Sem_Prag is then Set_No_Return (Entity (Id)); - elsif Ada_Version >= Ada_2020 then + elsif Ada_Version >= Ada_2022 then Error_Pragma_Arg ("no subprogram& found for pragma%", Arg); @@ -20403,7 +20523,8 @@ package body Sem_Prag is elsif Chars (Argx) = Name_Eliminated then if Ttypes.Standard_Long_Long_Integer_Size /= 64 then Error_Pragma_Arg - ("Eliminated not implemented on this target", Argx); + ("Eliminated requires Long_Long_Integer'Size = 64", + Argx); else return Eliminated; end if; @@ -24919,16 +25040,6 @@ package body Sem_Prag is Record_Rep_Item (E, N); end Universal_Alias; - -------------------- - -- Universal_Data -- - -------------------- - - -- pragma Universal_Data [(library_unit_NAME)]; - - when Pragma_Universal_Data => - GNAT_Pragma; - Error_Pragma ("??pragma% ignored (applies only to AAMP)"); - ---------------- -- Unmodified -- ---------------- @@ -25632,9 +25743,9 @@ package body Sem_Prag is Set_Specific_Warning_On (Loc, Message, Err); if Err then - Error_Msg + Error_Msg_N ("??pragma Warnings On with no matching " - & "Warnings Off", Loc); + & "Warnings Off", N); end if; end if; end; @@ -29206,8 +29317,8 @@ package body Sem_Prag is -- Check that the expression is a proper aggregate (no parentheses) if Paren_Count (Variants) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Variants)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Variants); end if; -- Ensure that the formal parameters are visible when analyzing all @@ -30245,19 +30356,9 @@ package body Sem_Prag is -- Process all formal parameters - Formal := First_Entity (Spec_Id); + Formal := First_Formal (Spec_Id); while Present (Formal) loop if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then - - -- IN parameters can act as output when the related type is - -- access-to-variable. - - if Ekind (Formal) = E_In_Parameter - and then Is_Access_Variable (Etype (Formal)) - then - Append_New_Elmt (Formal, Subp_Outputs); - end if; - Append_New_Elmt (Formal, Subp_Inputs); end if; @@ -30275,7 +30376,18 @@ package body Sem_Prag is end if; end if; - Next_Entity (Formal); + -- IN parameters of procedures and protected entries can act as + -- outputs when the related type is access-to-variable. + + if Ekind (Formal) = E_In_Parameter + and then Ekind (Spec_Id) not in E_Function + | E_Generic_Function + and then Is_Access_Variable (Etype (Formal)) + then + Append_New_Elmt (Formal, Subp_Outputs); + end if; + + Next_Formal (Formal); end loop; -- Otherwise the input denotes a task type, a task body, or the @@ -30475,6 +30587,16 @@ package body Sem_Prag is Stmt : Node_Id; begin + -- If the pragma comes from an aspect on a compilation unit that is a + -- package instance, then return the original package instantiation + -- node. + + if Nkind (Parent (Prag)) = N_Compilation_Unit_Aux then + return + Get_Unit_Instantiation_Node + (Defining_Entity (Unit (Enclosing_Comp_Unit_Node (Prag)))); + end if; + Stmt := Prev (Prag); while Present (Stmt) loop @@ -30639,17 +30761,17 @@ package body Sem_Prag is elsif Present (Generic_Parent (Specification (Stmt))) then return Stmt; - -- Ada 2020: contract on formal subprogram or on generated + -- Ada 2022: contract on formal subprogram or on generated -- Access_Subprogram_Wrapper, which appears after the related -- Access_Subprogram declaration. elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt)) - and then Ada_Version >= Ada_2020 + and then Ada_Version >= Ada_2022 then return Stmt; elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt)) - and then Ada_Version >= Ada_2020 + and then Ada_Version >= Ada_2022 then return Stmt; end if; @@ -30678,14 +30800,19 @@ package body Sem_Prag is elsif Nkind (Context) = N_Entry_Body then return Context; - -- The pragma appears inside the statements of a subprogram body. This - -- placement is the result of subprogram contract expansion. + -- The pragma appears inside the statements of a subprogram body at + -- some nested level. elsif Is_Statement (Context) and then Present (Enclosing_HSS (Context)) then return Parent (Enclosing_HSS (Context)); + -- The pragma appears directly in the statements of a subprogram body + + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then + return Parent (Context); + -- The pragma appears inside the declarative part of a package body elsif Nkind (Context) = N_Package_Body then @@ -30847,7 +30974,7 @@ package body Sem_Prag is -- Follow subprogram renaming chain if Is_Subprogram (Def_Id) - and then Nkind (Parent (Declaration_Node (Def_Id))) = + and then Parent_Kind (Declaration_Node (Def_Id)) = N_Subprogram_Renaming_Declaration and then Present (Alias (Def_Id)) then @@ -31118,7 +31245,7 @@ package body Sem_Prag is Pragma_Ada_2005 => -1, Pragma_Ada_12 => -1, Pragma_Ada_2012 => -1, - Pragma_Ada_2020 => -1, + Pragma_Ada_2022 => -1, Pragma_Aggregate_Individually_Assign => 0, Pragma_All_Calls_Remote => -1, Pragma_Allow_Integer_Address => -1, @@ -31184,7 +31311,6 @@ package body Sem_Prag is Pragma_Export_Function => -1, Pragma_Export_Object => -1, Pragma_Export_Procedure => -1, - Pragma_Export_Value => -1, Pragma_Export_Valued_Procedure => -1, Pragma_Extend_System => -1, Pragma_Extensions_Allowed => 0, @@ -31196,6 +31322,7 @@ package body Sem_Prag is Pragma_Finalize_Storage_Only => 0, Pragma_Ghost => 0, Pragma_Global => -1, + Pragma_GNAT_Annotate => 93, Pragma_Ident => -1, Pragma_Ignore_Pragma => 0, Pragma_Implementation_Defined => -1, @@ -31339,7 +31466,6 @@ package body Sem_Prag is Pragma_Unevaluated_Use_Of_Old => 0, Pragma_Unimplemented_Unit => 0, Pragma_Universal_Aliasing => 0, - Pragma_Universal_Data => 0, Pragma_Unmodified => 0, Pragma_Unreferenced => 0, Pragma_Unreferenced_Objects => 0, |