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 <schonb...@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.
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 247461)
+++ exp_disp.adb (working copy)
@@ -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
