+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
-- 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 --
---------------------------
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;
Frees => 0,
Total_Frees => 0,
Next => null);
+ Traceback_Count := Traceback_Count + 1;
Backtrace_Htable.Set (Elem);
else
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);
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);
-- 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
Header_Of (Previous).Next := Next;
end if;
- Tmp := Next;
+ Tmp := Next;
else
Previous := Tmp;
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");
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
-- 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;
----------------------------
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
-- 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 --
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);
projects / gcc.git / commitdiff