diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 189 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch8.adb | 86 |
4 files changed, 187 insertions, 110 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bf46454..fa77f2a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2018-05-24 Javier Miranda <miranda@adacore.com> + + * 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. + 2018-05-24 Ed Schonberg <schonberg@adacore.com> * einfo.ads, einfo.adb (Is_Activation_Record): New flag on diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a8e2499..6c3f7dc 100644 --- a/gcc/ada/exp_ch3.adb +++ b/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); diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index d41029d..9d2d5d9 100644 --- a/gcc/ada/exp_ch3.ads +++ b/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 diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index e48ba5e..e2ffb91 100644 --- a/gcc/ada/exp_ch8.adb +++ b/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; |