OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-07-04  Ed Schonberg  <schonberg@adacore.com>

	* 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  <gil@adacore.com>

	* 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  <squirek@adacore.com>

	* sem_ch12.adb (Instantiate_Package_Body): Add
	a guard to ignore Itypes which fail when installing primitives.

From-SVN: r237973
This commit is contained in:
Arnaud Charlet 2016-07-04 12:48:48 +02:00
parent e49de265ef
commit 1d2d8a8f5a
4 changed files with 112 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/ChangeLog
View File

@ -1,3 +1,21 @@
2016-07-04 Ed Schonberg <schonberg@adacore.com>
* 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 <gil@adacore.com>
* 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 <squirek@adacore.com>
* sem_ch12.adb (Instantiate_Package_Body): Add
a guard to ignore Itypes which fail when installing primitives.
2016-07-04 Bob Duff <duff@adacore.com>
* sem_eval.adb (Decompose_Expr): Set 'out' parameters

21
gcc/ada/g-debpoo.adb
View File

@ -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");

10
gcc/ada/sem_ch12.adb
View File

@ -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;
----------------------------

90
gcc/ada/sem_ch4.adb
View File

@ -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);