From: Arnaud Charlet Date: Wed, 6 Sep 2017 09:34:30 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=dd89dddff4f63572408c3bcd602eb8773288179c;p=gcc.git [multiple changes] 2017-09-06 Ed Schonberg * einfo.adb (Designated_Type): Use Is_Incomplete_Type to handle properly incomplete subtypes that may be created by explicit or implicit declarations. (Is_Base_Type): Take E_Incomplete_Subtype into account. (Subtype_Kind): Ditto. * sem_ch3.adb (Build_Discriminated_Subtype): Set properly the Ekind of a subtype of a discriminated incomplete type. (Fixup_Bad_Constraint): Use Subtype_Kind in all cases, including incomplete types, to preserve error reporting. (Process_Incomplete_Dependents): Do not create a subtype declaration for an incomplete subtype that is created internally. * sem_ch7.adb (Analyze_Package_Specification): Handle properly incomplete subtypes that do not require a completion, either because they are limited views, of they are generic actuals. 2017-09-06 Hristian Kirtchev * checks.adb (Insert_Valid_Check): Remove the suspicious manipulation of the Do_Range_Check flag as ths is no linger needed. Suppress validity check when analysing the validation variable. 2017-09-06 Philippe Gil * g-debpoo.adb: adapt GNAT.Debug_Pools to allow safe thread GNATCOLL.Memory 2017-09-06 Bob Duff * sem_elim.adb: Minor comment fix. 2017-09-06 Ed Schonberg * sem_util.adb (Is_Object_Reference): A function call is an object reference, and thus attribute references for attributes that are functions (such as Pred and Succ) as well as predefined operators are legal in contexts that require an object, such as the prefix of attribute Img and the Ada2020 version of 'Image. From-SVN: r251759 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1695362fac4..af389109ff7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2017-09-06 Ed Schonberg + + * einfo.adb (Designated_Type): Use Is_Incomplete_Type to handle + properly incomplete subtypes that may be created by explicit or + implicit declarations. + (Is_Base_Type): Take E_Incomplete_Subtype into account. + (Subtype_Kind): Ditto. + * sem_ch3.adb (Build_Discriminated_Subtype): Set properly the + Ekind of a subtype of a discriminated incomplete type. + (Fixup_Bad_Constraint): Use Subtype_Kind in all cases, including + incomplete types, to preserve error reporting. + (Process_Incomplete_Dependents): Do not create a subtype + declaration for an incomplete subtype that is created internally. + * sem_ch7.adb (Analyze_Package_Specification): Handle properly + incomplete subtypes that do not require a completion, either + because they are limited views, of they are generic actuals. + +2017-09-06 Hristian Kirtchev + + * checks.adb (Insert_Valid_Check): Remove the + suspicious manipulation of the Do_Range_Check flag as ths is + no linger needed. Suppress validity check when analysing the + validation variable. + +2017-09-06 Philippe Gil + + * g-debpoo.adb: adapt GNAT.Debug_Pools to allow safe thread + GNATCOLL.Memory + +2017-09-06 Bob Duff + + * sem_elim.adb: Minor comment fix. + +2017-09-06 Ed Schonberg + + * sem_util.adb (Is_Object_Reference): A function call is an + object reference, and thus attribute references for attributes + that are functions (such as Pred and Succ) as well as predefined + operators are legal in contexts that require an object, such as + the prefix of attribute Img and the Ada2020 version of 'Image. + 2017-09-06 Hristian Kirtchev * exp_util.adb, einfo.adb, sem_attr.adb, exp_ch4.adb, gnatls.adb, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index a6670fa7697..57518851322 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7333,21 +7333,12 @@ package body Checks is return; end if; - -- We are about to insert the validity check for Exp. We save and - -- reset the Do_Range_Check flag over this validity check, and then - -- put it back for the final original reference (Exp may be rewritten). - declare - DRC : constant Boolean := Do_Range_Check (Exp); - CE : Node_Id; - Obj : Node_Id; PV : Node_Id; Var_Id : Entity_Id; begin - Set_Do_Range_Check (Exp, False); - -- If the expression denotes an assignable object, capture its value -- in a variable and replace the original expression by the variable. -- This approach has several effects: @@ -7386,15 +7377,16 @@ package body Checks is -- Object := Var; -- update Object if Is_Variable (Exp) then - Obj := New_Copy_Tree (Exp); Var_Id := Make_Temporary (Loc, 'T', Exp); Insert_Action (Exp, Make_Object_Declaration (Loc, Defining_Identifier => Var_Id, Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Exp))); - Set_Validated_Object (Var_Id, Obj); + Expression => New_Copy_Tree (Exp)), + Suppress => Validity_Check); + + Set_Validated_Object (Var_Id, New_Copy_Tree (Exp)); Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc)); PV := New_Occurrence_Of (Var_Id, Loc); @@ -7474,20 +7466,6 @@ package body Checks is end if; end; end if; - - -- Put back the Do_Range_Check flag on the resulting (possibly - -- rewritten) expression. - - -- Note: it might be thought that a validity check is not required - -- when a range check is present, but that's not the case, because - -- the back end is allowed to assume for the range check that the - -- operand is within its declared range (an assumption that validity - -- checking is all about NOT assuming). - - -- Note: no need to worry about Possible_Local_Raise here, it will - -- already have been called if original node has Do_Range_Check set. - - Set_Do_Range_Check (Exp, DRC); end; end Insert_Valid_Check; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 25af42e838d..f89e9704caf 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7151,13 +7151,13 @@ package body Einfo is begin Desig_Type := Directly_Designated_Type (Id); - if Ekind (Desig_Type) = E_Incomplete_Type + if Is_Incomplete_Type (Desig_Type) and then Present (Full_View (Desig_Type)) then return Full_View (Desig_Type); elsif Is_Class_Wide_Type (Desig_Type) - and then Ekind (Etype (Desig_Type)) = E_Incomplete_Type + and then Is_Incomplete_Type (Etype (Desig_Type)) and then Present (Full_View (Etype (Desig_Type))) and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type)))) then @@ -7364,11 +7364,11 @@ package body Einfo is function Get_Full_View (T : Entity_Id) return Entity_Id is begin - if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then + if Is_Incomplete_Type (T) and then Present (Full_View (T)) then return Full_View (T); elsif Is_Class_Wide_Type (T) - and then Ekind (Root_Type (T)) = E_Incomplete_Type + and then Is_Incomplete_Type (Root_Type (T)) and then Present (Full_View (Root_Type (T))) then return Class_Wide_Type (Full_View (Root_Type (T))); @@ -7800,7 +7800,7 @@ package body Einfo is Entity_Is_Base_Type : constant array (Entity_Kind) of Boolean := (E_Enumeration_Subtype | - E_Incomplete_Type | + E_Incomplete_Subtype | E_Signed_Integer_Subtype | E_Modular_Integer_Subtype | E_Floating_Point_Subtype | @@ -9174,6 +9174,9 @@ package body Einfo is when Enumeration_Kind => Kind := E_Enumeration_Subtype; + when E_Incomplete_Type => + Kind := E_Incomplete_Subtype; + when Float_Kind => Kind := E_Floating_Point_Subtype; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index fe2debd09d3..42acdbdbed7 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -41,6 +41,7 @@ with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; with GNAT.HTable; with GNAT.Traceback; use GNAT.Traceback; +with Ada.Finalization; with Ada.Unchecked_Conversion; package body GNAT.Debug_Pools is @@ -386,6 +387,36 @@ package body GNAT.Debug_Pools is function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address renames STBE.PC_For; + type Scope_Lock is + new Ada.Finalization.Limited_Controlled with null record; + -- to handle Lock_Task/Unlock_Task calls + + overriding procedure Initialize (This : in out Scope_Lock); + -- lock task on initialization + + overriding procedure Finalize (This : in out Scope_Lock); + -- unlock task on finalization + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (This : in out Scope_Lock) is + pragma Unreferenced (This); + begin + Lock_Task.all; + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (This : in out Scope_Lock) is + pragma Unreferenced (This); + begin + Unlock_Task.all; + end Finalize; + ----------- -- Align -- ----------- @@ -906,14 +937,15 @@ package body GNAT.Debug_Pools is Reset_Disable_At_Exit : Boolean := False; + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin <> - Lock_Task.all; if Disable then Storage_Address := System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); - Unlock_Task.all; return; end if; @@ -1055,14 +1087,11 @@ package body GNAT.Debug_Pools is Disable := False; - Unlock_Task.all; - exception when others => if Reset_Disable_At_Exit then Disable := False; end if; - Unlock_Task.all; raise; end Allocate; @@ -1345,10 +1374,12 @@ package body GNAT.Debug_Pools is end loop; end Reset_Marks; - -- Start of processing for Free_Physically + Lock : Scope_Lock; + pragma Unreferenced (Lock); + + -- Start of processing for Free_Physically begin - Lock_Task.all; if Pool.Advanced_Scanning then @@ -1371,12 +1402,6 @@ package body GNAT.Debug_Pools is Free_Blocks (Ignore_Marks => True); end if; - Unlock_Task.all; - - exception - when others => - Unlock_Task.all; - raise; end Free_Physically; -------------- @@ -1387,8 +1412,11 @@ package body GNAT.Debug_Pools is (Storage_Address : Address; Size_In_Storage_Elements : out Storage_Count; Valid : out Boolean) is + + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin - Lock_Task.all; Valid := Is_Valid (Storage_Address); @@ -1408,13 +1436,6 @@ package body GNAT.Debug_Pools is Valid := False; end if; - Unlock_Task.all; - - exception - when others => - Unlock_Task.all; - raise; - end Get_Size; --------------------- @@ -1444,21 +1465,136 @@ package body GNAT.Debug_Pools is is pragma Unreferenced (Alignment); - Unlock_Task_Required : Boolean := False; Header : constant Allocation_Header_Access := Header_Of (Storage_Address); Valid : Boolean; Previous : System.Address; + Header_Block_Size_Was_Less_Than_0 : Boolean := True; begin <> - Lock_Task.all; - Unlock_Task_Required := True; - Valid := Is_Valid (Storage_Address); + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Valid := Is_Valid (Storage_Address); + + if Valid and then not (Header.Block_Size < 0) then + 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. + + if Header.Block_Size /= Size_In_Storage_Elements and then + Size_In_Storage_Elements /= Storage_Count'Last + then + Put_Line (Output_File (Pool), + "error: Deallocate size " + & Storage_Count'Image (Size_In_Storage_Elements) + & " does not match allocate size " + & Storage_Count'Image (Header.Block_Size)); + end if; + + if Pool.Low_Level_Traces then + Put (Output_File (Pool), + "info: Deallocated" + & Storage_Count'Image (Header.Block_Size) + & " bytes at "); + Print_Address (Output_File (Pool), Storage_Address); + Put (Output_File (Pool), + " (physically" + & Storage_Count'Image + (Header.Block_Size + Extra_Allocation) + & " bytes at "); + Print_Address (Output_File (Pool), Header.Allocation_Address); + Put (Output_File (Pool), "), at "); + + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + Print_Traceback (Output_File (Pool), + " Memory was allocated at ", + Header.Alloc_Traceback); + end if; + + -- Remove this block from the list of used blocks + + Previous := + To_Address (Header.Dealloc_Traceback); + + if Previous = System.Null_Address then + Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; + + if Pool.First_Used_Block /= System.Null_Address then + Header_Of (Pool.First_Used_Block).Dealloc_Traceback := + To_Traceback (null); + end if; + + else + Header_Of (Previous).Next := Header.Next; + + if Header.Next /= System.Null_Address then + Header_Of + (Header.Next).Dealloc_Traceback := To_Address (Previous); + end if; + end if; + + -- Update the Alloc_Traceback Frees/Total_Frees members + -- (if present) + + if Header.Alloc_Traceback /= null then + Header.Alloc_Traceback.Frees := + Header.Alloc_Traceback.Frees + 1; + Header.Alloc_Traceback.Total_Frees := + Header.Alloc_Traceback.Total_Frees + + Byte_Count (Header.Block_Size); + end if; + + Pool.Free_Count := Pool.Free_Count + 1; + + -- Update the header + + Header.all := + (Allocation_Address => Header.Allocation_Address, + Alloc_Traceback => Header.Alloc_Traceback, + Dealloc_Traceback => To_Traceback + (Find_Or_Create_Traceback + (Pool, Dealloc, + Header.Block_Size, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End)), + Next => System.Null_Address, + Block_Size => -Header.Block_Size); + + if Pool.Reset_Content_On_Free then + Set_Dead_Beef (Storage_Address, -Header.Block_Size); + end if; + + Pool.Logically_Deallocated := + Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); + + -- Link this free block with the others (at the end of the list, + -- so that we can start releasing the older blocks first later on) + + if Pool.First_Free_Block = System.Null_Address then + Pool.First_Free_Block := Storage_Address; + Pool.Last_Free_Block := Storage_Address; + + else + Header_Of (Pool.Last_Free_Block).Next := Storage_Address; + Pool.Last_Free_Block := Storage_Address; + end if; + + -- Do not physically release the memory here, but in Alloc. + -- See comment there for details. + end if; + + end; if not Valid then - Unlock_Task_Required := False; - Unlock_Task.all; if Storage_Address = System.Null_Address then if Pool.Raise_Exceptions and then @@ -1493,9 +1629,8 @@ package body GNAT.Debug_Pools is Code_Address_For_Deallocate_End); end if; - elsif Header.Block_Size < 0 then - Unlock_Task_Required := False; - Unlock_Task.all; + elsif Header_Block_Size_Was_Less_Than_0 then + if Pool.Raise_Exceptions then raise Freeing_Deallocated_Storage; else @@ -1511,121 +1646,8 @@ package body GNAT.Debug_Pools is Header.Alloc_Traceback); end if; - else - -- 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. - - if Header.Block_Size /= Size_In_Storage_Elements and then - Size_In_Storage_Elements /= Storage_Count'Last - then - Put_Line (Output_File (Pool), - "error: Deallocate size " - & Storage_Count'Image (Size_In_Storage_Elements) - & " does not match allocate size " - & Storage_Count'Image (Header.Block_Size)); - end if; - - if Pool.Low_Level_Traces then - Put (Output_File (Pool), - "info: Deallocated" - & Storage_Count'Image (Header.Block_Size) - & " bytes at "); - Print_Address (Output_File (Pool), Storage_Address); - Put (Output_File (Pool), - " (physically" - & Storage_Count'Image (Header.Block_Size + Extra_Allocation) - & " bytes at "); - Print_Address (Output_File (Pool), Header.Allocation_Address); - Put (Output_File (Pool), "), at "); - - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); - Print_Traceback (Output_File (Pool), " Memory was allocated at ", - Header.Alloc_Traceback); - end if; - - -- Remove this block from the list of used blocks - - Previous := - To_Address (Header.Dealloc_Traceback); - - if Previous = System.Null_Address then - Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; - - if Pool.First_Used_Block /= System.Null_Address then - Header_Of (Pool.First_Used_Block).Dealloc_Traceback := - To_Traceback (null); - end if; - - else - Header_Of (Previous).Next := Header.Next; - - if Header.Next /= System.Null_Address then - Header_Of - (Header.Next).Dealloc_Traceback := To_Address (Previous); - end if; - end if; - - -- Update the Alloc_Traceback Frees/Total_Frees members (if present) - - if Header.Alloc_Traceback /= null then - Header.Alloc_Traceback.Frees := Header.Alloc_Traceback.Frees + 1; - Header.Alloc_Traceback.Total_Frees := - Header.Alloc_Traceback.Total_Frees + - Byte_Count (Header.Block_Size); - end if; - - Pool.Free_Count := Pool.Free_Count + 1; - - -- Update the header - - Header.all := - (Allocation_Address => Header.Allocation_Address, - Alloc_Traceback => Header.Alloc_Traceback, - Dealloc_Traceback => To_Traceback - (Find_Or_Create_Traceback - (Pool, Dealloc, - Header.Block_Size, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End)), - Next => System.Null_Address, - Block_Size => -Header.Block_Size); - - if Pool.Reset_Content_On_Free then - Set_Dead_Beef (Storage_Address, -Header.Block_Size); - end if; - - Pool.Logically_Deallocated := - Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); - - -- Link this free block with the others (at the end of the list, so - -- that we can start releasing the older blocks first later on). - - if Pool.First_Free_Block = System.Null_Address then - Pool.First_Free_Block := Storage_Address; - Pool.Last_Free_Block := Storage_Address; - - else - Header_Of (Pool.Last_Free_Block).Next := Storage_Address; - Pool.Last_Free_Block := Storage_Address; - end if; - - -- Do not physically release the memory here, but in Alloc. - -- See comment there for details. - - Unlock_Task_Required := False; - Unlock_Task.all; end if; - exception - when others => - if Unlock_Task_Required then - Unlock_Task.all; - end if; - raise; end Deallocate; -------------------- @@ -1904,9 +1926,6 @@ package body GNAT.Debug_Pools is Size : Positive; Report : Report_Type := All_Reports) is - Total_Freed : constant Byte_Count := - Pool.Logically_Deallocated + Pool.Physically_Deallocated; - procedure Do_Report (Sort : Report_Type); -- Do a specific type of report @@ -1919,6 +1938,15 @@ package body GNAT.Debug_Pools is (others => null); -- Sorted array for the biggest memory users + Allocated_In_Pool : Byte_Count; + -- safe thread Pool.Allocated + + Elem_Safe : Traceback_Htable_Elem; + -- safe thread current elem.all; + + Max_M_Safe : Traceback_Htable_Elem; + -- safe thread Max(M).all + begin Put_Line (""); @@ -1940,52 +1968,83 @@ package body GNAT.Debug_Pools is Put_Line ("Results include total bytes and chunks allocated,"); Put_Line ("even if no longer allocated - Deallocations are" & " ignored"); - Grand_Total := Float (Pool.Allocated); + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Allocated_In_Pool := Pool.Allocated; + end; + + Grand_Total := Float (Allocated_In_Pool); when Marked_Blocks => Put_Line ("Special blocks marked by Mark_Traceback"); Grand_Total := 0.0; end case; - Elem := Backtrace_Htable.Get_First; + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem := Backtrace_Htable.Get_First; + end; + while Elem /= null loop + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem_Safe := Elem.all; + end; + -- Handle only alloc elememts - if Elem.Kind = Alloc then + if Elem_Safe.Kind = Alloc then -- Ignore small blocks (depending on the sorting criteria) to -- gain speed. if (Sort = Memory_Usage - and then Elem.Total - Elem.Total_Frees >= 1_000) + and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) or else (Sort = Allocations_Count - and then Elem.Count - Elem.Frees >= 1) - or else (Sort = Sort_Total_Allocs and then Elem.Count > 1) + and then Elem_Safe.Count - Elem_Safe.Frees >= 1) + or else (Sort = Sort_Total_Allocs + and then Elem_Safe.Count > 1) or else (Sort = Marked_Blocks - and then Elem.Total = 0) + and then Elem_Safe.Total = 0) then if Sort = Marked_Blocks then - Grand_Total := Grand_Total + Float (Elem.Count); + Grand_Total := Grand_Total + Float (Elem_Safe.Count); end if; for M in Max'Range loop Bigger := Max (M) = null; if not Bigger then + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Max_M_Safe := Max (M).all; + end; + case Sort is when All_Reports | Memory_Usage => Bigger := - Max (M).Total - Max (M).Total_Frees - < Elem.Total - Elem.Total_Frees; + Max_M_Safe.Total - Max_M_Safe.Total_Frees + < Elem_Safe.Total - Elem_Safe.Total_Frees; when Allocations_Count => Bigger := - Max (M).Count - Max (M).Frees - < Elem.Count - Elem.Frees; + Max_M_Safe.Count - Max_M_Safe.Frees + < Elem_Safe.Count - Elem_Safe.Frees; when Marked_Blocks | Sort_Total_Allocs => - Bigger := Max (M).Count < Elem.Count; + Bigger := Max_M_Safe.Count < Elem_Safe.Count; end case; end if; @@ -1998,7 +2057,13 @@ package body GNAT.Debug_Pools is end if; end if; - Elem := Backtrace_Htable.Get_Next; + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem := Backtrace_Htable.Get_Next; + end; + end loop; if Grand_Total = 0.0 then @@ -2012,37 +2077,56 @@ package body GNAT.Debug_Pools is Total : Byte_Count; P : Percent; begin + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Max_M_Safe := Max (M).all; + end; + case Sort is when All_Reports | Allocations_Count | Memory_Usage => - Total := Max (M).Total - Max (M).Total_Frees; + Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees; when Sort_Total_Allocs => - Total := Max (M).Total; + Total := Max_M_Safe.Total; when Marked_Blocks => - Total := Byte_Count (Max (M).Count); + Total := Byte_Count (Max_M_Safe.Count); end case; - P := Percent (100.0 * Float (Total) / Grand_Total); + declare + Normalized_Total : constant Float := Float (Total); + -- 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; + else + P := Percent (100.0 * Normalized_Total / Grand_Total); + end if; + end; case Sort is when Memory_Usage | Allocations_Count | All_Reports => declare Count : constant Natural := - Max (M).Count - Max (M).Frees; + Max_M_Safe.Count - Max_M_Safe.Frees; begin 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).Count'Img & " chunks at"); + & Max_M_Safe.Count'Img & " chunks at"); when Marked_Blocks => Put (P'Img & "%:" - & Max (M).Count'Img & " chunks /" + & Max_M_Safe.Count'Img & " chunks /" & Integer (Grand_Total)'Img & " at"); end case; end; @@ -2055,20 +2139,57 @@ package body GNAT.Debug_Pools is end loop; end Do_Report; + -- Local variables + + Total_Freed : Byte_Count; + -- safe thread pool logically & physically deallocated + + Traceback_Elements_Allocated : Byte_Count; + -- safe thread Traceback_Count + + Validity_Elements_Allocated : Byte_Count; + -- safe thread Validity_Count + + Ada_Allocs_Bytes : Byte_Count; + -- safe thread pool Allocated + + Ada_Allocs_Chunks : Byte_Count; + -- safe thread pool Alloc_Count + + Ada_Free_Chunks : Byte_Count; + -- safe thread pool Free_Count + + -- Start of processing for Dump + begin - Put_Line ("Traceback elements allocated: " & Traceback_Count'Img); - Put_Line ("Validity elements allocated: " & Validity_Count'Img); + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Total_Freed := + Pool.Logically_Deallocated + Pool.Physically_Deallocated; + Traceback_Elements_Allocated := Traceback_Count; + Validity_Elements_Allocated := Validity_Count; + Ada_Allocs_Bytes := Pool.Allocated; + Ada_Allocs_Chunks := Pool.Alloc_Count; + Ada_Free_Chunks := Pool.Free_Count; + end; + + Put_Line + ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img); + Put_Line + ("Validity elements allocated: " & Validity_Elements_Allocated'Img); Put_Line (""); - Put_Line ("Ada Allocs:" & Pool.Allocated'Img - & " bytes in" & Pool.Alloc_Count'Img & " chunks"); + Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img + & " bytes in" & Ada_Allocs_Chunks'Img & " chunks"); Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & - Pool.Free_Count'Img + Ada_Free_Chunks'Img & " chunks"); Put_Line ("Ada Current watermark: " & Byte_Count'Image (Pool.Current_Water_Mark) - & " in" & Byte_Count'Image (Pool.Alloc_Count - - Pool.Free_Count) & " chunks"); + & " in" & Byte_Count'Image (Ada_Allocs_Chunks - + Ada_Free_Chunks) & " chunks"); Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); case Report is @@ -2109,6 +2230,8 @@ package body GNAT.Debug_Pools is procedure Reset is Elem : Traceback_Htable_Elem_Ptr; + Lock : Scope_Lock; + pragma Unreferenced (Lock); begin Elem := Backtrace_Htable.Get_First; while Elem /= null loop @@ -2136,6 +2259,8 @@ package body GNAT.Debug_Pools is function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is + Lock : Scope_Lock; + pragma Unreferenced (Lock); begin return Pool.High_Water; end High_Water_Mark; @@ -2146,6 +2271,8 @@ package body GNAT.Debug_Pools is function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is + Lock : Scope_Lock; + pragma Unreferenced (Lock); begin return Pool.Allocated - Pool.Logically_Deallocated - Pool.Physically_Deallocated; @@ -2157,6 +2284,8 @@ package body GNAT.Debug_Pools is procedure System_Memory_Debug_Pool (Has_Unhandled_Memory : Boolean := True) is + Lock : Scope_Lock; + pragma Unreferenced (Lock); begin System_Memory_Debug_Pool_Enabled := True; Allow_Unhandled_Memory := Has_Unhandled_Memory; @@ -2177,6 +2306,8 @@ package body GNAT.Debug_Pools is Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; Low_Level_Traces : Boolean := Default_Low_Level_Traces) is + Lock : Scope_Lock; + pragma Unreferenced (Lock); begin Pool.Stack_Trace_Depth := Stack_Trace_Depth; Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index fcbf86e8cc4..6fbcea27ce2 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10094,7 +10094,11 @@ package body Sem_Ch3 is -- elaboration, because only the access type is needed in the -- initialization procedure. - Set_Ekind (Def_Id, Ekind (T)); + if Ekind (T) = E_Incomplete_Type then + Set_Ekind (Def_Id, E_Incomplete_Subtype); + else + Set_Ekind (Def_Id, Ekind (T)); + end if; if For_Access and then Within_Init_Proc then null; @@ -13629,15 +13633,9 @@ package body Sem_Ch3 is procedure Fixup_Bad_Constraint is begin - -- Set a reasonable Ekind for the entity. For an incomplete type, - -- we can't do much, but for other types, we can set the proper - -- corresponding subtype kind. + -- Set a reasonable Ekind for the entity, including incomplete types. - if Ekind (T) = E_Incomplete_Type then - Set_Ekind (Def_Id, Ekind (T)); - else - Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); - end if; + Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); -- Set Etype to the known type, to reduce chances of cascaded errors @@ -20802,7 +20800,9 @@ package body Sem_Ch3 is -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a -- corresponding subtype of the full view. - elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then + elsif Ekind (Priv_Dep) = E_Incomplete_Subtype + and then Comes_From_Source (Priv_Dep) + then Set_Subtype_Indication (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); Set_Etype (Priv_Dep, Full_T); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 0b415d737cb..d5e0f4b9f26 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1441,11 +1441,14 @@ package body Sem_Ch7 is -- Check on incomplete types - -- AI05-0213: A formal incomplete type has no completion + -- AI05-0213: A formal incomplete type has no completion, + -- and neither does the corresponding subtype in an instance. - if Ekind (E) = E_Incomplete_Type + if Is_Incomplete_Type (E) and then No (Full_View (E)) and then not Is_Generic_Type (E) + and then not From_Limited_With (E) + and then not Is_Generic_Actual_Type (E) then Error_Msg_N ("no declaration in visible part for incomplete}", E); end if; diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index f61a41ce388..cc0f43c9dd7 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2017, 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- -- @@ -194,7 +194,7 @@ package body Sem_Elim is -- Tables -- ------------ - -- The following table records the data for each pragmas, using the + -- The following table records the data for each pragma, using the -- entity name as the hash key for retrieval. Entries in this table -- are set by Process_Eliminate_Pragma and read by Check_Eliminated. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9290694387d..d9babcd8b3b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14153,18 +14153,21 @@ package body Sem_Util is -- In Ada 95, a function call is a constant object; a procedure -- call is not. - when N_Function_Call => + -- 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 => return Etype (N) /= Standard_Void_Type; - -- Attributes 'Input, 'Loop_Entry, 'Old, and 'Result produce - -- objects. + -- Attributes references 'Loop_Entry, 'Old, and 'Result yield + -- objects, even though they are not functions. when N_Attribute_Reference => return - Nam_In (Attribute_Name (N), Name_Input, - Name_Loop_Entry, + Nam_In (Attribute_Name (N), Name_Loop_Entry, Name_Old, - Name_Result); + Name_Result) + or else Is_Function_Attribute_Name (Attribute_Name (N)); when N_Selected_Component => return