diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 463b77fae67..daf27fb25e9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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, diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index d2f8534da81..64ccdeba326 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7af6dc087a4..63850131309 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 -- ------------------------------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 1891e2e5543..e8d966c8c33 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 28d563f7c39..44ae10aa342 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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); diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 09c364cbd82..411e5dbc4f2 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -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));