diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 41 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/g-debpoo.adb | 479 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_elim.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 15 |
8 files changed, 384 insertions, 225 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1695362..af38910 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * 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 <kirtchev@adacore.com> + + * 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 <gil@adacore.com> + + * g-debpoo.adb: adapt GNAT.Debug_Pools to allow safe thread + GNATCOLL.Memory + +2017-09-06 Bob Duff <duff@adacore.com> + + * sem_elim.adb: Minor comment fix. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * 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 <kirtchev@adacore.com> * 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 a6670fa..5751885 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 25af42e..f89e970 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 fe2debd..42acdbd 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 <<Allocate_Label>> - 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 <<Deallocate_Label>> - 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 fcbf86e..6fbcea27 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 0b415d7..d5e0f4b 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 f61a41c..cc0f43c 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 9290694..d9babcd 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 |