===================================================================
@@ -1670,7 +1670,7 @@ package body Exp_Util is
exit when Chars (Op) = Name
and then
(Name /= Name_Op_Eq
- or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
+ or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
Next_Elmt (Prim);
===================================================================
@@ -6209,6 +6209,36 @@ package body Einfo is
and then Present (Related_Instance (Id)));
end Is_Wrapper_Package;
+ -----------------
+ -- Last_Formal --
+ -----------------
+
+ function Last_Formal (Id : E) return E is
+ Formal : E;
+
+ begin
+ pragma Assert
+ (Is_Overloadable (Id)
+ or else Ekind_In (Id, E_Entry_Family,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
+
+ if Ekind (Id) = E_Enumeration_Literal then
+ return Empty;
+
+ else
+ Formal := First_Formal (Id);
+
+ if Present (Formal) then
+ while Present (Next_Formal (Formal)) loop
+ Formal := Next_Formal (Formal);
+ end loop;
+ end if;
+
+ return Formal;
+ end if;
+ end Last_Formal;
+
--------------------
-- Next_Component --
--------------------
===================================================================
@@ -2756,6 +2756,13 @@ package Einfo is
-- Points to the last entry in the list of associated entities chained
-- through the Next_Entity field. Empty if no entities are chained.
+-- Last_Formal (synthesized)
+-- Applies to subprograms and subprogram types, and also in entries
+-- and entry families. Returns last formal of the subprogram or entry.
+-- The formals are the first entities declared in a subprogram or in
+-- a subprogram type (the designated type of an Access_To_Subprogram
+-- definition) or in an entry.
+
-- Limited_View (Node23)
-- Present in non-generic package entities that are not instances. Bona
-- fide package with the limited-view list through the first_entity and
@@ -4881,9 +4888,10 @@ package Einfo is
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
-- Address_Clause (synth)
+ -- Entry_Index_Type (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
- -- Entry_Index_Type (synth)
+ -- Last_Formal (synth)
-- Number_Formals (synth)
-- Scope_Depth (synth)
@@ -5002,6 +5010,7 @@ package Einfo is
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Last_Formal (synth)
-- Number_Formals (synth)
-- Scope_Depth (synth)
@@ -5261,6 +5270,7 @@ package Einfo is
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Last_Formal (synth)
-- Number_Formals (synth)
-- E_Protected_Body
@@ -5385,6 +5395,7 @@ package Einfo is
-- Directly_Designated_Type (Node20)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
+ -- Last_Formal (synth)
-- Number_Formals (synth)
-- (plus type attributes)
@@ -6149,6 +6160,7 @@ package Einfo is
function Is_Task_Interface (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
+ function Last_Formal (Id : E) return E;
function Next_Component (Id : E) return E;
function Next_Component_Or_Discriminant (Id : E) return E;
function Next_Discriminant (Id : E) return E;
===================================================================
@@ -1782,7 +1782,7 @@ package body Exp_Disp is
or else TSS_Name = TSS_Stream_Output
or else
(Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
@@ -1824,7 +1824,7 @@ package body Exp_Disp is
or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
===================================================================
@@ -238,7 +238,7 @@ package body Exp_CG is
or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
or else Chars (E) = Name_uAssign
or else Is_Predefined_Interface_Primitive (E)
then
@@ -283,7 +283,7 @@ package body Exp_CG is
return Predef_Names_95 (J) /= Name_Op_Eq
or else
- Etype (First_Entity (E)) = Etype (Last_Entity (E));
+ Etype (First_Formal (E)) = Etype (Last_Formal (E));
end if;
end loop;
The compiler crashes processing a primitive that overrides the equality operator of a tagged type by means of a function that has a return statement that performs a dispatching call. The following test now compiles silently. package Alpha is type Object is abstract tagged null record; function "=" (L, R : in Object) return Boolean; function Equal (L, R : in Object) return Boolean is abstract; end Alpha; package body Alpha is function "=" (L, R : in Object) return Boolean is begin return Equal (Object'Class (L), Object'Class (R)); -- test end "="; end Alpha; Command: gcc -c -gnat05 alpha.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-22 Javier Miranda <miranda@adacore.com> * einfo.ads, einfo.adb (Last_Formal): New synthesized attribute. * exp_util.adb (Find_Prim_Op): Use new attribute to locate the last formal of a primitive. * exp_disp.adb (Is_Predefined_Dispatching_Operation, Is_Predefined_Dispatching_Alias): Use new attribute to locate the last formal of a primitive. * exp_cg.adb (Is_Predefined_Dispatching_Operation): Use new attribute to obtain the last formal of a primitive.