===================================================================
@@ -7430,8 +7430,6 @@
------------------------
function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
- E : Entity_Id;
-
begin
-- Predefined primitives
@@ -7446,20 +7444,19 @@
if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
return True;
- -- User-defined renamings of predefined equality have their own
- -- slot in the primary dispatch table
+ -- An overriding operation that is a user-defined renaming of
+ -- predefined equality inherits its slot from the overridden
+ -- operation. Otherwise it is treated as a predefined op and
+ -- occupies the same predefined slot as equality. A call to it is
+ -- transformed into a call to its alias, which is the predefined
+ -- equality op. A dispatching call thus uses the proper slot if
+ -- operation is further inherited and called with class-wide
+ -- arguments.
else
- E := Prim;
- while Present (Alias (E)) loop
- if Comes_From_Source (E) then
- return False;
- end if;
-
- E := Alias (E);
- end loop;
-
- return not Comes_From_Source (E);
+ return
+ not Comes_From_Source (Prim)
+ or else No (Overridden_Operation (Prim));
end if;
-- User-defined primitives
This patch fixes a bug in the handling of primitive operations that involve renamings of equality. The placement of the primitive in the dispatch table depends on whether the operation overrides an existing operation, is an explicit renaming, or is inherited by a type extension. Executing testz88 must yield: --- TestZ88 - Test equality for simple tagged types. -- Simple Equality Test -- Classwide Equality Test -- Renamed Classwide Equality Test --- TestZ88 Passed --- with Text_IO; use Text_IO; procedure TestZ88 is -- -- TestZ88.Pkg - Test dispatching equality. -- -- Edit History: -- -- 1/14/93 - RLB - Updated to use 'With Null'. -- 5/28/93 - RLB - Changed to 'With Null Record'. -- 8/13/96 - RLB - Added clarifying comments. Passed : Boolean := True; package A_Pack is type A is tagged record I : Integer; end record; function My_Eq (L, R : A) return Boolean renames "="; -- This is a dispatching renames, as it is primitive for -- A. A renames somewhere else is not dispatching. end A_Pack; package B_Pack is type B is new A_Pack.A with null record; end B_Pack; A_Var : A_Pack.A := (I => 10); B_Var : B_Pack.B := (I => 5); begin Put_Line ("--- TestZ88 - Test equality for simple tagged types."); declare use A_Pack, B_Pack; A_Var2 : A := (I => 20); A_Var3 : A := (I => 20); B_Var2 : B := (I => 5); begin -- Test simple equality. Put_Line ("-- Simple Equality Test"); if A_Var = A_Var2 then Put_Line ("** Simple Equality Failed (1)"); Passed := False; end if; if A_Var /= A_Var3 then null; else Put_Line ("** Simple Equality Failed (2)"); Passed := False; end if; if A_Var2 /= A_Var3 then Put_Line ("** Simple Equality Failed (3)"); Passed := False; end if; if B_Var = B_Var2 then null; else Put_Line ("** Simple Equality Failed (4)"); Passed := False; end if; end; declare use A_Pack, B_Pack; A_Var2 : A := (I => 20); B_Var2 : B := (I => 5); procedure Class_EQ (P1, P2 : A'Class; Result : Boolean; Key : Character) is -- Compare P1 = P2; the result ought to be Result. -- Use Key to produce error messages. begin if P1 = P2 then if Result then null; else Put_Line ("** Wrong result from equality (" & Key & ')'); Passed := False; end if; else if Result then Put_Line ("** Wrong result from equality (" & Key & ')'); Passed := False; end if; end if; -- Now, try a boolean expression: if (P1 /= P2) = Result then Put_Line ("** Wrong result from inequality (" & Key & ')'); Passed := False; end if; exception when Constraint_Error => Put_Line ("** Constraint_Error raised (" & Key & ')'); Passed := False; end Class_EQ; begin -- Test classwide equality. Put_Line ("-- Classwide Equality Test"); Class_EQ (A_Var, A_Var, True, 'A'); Class_EQ (A_Var, A_Var2, False, 'B'); Class_EQ (B_Var, B_Var2, True, 'C'); Class_EQ (A_Var, B_Var, False, 'D'); -- Different tags always return false. A_Var2.I := 5; Class_EQ (B_Var, A_Var2, False, 'E'); -- Different tags always return -- false, even when the values match. end; declare use A_Pack, B_Pack; A_Var2 : A := (I => 20); B_Var2 : B := (I => 5); procedure Renamed_Class_EQ (P1, P2 : A'Class; Result, Exc : Boolean; Key : Character) is -- Compare P1 = P2; the result ought to be Result, unless Exc -- is true, where it ought to raise an exception. -- Use Key to produce error messages. begin begin if My_Eq (P1, P2) then -- Note this is legal because it is dispatching. if Result or (not Exc) then null; else Put_Line ("** Wrong result from equality (" & Key & ')'); Passed := False; end if; else if Result or Exc then Put_Line ("** Wrong result from equality (" & Key & ')'); Passed := False; end if; end if; exception when Constraint_Error => if Exc then null; else Put_Line ("** Constraint_Error raised (" & Key & ')'); Passed := False; end if; end; begin -- Now, try a boolean expression: if My_Eq (P1, P2) /= Result or else Exc then Put_Line ("** Wrong result from equality (" & Key & ')'); Passed := False; end if; exception when Constraint_Error => if not Exc then Put_Line ("** Constraint_Error raised (" & Key & ')'); Passed := False; end if; end; end Renamed_Class_EQ; begin -- Test renamed classwide equality. Put_Line ("-- Renamed Classwide Equality Test"); Renamed_Class_EQ (A_Var, A_Var, True, False, 'A'); Renamed_Class_EQ (A_Var, A_Var2, False, False, 'B'); Renamed_Class_EQ (B_Var, B_Var2, True, False, 'C'); Renamed_Class_EQ (A_Var, B_Var, False, True, 'D'); A_Var2.I := 5; Renamed_Class_EQ (B_Var, A_Var2, False, True, 'E'); end; if Passed then Text_IO.Put_Line ("--- TestZ88 Passed"); else Text_IO.Put_Line ("*** TestZ88 Failed"); end if; end TestZ88; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-05-02 Ed Schonberg <schonberg@adacore.com> * exp_disp.adb (Set_All_DT_Position, In_Predef_Prim_DT): Refine predicate for the case where the primitive operation is a renaming of equality. An overriding operation that is a user-defined renaming of predefined equality inherits its slot from the overridden operation. Otherwise it is treated as a predefined op and occupies the same predefined slot as equality. A call to it is transformed into a call to its alias, which is the predefined equality. A dispatching call thus uses the proper slot if operation is further inherited and called with class-wide arguments.