+2019-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.ads, exp_ch4.adb (Build_Eq_Call): New visible
+ subprogram, extracted from Expand_Composite_Equality, to handle
+ properly the composition of equality for variant record types.
+ * exp_ch3.adb (MAke_Eq_If): Use Build_Eq_Call for each
+ component, to handle properly the case of a component with a
+ user-defined equality. Revert to predefined equality if the
+ user-defined operation is abstract, to maintain compatibility
+ with older versions,
+
2019-07-04 Justin Squirek <squirek@adacore.com>
* exp_ch3.adb (Build_Initialization_Call): Fixup
-- or a null statement if the list L is empty
+ -- Equality may be user-defined for a given component type, in which case
+ -- a function call is constructed instead of an operator node. This is an
+ -- Ada 2012 change in the composability of equality for untagged composite
+ -- types.
+
function Make_Eq_If
(E : Entity_Id;
L : List_Id) return Node_Id
C : Node_Id;
Field_Name : Name_Id;
Cond : Node_Id;
+ Next_Test : Node_Id;
+ Typ : Entity_Id;
begin
if No (L) then
C := First_Non_Pragma (L);
while Present (C) loop
+ Typ := Etype (Defining_Identifier (C));
Field_Name := Chars (Defining_Identifier (C));
-- The tags must not be compared: they are not part of the value.
-- discriminants could be picked up in the private type case.
if Field_Name = Name_uParent
- and then Is_Interface (Etype (Defining_Identifier (C)))
+ and then Is_Interface (Typ)
then
null;
elsif Field_Name /= Name_uTag then
- Evolve_Or_Else (Cond,
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Selector_Name => Make_Identifier (Loc, Field_Name)),
+ declare
+ Lhs : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_X),
+ Selector_Name => Make_Identifier (Loc, Field_Name));
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_Y),
- Selector_Name => Make_Identifier (Loc, Field_Name))));
+ Rhs : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_Y),
+ Selector_Name => Make_Identifier (Loc, Field_Name));
+ Eq_Call : Node_Id;
+
+ begin
+ -- Build equality code with a user-defined operator, if
+ -- available, and with the predefined "=" otherwise.
+ -- For compatibility with older Ada versions, and preserve
+ -- the workings of some ASIS tools, we also use the
+ -- predefined operation if the component-type equality
+ -- is abstract, rather than raising Program_Error.
+
+ if Ada_Version < Ada_2012 then
+ Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
+
+ else
+ Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
+
+ if No (Eq_Call) then
+ Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
+
+ -- If a component has a defined abstract equality,
+ -- its application raises Program_Error on that
+ -- component and therefore on the current variant.
+
+ elsif Nkind (Eq_Call) = N_Raise_Program_Error then
+ Set_Etype (Eq_Call, Standard_Boolean);
+ Next_Test := Make_Op_Not (Loc, Eq_Call);
+
+ else
+ Next_Test := Make_Op_Not (Loc, Eq_Call);
+ end if;
+ end if;
+ end;
+
+ Evolve_Or_Else (Cond, Next_Test);
end if;
Next_Non_Pragma (C);
Full_Type : Entity_Id;
Eq_Op : Entity_Id;
- function Find_Primitive_Eq return Node_Id;
- -- AI05-0123: Locate primitive equality for type if it exists, and
- -- build the corresponding call. If operation is abstract, replace
- -- call with an explicit raise. Return Empty if there is no primitive.
-
- -----------------------
- -- Find_Primitive_Eq --
- -----------------------
-
- function Find_Primitive_Eq return Node_Id is
- Prim_E : Elmt_Id;
- Prim : Node_Id;
-
- begin
- Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
- while Present (Prim_E) loop
- Prim := Node (Prim_E);
-
- -- Locate primitive equality with the right signature
-
- if Chars (Prim) = Name_Op_Eq
- and then Etype (First_Formal (Prim)) =
- Etype (Next_Formal (First_Formal (Prim)))
- and then Etype (Prim) = Standard_Boolean
- then
- if Is_Abstract_Subprogram (Prim) then
- return
- Make_Raise_Program_Error (Loc,
- Reason => PE_Explicit_Raise);
-
- else
- return
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Prim, Loc),
- Parameter_Associations => New_List (Lhs, Rhs));
- end if;
- end if;
-
- Next_Elmt (Prim_E);
- end loop;
-
- -- If not found, predefined operation will be used
-
- return Empty;
- end Find_Primitive_Eq;
-
-- Start of processing for Expand_Composite_Equality
begin
-- a primitive equality declared for it.
declare
- Op : constant Node_Id := Find_Primitive_Eq;
+ Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
begin
-- Use user-defined primitive if it exists, otherwise use
Adjust_Result_Type (N, Typ);
end Expand_Short_Circuit_Operator;
- -------------------------------------
+ -----------------------
+ -- Build_Eq_Call --
+ -----------------------
+
+ function Build_Eq_Call
+ (Typ : Entity_Id;
+ Loc : Source_Ptr;
+ Lhs : Node_Id;
+ Rhs : Node_Id) return Node_Id
+ is
+ Prim_E : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
+ while Present (Prim_E) loop
+ Prim := Node (Prim_E);
+
+ -- Locate primitive equality with the right signature
+
+ if Chars (Prim) = Name_Op_Eq
+ and then Etype (First_Formal (Prim)) =
+ Etype (Next_Formal (First_Formal (Prim)))
+ and then Etype (Prim) = Standard_Boolean
+ then
+ if Is_Abstract_Subprogram (Prim) then
+ return
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Explicit_Raise);
+
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Prim, Loc),
+ Parameter_Associations => New_List (Lhs, Rhs));
+ end if;
+ end if;
+
+ Next_Elmt (Prim_E);
+ end loop;
+
+ -- If not found, predefined operation will be used
+
+ return Empty;
+ end Build_Eq_Call;
+
+ ------------------------------------
-- Fixup_Universal_Fixed_Operation --
-------------------------------------
package Exp_Ch4 is
+ function Build_Eq_Call
+ (Typ : Entity_Id;
+ Loc : Source_Ptr;
+ Lhs : Node_Id;
+ Rhs : Node_Id) return Node_Id;
+ -- AI05-0123: Locate primitive equality for type if it exists, and build
+ -- the corresponding call. If operation is abstract, replace call with
+ -- an explicit raise. Return Empty if there is no primitive.
+ -- Used in the construction of record-equality routines for records here
+ -- and for variant records in exp_ch3.adb. These two paths are distinct
+ -- for historical but also technical reasons: for variant records the
+ -- constructed function includes a case statement with nested returns,
+ -- while for records without variants only a simple expression is needed.
+
procedure Expand_N_Allocator (N : Node_Id);
procedure Expand_N_And_Then (N : Node_Id);
procedure Expand_N_Case_Expression (N : Node_Id);
+2019-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat.dg/equal6.adb, gnat.dg/equal6_types.adb,
+ gnat.dg/equal6_types.ads: New testcase.
+
2019-07-04 Justin Squirek <squirek@adacore.com>
* gnat.dg/allocator.adb: New testcase.
--- /dev/null
+-- { dg-do run }
+with Text_IO;
+with Equal6_Types; use Equal6_Types;
+
+procedure Equal6 is
+ Packets_In : To_Evc_Optional_Packet_List_T;
+ Packets_Out : To_Evc_Optional_Packet_List_T;
+begin
+ Packets_In.list (1) :=
+ (Data_Used_Outside_Ertms_System =>
+ (Mail_Box =>
+ (Receiver => 31,
+ Data => (Length => 12, Message => (0, others => 0)))));
+
+ Packets_Out.list (1) :=
+ (Data_Used_Outside_Ertms_System =>
+ (Mail_Box =>
+ (Receiver => 31,
+ Data => (Length => 12, Message => (0, others => 1)))));
+
+ if not (Packets_In = Packets_Out) then
+ raise Program_Error;
+ end if;
+
+ if not (Equal1_Called and then Equal2_Called) then
+ raise Program_Error;
+ end if;
+
+end Equal6;
--- /dev/null
+package body Equal6_Types is
+
+ function "=" (L, R : in Mail_Box_Data_T) return Boolean is
+ use type Bits_T;
+ begin
+ Equal1_Called := True;
+ return L.Message (1) = R.Message (1);
+ end "=";
+
+ function "=" (L, R : in To_Evc_Optional_Packet_List_T) return Boolean is
+ begin
+ Equal2_Called := True;
+ return L.List (1) = R.List (1);
+ end "=";
+end Equal6_Types;
--- /dev/null
+package Equal6_Types is
+ type Bit_T is range 0 .. 1;
+
+ type Bits_T is array (Positive range <>) of Bit_T;
+
+ type Nid_Xuser_T is range 0 .. 511;
+
+ Dispatch_P44_To_Ntc_C : constant Nid_Xuser_T := 102;
+
+ type Mail_Box_Data_T is record
+ Length : Natural;
+ Message : Bits_T (1 .. 200);
+ end record;
+ function "=" (L, R : in Mail_Box_Data_T) return Boolean;
+ Equal1_Called : Boolean := False;
+
+ type Mail_Box_T (Receiver : Nid_Xuser_T := Nid_Xuser_T'First) is record
+ Data : Mail_Box_Data_T;
+ case Receiver is
+ when Dispatch_P44_To_Ntc_C =>
+ Stm_Id : Positive;
+ when others =>
+ null;
+ end case;
+ end record;
+
+ type Data_Used_Outside_Ertms_System_T is record
+ Mail_Box : Mail_Box_T;
+ end record;
+
+ type To_Evc_Optional_Packet_T
+ is record
+ Data_Used_Outside_Ertms_System : Data_Used_Outside_Ertms_System_T;
+ end record;
+
+ type To_Evc_Optional_Packet_List_Length_T is range 0 .. 50;
+ type To_Evc_Optional_Packet_Map_T is
+ array
+ (To_Evc_Optional_Packet_List_Length_T range <>)
+ of To_Evc_Optional_Packet_T;
+
+ type To_Evc_Optional_Packet_List_T is record
+ List : To_Evc_Optional_Packet_Map_T
+ (1 .. To_Evc_Optional_Packet_List_Length_T'Last);
+ end record;
+ function "=" (L, R : in To_Evc_Optional_Packet_List_T) return Boolean;
+ Equal2_Called : Boolean := False;
+
+end Equal6_Types;
projects / gcc.git / commitdiff