ada: Fix renaming of predefined equality operator for unchecked union types
The problem is that the predefined equality operator for unchecked union types is implemented out of line by invoking a function that takes more parameters than the two operands, which means that the renaming is not seen as type conforming with this function and, therefore, is rejected. The way out is to implement these additional parameters as "extra" formal parameters, since this kind of parameters is not taken into account for semantic checks. The change also factors out the duplicated generation of actuals for these additional parameters into a single procedure. gcc/ada/ * exp_ch3.ads (Build_Variant_Record_Equality): Add Spec_Id as second parameter. * exp_ch3.adb (Build_Variant_Record_Equality): For unchecked union types, build the additional parameters as extra formal parameters. (Expand_Freeze_Record_Type.Build_Variant_Record_Equality): Pass Empty as Spec_Id in call to Build_Variant_Record_Equality. * exp_ch4.ads (Expand_Unchecked_Union_Equality): New procedure. * exp_ch4.adb (Expand_Composite_Equality): In the presence of a function implementing composite equality, do not special case the unchecked union types, and only convert the operands if the base types are not the same like in Build_Equality_Call. (Build_Equality_Call): Do not special case the unchecked union types and relocate the operands only once. (Expand_N_Op_Eq): Do not special case the unchecked union types. (Expand_Unchecked_Union_Equality): New procedure implementing the specific expansion of calls to the predefined equality function. * exp_ch6.adb (Is_Unchecked_Union_Equality): New predicate. (Expand_Call): Call Is_Unchecked_Union_Equality to determine whether to call Expand_Unchecked_Union_Equality or Expand_Call_Helper. * exp_ch8.adb (Build_Body_For_Renaming): Set Has_Delayed_Freeze flag earlier on Id and pass Id in call to Build_Variant_Record_Equality.
This commit is contained in:
Eric Botcazou
Marc Poulhiès
parent
abc202d8c5
commit
37449332dd
6 changed files with 390 additions and 427 deletions
|
|
@ -4606,6 +4606,7 @@ package body Exp_Ch3 is
|
|||
|
||||
function Build_Variant_Record_Equality
|
||||
(Typ : Entity_Id;
|
||||
Spec_Id : Entity_Id;
|
||||
Body_Id : Entity_Id;
|
||||
Param_Specs : List_Id) return Node_Id
|
||||
is
|
||||
|
|
@ -4652,42 +4653,66 @@ package body Exp_Ch3 is
|
|||
|
||||
if Is_Unchecked_Union (Typ) then
|
||||
declare
|
||||
Right_Formal : constant Entity_Id :=
|
||||
(if Present (Spec_Id) then Last_Formal (Spec_Id) else Right);
|
||||
Scop : constant Entity_Id :=
|
||||
(if Present (Spec_Id) then Spec_Id else Body_Id);
|
||||
|
||||
procedure Decorate_Extra_Formal (F, F_Typ : Entity_Id);
|
||||
-- Decorate extra formal F with type F_Typ
|
||||
|
||||
---------------------------
|
||||
-- Decorate_Extra_Formal --
|
||||
---------------------------
|
||||
|
||||
procedure Decorate_Extra_Formal (F, F_Typ : Entity_Id) is
|
||||
begin
|
||||
Mutate_Ekind (F, E_In_Parameter);
|
||||
Set_Etype (F, F_Typ);
|
||||
Set_Scope (F, Scop);
|
||||
Set_Mechanism (F, By_Copy);
|
||||
end Decorate_Extra_Formal;
|
||||
|
||||
A : Entity_Id;
|
||||
B : Entity_Id;
|
||||
Discr : Entity_Id;
|
||||
Discr_Type : Entity_Id;
|
||||
Last_Extra : Entity_Id := Empty;
|
||||
New_Discrs : Elist_Id;
|
||||
|
||||
begin
|
||||
Mutate_Ekind (Body_Id, E_Subprogram_Body);
|
||||
New_Discrs := New_Elmt_List;
|
||||
|
||||
Discr := First_Discriminant (Typ);
|
||||
while Present (Discr) loop
|
||||
Discr_Type := Etype (Discr);
|
||||
|
||||
-- Add the new parameters as extra formals
|
||||
|
||||
A :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (Discr), 'A'));
|
||||
|
||||
Decorate_Extra_Formal (A, Discr_Type);
|
||||
|
||||
if Present (Last_Extra) then
|
||||
Set_Extra_Formal (Last_Extra, A);
|
||||
else
|
||||
Set_Extra_Formal (Right_Formal, A);
|
||||
Set_Extra_Formals (Scop, A);
|
||||
end if;
|
||||
|
||||
Append_Elmt (A, New_Discrs);
|
||||
|
||||
B :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (Discr), 'B'));
|
||||
|
||||
-- Add new parameters to the parameter list
|
||||
Decorate_Extra_Formal (B, Discr_Type);
|
||||
|
||||
Append_To (Param_Specs,
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => A,
|
||||
Parameter_Type =>
|
||||
New_Occurrence_Of (Discr_Type, Loc)));
|
||||
|
||||
Append_To (Param_Specs,
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => B,
|
||||
Parameter_Type =>
|
||||
New_Occurrence_Of (Discr_Type, Loc)));
|
||||
|
||||
Append_Elmt (A, New_Discrs);
|
||||
Set_Extra_Formal (A, B);
|
||||
Last_Extra := B;
|
||||
|
||||
-- Generate the following code to compare each of the inferred
|
||||
-- discriminants:
|
||||
|
|
@ -4706,6 +4731,7 @@ package body Exp_Ch3 is
|
|||
Make_Simple_Return_Statement (Loc,
|
||||
Expression =>
|
||||
New_Occurrence_Of (Standard_False, Loc)))));
|
||||
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
|
||||
|
|
@ -5319,7 +5345,7 @@ package body Exp_Ch3 is
|
|||
-- evaluate the conditions.
|
||||
|
||||
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
|
||||
-- Create An Equality function for the untagged variant record Typ and
|
||||
-- Create an equality function for the untagged variant record Typ and
|
||||
-- attach it to the TSS list.
|
||||
|
||||
procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id);
|
||||
|
|
@ -5417,6 +5443,7 @@ package body Exp_Ch3 is
|
|||
Discard_Node (
|
||||
Build_Variant_Record_Equality
|
||||
(Typ => Typ,
|
||||
Spec_Id => Empty,
|
||||
Body_Id => F,
|
||||
Param_Specs => New_List (
|
||||
Make_Parameter_Specification (Loc,
|
||||
|
|
|
|||
|
|
@ -109,10 +109,12 @@ package Exp_Ch3 is
|
|||
|
||||
function Build_Variant_Record_Equality
|
||||
(Typ : Entity_Id;
|
||||
Spec_Id : 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.
|
||||
-- record Typ with the given parameters specification list. If Spec_Id is
|
||||
-- present, the body is built for a renaming of the equality function.
|
||||
|
||||
function Freeze_Type (N : Node_Id) return Boolean;
|
||||
-- This function executes the freezing actions associated with the given
|
||||
|
|
|
|||
|
|
@ -2274,148 +2274,28 @@ package body Exp_Ch4 is
|
|||
Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
|
||||
|
||||
if Present (Eq_Op) then
|
||||
if Etype (First_Formal (Eq_Op)) /= Full_Type then
|
||||
declare
|
||||
Op_Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
|
||||
|
||||
-- Inherited equality from parent type. Convert the actuals to
|
||||
-- match signature of operation.
|
||||
L_Exp, R_Exp : Node_Id;
|
||||
|
||||
declare
|
||||
T : constant Entity_Id := Etype (First_Formal (Eq_Op));
|
||||
begin
|
||||
-- Adjust operands if necessary to comparison type
|
||||
|
||||
begin
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq_Op, Loc),
|
||||
Parameter_Associations => New_List (
|
||||
OK_Convert_To (T, Lhs),
|
||||
OK_Convert_To (T, Rhs)));
|
||||
end;
|
||||
|
||||
else
|
||||
-- Comparison between Unchecked_Union components
|
||||
|
||||
if Is_Unchecked_Union (Full_Type) then
|
||||
declare
|
||||
Lhs_Type : Node_Id := Full_Type;
|
||||
Rhs_Type : Node_Id := Full_Type;
|
||||
Lhs_Discr_Val : Node_Id;
|
||||
Rhs_Discr_Val : Node_Id;
|
||||
|
||||
begin
|
||||
-- Lhs subtype
|
||||
|
||||
if Nkind (Lhs) = N_Selected_Component then
|
||||
Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
|
||||
end if;
|
||||
|
||||
-- Rhs subtype
|
||||
|
||||
if Nkind (Rhs) = N_Selected_Component then
|
||||
Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
|
||||
end if;
|
||||
|
||||
-- Lhs of the composite equality
|
||||
|
||||
if Is_Constrained (Lhs_Type) then
|
||||
|
||||
-- Since the enclosing record type can never be an
|
||||
-- Unchecked_Union (this code is executed for records
|
||||
-- that do not have variants), we may reference its
|
||||
-- discriminant(s).
|
||||
|
||||
if Nkind (Lhs) = N_Selected_Component
|
||||
and then Has_Per_Object_Constraint
|
||||
(Entity (Selector_Name (Lhs)))
|
||||
then
|
||||
Lhs_Discr_Val :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => Prefix (Lhs),
|
||||
Selector_Name =>
|
||||
New_Copy
|
||||
(Get_Discriminant_Value
|
||||
(First_Discriminant (Lhs_Type),
|
||||
Lhs_Type,
|
||||
Stored_Constraint (Lhs_Type))));
|
||||
|
||||
else
|
||||
Lhs_Discr_Val :=
|
||||
New_Copy
|
||||
(Get_Discriminant_Value
|
||||
(First_Discriminant (Lhs_Type),
|
||||
Lhs_Type,
|
||||
Stored_Constraint (Lhs_Type)));
|
||||
|
||||
end if;
|
||||
else
|
||||
-- It is not possible to infer the discriminant since
|
||||
-- the subtype is not constrained.
|
||||
|
||||
return
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Unchecked_Union_Restriction);
|
||||
end if;
|
||||
|
||||
-- Rhs of the composite equality
|
||||
|
||||
if Is_Constrained (Rhs_Type) then
|
||||
if Nkind (Rhs) = N_Selected_Component
|
||||
and then Has_Per_Object_Constraint
|
||||
(Entity (Selector_Name (Rhs)))
|
||||
then
|
||||
Rhs_Discr_Val :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => Prefix (Rhs),
|
||||
Selector_Name =>
|
||||
New_Copy
|
||||
(Get_Discriminant_Value
|
||||
(First_Discriminant (Rhs_Type),
|
||||
Rhs_Type,
|
||||
Stored_Constraint (Rhs_Type))));
|
||||
|
||||
else
|
||||
Rhs_Discr_Val :=
|
||||
New_Copy
|
||||
(Get_Discriminant_Value
|
||||
(First_Discriminant (Rhs_Type),
|
||||
Rhs_Type,
|
||||
Stored_Constraint (Rhs_Type)));
|
||||
|
||||
end if;
|
||||
else
|
||||
return
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Unchecked_Union_Restriction);
|
||||
end if;
|
||||
|
||||
-- Call the TSS equality function with the inferred
|
||||
-- discriminant values.
|
||||
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq_Op, Loc),
|
||||
Parameter_Associations => New_List (
|
||||
Lhs,
|
||||
Rhs,
|
||||
Lhs_Discr_Val,
|
||||
Rhs_Discr_Val));
|
||||
end;
|
||||
|
||||
-- All cases other than comparing Unchecked_Union types
|
||||
if Base_Type (Full_Type) /= Base_Type (Op_Typ) then
|
||||
L_Exp := OK_Convert_To (Op_Typ, Lhs);
|
||||
R_Exp := OK_Convert_To (Op_Typ, Rhs);
|
||||
|
||||
else
|
||||
declare
|
||||
T : constant Entity_Id := Etype (First_Formal (Eq_Op));
|
||||
begin
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of (Eq_Op, Loc),
|
||||
Parameter_Associations => New_List (
|
||||
OK_Convert_To (T, Lhs),
|
||||
OK_Convert_To (T, Rhs)));
|
||||
end;
|
||||
L_Exp := Relocate_Node (Lhs);
|
||||
R_Exp := Relocate_Node (Rhs);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq_Op, Loc),
|
||||
Parameter_Associations => New_List (L_Exp, R_Exp));
|
||||
end;
|
||||
|
||||
-- Equality composes in Ada 2012 for untagged record types. It also
|
||||
-- composes for bounded strings, because they are part of the
|
||||
|
|
@ -8112,242 +7992,29 @@ package body Exp_Ch4 is
|
|||
-------------------------
|
||||
|
||||
procedure Build_Equality_Call (Eq : Entity_Id) is
|
||||
Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
|
||||
L_Exp : Node_Id := Relocate_Node (Lhs);
|
||||
R_Exp : Node_Id := Relocate_Node (Rhs);
|
||||
Op_Typ : constant Entity_Id := Etype (First_Formal (Eq));
|
||||
|
||||
L_Exp, R_Exp : Node_Id;
|
||||
|
||||
begin
|
||||
-- Adjust operands if necessary to comparison type
|
||||
|
||||
if Base_Type (Op_Type) /= Base_Type (A_Typ)
|
||||
if Base_Type (A_Typ) /= Base_Type (Op_Typ)
|
||||
and then not Is_Class_Wide_Type (A_Typ)
|
||||
then
|
||||
L_Exp := OK_Convert_To (Op_Type, L_Exp);
|
||||
R_Exp := OK_Convert_To (Op_Type, R_Exp);
|
||||
end if;
|
||||
|
||||
-- If we have an Unchecked_Union, we need to add the inferred
|
||||
-- discriminant values as actuals in the function call. At this
|
||||
-- point, the expansion has determined that both operands have
|
||||
-- inferable discriminants.
|
||||
|
||||
if Is_Unchecked_Union (Op_Type) then
|
||||
declare
|
||||
Lhs_Type : constant Entity_Id := Etype (L_Exp);
|
||||
Rhs_Type : constant Entity_Id := Etype (R_Exp);
|
||||
|
||||
Lhs_Discr_Vals : Elist_Id;
|
||||
-- List of inferred discriminant values for left operand.
|
||||
|
||||
Rhs_Discr_Vals : Elist_Id;
|
||||
-- List of inferred discriminant values for right operand.
|
||||
|
||||
Discr : Entity_Id;
|
||||
|
||||
begin
|
||||
Lhs_Discr_Vals := New_Elmt_List;
|
||||
Rhs_Discr_Vals := New_Elmt_List;
|
||||
|
||||
-- Per-object constrained selected components require special
|
||||
-- attention. If the enclosing scope of the component is an
|
||||
-- Unchecked_Union, we cannot reference its discriminants
|
||||
-- directly. This is why we use the extra parameters of the
|
||||
-- equality function of the enclosing Unchecked_Union.
|
||||
|
||||
-- type UU_Type (Discr : Integer := 0) is
|
||||
-- . . .
|
||||
-- end record;
|
||||
-- pragma Unchecked_Union (UU_Type);
|
||||
|
||||
-- 1. Unchecked_Union enclosing record:
|
||||
|
||||
-- type Enclosing_UU_Type (Discr : Integer := 0) is record
|
||||
-- . . .
|
||||
-- Comp : UU_Type (Discr);
|
||||
-- . . .
|
||||
-- end Enclosing_UU_Type;
|
||||
-- pragma Unchecked_Union (Enclosing_UU_Type);
|
||||
|
||||
-- Obj1 : Enclosing_UU_Type;
|
||||
-- Obj2 : Enclosing_UU_Type (1);
|
||||
|
||||
-- [. . .] Obj1 = Obj2 [. . .]
|
||||
|
||||
-- Generated code:
|
||||
|
||||
-- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
|
||||
|
||||
-- A and B are the formal parameters of the equality function
|
||||
-- of Enclosing_UU_Type. The function always has two extra
|
||||
-- formals to capture the inferred discriminant values for
|
||||
-- each discriminant of the type.
|
||||
|
||||
-- 2. Non-Unchecked_Union enclosing record:
|
||||
|
||||
-- type
|
||||
-- Enclosing_Non_UU_Type (Discr : Integer := 0)
|
||||
-- is record
|
||||
-- . . .
|
||||
-- Comp : UU_Type (Discr);
|
||||
-- . . .
|
||||
-- end Enclosing_Non_UU_Type;
|
||||
|
||||
-- Obj1 : Enclosing_Non_UU_Type;
|
||||
-- Obj2 : Enclosing_Non_UU_Type (1);
|
||||
|
||||
-- ... Obj1 = Obj2 ...
|
||||
|
||||
-- Generated code:
|
||||
|
||||
-- if not (uu_typeEQ (obj1.comp, obj2.comp,
|
||||
-- obj1.discr, obj2.discr)) then
|
||||
|
||||
-- In this case we can directly reference the discriminants of
|
||||
-- the enclosing record.
|
||||
|
||||
-- Process left operand of equality
|
||||
|
||||
if Nkind (Lhs) = N_Selected_Component
|
||||
and then
|
||||
Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
|
||||
then
|
||||
-- If enclosing record is an Unchecked_Union, use formals
|
||||
-- corresponding to each discriminant. The name of the
|
||||
-- formal is that of the discriminant, with added suffix,
|
||||
-- see Exp_Ch3.Build_Record_Equality for details.
|
||||
|
||||
if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
|
||||
then
|
||||
Discr :=
|
||||
First_Discriminant
|
||||
(Scope (Entity (Selector_Name (Lhs))));
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(Make_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (Discr), 'A')),
|
||||
To => Lhs_Discr_Vals);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
|
||||
-- If enclosing record is of a non-Unchecked_Union type, it
|
||||
-- is possible to reference its discriminants directly.
|
||||
|
||||
else
|
||||
Discr := First_Discriminant (Lhs_Type);
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(Make_Selected_Component (Loc,
|
||||
Prefix => Prefix (Lhs),
|
||||
Selector_Name =>
|
||||
New_Copy
|
||||
(Get_Discriminant_Value (Discr,
|
||||
Lhs_Type,
|
||||
Stored_Constraint (Lhs_Type)))),
|
||||
To => Lhs_Discr_Vals);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Otherwise operand is on object with a constrained type.
|
||||
-- Infer the discriminant values from the constraint.
|
||||
|
||||
else
|
||||
Discr := First_Discriminant (Lhs_Type);
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(New_Copy
|
||||
(Get_Discriminant_Value (Discr,
|
||||
Lhs_Type,
|
||||
Stored_Constraint (Lhs_Type))),
|
||||
To => Lhs_Discr_Vals);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Similar processing for right operand of equality
|
||||
|
||||
if Nkind (Rhs) = N_Selected_Component
|
||||
and then
|
||||
Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
|
||||
then
|
||||
if Is_Unchecked_Union
|
||||
(Scope (Entity (Selector_Name (Rhs))))
|
||||
then
|
||||
Discr :=
|
||||
First_Discriminant
|
||||
(Scope (Entity (Selector_Name (Rhs))));
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(Make_Identifier (Loc,
|
||||
Chars => New_External_Name (Chars (Discr), 'B')),
|
||||
To => Rhs_Discr_Vals);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
|
||||
else
|
||||
Discr := First_Discriminant (Rhs_Type);
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(Make_Selected_Component (Loc,
|
||||
Prefix => Prefix (Rhs),
|
||||
Selector_Name =>
|
||||
New_Copy (Get_Discriminant_Value
|
||||
(Discr,
|
||||
Rhs_Type,
|
||||
Stored_Constraint (Rhs_Type)))),
|
||||
To => Rhs_Discr_Vals);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
else
|
||||
Discr := First_Discriminant (Rhs_Type);
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(New_Copy (Get_Discriminant_Value
|
||||
(Discr,
|
||||
Rhs_Type,
|
||||
Stored_Constraint (Rhs_Type))),
|
||||
To => Rhs_Discr_Vals);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Now merge the list of discriminant values so that values
|
||||
-- of corresponding discriminants are adjacent.
|
||||
|
||||
declare
|
||||
Params : List_Id;
|
||||
L_Elmt : Elmt_Id;
|
||||
R_Elmt : Elmt_Id;
|
||||
|
||||
begin
|
||||
Params := New_List (L_Exp, R_Exp);
|
||||
L_Elmt := First_Elmt (Lhs_Discr_Vals);
|
||||
R_Elmt := First_Elmt (Rhs_Discr_Vals);
|
||||
while Present (L_Elmt) loop
|
||||
Append_To (Params, Node (L_Elmt));
|
||||
Append_To (Params, Node (R_Elmt));
|
||||
Next_Elmt (L_Elmt);
|
||||
Next_Elmt (R_Elmt);
|
||||
end loop;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq, Loc),
|
||||
Parameter_Associations => Params));
|
||||
end;
|
||||
end;
|
||||
|
||||
-- Normal case, not an unchecked union
|
||||
L_Exp := OK_Convert_To (Op_Typ, Lhs);
|
||||
R_Exp := OK_Convert_To (Op_Typ, Rhs);
|
||||
|
||||
else
|
||||
Rewrite (N,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq, Loc),
|
||||
Parameter_Associations => New_List (L_Exp, R_Exp)));
|
||||
L_Exp := Relocate_Node (Lhs);
|
||||
R_Exp := Relocate_Node (Rhs);
|
||||
end if;
|
||||
|
||||
Rewrite (N,
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq, Loc),
|
||||
Parameter_Associations => New_List (L_Exp, R_Exp)));
|
||||
|
||||
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
|
||||
end Build_Equality_Call;
|
||||
|
||||
|
|
@ -8721,62 +8388,18 @@ package body Exp_Ch4 is
|
|||
|
||||
-- Ada 2005 (AI-216): Program_Error is raised when evaluating the
|
||||
-- predefined equality operator for a type which has a subcomponent
|
||||
-- of an Unchecked_Union type whose nominal subtype is unconstrained.
|
||||
-- of an unchecked union type whose nominal subtype is unconstrained.
|
||||
|
||||
elsif Has_Unconstrained_UU_Component (Typl) then
|
||||
Insert_Action (N,
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Unchecked_Union_Restriction));
|
||||
|
||||
-- Prevent Gigi from generating incorrect code by rewriting the
|
||||
-- equality as a standard False. (is this documented somewhere???)
|
||||
|
||||
Rewrite (N,
|
||||
New_Occurrence_Of (Standard_False, Loc));
|
||||
|
||||
elsif Is_Unchecked_Union (Typl) then
|
||||
|
||||
-- If we can infer the discriminants of the operands, we make a
|
||||
-- call to the TSS equality function.
|
||||
|
||||
if Has_Inferable_Discriminants (Lhs)
|
||||
and then
|
||||
Has_Inferable_Discriminants (Rhs)
|
||||
then
|
||||
Build_Equality_Call
|
||||
(TSS (Root_Type (Typl), TSS_Composite_Equality));
|
||||
|
||||
else
|
||||
-- Ada 2005 (AI-216): Program_Error is raised when evaluating
|
||||
-- the predefined equality operator for an Unchecked_Union type
|
||||
-- if either of the operands lack inferable discriminants.
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Unchecked_Union_Restriction));
|
||||
|
||||
-- Emit a warning on source equalities only, otherwise the
|
||||
-- message may appear out of place due to internal use. The
|
||||
-- warning is unconditional because it is required by the
|
||||
-- language.
|
||||
|
||||
if Comes_From_Source (N) then
|
||||
Error_Msg_N
|
||||
("Unchecked_Union discriminants cannot be determined??",
|
||||
N);
|
||||
Error_Msg_N
|
||||
("\Program_Error will be raised for equality operation??",
|
||||
N);
|
||||
end if;
|
||||
|
||||
-- Prevent Gigi from generating incorrect code by rewriting
|
||||
-- the equality as a standard False (documented where???).
|
||||
|
||||
Rewrite (N,
|
||||
New_Occurrence_Of (Standard_False, Loc));
|
||||
end if;
|
||||
|
||||
-- If a type support function is present (for complex cases), use it
|
||||
-- If a type support function is present, e.g. if there is a variant
|
||||
-- part, including an unchecked union type, use it.
|
||||
|
||||
elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
|
||||
Build_Equality_Call
|
||||
|
|
@ -13531,6 +13154,247 @@ package body Exp_Ch4 is
|
|||
Adjust_Result_Type (N, Typ);
|
||||
end Expand_Short_Circuit_Operator;
|
||||
|
||||
-------------------------------------
|
||||
-- Expand_Unchecked_Union_Equality --
|
||||
-------------------------------------
|
||||
|
||||
procedure Expand_Unchecked_Union_Equality
|
||||
(N : Node_Id;
|
||||
Eq : Entity_Id;
|
||||
Lhs : Node_Id;
|
||||
Rhs : Node_Id)
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
function Get_Discr_Values (Op : Node_Id; Lhs : Boolean) return Elist_Id;
|
||||
-- Return the list of inferred discriminant values for Op
|
||||
|
||||
----------------------
|
||||
-- Get_Discr_Values --
|
||||
----------------------
|
||||
|
||||
function Get_Discr_Values (Op : Node_Id; Lhs : Boolean) return Elist_Id
|
||||
is
|
||||
Typ : constant Entity_Id := Etype (Op);
|
||||
Values : constant Elist_Id := New_Elmt_List;
|
||||
|
||||
function Get_Extra_Formal (Nam : Name_Id) return Entity_Id;
|
||||
-- Return the extra formal Nam from the current scope, which must be
|
||||
-- an equality function for an unchecked union type.
|
||||
|
||||
----------------------
|
||||
-- Get_Extra_Formal --
|
||||
----------------------
|
||||
|
||||
function Get_Extra_Formal (Nam : Name_Id) return Entity_Id is
|
||||
Func : constant Entity_Id := Current_Scope;
|
||||
|
||||
Formal : Entity_Id;
|
||||
|
||||
begin
|
||||
pragma Assert (Ekind (Func) = E_Function);
|
||||
|
||||
Formal := Extra_Formals (Func);
|
||||
while Present (Formal) loop
|
||||
if Chars (Formal) = Nam then
|
||||
return Formal;
|
||||
end if;
|
||||
|
||||
Formal := Extra_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
-- An extra formal of the proper name must be found
|
||||
|
||||
raise Program_Error;
|
||||
end Get_Extra_Formal;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Discr : Entity_Id;
|
||||
|
||||
-- Start of processing for Get_Discr_Values
|
||||
|
||||
begin
|
||||
-- Per-object constrained selected components require special
|
||||
-- attention. If the enclosing scope of the component is an
|
||||
-- Unchecked_Union, we cannot reference its discriminants
|
||||
-- directly. This is why we use the extra parameters of the
|
||||
-- equality function of the enclosing Unchecked_Union.
|
||||
|
||||
-- type UU_Type (Discr : Integer := 0) is
|
||||
-- . . .
|
||||
-- end record;
|
||||
-- pragma Unchecked_Union (UU_Type);
|
||||
|
||||
-- 1. Unchecked_Union enclosing record:
|
||||
|
||||
-- type Enclosing_UU_Type (Discr : Integer := 0) is record
|
||||
-- . . .
|
||||
-- Comp : UU_Type (Discr);
|
||||
-- . . .
|
||||
-- end Enclosing_UU_Type;
|
||||
-- pragma Unchecked_Union (Enclosing_UU_Type);
|
||||
|
||||
-- Obj1 : Enclosing_UU_Type;
|
||||
-- Obj2 : Enclosing_UU_Type (1);
|
||||
|
||||
-- [. . .] Obj1 = Obj2 [. . .]
|
||||
|
||||
-- Generated code:
|
||||
|
||||
-- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
|
||||
|
||||
-- A and B are the formal parameters of the equality function
|
||||
-- of Enclosing_UU_Type. The function always has two extra
|
||||
-- formals to capture the inferred discriminant values for
|
||||
-- each discriminant of the type.
|
||||
|
||||
-- 2. Non-Unchecked_Union enclosing record:
|
||||
|
||||
-- type
|
||||
-- Enclosing_Non_UU_Type (Discr : Integer := 0)
|
||||
-- is record
|
||||
-- . . .
|
||||
-- Comp : UU_Type (Discr);
|
||||
-- . . .
|
||||
-- end Enclosing_Non_UU_Type;
|
||||
|
||||
-- Obj1 : Enclosing_Non_UU_Type;
|
||||
-- Obj2 : Enclosing_Non_UU_Type (1);
|
||||
|
||||
-- ... Obj1 = Obj2 ...
|
||||
|
||||
-- Generated code:
|
||||
|
||||
-- if not (uu_typeEQ (obj1.comp, obj2.comp,
|
||||
-- obj1.discr, obj2.discr)) then
|
||||
|
||||
-- In this case we can directly reference the discriminants of
|
||||
-- the enclosing record.
|
||||
|
||||
if Nkind (Op) = N_Selected_Component
|
||||
and then Has_Per_Object_Constraint (Entity (Selector_Name (Op)))
|
||||
then
|
||||
-- If enclosing record is an Unchecked_Union, use formals
|
||||
-- corresponding to each discriminant. The name of the
|
||||
-- formal is that of the discriminant, with added suffix,
|
||||
-- see Exp_Ch3.Build_Variant_Record_Equality for details.
|
||||
|
||||
if Is_Unchecked_Union (Scope (Entity (Selector_Name (Op)))) then
|
||||
Discr :=
|
||||
First_Discriminant
|
||||
(Scope (Entity (Selector_Name (Op))));
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(New_Occurrence_Of
|
||||
(Get_Extra_Formal
|
||||
(New_External_Name
|
||||
(Chars (Discr), (if Lhs then 'A' else 'B'))), Loc),
|
||||
To => Values);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
|
||||
-- If enclosing record is of a non-Unchecked_Union type, it
|
||||
-- is possible to reference its discriminants directly.
|
||||
|
||||
else
|
||||
Discr := First_Discriminant (Typ);
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(Make_Selected_Component (Loc,
|
||||
Prefix => Prefix (Op),
|
||||
Selector_Name =>
|
||||
New_Copy
|
||||
(Get_Discriminant_Value (Discr,
|
||||
Typ,
|
||||
Stored_Constraint (Typ)))),
|
||||
To => Values);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Otherwise operand is on object with a constrained type.
|
||||
-- Infer the discriminant values from the constraint.
|
||||
|
||||
else
|
||||
Discr := First_Discriminant (Typ);
|
||||
while Present (Discr) loop
|
||||
Append_Elmt
|
||||
(New_Copy
|
||||
(Get_Discriminant_Value (Discr,
|
||||
Typ,
|
||||
Stored_Constraint (Typ))),
|
||||
To => Values);
|
||||
Next_Discriminant (Discr);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
return Values;
|
||||
end Get_Discr_Values;
|
||||
|
||||
-- Start of processing for Expand_Unchecked_Union_Equality
|
||||
|
||||
begin
|
||||
-- If we can infer the discriminants of the operands, make a call to Eq
|
||||
|
||||
if Has_Inferable_Discriminants (Lhs)
|
||||
and then
|
||||
Has_Inferable_Discriminants (Rhs)
|
||||
then
|
||||
declare
|
||||
Lhs_Values : constant Elist_Id := Get_Discr_Values (Lhs, True);
|
||||
Rhs_Values : constant Elist_Id := Get_Discr_Values (Rhs, False);
|
||||
|
||||
Formal : Entity_Id;
|
||||
L_Elmt : Elmt_Id;
|
||||
R_Elmt : Elmt_Id;
|
||||
|
||||
begin
|
||||
-- Add the inferred discriminant values as extra actuals
|
||||
|
||||
Formal := Extra_Formals (Eq);
|
||||
L_Elmt := First_Elmt (Lhs_Values);
|
||||
R_Elmt := First_Elmt (Rhs_Values);
|
||||
|
||||
while Present (L_Elmt) loop
|
||||
Analyze_And_Resolve (Node (L_Elmt), Etype (Formal));
|
||||
Add_Extra_Actual_To_Call (N, Formal, Node (L_Elmt));
|
||||
|
||||
Formal := Extra_Formal (Formal);
|
||||
|
||||
Analyze_And_Resolve (Node (R_Elmt), Etype (Formal));
|
||||
Add_Extra_Actual_To_Call (N, Formal, Node (R_Elmt));
|
||||
|
||||
Formal := Extra_Formal (Formal);
|
||||
Next_Elmt (L_Elmt);
|
||||
Next_Elmt (R_Elmt);
|
||||
end loop;
|
||||
end;
|
||||
|
||||
-- Ada 2005 (AI-216): Program_Error is raised when evaluating
|
||||
-- the predefined equality operator for an Unchecked_Union type
|
||||
-- if either of the operands lack inferable discriminants.
|
||||
|
||||
else
|
||||
Insert_Action (N,
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Unchecked_Union_Restriction));
|
||||
|
||||
-- Give a warning on source equalities only, otherwise the message
|
||||
-- may appear out of place due to internal use. It is unconditional
|
||||
-- because it is required by the language.
|
||||
|
||||
if Comes_From_Source (Original_Node (N)) then
|
||||
Error_Msg_N
|
||||
("Unchecked_Union discriminants cannot be determined??", N);
|
||||
Error_Msg_N
|
||||
("\Program_Error will be raised for equality operation??", N);
|
||||
end if;
|
||||
|
||||
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
|
||||
end if;
|
||||
end Expand_Unchecked_Union_Equality;
|
||||
|
||||
------------------------------------
|
||||
-- Fixup_Universal_Fixed_Operation --
|
||||
-------------------------------------
|
||||
|
|
|
|||
|
|
@ -105,6 +105,14 @@ package Exp_Ch4 is
|
|||
-- membership test. The whole membership is rewritten connecting these
|
||||
-- with OR ELSE.
|
||||
|
||||
procedure Expand_Unchecked_Union_Equality
|
||||
(N : Node_Id;
|
||||
Eq : Entity_Id;
|
||||
Lhs : Node_Id;
|
||||
Rhs : Node_Id);
|
||||
-- Expand a call to the predefined equality operator of an unchecked union
|
||||
-- type, possibly rewriting as a raise statement.
|
||||
|
||||
function Integer_Promotion_Possible (N : Node_Id) return Boolean;
|
||||
-- Returns true if the node is a type conversion whose operand is an
|
||||
-- arithmetic operation on signed integers, and the base type of the
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@ with Expander; use Expander;
|
|||
with Exp_Aggr; use Exp_Aggr;
|
||||
with Exp_Atag; use Exp_Atag;
|
||||
with Exp_Ch3; use Exp_Ch3;
|
||||
with Exp_Ch4; use Exp_Ch4;
|
||||
with Exp_Ch7; use Exp_Ch7;
|
||||
with Exp_Ch9; use Exp_Ch9;
|
||||
with Exp_Dbug; use Exp_Dbug;
|
||||
|
|
@ -2800,7 +2801,40 @@ package body Exp_Ch6 is
|
|||
-----------------
|
||||
|
||||
procedure Expand_Call (N : Node_Id) is
|
||||
Post_Call : List_Id;
|
||||
function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean;
|
||||
-- Return True if N is a call to the predefined equality operator of an
|
||||
-- unchecked union type, or a renaming thereof.
|
||||
|
||||
---------------------------------
|
||||
-- Is_Unchecked_Union_Equality --
|
||||
---------------------------------
|
||||
|
||||
function Is_Unchecked_Union_Equality (N : Node_Id) return Boolean is
|
||||
begin
|
||||
if Is_Entity_Name (Name (N))
|
||||
and then Ekind (Entity (Name (N))) = E_Function
|
||||
and then Present (First_Formal (Entity (Name (N))))
|
||||
and then
|
||||
Is_Unchecked_Union (Etype (First_Formal (Entity (Name (N)))))
|
||||
then
|
||||
declare
|
||||
Func : constant Entity_Id := Entity (Name (N));
|
||||
Typ : constant Entity_Id := Etype (First_Formal (Func));
|
||||
Decl : constant Node_Id :=
|
||||
Original_Node (Parent (Declaration_Node (Func)));
|
||||
|
||||
begin
|
||||
return Func = TSS (Typ, TSS_Composite_Equality)
|
||||
or else (Nkind (Decl) = N_Subprogram_Renaming_Declaration
|
||||
and then Nkind (Name (Decl)) = N_Operator_Symbol
|
||||
and then Chars (Name (Decl)) = Name_Op_Eq
|
||||
and then Ekind (Entity (Name (Decl))) = E_Operator);
|
||||
end;
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end Is_Unchecked_Union_Equality;
|
||||
|
||||
-- If this is an indirect call through an Access_To_Subprogram
|
||||
-- with contract specifications, it is rewritten as a call to
|
||||
|
|
@ -2815,6 +2849,10 @@ package body Exp_Ch6 is
|
|||
and then Present
|
||||
(Access_Subprogram_Wrapper (Etype (Name (N))));
|
||||
|
||||
Post_Call : List_Id;
|
||||
|
||||
-- Start of processing for Expand_Call
|
||||
|
||||
begin
|
||||
pragma Assert (Nkind (N) in N_Entry_Call_Statement
|
||||
| N_Function_Call
|
||||
|
|
@ -2890,6 +2928,29 @@ package body Exp_Ch6 is
|
|||
Analyze_And_Resolve (N, Typ);
|
||||
end;
|
||||
|
||||
-- Case of a call to the predefined equality operator of an unchecked
|
||||
-- union type, which requires specific processing.
|
||||
|
||||
elsif Is_Unchecked_Union_Equality (N) then
|
||||
declare
|
||||
Eq : constant Entity_Id := Entity (Name (N));
|
||||
Lhs : constant Node_Id := First_Actual (N);
|
||||
Rhs : constant Node_Id := Next_Actual (Lhs);
|
||||
|
||||
begin
|
||||
Expand_Unchecked_Union_Equality (N, Eq, Lhs, Rhs);
|
||||
|
||||
-- If the call was not rewritten as a raise, expand the actuals
|
||||
|
||||
if Nkind (N) = N_Function_Call then
|
||||
pragma Assert (Check_Number_Of_Actuals (N, Eq));
|
||||
Expand_Actuals (N, Eq, Post_Call);
|
||||
pragma Assert (Is_Empty_List (Post_Call));
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- Normal case
|
||||
|
||||
else
|
||||
Expand_Call_Helper (N, Post_Call);
|
||||
Insert_Post_Call_Actions (N, Post_Call);
|
||||
|
|
|
|||
|
|
@ -294,10 +294,10 @@ package body Exp_Ch8 is
|
|||
begin
|
||||
Set_Alias (Id, Empty);
|
||||
Set_Has_Completion (Id, False);
|
||||
Set_Has_Delayed_Freeze (Id);
|
||||
Rewrite (N,
|
||||
Make_Subprogram_Declaration (Loc,
|
||||
Specification => Specification (N)));
|
||||
Set_Has_Delayed_Freeze (Id);
|
||||
|
||||
Body_Id := Make_Defining_Identifier (Loc, Chars (Id));
|
||||
Set_Debug_Info_Needed (Body_Id);
|
||||
|
|
@ -306,6 +306,7 @@ package body Exp_Ch8 is
|
|||
Decl :=
|
||||
Build_Variant_Record_Equality
|
||||
(Typ => Typ,
|
||||
Spec_Id => Id,
|
||||
Body_Id => Body_Id,
|
||||
Param_Specs => Copy_Parameter_List (Id));
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue