-- user-defined equality. Factored out of Predefined_Primitive_Bodies.
function Make_Eq_Case
- (E : Entity_Id;
- CL : Node_Id;
- Discr : Entity_Id := Empty) return List_Id;
+ (E : Entity_Id;
+ CL : Node_Id;
+ Discrs : Elist_Id := New_Elmt_List) return List_Id;
-- Building block for variant record equality. Defined to share the code
-- between the tagged and non-tagged case. Given a Component_List node CL,
-- it generates an 'if' followed by a 'case' statement that compares all
-- components of local temporaries named X and Y (that are declared as
-- formals at some upper level). E provides the Sloc to be used for the
- -- generated code. Discr is used as the case statement switch in the case
- -- of Unchecked_Union equality.
+ -- generated code.
+ --
+ -- IF E is an unchecked_union, Discrs is the list of formals created for
+ -- the inferred discriminants of one operand. These formals are used in
+ -- the generated case statements for each variant of the unchecked union.
function Make_Eq_If
(E : Entity_Id;
Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts)));
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
Append_To (Pspecs,
Make_Parameter_Specification (Loc,
-- Unchecked_Unions require additional machinery to support equality.
-- Two extra parameters (A and B) are added to the equality function
- -- parameter list in order to capture the inferred values of the
- -- discriminants in later calls.
+ -- parameter list for each discriminant of the type, in order to
+ -- capture the inferred values of the discriminants in equality calls.
+ -- The names of the parameters match the names of the corresponding
+ -- discriminant, with an added suffix.
if Is_Unchecked_Union (Typ) then
declare
- Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
+ Discr : Entity_Id;
+ Discr_Type : Entity_Id;
+ A, B : Entity_Id;
+ New_Discrs : Elist_Id;
- A : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Name_A);
+ begin
+ New_Discrs := New_Elmt_List;
- B : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Name_B);
+ Discr := First_Discriminant (Typ);
+ while Present (Discr) loop
+ Discr_Type := Etype (Discr);
+ A := Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Discr), 'A'));
- begin
- -- Add A and B to the parameter list
+ B := Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Discr), 'B'));
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => A,
- Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+ -- Add new parameters to the parameter list
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => B,
- Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type => New_Reference_To (Discr_Type, Loc)));
- -- Generate the following header code to compare the inferred
- -- discriminants:
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => B,
+ Parameter_Type => New_Reference_To (Discr_Type, Loc)));
- -- if a /= b then
- -- return False;
- -- end if;
+ Append_Elmt (A, New_Discrs);
- Append_To (Stmts,
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (A, Loc),
- Right_Opnd => New_Reference_To (B, Loc)),
- Then_Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_False, Loc)))));
+ -- Generate the following code to compare each of the inferred
+ -- discriminants:
+
+ -- if a /= b then
+ -- return False;
+ -- end if;
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Reference_To (A, Loc),
+ Right_Opnd => New_Reference_To (B, Loc)),
+ Then_Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ New_Occurrence_Of (Standard_False, Loc)))));
+ Next_Discriminant (Discr);
+ end loop;
-- Generate component-by-component comparison. Note that we must
- -- propagate one of the inferred discriminant formals to act as
- -- the case statement switch.
+ -- propagate the inferred discriminants formals to act as
+ -- the case statement switch. Their value is added when an
+ -- equality call on unchecked unions is expanded.
Append_List_To (Stmts,
- Make_Eq_Case (Typ, Comps, A));
+ Make_Eq_Case (Typ, Comps, New_Discrs));
end;
-- Normal case (not unchecked union)
function Make_Eq_Case
(E : Entity_Id;
CL : Node_Id;
- Discr : Entity_Id := Empty) return List_Id
+ Discrs : Elist_Id := New_Elmt_List) return List_Id
is
Loc : constant Source_Ptr := Sloc (E);
Result : constant List_Id := New_List;
Variant : Node_Id;
Alt_List : List_Id;
+ function Corresponding_Formal (C : Node_Id) return Entity_Id;
+ -- Given the discriminant that controls a given variant of an unchecked
+ -- union, find the formal of the equality function that carries the
+ -- inferred value of the discriminant.
+
+ function External_Name (E : Entity_Id) return Name_Id;
+ -- The value of a given discriminant is conveyed in the corresponding
+ -- formal parameter of the equality routine. The name of this formal
+ -- parameter carries a one-character suffix which is removed here.
+
+ --------------------------
+ -- Corresponding_Formal --
+ --------------------------
+
+ function Corresponding_Formal (C : Node_Id) return Entity_Id is
+ Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
+ Elm : Elmt_Id;
+
+ begin
+ Elm := First_Elmt (Discrs);
+ while Present (Elm) loop
+ if Chars (Discr) = External_Name (Node (Elm)) then
+ return Node (Elm);
+ end if;
+ Next_Elmt (Elm);
+ end loop;
+
+ -- A formal of the proper name must be found
+
+ raise Program_Error;
+ end Corresponding_Formal;
+
+ -------------------
+ -- External_Name --
+ -------------------
+
+ function External_Name (E : Entity_Id) return Name_Id is
+ begin
+ Get_Name_String (Chars (E));
+ Name_Len := Name_Len - 1;
+ return Name_Find;
+ end External_Name;
+
begin
Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
- Statements => Make_Eq_Case (E, Component_List (Variant))));
+ Statements =>
+ Make_Eq_Case (E, Component_List (Variant), Discrs)));
Next_Non_Pragma (Variant);
end loop;
- -- If we have an Unchecked_Union, use one of the parameters that
- -- captures the discriminants.
+ -- If we have an Unchecked_Union, use one of the parameters of the
+ -- enclosing equality routine that captures the discriminant, to use
+ -- as the expression in the generated case statement.
if Is_Unchecked_Union (E) then
Append_To (Result,
Make_Case_Statement (Loc,
- Expression => New_Reference_To (Discr, Loc),
+ Expression =>
+ New_Reference_To (Corresponding_Formal (CL), Loc),
Alternatives => Alt_List));
else
if Is_Unchecked_Union (Op_Type) then
declare
- Lhs_Type : constant Node_Id := Etype (L_Exp);
- Rhs_Type : constant Node_Id := Etype (R_Exp);
- Lhs_Discr_Val : Node_Id;
- Rhs_Discr_Val : Node_Id;
+ Lhs_Type : constant Node_Id := Etype (L_Exp);
+ Rhs_Type : constant Node_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 two extra parameters of
- -- the equality function of the enclosing Unchecked_Union.
+ -- 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
-- . . .
-- 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.
+ -- formals to capture the inferred discriminant values for
+ -- each discriminant of the type.
-- 2. Non-Unchecked_Union enclosing record:
-- In this case we can directly reference the discriminants of
-- the enclosing record.
- -- Lhs of equality
+ -- Process left operand of equality
if Nkind (Lhs) = N_Selected_Component
and then
Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
then
- -- Enclosing record is an Unchecked_Union, use formal A
+ -- 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
- Lhs_Discr_Val := Make_Identifier (Loc, Name_A);
+ 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;
- -- Enclosing record is of a non-Unchecked_Union type, it is
- -- possible to reference the discriminant.
+ -- If enclosing record is of a non-Unchecked_Union type, it
+ -- is possible to reference its discriminants directly.
else
- 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))));
+ 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;
- -- Comment needed here ???
+ -- Otherwise operand is on object with a constrained type.
+ -- Infer the discriminant values from the constraint.
else
- -- Infer the discriminant value
-
- Lhs_Discr_Val :=
- New_Copy
- (Get_Discriminant_Value
- (First_Discriminant (Lhs_Type),
- Lhs_Type,
- Stored_Constraint (Lhs_Type)));
+
+ 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;
- -- Rhs of equality
+ -- 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))))
+ (Scope (Entity (Selector_Name (Rhs))))
then
- Rhs_Discr_Val := Make_Identifier (Loc, Name_B);
+ 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
- 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))));
-
+ 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
- Rhs_Discr_Val :=
- New_Copy (Get_Discriminant_Value (
- First_Discriminant (Rhs_Type),
- Rhs_Type,
- Stored_Constraint (Rhs_Type)));
+ 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;
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Reference_To (Eq, Loc),
- Parameter_Associations => New_List (
- L_Exp,
- R_Exp,
- Lhs_Discr_Val,
- Rhs_Discr_Val)));
+ -- 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_Reference_To (Eq, Loc),
+ Parameter_Associations => Params));
+ end;
end;
-- Normal case, not an unchecked union
else
Rewrite (N,
Make_Function_Call (Loc,
- Name => New_Reference_To (Eq, Loc),
+ Name => New_Reference_To (Eq, Loc),
Parameter_Associations => New_List (L_Exp, R_Exp)));
end if;
projects / gcc.git / commitdiff