From c23c86bb171edf47767dbc56545c0b535b526c5b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 11:51:24 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Hristian Kirtchev * sem_ch3.adb, sem_ch7.adb, sem_util.adb, g-debpoo.adb, sem_ch4.adb, sem_ch6.adb, sem_ch8.adb: Minor reformatting. * exp_util.adb (Is_Source_Object): Account for the cases where the source object may appear as a dereference or within a type conversion. * exp_ch6.adb: Fix missing space in error message. 2017-09-06 Ed Schonberg * sem_prag.adb: Update description of Eliminate. From-SVN: r251762 --- gcc/ada/ChangeLog | 14 ++ gcc/ada/exp_ch6.adb | 2 +- gcc/ada/exp_util.adb | 30 ++++- gcc/ada/g-debpoo.adb | 150 +++++++++++---------- gcc/ada/sem_ch3.adb | 6 +- gcc/ada/sem_ch4.adb | 5 +- gcc/ada/sem_ch6.adb | 3 +- gcc/ada/sem_ch7.adb | 4 +- gcc/ada/sem_ch8.adb | 1 - gcc/ada/sem_prag.adb | 29 ++-- gcc/ada/sem_util.adb | 309 ++++++++++++++++++++++--------------------- 11 files changed, 293 insertions(+), 260 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 19a6d3aeff6..5667112694d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2017-09-06 Hristian Kirtchev + + * sem_ch3.adb, sem_ch7.adb, sem_util.adb, g-debpoo.adb, sem_ch4.adb, + sem_ch6.adb, sem_ch8.adb: Minor reformatting. + * exp_util.adb (Is_Source_Object): Account for + the cases where the source object may appear as a dereference + or within a type conversion. + * exp_ch6.adb: Fix missing space in error message. + +2017-09-06 Ed Schonberg + + * sem_prag.adb: Update description of Eliminate. + + 2017-09-06 Ed Schonberg * sem_attr.adb (Analyze_Attribute, case 'Loop_Entry): Handle diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3fb546805ff..3101b7c35c1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3515,7 +3515,7 @@ package body Exp_Ch6 is elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then Error_Msg_NE ("tag-indeterminate expression must have type&" - & "(RM 5.2 (6))", + & " (RM 5.2 (6))", Call_Node, Root_Type (Etype (Name (Ass)))); else diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bcdd92af93f..7f7bc0bd977 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7648,11 +7648,12 @@ package body Exp_Util is ---------------------- function Is_Displace_Call (N : Node_Id) return Boolean is - Call : Node_Id := N; + Call : Node_Id; begin -- Strip various actions which may precede a call to Displace + Call := N; loop if Nkind (Call) = N_Explicit_Dereference then Call := Prefix (Call); @@ -7678,12 +7679,31 @@ package body Exp_Util is ---------------------- function Is_Source_Object (N : Node_Id) return Boolean is + Obj : Node_Id; + begin + -- Strip various actions which may be associated with the object + + Obj := N; + loop + if Nkind (Obj) = N_Explicit_Dereference then + Obj := Prefix (Obj); + + elsif Nkind_In (Obj, N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Obj := Expression (Obj); + + else + exit; + end if; + end loop; + return - Present (N) - and then Nkind (N) in N_Has_Entity - and then Is_Object (Entity (N)) - and then Comes_From_Source (N); + Present (Obj) + and then Nkind (Obj) in N_Has_Entity + and then Is_Object (Entity (Obj)) + and then Comes_From_Source (Obj); end Is_Source_Object; -- Local variables diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 42acdbdbed7..9934e6185e4 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -389,13 +389,13 @@ package body GNAT.Debug_Pools is type Scope_Lock is new Ada.Finalization.Limited_Controlled with null record; - -- to handle Lock_Task/Unlock_Task calls + -- Used to handle Lock_Task/Unlock_Task calls overriding procedure Initialize (This : in out Scope_Lock); - -- lock task on initialization + -- Lock task on initialization overriding procedure Finalize (This : in out Scope_Lock); - -- unlock task on finalization + -- Unlock task on finalization ---------------- -- Initialize -- @@ -431,11 +431,13 @@ package body GNAT.Debug_Pools is -- Header_Of -- --------------- - function Header_Of (Address : System.Address) - return Allocation_Header_Access + function Header_Of + (Address : System.Address) return Allocation_Header_Access is - function Convert is new Ada.Unchecked_Conversion - (System.Address, Allocation_Header_Access); + function Convert is + new Ada.Unchecked_Conversion + (System.Address, + Allocation_Header_Access); begin return Convert (Address - Header_Offset); end Header_Of; @@ -457,7 +459,8 @@ package body GNAT.Debug_Pools is ---------- function Next - (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr is + (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr + is begin return E.Next; end Next; @@ -1366,6 +1369,7 @@ package body GNAT.Debug_Pools is procedure Reset_Marks is Current : System.Address := Pool.First_Free_Block; Header : Allocation_Header_Access; + begin while Current /= System.Null_Address loop Header := Header_Of (Current); @@ -1377,10 +1381,9 @@ package body GNAT.Debug_Pools is Lock : Scope_Lock; pragma Unreferenced (Lock); - -- Start of processing for Free_Physically + -- Start of processing for Free_Physically begin - if Pool.Advanced_Scanning then -- Reset the mark for each freed block @@ -1393,7 +1396,7 @@ package body GNAT.Debug_Pools is Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning); -- The contract is that we need to free at least Minimum_To_Free bytes, - -- even if this means freeing marked blocks in the advanced scheme + -- even if this means freeing marked blocks in the advanced scheme. if Total_Freed < Pool.Minimum_To_Free and then Pool.Advanced_Scanning @@ -1401,7 +1404,6 @@ package body GNAT.Debug_Pools is Pool.Marked_Blocks_Deallocated := True; Free_Blocks (Ignore_Marks => True); end if; - end Free_Physically; -------------- @@ -1411,19 +1413,19 @@ package body GNAT.Debug_Pools is procedure Get_Size (Storage_Address : Address; Size_In_Storage_Elements : out Storage_Count; - Valid : out Boolean) is - + Valid : out Boolean) + is Lock : Scope_Lock; pragma Unreferenced (Lock); begin - Valid := Is_Valid (Storage_Address); if Is_Valid (Storage_Address) then declare - Header : constant Allocation_Header_Access := - Header_Of (Storage_Address); + Header : constant Allocation_Header_Access := + Header_Of (Storage_Address); + begin if Header.Block_Size >= 0 then Valid := True; @@ -1435,7 +1437,6 @@ package body GNAT.Debug_Pools is else Valid := False; end if; - end Get_Size; --------------------- @@ -1445,7 +1446,8 @@ package body GNAT.Debug_Pools is procedure Print_Traceback (Output_File : File_Type; Prefix : String; - Traceback : Traceback_Htable_Elem_Ptr) is + Traceback : Traceback_Htable_Elem_Ptr) + is begin if Traceback /= null then Put (Output_File, Prefix); @@ -1466,9 +1468,10 @@ package body GNAT.Debug_Pools is pragma Unreferenced (Alignment); Header : constant Allocation_Header_Access := - Header_Of (Storage_Address); - Valid : Boolean; + Header_Of (Storage_Address); Previous : System.Address; + Valid : Boolean; + Header_Block_Size_Was_Less_Than_0 : Boolean := True; begin @@ -1477,6 +1480,7 @@ package body GNAT.Debug_Pools is declare Lock : Scope_Lock; pragma Unreferenced (Lock); + begin Valid := Is_Valid (Storage_Address); @@ -1484,9 +1488,9 @@ package body GNAT.Debug_Pools is Header_Block_Size_Was_Less_Than_0 := False; -- Some sort of codegen problem or heap corruption caused the - -- Size_In_Storage_Elements to be wrongly computed. - -- The code below is all based on the assumption that Header.all - -- is not corrupted, such that the error is non-fatal. + -- Size_In_Storage_Elements to be wrongly computed. The code + -- below is all based on the assumption that Header.all is not + -- corrupted, such that the error is non-fatal. if Header.Block_Size /= Size_In_Storage_Elements and then Size_In_Storage_Elements /= Storage_Count'Last @@ -1591,11 +1595,9 @@ package body GNAT.Debug_Pools is -- Do not physically release the memory here, but in Alloc. -- See comment there for details. end if; - end; if not Valid then - if Storage_Address = System.Null_Address then if Pool.Raise_Exceptions and then Size_In_Storage_Elements /= Storage_Count'Last @@ -1611,14 +1613,15 @@ package body GNAT.Debug_Pools is end if; end if; - if Allow_Unhandled_Memory and then not Is_Handled (Storage_Address) + if Allow_Unhandled_Memory + and then not Is_Handled (Storage_Address) then System.CRTL.free (Storage_Address); return; end if; - if Pool.Raise_Exceptions and then - Size_In_Storage_Elements /= Storage_Count'Last + if Pool.Raise_Exceptions + and then Size_In_Storage_Elements /= Storage_Count'Last then raise Freeing_Not_Allocated_Storage; else @@ -1630,7 +1633,6 @@ package body GNAT.Debug_Pools is end if; elsif Header_Block_Size_Was_Less_Than_0 then - if Pool.Raise_Exceptions then raise Freeing_Deallocated_Storage; else @@ -1645,9 +1647,7 @@ package body GNAT.Debug_Pools is Print_Traceback (Output_File (Pool), " Memory was allocated at ", Header.Alloc_Traceback); end if; - end if; - end Deallocate; -------------------- @@ -1750,7 +1750,6 @@ package body GNAT.Debug_Pools is Display_Slots : Boolean := False; Display_Leaks : Boolean := False) is - package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable (Header_Num => Header, Element => Traceback_Htable_Elem, @@ -1764,9 +1763,9 @@ package body GNAT.Debug_Pools is Equal => Equal); -- This needs a comment ??? probably some of the ones below do too??? + Current : System.Address; Data : Traceback_Htable_Elem_Ptr; Elem : Traceback_Htable_Elem_Ptr; - Current : System.Address; Header : Allocation_Header_Access; K : Traceback_Kind; @@ -1805,13 +1804,13 @@ package body GNAT.Debug_Pools is if Data.Kind in Alloc .. Dealloc then Elem := new Traceback_Htable_Elem' - (Traceback => new Tracebacks_Array'(Data.Traceback.all), - Count => Data.Count, - Kind => Data.Kind, - Total => Data.Total, - Frees => Data.Frees, - Total_Frees => Data.Total_Frees, - Next => null); + (Traceback => new Tracebacks_Array'(Data.Traceback.all), + Count => Data.Count, + Kind => Data.Kind, + Total => Data.Total, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); Backtrace_Htable_Cumulate.Set (Elem); if Cumulate then @@ -1828,15 +1827,18 @@ package body GNAT.Debug_Pools is -- If not, insert it if Elem = null then - Elem := new Traceback_Htable_Elem' - (Traceback => new Tracebacks_Array' - (Data.Traceback (T .. Data.Traceback'Last)), - Count => Data.Count, - Kind => K, - Total => Data.Total, - Frees => Data.Frees, - Total_Frees => Data.Total_Frees, - Next => null); + Elem := + new Traceback_Htable_Elem' + (Traceback => + new Tracebacks_Array' + (Data.Traceback + (T .. Data.Traceback'Last)), + Count => Data.Count, + Kind => K, + Total => Data.Total, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); Backtrace_Htable_Cumulate.Set (Elem); -- Properly take into account that the subprograms @@ -1924,11 +1926,15 @@ package body GNAT.Debug_Pools is procedure Dump (Pool : Debug_Pool; Size : Positive; - Report : Report_Type := All_Reports) is - + Report : Report_Type := All_Reports) + is procedure Do_Report (Sort : Report_Type); -- Do a specific type of report + --------------- + -- Do_Report -- + --------------- + procedure Do_Report (Sort : Report_Type) is Elem : Traceback_Htable_Elem_Ptr; Bigger : Boolean; @@ -1991,7 +1997,6 @@ package body GNAT.Debug_Pools is end; while Elem /= null loop - declare Lock : Scope_Lock; pragma Unreferenced (Lock); @@ -2005,13 +2010,13 @@ package body GNAT.Debug_Pools is -- gain speed. if (Sort = Memory_Usage - and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) + and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) or else (Sort = Allocations_Count - and then Elem_Safe.Count - Elem_Safe.Frees >= 1) + and then Elem_Safe.Count - Elem_Safe.Frees >= 1) or else (Sort = Sort_Total_Allocs - and then Elem_Safe.Count > 1) + and then Elem_Safe.Count > 1) or else (Sort = Marked_Blocks - and then Elem_Safe.Total = 0) + and then Elem_Safe.Total = 0) then if Sort = Marked_Blocks then Grand_Total := Grand_Total + Float (Elem_Safe.Count); @@ -2020,7 +2025,6 @@ package body GNAT.Debug_Pools is for M in Max'Range loop Bigger := Max (M) = null; if not Bigger then - declare Lock : Scope_Lock; pragma Unreferenced (Lock); @@ -2063,7 +2067,6 @@ package body GNAT.Debug_Pools is begin Elem := Backtrace_Htable.Get_Next; end; - end loop; if Grand_Total = 0.0 then @@ -2074,10 +2077,11 @@ package body GNAT.Debug_Pools is exit when Max (M) = null; declare type Percent is delta 0.1 range 0.0 .. 100.0; + + P : Percent; Total : Byte_Count; - P : Percent; - begin + begin declare Lock : Scope_Lock; pragma Unreferenced (Lock); @@ -2104,6 +2108,7 @@ package body GNAT.Debug_Pools is -- In multi tasking configuration, memory deallocations -- during Do_Report processing can lead to Total > -- Grand_Total. As Percent requires Total <= Grand_Total + begin if Normalized_Total > Grand_Total then P := 100.0; @@ -2113,7 +2118,10 @@ package body GNAT.Debug_Pools is end; case Sort is - when Memory_Usage | Allocations_Count | All_Reports => + when All_Reports + | Allocations_Count + | Memory_Usage + => declare Count : constant Natural := Max_M_Safe.Count - Max_M_Safe.Frees; @@ -2121,9 +2129,11 @@ package body GNAT.Debug_Pools is Put (P'Img & "%:" & Total'Img & " bytes in" & Count'Img & " chunks at"); end; + when Sort_Total_Allocs => Put (P'Img & "%:" & Total'Img & " bytes in" & Max_M_Safe.Count'Img & " chunks at"); + when Marked_Blocks => Put (P'Img & "%:" & Max_M_Safe.Count'Img & " chunks /" @@ -2257,8 +2267,7 @@ package body GNAT.Debug_Pools is -- High_Water_Mark -- --------------------- - function High_Water_Mark - (Pool : Debug_Pool) return Byte_Count is + function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is Lock : Scope_Lock; pragma Unreferenced (Lock); begin @@ -2269,8 +2278,7 @@ package body GNAT.Debug_Pools is -- Current_Water_Mark -- ------------------------ - function Current_Water_Mark - (Pool : Debug_Pool) return Byte_Count is + function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is Lock : Scope_Lock; pragma Unreferenced (Lock); begin @@ -2283,7 +2291,8 @@ package body GNAT.Debug_Pools is ------------------------------ procedure System_Memory_Debug_Pool - (Has_Unhandled_Memory : Boolean := True) is + (Has_Unhandled_Memory : Boolean := True) + is Lock : Scope_Lock; pragma Unreferenced (Lock); begin @@ -2329,9 +2338,9 @@ package body GNAT.Debug_Pools is Header : Allocation_Header_Access; begin - -- We might get Null_Address if the call from gdb was done - -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0, - -- instead of passing the value of my_var + -- We might get Null_Address if the call from gdb was done incorrectly. + -- For instance, doing a "print_pool(my_var)" passes 0x0, instead of + -- passing the value of my_var. if A = System.Null_Address then Put_Line @@ -2369,7 +2378,6 @@ package body GNAT.Debug_Pools is Display_Slots : Boolean := False; Display_Leaks : Boolean := False) is - procedure Internal is new Print_Info (Put_Line => Stdout_Put_Line, Put => Stdout_Put); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 93a2c891d5d..7929f0256bd 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -20785,7 +20785,7 @@ package body Sem_Ch3 is -- corresponding subtype of the full view. elsif Ekind (Priv_Dep) = E_Incomplete_Subtype - and then Comes_From_Source (Priv_Dep) + and then Comes_From_Source (Priv_Dep) then Set_Subtype_Indication (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); @@ -20793,8 +20793,8 @@ package body Sem_Ch3 is Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); Set_Analyzed (Parent (Priv_Dep), False); - -- Reanalyze the declaration, suppressing the call to - -- Enter_Name to avoid duplicate names. + -- Reanalyze the declaration, suppressing the call to Enter_Name + -- to avoid duplicate names. Analyze_Subtype_Declaration (N => Parent (Priv_Dep), diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index cb50ee77fd8..8952a9ef7e5 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2936,8 +2936,8 @@ package body Sem_Ch4 is Set_Etype (Alt, It.Typ); - -- If the alternative is an enumeration literal, use - -- the one for this interpretation. + -- If the alternative is an enumeration literal, use the one + -- for this interpretation. if Is_Entity_Name (Alt) then Set_Entity (Alt, It.Nam); @@ -2948,7 +2948,6 @@ package body Sem_Ch4 is if No (It.Typ) then Set_Is_Overloaded (Alt, False); Common_Type := Etype (Alt); - end if; Candidate_Interps := Alt; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fc01d8b015f..837f390a2ef 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1468,8 +1468,7 @@ package body Sem_Ch6 is -- there are various error checks that are applied on this body -- when it is analyzed (e.g. correct aspect placement). - if Has_Completion (Prev) - then + if Has_Completion (Prev) then Error_Msg_Sloc := Sloc (Prev); Error_Msg_NE ("duplicate body for & declared#", N, Prev); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index d5e0f4b9f26..1ec33951c78 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1441,8 +1441,8 @@ package body Sem_Ch7 is -- Check on incomplete types - -- AI05-0213: A formal incomplete type has no completion, - -- and neither does the corresponding subtype in an instance. + -- AI05-0213: A formal incomplete type has no completion, and neither + -- does the corresponding subtype in an instance. if Is_Incomplete_Type (E) and then No (Full_View (E)) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index ac1897cdab5..ca9ac47950f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2892,7 +2892,6 @@ package body Sem_Ch8 is -- Case of Renaming_As_Body if Present (Rename_Spec) then - Check_Previous_Null_Procedure (N, Rename_Spec); -- Renaming declaration is the completion of the declaration of diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 2e280a5c760..bfca18d87df 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14734,25 +14734,11 @@ package body Sem_Prag is --------------- -- pragma Eliminate ( - -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, - -- [,[Entity =>] IDENTIFIER | - -- SELECTED_COMPONENT | - -- STRING_LITERAL] - -- [, OVERLOADING_RESOLUTION]); - - -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | - -- SOURCE_LOCATION - - -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE | - -- FUNCTION_PROFILE - - -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES - - -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,] - -- Result_Type => result_SUBTYPE_NAME] - - -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) - -- SUBTYPE_NAME ::= STRING_LITERAL + -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, + -- [Entity =>] IDENTIFIER | + -- SELECTED_COMPONENT | + -- STRING_LITERAL] + -- [, Source_Location => SOURCE_TRACE]); -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE -- SOURCE_TRACE ::= STRING_LITERAL @@ -14766,6 +14752,11 @@ package body Sem_Prag is Name_Result_Type, Name_Source_Location); + -- Note : Parameter_Types and Result_Type are leftovers from + -- prior implementations of the pragma. They are not generated + -- by the gnatelim tool, and play no role in selecting which + -- of a set of overloaded names is chosen for elimination. + Unit_Name : Node_Id renames Args (1); Entity : Node_Id renames Args (2); Parameter_Types : Node_Id renames Args (3); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6126b201e50..a0fcc41be37 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1900,157 +1900,6 @@ package body Sem_Util is end if; end Cannot_Raise_Constraint_Error; - ------------------------------------ - -- Check_Previous_Null_Procedure -- - ------------------------------------ - - procedure Check_Previous_Null_Procedure - (Decl : Node_Id; - Prev : Entity_Id) - is - begin - if Ekind (Prev) = E_Procedure - and then Nkind (Parent (Prev)) = N_Procedure_Specification - and then Null_Present (Parent (Prev)) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N - ("declaration cannot complete previous null procedure#", Decl); - end if; - end Check_Previous_Null_Procedure; - - ----------------------------- - -- Check_Part_Of_Reference -- - ----------------------------- - - procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is - Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id); - Decl : Node_Id; - OK_Use : Boolean := False; - Par : Node_Id; - Prag_Nam : Name_Id; - Spec_Id : Entity_Id; - - begin - -- Traverse the parent chain looking for a suitable context for the - -- reference to the concurrent constituent. - - Par := Parent (Ref); - while Present (Par) loop - if Nkind (Par) = N_Pragma then - Prag_Nam := Pragma_Name (Par); - - -- A concurrent constituent is allowed to appear in pragmas - -- Initial_Condition and Initializes as this is part of the - -- elaboration checks for the constituent (SPARK RM 9.3). - - if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then - OK_Use := True; - exit; - - -- When the reference appears within pragma Depends or Global, - -- check whether the pragma applies to a single task type. Note - -- that the pragma is not encapsulated by the type definition, - -- but this is still a valid context. - - elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then - Decl := Find_Related_Declaration_Or_Body (Par); - - if Nkind (Decl) = N_Object_Declaration - and then Defining_Entity (Decl) = Conc_Typ - then - OK_Use := True; - exit; - end if; - end if; - - -- The reference appears somewhere in the definition of the single - -- protected/task type (SPARK RM 9.3). - - elsif Nkind_In (Par, N_Single_Protected_Declaration, - N_Single_Task_Declaration) - and then Defining_Entity (Par) = Conc_Typ - then - OK_Use := True; - exit; - - -- The reference appears within the expanded declaration or the body - -- of the single protected/task type (SPARK RM 9.3). - - elsif Nkind_In (Par, N_Protected_Body, - N_Protected_Type_Declaration, - N_Task_Body, - N_Task_Type_Declaration) - then - Spec_Id := Unique_Defining_Entity (Par); - - if Present (Anonymous_Object (Spec_Id)) - and then Anonymous_Object (Spec_Id) = Conc_Typ - then - OK_Use := True; - exit; - end if; - - -- The reference has been relocated within an internally generated - -- package or subprogram. Assume that the reference is legal as the - -- real check was already performed in the original context of the - -- reference. - - elsif Nkind_In (Par, N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Subprogram_Declaration) - and then not Comes_From_Source (Par) - then - -- Continue to examine the context if the reference appears in a - -- subprogram body which was previously an expression function. - - if Nkind (Par) = N_Subprogram_Body - and then Was_Expression_Function (Par) - then - null; - - -- Otherwise the reference is legal - - else - OK_Use := True; - exit; - end if; - - -- The reference has been relocated to an inlined body for GNATprove. - -- Assume that the reference is legal as the real check was already - -- performed in the original context of the reference. - - elsif GNATprove_Mode - and then Nkind (Par) = N_Subprogram_Body - and then Chars (Defining_Entity (Par)) = Name_uParent - then - OK_Use := True; - exit; - end if; - - Par := Parent (Par); - end loop; - - -- The reference is illegal as it appears outside the definition or - -- body of the single protected/task type. - - if not OK_Use then - Error_Msg_NE - ("reference to variable & cannot appear in this context", - Ref, Var_Id); - Error_Msg_Name_1 := Chars (Var_Id); - - if Ekind (Conc_Typ) = E_Protected_Type then - Error_Msg_NE - ("\% is constituent of single protected type &", Ref, Conc_Typ); - else - Error_Msg_NE - ("\% is constituent of single task type &", Ref, Conc_Typ); - end if; - end if; - end Check_Part_Of_Reference; - ----------------------------------------- -- Check_Dynamically_Tagged_Expression -- ----------------------------------------- @@ -3333,6 +3182,138 @@ package body Sem_Util is end if; end Check_Nonvolatile_Function_Profile; + ----------------------------- + -- Check_Part_Of_Reference -- + ----------------------------- + + procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is + Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id); + Decl : Node_Id; + OK_Use : Boolean := False; + Par : Node_Id; + Prag_Nam : Name_Id; + Spec_Id : Entity_Id; + + begin + -- Traverse the parent chain looking for a suitable context for the + -- reference to the concurrent constituent. + + Par := Parent (Ref); + while Present (Par) loop + if Nkind (Par) = N_Pragma then + Prag_Nam := Pragma_Name (Par); + + -- A concurrent constituent is allowed to appear in pragmas + -- Initial_Condition and Initializes as this is part of the + -- elaboration checks for the constituent (SPARK RM 9.3). + + if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then + OK_Use := True; + exit; + + -- When the reference appears within pragma Depends or Global, + -- check whether the pragma applies to a single task type. Note + -- that the pragma is not encapsulated by the type definition, + -- but this is still a valid context. + + elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then + Decl := Find_Related_Declaration_Or_Body (Par); + + if Nkind (Decl) = N_Object_Declaration + and then Defining_Entity (Decl) = Conc_Typ + then + OK_Use := True; + exit; + end if; + end if; + + -- The reference appears somewhere in the definition of the single + -- protected/task type (SPARK RM 9.3). + + elsif Nkind_In (Par, N_Single_Protected_Declaration, + N_Single_Task_Declaration) + and then Defining_Entity (Par) = Conc_Typ + then + OK_Use := True; + exit; + + -- The reference appears within the expanded declaration or the body + -- of the single protected/task type (SPARK RM 9.3). + + elsif Nkind_In (Par, N_Protected_Body, + N_Protected_Type_Declaration, + N_Task_Body, + N_Task_Type_Declaration) + then + Spec_Id := Unique_Defining_Entity (Par); + + if Present (Anonymous_Object (Spec_Id)) + and then Anonymous_Object (Spec_Id) = Conc_Typ + then + OK_Use := True; + exit; + end if; + + -- The reference has been relocated within an internally generated + -- package or subprogram. Assume that the reference is legal as the + -- real check was already performed in the original context of the + -- reference. + + elsif Nkind_In (Par, N_Package_Body, + N_Package_Declaration, + N_Subprogram_Body, + N_Subprogram_Declaration) + and then not Comes_From_Source (Par) + then + -- Continue to examine the context if the reference appears in a + -- subprogram body which was previously an expression function. + + if Nkind (Par) = N_Subprogram_Body + and then Was_Expression_Function (Par) + then + null; + + -- Otherwise the reference is legal + + else + OK_Use := True; + exit; + end if; + + -- The reference has been relocated to an inlined body for GNATprove. + -- Assume that the reference is legal as the real check was already + -- performed in the original context of the reference. + + elsif GNATprove_Mode + and then Nkind (Par) = N_Subprogram_Body + and then Chars (Defining_Entity (Par)) = Name_uParent + then + OK_Use := True; + exit; + end if; + + Par := Parent (Par); + end loop; + + -- The reference is illegal as it appears outside the definition or + -- body of the single protected/task type. + + if not OK_Use then + Error_Msg_NE + ("reference to variable & cannot appear in this context", + Ref, Var_Id); + Error_Msg_Name_1 := Chars (Var_Id); + + if Ekind (Conc_Typ) = E_Protected_Type then + Error_Msg_NE + ("\% is constituent of single protected type &", Ref, Conc_Typ); + else + Error_Msg_NE + ("\% is constituent of single task type &", Ref, Conc_Typ); + end if; + end if; + end Check_Part_Of_Reference; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -3363,6 +3344,25 @@ package body Sem_Util is end loop; end Check_Potentially_Blocking_Operation; + ------------------------------------ + -- Check_Previous_Null_Procedure -- + ------------------------------------ + + procedure Check_Previous_Null_Procedure + (Decl : Node_Id; + Prev : Entity_Id) + is + begin + if Ekind (Prev) = E_Procedure + and then Nkind (Parent (Prev)) = N_Procedure_Specification + and then Null_Present (Parent (Prev)) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N + ("declaration cannot complete previous null procedure#", Decl); + end if; + end Check_Previous_Null_Procedure; + --------------------------------- -- Check_Result_And_Post_State -- --------------------------------- @@ -14175,7 +14175,10 @@ package body Sem_Util is -- Note that predefined operators are functions as well, and so -- are attributes that are (can be renamed as) functions. - when N_Function_Call | N_Binary_Op | N_Unary_Op => + when N_Binary_Op + | N_Function_Call + | N_Unary_Op + => return Etype (N) /= Standard_Void_Type; -- Attributes references 'Loop_Entry, 'Old, and 'Result yield @@ -14186,7 +14189,7 @@ package body Sem_Util is Nam_In (Attribute_Name (N), Name_Loop_Entry, Name_Old, Name_Result) - or else Is_Function_Attribute_Name (Attribute_Name (N)); + or else Is_Function_Attribute_Name (Attribute_Name (N)); when N_Selected_Component => return -- 2.30.2