From 1d2d8a8f5a35b317abe53360082e275e44d3947b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Jul 2016 12:48:48 +0200 Subject: [PATCH] [multiple changes] 2016-07-04 Ed Schonberg * sem_ch4.adb (Compatible_Types_In_Predicate): New function to handle cases where a formal of a predicate function and the corresponding actual have different views of the same type. 2016-07-04 Philippe Gil * g-debpoo.adb (Free_Blocks) free blocks also until Logically_Deallocated less than Maximum_Logically_Freed_Memory (Dump) add dump of number of traceback & validity elements already allocated. 2016-07-04 Justin Squirek * sem_ch12.adb (Instantiate_Package_Body): Add a guard to ignore Itypes which fail when installing primitives. From-SVN: r237973 --- gcc/ada/ChangeLog | 18 +++++++++ gcc/ada/g-debpoo.adb | 21 +++++++++-- gcc/ada/sem_ch12.adb | 10 +++-- gcc/ada/sem_ch4.adb | 90 ++++++++++++++++++++++++++++++++++---------- 4 files changed, 112 insertions(+), 27 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ffdbb4a9610..2e6926d006a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2016-07-04 Ed Schonberg + + * sem_ch4.adb (Compatible_Types_In_Predicate): New function + to handle cases where a formal of a predicate function and the + corresponding actual have different views of the same type. + +2016-07-04 Philippe Gil + + * g-debpoo.adb (Free_Blocks) free blocks also until + Logically_Deallocated less than Maximum_Logically_Freed_Memory + (Dump) add dump of number of traceback & validity elements + already allocated. + +2016-07-04 Justin Squirek + + * sem_ch12.adb (Instantiate_Package_Body): Add + a guard to ignore Itypes which fail when installing primitives. + 2016-07-04 Bob Duff * sem_eval.adb (Decompose_Expr): Set 'out' parameters diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 567bb758a41..f7d3c2df70e 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -101,6 +101,9 @@ package body GNAT.Debug_Pools is -- If True, protects Deallocate against releasing memory allocated before -- System_Memory_Debug_Pool_Enabled was set. + Traceback_Count : Byte_Count := 0; + -- Total number of traceback elements + --------------------------- -- Back Trace Hash Table -- --------------------------- @@ -332,6 +335,10 @@ package body GNAT.Debug_Pools is pragma Inline (Set_Valid); -- Mark the address Storage as being under control of the memory pool -- (if Value is True), or not (if Value is False). + + Validity_Count : Byte_Count := 0; + -- Total number of validity elements + end Validity; use Validity; @@ -630,6 +637,7 @@ package body GNAT.Debug_Pools is Frees => 0, Total_Frees => 0, Next => null); + Traceback_Count := Traceback_Count + 1; Backtrace_Htable.Set (Elem); else @@ -845,6 +853,7 @@ package body GNAT.Debug_Pools is if Value then Ptr := new Validity_Bits; + Validity_Count := Validity_Count + 1; Ptr.Valid := To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); Validy_Htable.Set (Block_Number, Ptr); @@ -1180,7 +1189,10 @@ package body GNAT.Debug_Pools is begin while Tmp /= System.Null_Address - and then Total_Freed < Pool.Minimum_To_Free + and then + not (Total_Freed > Pool.Minimum_To_Free + and Pool.Logically_Deallocated < + Byte_Count (Pool.Maximum_Logically_Freed_Memory)) loop Header := Header_Of (Tmp); @@ -1188,12 +1200,12 @@ package body GNAT.Debug_Pools is -- referenced anywhere, we can free it physically. if Ignore_Marks or else not Marked (Tmp) then - declare pragma Suppress (All_Checks); -- Suppress the checks on this section. If they are overflow -- errors, it isn't critical, and we'd rather avoid a -- Constraint_Error in that case. + begin -- Note that block_size < zero for freed blocks @@ -1238,7 +1250,7 @@ package body GNAT.Debug_Pools is Header_Of (Previous).Next := Next; end if; - Tmp := Next; + Tmp := Next; else Previous := Tmp; @@ -2018,6 +2030,9 @@ package body GNAT.Debug_Pools is end Do_Report; begin + Put_Line ("Traceback elements allocated: " & Traceback_Count'Img); + Put_Line ("Validity elements allocated: " & Validity_Count'Img); + Put_Line (""); Put_Line ("Ada Allocs:" & Pool.Allocated'Img & " bytes in" & Pool.Alloc_Count'Img & " chunks"); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 02fe1023745..f21ebc52ba0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10932,6 +10932,7 @@ package body Sem_Ch12 is E := First_Entity (Act_Decl_Id); while Present (E) loop if Is_Type (E) + and then not Is_Itype (E) and then Is_Generic_Actual_Type (E) and then Is_Tagged_Type (E) then @@ -12855,10 +12856,11 @@ package body Sem_Ch12 is -- or in the declaration of the main unit, which in this last case must -- be a body. - return Current_Unit = Cunit (Main_Unit) - or else Current_Unit = Library_Unit (Cunit (Main_Unit)) - or else (Present (Library_Unit (Current_Unit)) - and then Is_In_Main_Unit (Library_Unit (Current_Unit))); + return + Current_Unit = Cunit (Main_Unit) + or else Current_Unit = Library_Unit (Cunit (Main_Unit)) + or else (Present (Library_Unit (Current_Unit)) + and then Is_In_Main_Unit (Library_Unit (Current_Unit))); end Is_In_Main_Unit; ---------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 30ef4919bbb..17c6308f8ff 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3087,6 +3087,21 @@ package body Sem_Ch4 is Subp_Type : constant Entity_Id := Etype (Nam); Norm_OK : Boolean; + function Compatible_Types_In_Predicate + (T1 : Entity_Id; + T2 : Entity_Id) return Boolean; + -- For an Ada 2012 predicate or invariant, a call may mention an + -- incomplete type, while resolution of the corresponding predicate + -- function may see the full view, as a consequence of the delayed + -- resolution of the corresponding expressions. This may occur in + -- the body of a predicate function, or in a call to such. Anomalies + -- involving private and full views can also happen. In each case, + -- rewrite node or add conversions to remove spurious type errors. + + procedure Indicate_Name_And_Type; + -- If candidate interpretation matches, indicate name and type of result + -- on call node. + function Operator_Hidden_By (Fun : Entity_Id) return Boolean; -- There may be a user-defined operator that hides the current -- interpretation. We must check for this independently of the @@ -3100,9 +3115,59 @@ package body Sem_Ch4 is -- Finally, The abstract operations on address do not hide the -- predefined operator (this is the purpose of making them abstract). - procedure Indicate_Name_And_Type; - -- If candidate interpretation matches, indicate name and type of - -- result on call node. + ----------------------------------- + -- Compatible_Types_In_Predicate -- + ----------------------------------- + + function Compatible_Types_In_Predicate + (T1 : Entity_Id; + T2 : Entity_Id) return Boolean + is + function Common_Type (T : Entity_Id) return Entity_Id; + -- Find non-private full view if any, without going to ancestor type + -- (as opposed to Underlying_Type). + + ----------------- + -- Common_Type -- + ----------------- + + function Common_Type (T : Entity_Id) return Entity_Id is + begin + if Is_Private_Type (T) and then Present (Full_View (T)) then + return Base_Type (Full_View (T)); + else + return Base_Type (T); + end if; + end Common_Type; + + -- Start of processing for Compatible_Types_In_Predicate + + begin + if (Ekind (Current_Scope) = E_Function + and then Is_Predicate_Function (Current_Scope)) + or else + (Ekind (Nam) = E_Function + and then Is_Predicate_Function (Nam)) + then + if Is_Incomplete_Type (T1) + and then Present (Full_View (T1)) + and then Full_View (T1) = T2 + then + Set_Etype (Formal, Etype (Actual)); + return True; + + elsif Common_Type (T1) = Common_Type (T2) then + Rewrite (Actual, Unchecked_Convert_To (Etype (Formal), Actual)); + return True; + + else + return False; + end if; + + else + return False; + end if; + end Compatible_Types_In_Predicate; ---------------------------- -- Indicate_Name_And_Type -- @@ -3409,24 +3474,9 @@ package body Sem_Ch4 is Next_Actual (Actual); Next_Formal (Formal); - -- For an Ada 2012 predicate or invariant, a call may mention - -- an incomplete type, while resolution of the corresponding - -- predicate function may see the full view, as a consequence - -- of the delayed resolution of the corresponding expressions. - -- This can occur in the body of a predicate function, or in - -- a call to such. - - elsif ((Ekind (Current_Scope) = E_Function - and then Is_Predicate_Function (Current_Scope)) - or else - (Ekind (Nam) = E_Function - and then Is_Predicate_Function (Nam))) - and then - (Base_Type (Underlying_Type (Etype (Formal))) = - Base_Type (Underlying_Type (Etype (Actual)))) - and then Serious_Errors_Detected = 0 + elsif Compatible_Types_In_Predicate + (Etype (Formal), Etype (Actual)) then - Set_Etype (Formal, Etype (Actual)); Next_Actual (Actual); Next_Formal (Formal); -- 2.30.2