For a renaming of the equality operator of a variant record the compiler
erroneously generates code that compares all the record component (thus
computing wrong results).
After this patch the following test provides the correct results.
package Types is
type Data (Bool : Boolean := False) is record
case Bool is
when False =>
null;
when True =>
Val1 : Integer range 0 .. 2 ** 23 - 1;
Val2 : Float;
end case;
end record;
function IsEqual (Left, Right : Data) return Boolean renames "=";
end Types;
with Types;
with Ada.Text_IO;
procedure Main is
A : Types.Data := Types.Data'(Bool => True,
Val1 => 16#05A5A5#,
Val2 => 999999999.0);
B : Types.Data := Types.Data'(Bool => True,
Val1 => 16#0A5A5A#,
Val2 => 6666666666.0);
use type Types.Data;
begin
A := (Bool => False); -- Test
B := (Bool => False); -- Test
if Types.IsEqual (A, B) then -- Test
Ada.Text_IO.Put_Line ("OK");
else
Ada.Text_IO.Put_Line ("ERROR");
end if;
end Main;
Command: gnatmake main; ./main
Output: OK
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-24 Javier Miranda <mira...@adacore.com>
gcc/ada/
* exp_ch8.adb (Build_Body_For_Renaming): Adding support to build the
body of a variant record equality renaming.
(Expand_N_Subprogram_Renaming_Declaration): Adapt the code to the new
implementation of Build_Body_For_Renaming.
* exp_ch3.ads (Build_Variant_Record_Equality): New library level
function that factorizes the functionality needed by
Build_Body_For_Renaming and Expand_Freeze_Record_Type to build the body
of a variant record equality subprogram.
* exp_ch3.adb (Build_Variant_Record_Equality): New subprogram.
(Build_Variant_Record_Equality): New local procedure of
Expand_Freeze_Record_Type containing all the code specific for freezing
the record type that cannot be place in the new library level function.--- gcc/ada/exp_ch3.adb
+++ gcc/ada/exp_ch3.adb
@@ -131,10 +131,6 @@ package body Exp_Ch3 is
-- of a record type that has user-defined primitive equality operations.
-- The resulting operation is a TSS subprogram.
- procedure Build_Variant_Record_Equality (Typ : Entity_Id);
- -- Create An Equality function for the untagged variant record Typ and
- -- attach it to the TSS list
-
procedure Check_Stream_Attributes (Typ : Entity_Id);
-- Check that if a limited extension has a parent with user-defined stream
-- attributes, and does not itself have user-defined stream-attributes,
@@ -4235,7 +4231,14 @@ package body Exp_Ch3 is
-- Generates:
- -- function _Equality (X, Y : T) return Boolean is
+ -- function <<Body_Id>> (Left, Right : T) return Boolean is
+ -- [ X : T renames Left; ]
+ -- [ Y : T renames Right; ]
+ -- -- The above renamings are generated only if the parameters of
+ -- -- this built function (which are passed by the caller) are not
+ -- -- named 'X' and 'Y'; these names are required to reuse several
+ -- -- expander routines when generating this body.
+
-- begin
-- -- Compare discriminants
@@ -4266,71 +4269,45 @@ package body Exp_Ch3 is
-- return True;
-- end _Equality;
- procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
-
- F : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
-
- X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
- Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
-
- Def : constant Node_Id := Parent (Typ);
- Comps : constant Node_Id := Component_List (Type_Definition (Def));
- Stmts : constant List_Id := New_List;
- Pspecs : constant List_Id := New_List;
+ function Build_Variant_Record_Equality
+ (Typ : Entity_Id;
+ Body_Id : Entity_Id;
+ Param_Specs : List_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def : constant Node_Id := Parent (Typ);
+ Comps : constant Node_Id := Component_List (Type_Definition (Def));
+ Left : constant Entity_Id := Defining_Identifier
+ (First (Param_Specs));
+ Right : constant Entity_Id := Defining_Identifier
+ (Next (First (Param_Specs)));
+ Decls : constant List_Id := New_List;
+ Stmts : constant List_Id := New_List;
+ Subp_Body : Node_Id;
begin
- -- If we have a variant record with restriction No_Implicit_Conditionals
- -- in effect, then we skip building the procedure. This is safe because
- -- if we can see the restriction, so can any caller, calls to equality
- -- test routines are not allowed for variant records if this restriction
- -- is active.
-
- if Restriction_Active (No_Implicit_Conditionals) then
- return;
+ pragma Assert (not Is_Tagged_Type (Typ));
+
+ -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
+ -- the name of the formals must be X and Y; otherwise we generate two
+ -- renaming declarations for such purpose.
+
+ if Chars (Left) /= Name_X then
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name => Make_Identifier (Loc, Chars (Left))));
end if;
- -- Derived Unchecked_Union types no longer inherit the equality function
- -- of their parent.
-
- if Is_Derived_Type (Typ)
- and then not Is_Unchecked_Union (Typ)
- and then not Has_New_Non_Standard_Rep (Typ)
- then
- declare
- Parent_Eq : constant Entity_Id :=
- TSS (Root_Type (Typ), TSS_Composite_Equality);
- begin
- if Present (Parent_Eq) then
- Copy_TSS (Parent_Eq, Typ);
- return;
- end if;
- end;
+ if Chars (Right) /= Name_Y then
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name => Make_Identifier (Loc, Chars (Right))));
end if;
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => F,
- Parameter_Specifications => Pspecs,
- Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
-
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => X,
- Parameter_Type => New_Occurrence_Of (Typ, Loc)));
-
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Y,
- Parameter_Type => New_Occurrence_Of (Typ, Loc)));
-
-- Unchecked_Unions require additional machinery to support equality.
-- Two extra parameters (A and B) are added to the equality function
-- parameter list for each discriminant of the type, in order to
@@ -4359,13 +4336,13 @@ package body Exp_Ch3 is
-- Add new parameters to the parameter list
- Append_To (Pspecs,
+ Append_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type =>
New_Occurrence_Of (Discr_Type, Loc)));
- Append_To (Pspecs,
+ Append_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type =>
@@ -4413,12 +4390,20 @@ package body Exp_Ch3 is
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)));
- Set_TSS (Typ, F);
- Set_Is_Pure (F);
+ Subp_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Body_Id,
+ Parameter_Specifications => Param_Specs,
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (F);
- end if;
+ return Subp_Body;
end Build_Variant_Record_Equality;
-----------------------------
@@ -4963,6 +4948,68 @@ package body Exp_Ch3 is
-------------------------------
procedure Expand_Freeze_Record_Type (N : Node_Id) is
+ procedure Build_Variant_Record_Equality (Typ : Entity_Id);
+ -- Create An Equality function for the untagged variant record Typ and
+ -- attach it to the TSS list.
+
+ procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ F : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
+ begin
+ -- For a variant record with restriction No_Implicit_Conditionals
+ -- in effect we skip building the procedure. This is safe because
+ -- if we can see the restriction, so can any caller, and calls to
+ -- equality test routines are not allowed for variant records if
+ -- this restriction is active.
+
+ if Restriction_Active (No_Implicit_Conditionals) then
+ return;
+ end if;
+
+ -- Derived Unchecked_Union types no longer inherit the equality
+ -- function of their parent.
+
+ if Is_Derived_Type (Typ)
+ and then not Is_Unchecked_Union (Typ)
+ and then not Has_New_Non_Standard_Rep (Typ)
+ then
+ declare
+ Parent_Eq : constant Entity_Id :=
+ TSS (Root_Type (Typ), TSS_Composite_Equality);
+ begin
+ if Present (Parent_Eq) then
+ Copy_TSS (Parent_Eq, Typ);
+ return;
+ end if;
+ end;
+ end if;
+
+ Discard_Node (
+ Build_Variant_Record_Equality
+ (Typ => Typ,
+ Body_Id => F,
+ Param_Specs => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc,
+ Name_X),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc,
+ Name_Y),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
+
+ Set_TSS (Typ, F);
+ Set_Is_Pure (F);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (F);
+ end if;
+ end Build_Variant_Record_Equality;
+
+ -- Local variables
+
Typ : constant Node_Id := Entity (N);
Typ_Decl : constant Node_Id := Parent (Typ);
--- gcc/ada/exp_ch3.ads
+++ gcc/ada/exp_ch3.ads
@@ -84,6 +84,13 @@ package Exp_Ch3 is
-- Constructor_Ref is a call to a constructor subprogram. It is currently
-- used only to support C++ constructors.
+ function Build_Variant_Record_Equality
+ (Typ : Entity_Id;
+ Body_Id : Entity_Id;
+ Param_Specs : List_Id) return Node_Id;
+ -- Build the body of the equality function Body_Id for the untagged variant
+ -- record Typ with the given parameters specification list.
+
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted. We
--- gcc/ada/exp_ch8.adb
+++ gcc/ada/exp_ch8.adb
@@ -25,6 +25,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
+with Exp_Ch3; use Exp_Ch3;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
@@ -35,6 +36,7 @@ with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -260,15 +262,17 @@ package body Exp_Ch8 is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Entity (N);
- function Build_Body_For_Renaming return Node_Id;
+ function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
-- Build and return the body for the renaming declaration of an equality
- -- or inequality operator.
+ -- or inequality operator of type Typ.
-----------------------------
-- Build_Body_For_Renaming --
-----------------------------
- function Build_Body_For_Renaming return Node_Id is
+ function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
+ Left : constant Entity_Id := First_Formal (Id);
+ Right : constant Entity_Id := Next_Formal (Left);
Body_Id : Entity_Id;
Decl : Node_Id;
@@ -283,16 +287,44 @@ package body Exp_Ch8 is
Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
Set_Debug_Info_Needed (Body_Id);
- Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Body_Id,
- Parameter_Specifications => Copy_Parameter_List (Id),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
- Declarations => Empty_List,
- Handled_Statement_Sequence => Empty);
+ if Has_Variant_Part (Typ) then
+ Decl :=
+ Build_Variant_Record_Equality
+ (Typ => Typ,
+ Body_Id => Body_Id,
+ Param_Specs => Copy_Parameter_List (Id));
+
+ -- Build body for renamed equality, to capture its current
+ -- meaning. It may be redefined later, but the renaming is
+ -- elaborated where it occurs. This is technically known as
+ -- Squirreling semantics. Renaming is rewritten as a subprogram
+ -- declaration, and the generated body is inserted into the
+ -- freeze actions for the subprogram.
+
+ else
+ Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Body_Id,
+ Parameter_Specifications => Copy_Parameter_List (Id),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence => Empty);
+
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Expand_Record_Equality
+ (Id,
+ Typ => Typ,
+ Lhs => Make_Identifier (Loc, Chars (Left)),
+ Rhs => Make_Identifier (Loc, Chars (Right)),
+ Bodies => Declarations (Decl))))));
+ end if;
return Decl;
end Build_Body_For_Renaming;
@@ -328,10 +360,7 @@ package body Exp_Ch8 is
and then Scope (Entity (Nam)) = Standard_Standard
then
declare
- Left : constant Entity_Id := First_Formal (Id);
- Right : constant Entity_Id := Next_Formal (Left);
- Typ : constant Entity_Id := Etype (Left);
- Decl : Node_Id;
+ Typ : constant Entity_Id := Etype (First_Formal (Id));
begin
-- Check whether this is a renaming of a predefined equality on an
@@ -342,28 +371,7 @@ package body Exp_Ch8 is
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
then
- -- Build body for renamed equality, to capture its current
- -- meaning. It may be redefined later, but the renaming is
- -- elaborated where it occurs. This is technically known as
- -- Squirreling semantics. Renaming is rewritten as a subprogram
- -- declaration, and the generated body is inserted into the
- -- freeze actions for the subprogram.
-
- Decl := Build_Body_For_Renaming;
-
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Expand_Record_Equality
- (Id,
- Typ => Typ,
- Lhs => Make_Identifier (Loc, Chars (Left)),
- Rhs => Make_Identifier (Loc, Chars (Right)),
- Bodies => Declarations (Decl))))));
-
- Append_Freeze_Action (Id, Decl);
+ Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
end if;
end;
end if;
