From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id F0D78385843F; Wed, 1 Dec 2021 10:26:55 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org F0D78385843F MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-5675] [Ada] Improve support for casing on types with controlled parts X-Act-Checkin: gcc X-Git-Author: Steve Baird X-Git-Refname: refs/heads/master X-Git-Oldrev: be6bb3fc57e2af376e5c18eeca51119e87a55ee3 X-Git-Newrev: bb2fc099e28c6e0fc3f77598c514fa6ec72d846d Message-Id: <20211201102655.F0D78385843F@sourceware.org> Date: Wed, 1 Dec 2021 10:26:55 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 01 Dec 2021 10:26:56 -0000 https://gcc.gnu.org/g:bb2fc099e28c6e0fc3f77598c514fa6ec72d846d commit r12-5675-gbb2fc099e28c6e0fc3f77598c514fa6ec72d846d Author: Steve Baird Date: Fri Nov 5 15:22:05 2021 -0700 [Ada] Improve support for casing on types with controlled parts gcc/ada/ * sem_case.adb (Check_Bindings): Provide a second strategy for implementing bindings and choose which strategy to use for a given binding. The previous approach was to introduce a new object and assign the bound value to the object. The new approach is to introduce a renaming of a dereference of an access value that references the appropriate subcomponent, so no copies are made. The original strategy is still used if the type of the object is elementary. When the renaming approach is used, the initialization of the access value is not generated until expansion. Until this missing initialization is added, the tree looks like a known-at-compile-time dereference of a null access value: Temp : Some_Access_Type; Obj : Designated_Type renames Temp.all; This leads to problems, so a bogus initial value is provided here and then later deleted during expansion. (Check_Composite_Case_Selector): Disallow a case selector expression that requires finalization. Note that it is ok if the selector's type requires finalization, as long as the expression itself doesn't have any "newly constructed" parts. * exp_ch5.adb (Pattern_Match): Detect the case where analysis of a general (i.e., composite selector type) case statement chose to implement a binding as a renaming rather than by making a copy. In that case, generate the assignments to initialize the access-valued object whose designated value is later renamed (and remove the bogus initial value for that object that was added during analysis). * sem_util.ads, sem_util.adb: Add new function Is_Newly_Constructed corresponding to RM 4.4 term. Diff: --- gcc/ada/exp_ch5.adb | 198 +++++++++++++++++++++++++++++-------------- gcc/ada/sem_case.adb | 233 +++++++++++++++++++++++++++++++++++++++------------ gcc/ada/sem_util.adb | 111 ++++++++++++++++++++++++ gcc/ada/sem_util.ads | 19 +++++ 4 files changed, 444 insertions(+), 117 deletions(-) diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 47c6b800eb0..42cffd5186a 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3348,6 +3348,13 @@ package body Exp_Ch5 is Alt : Node_Id; Suppress_Choice_Index_Update : Boolean := False) return Node_Id is + procedure Finish_Binding_Object_Declaration + (Component_Assoc : Node_Id; Subobject : Node_Id); + -- Finish the work that was started during analysis to + -- declare a binding object. If we are generating a copy, + -- then initialize it. If we are generating a renaming, then + -- initialize the access value designating the renamed object. + function Update_Choice_Index return Node_Id is ( Make_Assignment_Statement (Loc, Name => @@ -3368,6 +3375,130 @@ package body Exp_Ch5 is function Indexed_Element (Idx : Pos) return Node_Id; -- Returns the Nth (well, ok, the Idxth) element of Object + --------------------------------------- + -- Finish_Binding_Object_Declaration -- + --------------------------------------- + + procedure Finish_Binding_Object_Declaration + (Component_Assoc : Node_Id; Subobject : Node_Id) + is + Decl_Chars : constant Name_Id := + Binding_Chars (Component_Assoc); + + Block_Stmt : constant Node_Id := First (Statements (Alt)); + pragma Assert (Nkind (Block_Stmt) = N_Block_Statement); + pragma Assert (No (Next (Block_Stmt))); + + Decl : Node_Id := First (Declarations (Block_Stmt)); + Def_Id : Node_Id := Empty; + + -- Declare_Copy indicates which of the two approaches + -- was chosen during analysis: declare (and initialize) + -- a new variable, or use access values to declare a renaming + -- of the appropriate subcomponent of the selector value. + Declare_Copy : constant Boolean := + Nkind (Decl) = N_Object_Declaration; + + function Make_Conditional (Stmt : Node_Id) return Node_Id; + -- If there is only one choice for this alternative, then + -- simply return the argument. If there is more than one + -- choice, then wrap an if-statement around the argument + -- so that it is only executed if the current choice matches. + + ---------------------- + -- Make_Conditional -- + ---------------------- + + function Make_Conditional (Stmt : Node_Id) return Node_Id + is + Condition : Node_Id; + begin + if Present (Choice_Index_Decl) then + Condition := + Make_Op_Eq (Loc, + New_Occurrence_Of + (Defining_Identifier (Choice_Index_Decl), Loc), + Make_Integer_Literal (Loc, Int (Choice_Index))); + + return Make_If_Statement (Loc, + Condition => Condition, + Then_Statements => New_List (Stmt)); + else + -- execute Stmt unconditionally + return Stmt; + end if; + end Make_Conditional; + + begin + -- find the variable to be modified (and its declaration) + loop + if Nkind (Decl) in N_Object_Declaration + | N_Object_Renaming_Declaration + then + Def_Id := Defining_Identifier (Decl); + exit when Chars (Def_Id) = Decl_Chars; + end if; + Next (Decl); + pragma Assert (Present (Decl)); + end loop; + + -- For a binding object, we sometimes make a copy and + -- sometimes introduce a renaming. That decision is made + -- elsewhere. The renaming case involves dereferencing an + -- access value because of the possibility of multiple + -- choices (with multiple binding definitions) for a single + -- alternative. In the copy case, we initialize the copy + -- here (conditionally if there are multiple choices); in the + -- renaming case, we initialize (again, maybe conditionally) + -- the access value. + + if Declare_Copy then + declare + Assign_Value : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Def_Id, Loc), + Expression => Subobject); + + HSS : constant Node_Id := + Handled_Statement_Sequence (Block_Stmt); + begin + Prepend (Make_Conditional (Assign_Value), + Statements (HSS)); + Set_Analyzed (HSS, False); + end; + else + pragma Assert (Nkind (Name (Decl)) = N_Explicit_Dereference); + + declare + Ptr_Obj : constant Entity_Id := + Entity (Prefix (Name (Decl))); + Ptr_Decl : constant Node_Id := Parent (Ptr_Obj); + + Assign_Reference : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ptr_Obj, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => Subobject, + Attribute_Name => Name_Unrestricted_Access)); + begin + Insert_After + (After => Ptr_Decl, + Node => Make_Conditional (Assign_Reference)); + + if Present (Expression (Ptr_Decl)) then + -- Delete bogus initial value built during analysis. + -- Look for "5432" in sem_case.adb. + pragma Assert (Nkind (Expression (Ptr_Decl)) = + N_Unchecked_Type_Conversion); + Set_Expression (Ptr_Decl, Empty); + end if; + end; + end if; + + Set_Analyzed (Block_Stmt, False); + end Finish_Binding_Object_Declaration; + --------------------- -- Indexed_Element -- --------------------- @@ -3519,70 +3650,9 @@ package body Exp_Ch5 is if Binding_Chars (Component_Assoc) /= No_Name then - declare - Decl_Chars : constant Name_Id := - Binding_Chars (Component_Assoc); - - Block_Stmt : constant Node_Id := - First (Statements (Alt)); - pragma Assert - (Nkind (Block_Stmt) = N_Block_Statement); - pragma Assert (No (Next (Block_Stmt))); - Decl : Node_Id - := First (Declarations (Block_Stmt)); - Def_Id : Node_Id := Empty; - - Assignment_Stmt : Node_Id; - Condition : Node_Id; - Prepended_Stmt : Node_Id; - begin - -- find the variable to be modified - while No (Def_Id) or else - Chars (Def_Id) /= Decl_Chars - loop - Def_Id := Defining_Identifier (Decl); - Next (Decl); - end loop; - - Assignment_Stmt := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of - (Def_Id, Loc), - Expression => Subobject); - - -- conditional if multiple choices - - if Present (Choice_Index_Decl) then - Condition := - Make_Op_Eq (Loc, - New_Occurrence_Of - (Defining_Identifier - (Choice_Index_Decl), Loc), - Make_Integer_Literal - (Loc, Int (Choice_Index))); - - Prepended_Stmt := - Make_If_Statement (Loc, - Condition => Condition, - Then_Statements => - New_List (Assignment_Stmt)); - else - -- assignment is unconditional - Prepended_Stmt := Assignment_Stmt; - end if; - - declare - HSS : constant Node_Id := - Handled_Statement_Sequence - (Block_Stmt); - begin - Prepend (Prepended_Stmt, - Statements (HSS)); - - Set_Analyzed (Block_Stmt, False); - Set_Analyzed (HSS, False); - end; - end; + Finish_Binding_Object_Declaration + (Component_Assoc => Component_Assoc, + Subobject => Subobject); end if; Next (Choice); diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 1bd267016d9..eb592c49f62 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -1991,6 +1991,154 @@ package body Sem_Case is procedure Check_Bindings is use Case_Bindings_Table; + + function Binding_Subtype (Idx : Binding_Index; + Tab : Table_Type) + return Entity_Id is + (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc)))); + + procedure Declare_Binding_Objects + (Alt_Start : Binding_Index; + Alt : Node_Id; + First_Choice_Bindings : Natural; + Tab : Table_Type); + -- Declare the binding objects for a given alternative + + ------------------------------ + -- Declare_Binding_Objects -- + ------------------------------ + + procedure Declare_Binding_Objects + (Alt_Start : Binding_Index; + Alt : Node_Id; + First_Choice_Bindings : Natural; + Tab : Table_Type) + is + Loc : constant Source_Ptr := Sloc (Alt); + Declarations : constant List_Id := New_List; + Decl : Node_Id; + Obj_Type : Entity_Id; + Def_Id : Entity_Id; + begin + for FC_Idx in Alt_Start .. + Alt_Start + Binding_Index (First_Choice_Bindings - 1) + loop + Obj_Type := Binding_Subtype (FC_Idx, Tab); + Def_Id := Make_Defining_Identifier + (Loc, + Binding_Chars (Tab (FC_Idx).Comp_Assoc)); + + -- Either make a copy or rename the original. At a + -- minimum, we do not want a copy if it would need + -- finalization. Copies may also introduce problems + -- if default init can have side effects (although we + -- could suppress such default initialization). + -- We have to make a copy in any cases where + -- Unrestricted_Access doesn't work. + -- + -- This is where the copy-or-rename decision is made. + -- In many cases either way would work and so we have + -- some flexibility here. + + if not Is_By_Copy_Type (Obj_Type) then + -- Generate + -- type Ref + -- is access constant Obj_Type; + -- Ptr : Ref := ; + -- Obj : Obj_Type renames Ptr.all; + -- + -- Initialization of Ptr will be generated later + -- during expansion. + + declare + Ptr_Type : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + Ptr_Type_Def : constant Node_Id := + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Obj_Type, Loc)); + + Ptr_Type_Decl : constant Node_Id := + Make_Full_Type_Declaration (Loc, + Ptr_Type, + Type_Definition => Ptr_Type_Def); + + Ptr_Obj : constant Entity_Id := + Make_Temporary (Loc, 'T'); + + -- We will generate initialization code for this + -- object later (during expansion) but in the + -- meantime we don't want the dereference that + -- is generated a few lines below here to be + -- transformed into a Raise_C_E. To prevent this, + -- we provide a bogus initial value here; this + -- initial value will be removed later during + -- expansion. + + Ptr_Obj_Decl : constant Node_Id := + Make_Object_Declaration + (Loc, Ptr_Obj, + Object_Definition => + New_Occurrence_Of (Ptr_Type, Loc), + Expression => + Unchecked_Convert_To + (Ptr_Type, + Make_Integer_Literal (Loc, 5432))); + begin + Mutate_Ekind (Ptr_Type, E_Access_Type); + + -- in effect, Storage_Size => 0 + Set_No_Pool_Assigned (Ptr_Type); + + Set_Is_Access_Constant (Ptr_Type); + + -- We could set Ptr_Type'Alignment here if that + -- ever turns out to be needed for renaming a + -- misaligned subcomponent. + + Mutate_Ekind (Ptr_Obj, E_Variable); + Set_Etype (Ptr_Obj, Ptr_Type); + + Decl := + Make_Object_Renaming_Declaration + (Loc, Def_Id, + Subtype_Mark => + New_Occurrence_Of (Obj_Type, Loc), + Name => + Make_Explicit_Dereference + (Loc, New_Occurrence_Of (Ptr_Obj, Loc))); + + Append_To (Declarations, Ptr_Type_Decl); + Append_To (Declarations, Ptr_Obj_Decl); + end; + else + Decl := Make_Object_Declaration + (Sloc => Loc, + Defining_Identifier => Def_Id, + Object_Definition => + New_Occurrence_Of (Obj_Type, Loc)); + end if; + Append_To (Declarations, Decl); + end loop; + + declare + Old_Statements : constant List_Id := Statements (Alt); + New_Statements : constant List_Id := New_List; + + Block_Statement : constant Node_Id := + Make_Block_Statement (Sloc => Loc, + Declarations => Declarations, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements + (Loc, Old_Statements), + Has_Created_Identifier => True); + begin + Append_To (New_Statements, Block_Statement); + Set_Statements (Alt, New_Statements); + end; + end Declare_Binding_Objects; begin if Last = 0 then -- no bindings to check @@ -2005,10 +2153,6 @@ package body Sem_Case is return Boolean is ( Binding_Chars (Tab (Idx1).Comp_Assoc) = Binding_Chars (Tab (Idx2).Comp_Assoc)); - - function Binding_Subtype (Idx : Binding_Index) - return Entity_Id is - (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc)))); begin -- Verify that elements with given choice or alt value -- are contiguous, and that elements with equal @@ -2172,8 +2316,8 @@ package body Sem_Case is loop if Same_Id (Idx2, FC_Idx) then if not Subtypes_Statically_Match - (Binding_Subtype (Idx2), - Binding_Subtype (FC_Idx)) + (Binding_Subtype (Idx2, Tab), + Binding_Subtype (FC_Idx, Tab)) then Error_Msg_N ("subtype of binding in " @@ -2228,50 +2372,12 @@ package body Sem_Case is -- the current alternative. Then analyze them. if First_Choice_Bindings > 0 then - declare - Loc : constant Source_Ptr := Sloc (Alt); - Declarations : constant List_Id := New_List; - Decl : Node_Id; - begin - for FC_Idx in - Alt_Start .. - Alt_Start + - Binding_Index (First_Choice_Bindings - 1) - loop - Decl := Make_Object_Declaration - (Sloc => Loc, - Defining_Identifier => - Make_Defining_Identifier - (Loc, - Binding_Chars - (Tab (FC_Idx).Comp_Assoc)), - Object_Definition => - New_Occurrence_Of - (Binding_Subtype (FC_Idx), Loc)); - - Append_To (Declarations, Decl); - end loop; - - declare - Old_Statements : constant List_Id := - Statements (Alt); - New_Statements : constant List_Id := - New_List; - - Block_Statement : constant Node_Id := - Make_Block_Statement (Sloc => Loc, - Declarations => Declarations, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements - (Loc, Old_Statements), - Has_Created_Identifier => True); - begin - Append_To - (New_Statements, Block_Statement); - - Set_Statements (Alt, New_Statements); - end; - end; + Declare_Binding_Objects + (Alt_Start => Alt_Start, + Alt => Alt, + First_Choice_Bindings => + First_Choice_Bindings, + Tab => Tab); end if; end; end if; @@ -3361,11 +3467,32 @@ package body Sem_Case is begin if not Is_Composite_Type (Subtyp) then Error_Msg_N - ("case selector type neither discrete nor composite", N); + ("case selector type must be discrete or composite", N); elsif Is_Limited_Type (Subtyp) then - Error_Msg_N ("case selector type is limited", N); + Error_Msg_N ("case selector type must not be limited", N); elsif Is_Class_Wide_Type (Subtyp) then - Error_Msg_N ("case selector type is class-wide", N); + Error_Msg_N ("case selector type must not be class-wide", N); + elsif Needs_Finalization (Subtyp) + and then Is_Newly_Constructed + (Expression (N), Context_Requires_NC => False) + then + -- We could allow this case as long as there are no bindings. + -- + -- If there are bindings, then allowing this case will get + -- messy because the selector expression will be finalized + -- before the statements of the selected alternative are + -- executed (unless we add an INOX-specific change to the + -- accessibility rules to prevent this earlier-than-wanted + -- finalization, but adding new INOX-specific accessibility + -- complexity is probably not the direction we want to go). + -- This early selector finalization would be ok if we made + -- copies in this case (so that the bindings would not yield + -- a view of a finalized object), but then we'd have to deal + -- with finalizing those copies (which would necessarily + -- include defining their accessibility level). So it gets + -- messy either way. + + Error_Msg_N ("case selector must not require finalization", N); end if; end Check_Composite_Case_Selector; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 77302924e11..2f5070a9789 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18426,6 +18426,117 @@ package body Sem_Util is end case; end Is_Name_Reference; + -------------------------- + -- Is_Newly_Constructed -- + -------------------------- + + function Is_Newly_Constructed + (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean + is + Original_Exp : constant Node_Id := Original_Node (Exp); + + function Is_NC (Exp : Node_Id) return Boolean is + (Is_Newly_Constructed (Exp, Context_Requires_NC)); + + -- If the context requires that the expression shall be newly + -- constructed, then "True" is a good result in the sense that the + -- expression satisfies the requirements of the context (and "False" + -- is analogously a bad result). If the context requires that the + -- expression shall *not* be newly constructed, then things are + -- reversed: "False" is the good value and "True" is the bad value. + + Good_Result : constant Boolean := Context_Requires_NC; + Bad_Result : constant Boolean := not Good_Result; + begin + case Nkind (Original_Exp) is + when N_Aggregate + | N_Extension_Aggregate + | N_Function_Call + | N_Op + => + return True; + + when N_Identifier => + return Present (Entity (Original_Exp)) + and then Ekind (Entity (Original_Exp)) = E_Function; + + when N_Qualified_Expression => + return Is_NC (Expression (Original_Exp)); + + when N_Type_Conversion + | N_Unchecked_Type_Conversion + => + if Is_View_Conversion (Original_Exp) then + return Is_NC (Expression (Original_Exp)); + elsif not Comes_From_Source (Exp) then + if Exp /= Original_Exp then + return Is_NC (Original_Exp); + else + return Is_NC (Expression (Original_Exp)); + end if; + else + return False; + end if; + + when N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + => + return Nkind (Exp) = N_Function_Call; + + -- A use of 'Input is a function call, hence allowed. Normally the + -- attribute will be changed to a call, but the attribute by itself + -- can occur with -gnatc. + + when N_Attribute_Reference => + return Attribute_Name (Original_Exp) = Name_Input; + + -- "return raise ..." is OK + + when N_Raise_Expression => + return Good_Result; + + -- For a case expression, all dependent expressions must be legal + + when N_Case_Expression => + declare + Alt : Node_Id; + + begin + Alt := First (Alternatives (Original_Exp)); + while Present (Alt) loop + if Is_NC (Expression (Alt)) = Bad_Result then + return Bad_Result; + end if; + + Next (Alt); + end loop; + + return Good_Result; + end; + + -- For an if expression, all dependent expressions must be legal + + when N_If_Expression => + declare + Then_Expr : constant Node_Id := + Next (First (Expressions (Original_Exp))); + Else_Expr : constant Node_Id := Next (Then_Expr); + begin + if (Is_NC (Then_Expr) = Bad_Result) + or else (Is_NC (Else_Expr) = Bad_Result) + then + return Bad_Result; + else + return Good_Result; + end if; + end; + + when others => + return False; + end case; + end Is_Newly_Constructed; + ------------------------------------ -- Is_Non_Preelaborable_Construct -- ------------------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e251f1ad9fc..2878fce80ff 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1521,6 +1521,25 @@ package Sem_Util is -- integer for use in compile-time checking. Note: Level is restricted to -- be non-dynamic. + function Is_Newly_Constructed + (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean; + -- Indicates whether a given expression is "newly constructed" (RM 4.4). + -- Context_Requires_NC determines the result returned for cases like a + -- raise expression or a conditional expression where some-but-not-all + -- operative constituents are newly constructed. Thus, this is a + -- somewhat unusual predicate in that the result required in order to + -- satisfy whatever legality rule is being checked can influence the + -- result of the predicate. Context_Requires_NC might be True for + -- something like the "newly constructed" rule for a limited expression + -- of a return statement, and False for something like the + -- "newly constructed" rule pertaining to a limited object renaming in a + -- declare expression. Eventually, the code to implement every + -- RM legality rule requiring/prohibiting a "newly constructed" expression + -- should be implemented by calling this function; that's not done yet. + -- The function name doesn't quite match the RM definition of the term if + -- Context_Requires_NC = False; in that case, "Might_Be_Newly_Constructed" + -- might be a more accurate name. + function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Subp : Entity_Id) return Boolean; -- Return True if Subp is a primitive of an abstract type, where the