diff options
Diffstat (limited to 'gcc/ada/exp_prag.adb')
| -rw-r--r-- | gcc/ada/exp_prag.adb | 145 |
1 files changed, 89 insertions, 56 deletions
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index d616fb6..43ecdcd 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_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- -- @@ -23,38 +23,42 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Casing; use Casing; -with Checks; use Checks; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Ch11; use Exp_Ch11; -with Exp_Util; use Exp_Util; -with Expander; use Expander; -with Inline; use Inline; -with Lib; use Lib; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch8; use Sem_Ch8; -with Sem_Prag; use Sem_Prag; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Snames; use Snames; -with Stringt; use Stringt; -with Stand; use Stand; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Validsw; use Validsw; +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +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_Ch11; use Exp_Ch11; +with Exp_Util; use Exp_Util; +with Expander; use Expander; +with Inline; use Inline; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch8; use Sem_Ch8; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Validsw; use Validsw; package body Exp_Prag is @@ -771,7 +775,7 @@ package body Exp_Prag is function Get_Nth_Arg_Type (Subprogram : Entity_Id; N : Positive) return Entity_Id; - -- Returns the type of the Nth argument of Subprogram. + -- Returns the type of the Nth argument of Subprogram function To_Addresses (Elmts : Elist_Id) return List_Id; -- Returns a new list containing each element of Elmts wrapped in an @@ -821,9 +825,9 @@ package body Exp_Prag is Init_Val : Node_Id) return Node_Id is -- Expressions for each component of the returned Dim3 - Dim_X : Node_Id; - Dim_Y : Node_Id; - Dim_Z : Node_Id; + Dim_X : Node_Id; + Dim_Y : Node_Id; + Dim_Z : Node_Id; -- Type of CUDA.Internal.Dim3 - inferred from -- RE_Push_Call_Configuration to avoid needing changes in GNAT when @@ -835,12 +839,13 @@ package body Exp_Prag is First_Component : Entity_Id := First_Entity (RTE (RE_Dim3)); Second_Component : Entity_Id := Next_Entity (First_Component); Third_Component : Entity_Id := Next_Entity (Second_Component); + begin - -- Sem_prag.adb ensured that Init_Val is either a Dim3, an - -- aggregate of three Any_Integers or Any_Integer. + -- Sem_prag.adb ensured that Init_Val is either a Dim3, an aggregate + -- of three Any_Integers or Any_Integer. - -- If Init_Val is a Dim3, use each of its components. + -- If Init_Val is a Dim3, use each of its components if Etype (Init_Val) = RTE (RE_Dim3) then Dim_X := Make_Selected_Component (Loc, @@ -862,7 +867,7 @@ package body Exp_Prag is Dim_Y := Next (Dim_X); Dim_Z := Next (Dim_Y); - -- Otherwise, we know it is an integer and the rest defaults to 1. + -- Otherwise, we know it is an integer and the rest defaults to 1 else Dim_X := Init_Val; @@ -1011,14 +1016,13 @@ package body Exp_Prag is Default_Val => Make_Null (Loc)); end Build_Stream_Declaration; - ------------------------ - -- Etype_Or_Dim3 -- - ------------------------ + ------------------- + -- Etype_Or_Dim3 -- + ------------------- function Etype_Or_Dim3 (N : Node_Id) return Node_Id is begin - if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) - then + if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) then return New_Occurrence_Of (RTE (RE_Dim3), Sloc (N)); end if; @@ -1036,7 +1040,7 @@ package body Exp_Prag is Argument : Entity_Id := First_Entity (Subprogram); begin for J in 2 .. N loop - Argument := Next_Entity (Argument); + Next_Entity (Argument); end loop; return Etype (Argument); @@ -1098,8 +1102,7 @@ package body Exp_Prag is Object_Definition => Etype_Or_Dim3 (Block_Dimensions), Expression => Block_Dimensions); - -- List holding the entities of the copies of Procedure_Call's - -- arguments. + -- List holding the entities of the copies of Procedure_Call's arguments Kernel_Arg_Copies : constant Elist_Id := New_Elmt_List; @@ -1114,7 +1117,7 @@ package body Exp_Prag is Pop_Call : Node_Id; Push_Call : Node_Id; - -- Declaration of all temporaries required for CUDA API Calls. + -- Declaration of all temporaries required for CUDA API Calls Blk_Decls : constant List_Id := New_List; @@ -1567,7 +1570,7 @@ package body Exp_Prag is -- effects). Assign prefix value to temp on Eval_Statement -- list, so assignment will be executed conditionally. - Set_Ekind (Temp, E_Variable); + Mutate_Ekind (Temp, E_Variable); Set_Suppress_Initialization (Temp); Analyze (Decl); @@ -2036,7 +2039,7 @@ package body Exp_Prag is Expression => Relocate_Node (Rtti_Name)))))); Rewrite (Expression (Foreign_Data), - Unchecked_Convert_To (Standard_A_Char, + OK_Convert_To (Standard_Address, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (Dum)), Attribute_Name => Name_Address))); @@ -2269,7 +2272,7 @@ package body Exp_Prag is Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition")); - Set_Ekind (Proc_Id, E_Procedure); + Mutate_Ekind (Proc_Id, E_Procedure); Set_Is_Initial_Condition_Procedure (Proc_Id); -- Generate: @@ -2358,6 +2361,7 @@ package body Exp_Prag is S : Entity_Id; E : Entity_Id; + Remove_Inspection_Point : Boolean := False; begin if No (Pragma_Argument_Associations (N)) then A := New_List; @@ -2369,10 +2373,9 @@ package body Exp_Prag is if Comes_From_Source (E) and then Is_Object (E) and then not Is_Entry_Formal (E) + and then not Is_Formal_Object (E) and then Ekind (E) /= E_Component and then Ekind (E) /= E_Discriminant - and then Ekind (E) /= E_Generic_In_Parameter - and then Ekind (E) /= E_Generic_In_Out_Parameter then Append_To (A, Make_Pragma_Argument_Association (Loc, @@ -2398,6 +2401,36 @@ package body Exp_Prag is Expand (Expression (Assoc)); Next (Assoc); end loop; + + -- If any of the references have a freeze node, it must appear before + -- pragma Inspection_Point, otherwise the entity won't be available when + -- Gigi processes Inspection_Point. + -- When this requirement isn't met, turn the pragma into a no-op. + + Assoc := First (Pragma_Argument_Associations (N)); + while Present (Assoc) loop + + if Present (Freeze_Node (Entity (Expression (Assoc)))) and then + not Is_Frozen (Entity (Expression (Assoc))) + then + Error_Msg_NE ("??inspection point references unfrozen object &", + Assoc, + Entity (Expression (Assoc))); + Remove_Inspection_Point := True; + end if; + + Next (Assoc); + end loop; + + if Remove_Inspection_Point then + Error_Msg_N ("\pragma will be ignored", N); + + -- We can't just remove the pragma from the tree as it might be + -- iterated over by the caller. Turn it into a null statement + -- instead. + + Rewrite (N, Make_Null_Statement (Sloc (N))); + end if; end Expand_Pragma_Inspection_Point; -------------------------------------- @@ -3141,7 +3174,7 @@ package body Exp_Prag is begin -- When applied to a variable, the default initialization must not be -- done. As it is already done when the pragma is found, we just get rid - -- of the call the initialization procedure which followed the object + -- of the call to the initialization procedure which followed the object -- declaration. The call is inserted after the declaration, but validity -- checks may also have been inserted and thus the initialization call -- does not necessarily appear immediately after the object declaration. |