Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/exp_ch8.adb @ 131:84e7813d76e9
gcc-8.2
author | mir3636 |
---|---|
date | Thu, 25 Oct 2018 07:37:49 +0900 |
parents | 04ced10e8804 |
children | 1830386684a0 |
line wrap: on
line diff
--- a/gcc/ada/exp_ch8.adb Fri Oct 27 22:46:09 2017 +0900 +++ b/gcc/ada/exp_ch8.adb Thu Oct 25 07:37:49 2018 +0900 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -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 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 @@ 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 @@ 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 @@ 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 @@ 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;