diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2a1a406850e..d71dcaf8969 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -358,9 +358,11 @@ package Einfo is -- -- For objects, the Actual_Subtype is set only if this is a discriminated -- type. For arrays, the bounds of the expression are obtained and the --- Etype of the object is directly the constrained subtype. This is --- rather irregular, and the semantic checks that depend on the nominal --- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). +-- Etype of the object is directly the constrained subtype, except in the +-- case of a return object that lives on the secondary stack where Etype +-- is the nominal unconstrained subtype. This is rather irregular and the +-- semantic checks that depend on the nominal subtype being unconstrained +-- use flag Is_Constr_Subt_For_U_Nominal(qv). -- Address_Clause (synthesized) -- Applies to entries, objects and subprograms. Set if an address clause diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3f51ed6b457..4d8bb817b80 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6841,7 +6841,7 @@ package body Exp_Aggr is or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration and then (Needs_Finalization (Typ) - or else Is_Build_In_Place_Return_Object + or else Is_Special_Return_Object (Defining_Identifier (Parent_Node)))) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5050ec6eab5..6de5843b4ba 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6289,6 +6289,18 @@ package body Exp_Ch3 is -- Generate all default initialization actions for object Def_Id. Any -- new code is inserted after node After. + procedure Initialize_Return_Object + (Tag_Assign : Node_Id; + Adj_Call : Node_Id; + Expr : Node_Id; + Init_Stmt : Node_Id; + After : Node_Id); + -- Generate all initialization actions for return object Def_Id. Any + -- new code is inserted after node After. + + function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id; + -- Make an allocator for a return object initialized with Expr + function OK_To_Rename_Ref (N : Node_Id) return Boolean; -- Return True if N denotes an entity with OK_To_Rename set @@ -7047,6 +7059,108 @@ package body Exp_Ch3 is end if; end Default_Initialize_Object; + ------------------------------ + -- Initialize_Return_Object -- + ------------------------------ + + procedure Initialize_Return_Object + (Tag_Assign : Node_Id; + Adj_Call : Node_Id; + Expr : Node_Id; + Init_Stmt : Node_Id; + After : Node_Id) + is + begin + if Present (Tag_Assign) then + Insert_Action_After (After, Tag_Assign); + end if; + + if Present (Adj_Call) then + Insert_Action_After (After, Adj_Call); + end if; + + if No (Expr) then + Default_Initialize_Object (After); + + elsif Is_Delayed_Aggregate (Expr) + and then not No_Initialization (N) + then + Convert_Aggr_In_Object_Decl (N); + + elsif Present (Init_Stmt) then + Insert_Action_After (After, Init_Stmt); + Set_Expression (N, Empty); + end if; + end Initialize_Return_Object; + + ------------------------------- + -- Make_Allocator_For_Return -- + ------------------------------- + + function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is + Func_Id : constant Entity_Id := Return_Applies_To (Scope (Def_Id)); + + Alloc : Node_Id; + + begin + -- If the return object's declaration includes an expression and the + -- declaration isn't marked as No_Initialization, then we generate an + -- allocator with a qualified expression. Although this is necessary + -- only in the case where the result type is an interface (or class- + -- wide interface), we do it in all cases for the sake of consistency + -- instead of subsequently generating a separate assignment. + + if Present (Expr) + and then not Is_Delayed_Aggregate (Expr) + and then not No_Initialization (N) + then + -- Ada 2005 (AI95-344): If the result type is class-wide, insert + -- a check that the level of the return expression's underlying + -- type is not deeper than the level of the master enclosing the + -- function. + + -- AI12-043: The check is made immediately after the return object + -- is created. + + if Is_Class_Wide_Type (Etype (Func_Id)) then + Apply_CW_Accessibility_Check (Expr, Func_Id); + end if; + + -- We always use the type of the expression for the qualified + -- expression, rather than the return object's type. We cannot + -- always use the return object's type because the expression + -- might be of a specific type and the result object mignt not. + + Alloc := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Expr), Loc), + Expression => New_Copy_Tree (Expr))); + + else + Alloc := + Make_Allocator (Loc, + Expression => New_Occurrence_Of (Typ, Loc)); + + -- If the return object requires default initialization, then it + -- will happen later following the elaboration of the renaming. + -- If we don't turn it off here, then the object will be default + -- initialized twice. + + Set_No_Initialization (Alloc); + end if; + + -- Set the flag indicating that the allocator is made for a special + -- return object. This is used to bypass various legality checks as + -- well as to make sure that the result is not adjusted twice. + + Set_For_Special_Return_Object (Alloc); + + return Alloc; + end Make_Allocator_For_Return; + ---------------------- -- OK_To_Rename_Ref -- ---------------------- @@ -7060,10 +7174,9 @@ package body Exp_Ch3 is -- Local variables - Adj_Call : Node_Id; - Expr_Q : Node_Id; - Id_Ref : Node_Id; - Tag_Assign : Node_Id; + Adj_Call : Node_Id := Empty; + Expr_Q : Node_Id := Empty; + Tag_Assign : Node_Id := Empty; Init_After : Node_Id := N; -- Node after which the initialization actions are to be inserted. This @@ -7172,8 +7285,6 @@ package body Exp_Ch3 is -- Default initialization required, and no expression present if No (Expr) then - Expr_Q := Expr; - -- If we have a type with a variant part, the initialization proc -- will contain implicit tests of the discriminant values, which -- counts as a violation of the restriction No_Implicit_Conditionals. @@ -7232,7 +7343,7 @@ package body Exp_Ch3 is end if; end if; - if not Is_Build_In_Place_Return_Object (Def_Id) then + if not Is_Special_Return_Object (Def_Id) then Default_Initialize_Object (Init_After); end if; @@ -7292,7 +7403,7 @@ package body Exp_Ch3 is Expander_Mode_Restore; end if; - if not Is_Build_In_Place_Return_Object (Def_Id) then + if not Is_Special_Return_Object (Def_Id) then Convert_Aggr_In_Object_Decl (N); end if; @@ -7363,12 +7474,12 @@ package body Exp_Ch3 is then pragma Assert (Is_Class_Wide_Type (Typ)); - -- If the object is a built-in-place return object, bypass special + -- If the object is a special return object, then bypass special -- treatment of class-wide interface initialization below. In this -- case, the expansion of the return statement will take care of -- creating the object (via allocator) and initializing it. - if Is_Build_In_Place_Return_Object (Def_Id) then + if Is_Special_Return_Object (Def_Id) then null; elsif Tagged_Type_Expansion then @@ -7668,8 +7779,7 @@ package body Exp_Ch3 is if Present (Tag_Assign) then if Present (Following_Address_Clause (N)) then Ensure_Freeze_Node (Def_Id); - - else + elsif not Is_Special_Return_Object (Def_Id) then Insert_Action_After (Init_After, Tag_Assign); end if; @@ -7679,23 +7789,26 @@ package body Exp_Ch3 is -- record type. elsif Is_CPP_Constructor_Call (Expr) then + declare + Id_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); - -- The call to the initialization procedure does NOT freeze the - -- object being initialized. + begin + -- The call to the initialization procedure does NOT freeze + -- the object being initialized. - Id_Ref := New_Occurrence_Of (Def_Id, Loc); - Set_Must_Not_Freeze (Id_Ref); - Set_Assignment_OK (Id_Ref); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); - Insert_Actions_After (Init_After, - Build_Initialization_Call (Loc, Id_Ref, Typ, - Constructor_Ref => Expr)); + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ, + Constructor_Ref => Expr)); - -- We remove here the original call to the constructor - -- to avoid its management in the backend + -- We remove here the original call to the constructor + -- to avoid its management in the backend - Set_Expression (N, Empty); - return; + Set_Expression (N, Empty); + return; + end; -- Handle initialization of limited tagged types @@ -7735,18 +7848,15 @@ package body Exp_Ch3 is then Set_Is_Known_Valid (Def_Id); - elsif Is_Access_Type (Typ) then + -- For access types, set the Is_Known_Non_Null flag if the + -- initializing value is known to be non-null. We can also + -- set Can_Never_Be_Null if this is a constant. - -- For access types set the Is_Known_Non_Null flag if the - -- initializing value is known to be non-null. We can also set - -- Can_Never_Be_Null if this is a constant. + elsif Is_Access_Type (Typ) and then Known_Non_Null (Expr) then + Set_Is_Known_Non_Null (Def_Id, True); - if Known_Non_Null (Expr) then - Set_Is_Known_Non_Null (Def_Id, True); - - if Constant_Present (N) then - Set_Can_Never_Be_Null (Def_Id); - end if; + if Constant_Present (N) then + Set_Can_Never_Be_Null (Def_Id); end if; end if; @@ -7762,6 +7872,7 @@ package body Exp_Ch3 is and then not Is_Generic_Type (Typ) then Ensure_Valid (Expr); + if Safe_To_Capture_Value (N, Def_Id) then Set_Is_Known_Valid (Def_Id); end if; @@ -7839,10 +7950,9 @@ package body Exp_Ch3 is Obj_Ref => New_Occurrence_Of (Def_Id, Loc), Typ => Base_Typ); - -- Guard against a missing [Deep_]Adjust when the base type - -- was not properly frozen. - - if Present (Adj_Call) then + if Present (Adj_Call) + and then not Is_Special_Return_Object (Def_Id) + then Insert_Action_After (Init_After, Adj_Call); end if; end if; @@ -8092,78 +8202,12 @@ package body Exp_Ch3 is -- an unconstrained array on the heap. In this case the -- result object's type is a constrained array type even -- though the function's type is unconstrained. + Obj_Alloc_Formal : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); Pool_Id : constant Entity_Id := Make_Temporary (Loc, 'P'); - function Make_Allocator_For_BIP_Return return Node_Id; - -- Make an allocator for the BIP return being processed - - ----------------------------------- - -- Make_Allocator_For_BIP_Return -- - ----------------------------------- - - function Make_Allocator_For_BIP_Return return Node_Id is - Alloc : Node_Id; - - begin - if Present (Expr_Q) - and then not Is_Delayed_Aggregate (Expr_Q) - and then not No_Initialization (N) - then - -- Always use the type of the expression for the - -- qualified expression, rather than the result type. - -- In general we cannot always use the result type - -- for the allocator, because the expression might be - -- of a specific type, such as in the case of an - -- aggregate or even a nonlimited object when the - -- result type is a limited class-wide interface type. - - Alloc := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Expr_Q), Loc), - Expression => New_Copy_Tree (Expr_Q))); - - else - -- If the function returns a class-wide type we cannot - -- use the return type for the allocator. Instead we - -- use the type of the expression, which must be an - -- aggregate of a definite type. - - if Is_Class_Wide_Type (Typ) then - Alloc := - Make_Allocator (Loc, - Expression => - New_Occurrence_Of (Etype (Expr_Q), Loc)); - - else - Alloc := - Make_Allocator (Loc, - Expression => - New_Occurrence_Of (Typ, Loc)); - end if; - - -- If the object requires default initialization then - -- that will happen later following the elaboration of - -- the object renaming. If we don't turn it off here - -- then the object will be default initialized twice. - - Set_No_Initialization (Alloc); - end if; - - -- Set the flag indicating that the allocator came from - -- a build-in-place return statement, so we can avoid - -- adjusting the allocated object. - - Set_Alloc_For_BIP_Return (Alloc); - - return Alloc; - end Make_Allocator_For_BIP_Return; - Acc_Typ : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_Obj_Id : Entity_Id; @@ -8209,13 +8253,13 @@ package body Exp_Ch3 is -- First create the Heap_Allocator - Heap_Allocator := Make_Allocator_For_BIP_Return; + Heap_Allocator := Make_Allocator_For_Return (Expr_Q); -- The Pool_Allocator is just like the Heap_Allocator, -- except we set Storage_Pool and Procedure_To_Call so -- it will use the user-defined storage pool. - Pool_Allocator := Make_Allocator_For_BIP_Return; + Pool_Allocator := Make_Allocator_For_Return (Expr_Q); -- Do not generate the renaming of the build-in-place -- pool parameter on ZFP because the parameter is not @@ -8256,7 +8300,7 @@ package body Exp_Ch3 is -- allocation. else - SS_Allocator := Make_Allocator_For_BIP_Return; + SS_Allocator := Make_Allocator_For_Return (Expr_Q); -- The heap and pool allocators are marked as -- Comes_From_Source since they correspond to an @@ -8427,7 +8471,10 @@ package body Exp_Ch3 is -- From now on, the type of the return object is the -- designated type. - Set_Etype (Def_Id, Desig_Typ); + if Desig_Typ /= Typ then + Set_Etype (Def_Id, Desig_Typ); + Set_Actual_Subtype (Def_Id, Typ); + end if; -- Remember the local access object for use in the -- dereference of the renaming created below. @@ -8474,6 +8521,7 @@ package body Exp_Ch3 is Alloc_Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Alloc_Obj_Id, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => @@ -8492,18 +8540,8 @@ package body Exp_Ch3 is -- Initialize the object now that it has got its final subtype, -- but before rewriting it as a renaming. - if No (Expr_Q) then - Default_Initialize_Object (Init_After); - - elsif Is_Delayed_Aggregate (Expr_Q) - and then not No_Initialization (N) - then - Convert_Aggr_In_Object_Decl (N); - - elsif Present (Init_Stmt) then - Insert_Action_After (Init_After, Init_Stmt); - Set_Expression (N, Empty); - end if; + Initialize_Return_Object + (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After); -- Replace the return object declaration with a renaming of a -- dereference of the access value designating the return object. @@ -8513,6 +8551,198 @@ package body Exp_Ch3 is Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); Set_Etype (Expr_Q, Etype (Def_Id)); + Rewrite_As_Renaming := True; + end; + + -- If we can rename the initialization expression, we need to make sure + -- that we use the proper type in the case of a return object that lives + -- on the secondary stack. See other cases below for a similar handling. + + elsif Rewrite_As_Renaming then + if Is_Secondary_Stack_Return_Object (Def_Id) then + declare + Func_Id : constant Entity_Id := + Return_Applies_To (Scope (Def_Id)); + + Desig_Typ : constant Entity_Id := + (if Ekind (Typ) = E_Array_Subtype + then Etype (Func_Id) else Typ); + + begin + -- From now on, the type of the return object is the + -- designated type. + + if Desig_Typ /= Typ then + Set_Etype (Def_Id, Desig_Typ); + Set_Actual_Subtype (Def_Id, Typ); + end if; + end; + end if; + + -- If this is the return object of a function returning on the secondary + -- stack, convert the declaration to a renaming of the dereference of ah + -- allocator for the secondary stack. + + -- Result : T [:= ]; + + -- is converted to + + -- type Txx is access all ...; + -- Rxx : constant Txx := + -- new ['()][storage_pool = + -- system__secondary_stack__ss_pool][procedure_to_call = + -- system__secondary_stack__ss_allocate]; + + -- Result : T renames Rxx.all; + + elsif Is_Secondary_Stack_Return_Object (Def_Id) then + declare + Func_Id : constant Entity_Id := + Return_Applies_To (Scope (Def_Id)); + + Desig_Typ : constant Entity_Id := + (if Ekind (Typ) = E_Array_Subtype + then Etype (Func_Id) else Typ); + -- Ensure that the we use a fat pointer when allocating + -- an unconstrained array on the heap. In this case the + -- result object's type is a constrained array type even + -- though the function's type is unconstrained. + + Acc_Typ : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Ptr_Type_Decl : Node_Id; + + begin + -- Create an access type designating the function's + -- result subtype. + + Acc_Typ := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Desig_Typ, Loc))); + + Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Acc_Typ, Loc), + Expression => Make_Allocator_For_Return (Expr_Q)); + + Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); + + Set_Uses_Sec_Stack (Func_Id); + Set_Uses_Sec_Stack (Scope (Def_Id)); + Set_Sec_Stack_Needed_For_Return (Scope (Def_Id)); + + -- From now on, the type of the return object is the + -- designated type. + + if Desig_Typ /= Typ then + Set_Etype (Def_Id, Desig_Typ); + Set_Actual_Subtype (Def_Id, Typ); + end if; + + -- Initialize the object now that it has got its final subtype, + -- but before rewriting it as a renaming. + + Initialize_Return_Object + (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After); + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return object. + + Expr_Q := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)); + Set_Etype (Expr_Q, Etype (Def_Id)); + + Rewrite_As_Renaming := True; + end; + + -- If this is the return object of a function returning a by-reference + -- type, convert the declaration to a renaming of the dereference of ah + -- allocator for the return stack. + + -- Result : T [:= ]; + + -- is converted to + + -- type Txx is access all ...; + -- Rxx : constant Txx := + -- new ['()][storage_pool = + -- system__secondary_stack__rs_pool][procedure_to_call = + -- system__secondary_stack__rs_allocate]; + + -- Result : T renames Rxx.all; + + elsif Back_End_Return_Slot + and then Is_By_Reference_Return_Object (Def_Id) + then + declare + Acc_Typ : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Ptr_Type_Decl : Node_Id; + + begin + -- Create an access type designating the function's + -- result subtype. + + Acc_Typ := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Typ, Loc))); + + Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool)); + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Acc_Typ, Loc), + Expression => Make_Allocator_For_Return (Expr_Q)); + + Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); + + -- Initialize the object now that it has got its final subtype, + -- but before rewriting it as a renaming. + + Initialize_Return_Object + (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After); + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return object. + + Expr_Q := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)); + Set_Etype (Expr_Q, Etype (Def_Id)); + Rewrite_As_Renaming := True; end; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7edef4c39c3..a8980a63d46 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -898,6 +898,11 @@ package body Exp_Ch4 is (Directly_Designated_Type (Etype (N)))); null; + -- Likewise if the allocator is made for a special return object + + elsif For_Special_Return_Object (N) then + null; + elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then TagT := T; TagR := @@ -946,19 +951,18 @@ package body Exp_Ch4 is -- Adjust procedure, and the object is built in place. In Ada 95, the -- object can be limited but not inherently limited if this allocator -- came from a return statement (we're allocating the result on the - -- secondary stack). In that case, the object will be moved, so we do - -- want to Adjust. However, if it's a nonlimited build-in-place - -- function call, Adjust is not wanted. - -- - -- Needs_Finalization (DesigT) can differ from Needs_Finalization (T) + -- secondary stack); in that case, the object will be moved, so we do + -- want to Adjust. But the call is always skipped if the allocator is + -- made for a special return object because it's generated elsewhere. + + -- Needs_Finalization (DesigT) may differ from Needs_Finalization (T) -- if one of the two types is class-wide, and the other is not. if Needs_Finalization (DesigT) and then Needs_Finalization (T) and then not Aggr_In_Place and then not Is_Limited_View (T) - and then not Alloc_For_BIP_Return (N) - and then not Is_Build_In_Place_Function_Call (Expression (N)) + and then not For_Special_Return_Object (N) then -- An unchecked conversion is needed in the classwide case because -- the designated type can be an ancestor of the subtype mark of @@ -2724,6 +2728,7 @@ package body Exp_Ch4 is Len : Unat; J : Nat; Clen : Node_Id; + Decl : Node_Id; Set : Boolean; -- Start of processing for Expand_Concatenate @@ -3250,10 +3255,32 @@ package body Exp_Ch4 is Set_Is_Internal (Ent); Set_Debug_Info_Needed (Ent); + -- If the bound is statically known to be out of range, we do not want + -- to abort, we want a warning and a constraint error at run time. Note + -- that we have arranged that the result will not be treated as a static + -- constant, so we won't get an illegality during the insertion. We also + -- enable all checks (in particular range checks) in case the bounds of + -- Subtyp_Ind are out of range. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => Subtyp_Ind); + Insert_Action (Cnode, Decl); + + -- If the result of the concatenation appears as the initializing + -- expression of an object declaration, we can just rename the + -- result, rather than copying it. + + Set_OK_To_Rename (Ent); + -- If we are concatenating strings and the current scope already uses - -- the secondary stack, allocate the resulting string also on the - -- secondary stack to avoid putting too much pressure on the primary - -- stack. + -- the secondary stack, allocate the result also on the secondary stack + -- to avoid putting too much pressure on the primary stack. + + -- We use an unconstrained allocation, i.e. we also allocate the bounds, + -- so that the result can be renamed in all contexts. + -- Don't do this if -gnatd.h is set, as this will break the wrapping of -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat. @@ -3263,85 +3290,78 @@ package body Exp_Ch4 is and then not Debug_Flag_Dot_H then -- Generate: - -- subtype Axx is ...; - -- type Ayy is access Axx; - -- Rxx : Ayy := new [storage_pool = ss_pool]; - -- Sxx : renames Rxx.all; + -- subtype Axx is String ( .. ) + -- type Ayy is access String; + -- Rxx : Ayy := new [storage_pool = ss_pool]; + -- Sxx : String renames Rxx.all; declare - Alloc : Node_Id; ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Alloc : Node_Id; + Deref : Node_Id; Temp : Entity_Id; begin - Insert_Action (Cnode, + Insert_Action (Decl, Make_Subtype_Declaration (Loc, Defining_Identifier => ConstrT, Subtype_Indication => Subtyp_Ind), Suppress => All_Checks); - Freeze_Itype (ConstrT, Cnode); - Insert_Action (Cnode, + Freeze_Itype (ConstrT, Decl); + + Insert_Action (Decl, Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))), + Subtype_Indication => New_Occurrence_Of (Atyp, Loc))), Suppress => All_Checks); + + Mutate_Ekind (Acc_Typ, E_Access_Type); + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + Alloc := Make_Allocator (Loc, Expression => New_Occurrence_Of (ConstrT, Loc)); - -- Allocate on the secondary stack. This is currently done - -- only for type String, which normally doesn't have default - -- initialization, but we need to Set_No_Initialization in case - -- of Initialize_Scalars or Normalize_Scalars; otherwise, the - -- allocator will get transformed and will not use the secondary - -- stack. + -- This is currently done only for type String, which normally + -- doesn't have default initialization, but we need to set the + -- No_Initialization flag in case of either Initialize_Scalars + -- or Normalize_Scalars. - Set_Storage_Pool (Alloc, RTE (RE_SS_Pool)); - Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate)); Set_No_Initialization (Alloc); Temp := Make_Temporary (Loc, 'R', Alloc); - Insert_Action (Cnode, + Insert_Action (Decl, Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => Alloc), Suppress => All_Checks); - Insert_Action (Cnode, + Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)); + Set_Etype (Deref, Atyp); + + Rewrite (Decl, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Ent, - Subtype_Mark => New_Occurrence_Of (ConstrT, Loc), - Name => - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Temp, Loc))), - Suppress => All_Checks); + Subtype_Mark => New_Occurrence_Of (Atyp, Loc), + Name => Deref)); + + -- We do not analyze this renaming declaration because this would + -- change the subtype of Ent back to a constrained string. + + Set_Etype (Ent, Atyp); + Set_Renamed_Object (Ent, Deref); + Set_Analyzed (Decl); end; - else - -- If the bound is statically known to be out of range, we do not - -- want to abort, we want a warning and a runtime constraint error. - -- Note that we have arranged that the result will not be treated as - -- a static constant, so we won't get an illegality during this - -- insertion. - -- We also enable checks (in particular range checks) in case the - -- bounds of Subtyp_Ind are out of range. - - Insert_Action (Cnode, - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Object_Definition => Subtyp_Ind)); end if; - -- If the result of the concatenation appears as the initializing - -- expression of an object declaration, we can just rename the - -- result, rather than copying it. - - Set_OK_To_Rename (Ent); - -- Catch the static out of range case now if Raises_Constraint_Error (High_Bound) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ae59ad7017d..7555bf5dcf5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -192,16 +192,6 @@ package body Exp_Ch6 is -- the activation Chain. Note: Master_Actual can be Empty, but only if -- there are no tasks. - procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); - -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check - -- that the level of the return expression's underlying type is not deeper - -- than the level of the master enclosing the function. Always generate the - -- check when the type of the return expression is class-wide, when it's a - -- type conversion, or when it's a formal parameter. Otherwise suppress the - -- check in the case where the return expression has a specific type whose - -- level is known not to be statically deeper than the result type of the - -- function. - function Caller_Known_Size (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; @@ -5140,10 +5130,15 @@ package body Exp_Ch6 is end if; -- Another optimization: if the returned value is used to initialize an - -- object, and the secondary stack is not involved in the call, then no - -- need to copy/readjust/finalize, we can just initialize it in place. + -- object, then no need to copy/readjust/finalize, we can initialize it + -- in place. However, if the call returns on the secondary stack or this + -- is a special return object, then we need the expansion because we'll + -- be renaming the temporary as the (permanent) object. - if Nkind (Par) = N_Object_Declaration and then not Use_Sec_Stack then + if Nkind (Par) = N_Object_Declaration + and then not Use_Sec_Stack + and then not Is_Special_Return_Object (Defining_Entity (Par)) + then return; end if; @@ -5300,7 +5295,7 @@ package body Exp_Ch6 is -- Assert that if F says "return R : T := G(...) do..." -- then F and G are both b-i-p, or neither b-i-p. - if Nkind (Exp) = N_Function_Call then + if Present (Exp) and then Nkind (Exp) = N_Function_Call then pragma Assert (Ekind (Current_Subprogram) = E_Function); pragma Assert (Is_Build_In_Place_Function (Current_Subprogram) = @@ -5308,16 +5303,6 @@ package body Exp_Ch6 is null; end if; - -- Ada 2005 (AI95-344): If the result type is class-wide, then insert - -- a check that the level of the return expression's underlying type - -- is not deeper than the level of the master enclosing the function. - - -- AI12-043: The check is made immediately after the return object - -- is created. - - if Present (Exp) and then Is_Class_Wide_Type (Ret_Typ) then - Apply_CW_Accessibility_Check (Exp, Func_Id); - end if; else Exp := Empty; end if; @@ -6529,19 +6514,6 @@ package body Exp_Ch6 is -- need to reify the return object, so we can build it "in place", and -- we need a block statement to hang finalization and tasking stuff. - -- ??? In order to avoid disruption, we avoid translating to extended - -- return except in the cases where we really need to (Ada 2005 for - -- inherently limited). We might prefer to do this translation in all - -- cases (except perhaps for the case of Ada 95 inherently limited), - -- in order to fully exercise the Expand_N_Extended_Return_Statement - -- code. This would also allow us to do the build-in-place optimization - -- for efficiency even in cases where it is semantically not required. - - -- As before, we check the type of the return expression rather than the - -- return type of the function, because the latter may be a limited - -- class-wide interface type, which is not a limited type, even though - -- the type of the expression may be. - pragma Assert (Comes_From_Extended_Return_Statement (N) or else not Is_Build_In_Place_Function_Call (Exp) @@ -6682,15 +6654,18 @@ package body Exp_Ch6 is -- type Ann is access R_Type; -- for Ann'Storage_pool use rs_pool; - -- Rnn : Ann := new Exp_Typ'(Exp); + -- Rnn : constant Ann := new Exp_Typ'(Exp); -- return Rnn.all; -- but optimize the case where the result is a function call that -- also needs finalization. In this case the result can directly be -- allocated on the return stack of the caller and no further - -- processing is required. + -- processing is required. Likewise if this is a return object. - if Present (Utyp) + if Comes_From_Extended_Return_Statement (N) then + null; + + elsif Present (Utyp) and then Needs_Finalization (Utyp) and then not (Exp_Is_Function_Call and then Needs_Finalization (Exp_Typ)) @@ -6733,6 +6708,7 @@ package body Exp_Ch6 is Make_Object_Declaration (Loc, Defining_Identifier => Temp, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => Alloc_Node))); @@ -6753,11 +6729,16 @@ package body Exp_Ch6 is Set_Enclosing_Sec_Stack_Return (N); + -- Nothing else to do for a return object + + if Comes_From_Extended_Return_Statement (N) then + null; + -- Optimize the case where the result is a function call that also -- returns on the secondary stack. In this case the result is already -- on the secondary stack and no further processing is required. - if Exp_Is_Function_Call + elsif Exp_Is_Function_Call and then Needs_Secondary_Stack (Exp_Typ) then -- Remove side effects from the expression now so that other parts @@ -6782,7 +6763,7 @@ package body Exp_Ch6 is -- type Ann is access R_Type; -- for Ann'Storage_pool use ss_pool; - -- Rnn : Ann := new Exp_Typ'(Exp); + -- Rnn : constant Ann := new Exp_Typ'(Exp); -- return Rnn.all; -- And we do the same for class-wide types that are not potentially @@ -6806,7 +6787,6 @@ package body Exp_Ch6 is begin Mutate_Ekind (Acc_Typ, E_Access_Type); - Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); -- This is an allocator for the secondary stack, and it's fine @@ -6836,6 +6816,7 @@ package body Exp_Ch6 is Make_Object_Declaration (Loc, Defining_Identifier => Temp, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => Alloc_Node))); @@ -7900,6 +7881,16 @@ package body Exp_Ch6 is and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E))); end Is_Build_In_Place_Return_Object; + ----------------------------------- + -- Is_By_Reference_Return_Object -- + ----------------------------------- + + function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Return_Object (E) + and then Is_By_Reference_Type (Etype (Return_Applies_To (Scope (E)))); + end Is_By_Reference_Return_Object; + ----------------------- -- Is_Null_Procedure -- ----------------------- @@ -7959,6 +7950,28 @@ package body Exp_Ch6 is end if; end Is_Null_Procedure; + -------------------------------------- + -- Is_Secondary_Stack_Return_Object -- + -------------------------------------- + + function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Return_Object (E) + and then Needs_Secondary_Stack (Etype (Return_Applies_To (Scope (E)))); + end Is_Secondary_Stack_Return_Object; + + ------------------------------ + -- Is_Special_Return_Object -- + ------------------------------ + + function Is_Special_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Build_In_Place_Return_Object (E) + or else Is_Secondary_Stack_Return_Object (E) + or else (Back_End_Return_Slot + and then Is_By_Reference_Return_Object (E)); + end Is_Special_Return_Object; + ------------------------------------------- -- Make_Build_In_Place_Call_In_Allocator -- ------------------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 66888c51a07..41ddf8dd8d0 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -99,6 +99,16 @@ package Exp_Ch6 is -- Adds Extra_Actual as a named parameter association for the formal -- Extra_Formal in Subprogram_Call. + procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); + -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check + -- that the level of the return expression's underlying type is not deeper + -- than the level of the master enclosing the function. Always generate the + -- check when the type of the return expression is class-wide, when it's a + -- type conversion, or when it's a formal parameter. Otherwise suppress the + -- check in the case where the return expression has a specific type whose + -- level is known not to be statically deeper than the result type of the + -- function. + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String; -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names -- for build-in-place formal parameters of the given kind. @@ -158,13 +168,28 @@ package Exp_Ch6 is -- True in >= Ada 2005 and must be False in Ada 95. function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Return True is E is a return object of a function + -- Ada 2005 (AI-318-02): Return True if E is a return object of a function -- that uses build-in-place protocols. + function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean; + -- Return True if E is a return object of a function whose return type is + -- required to be passed by reference, as defined in (RM 6.2(4-9)). + function Is_Null_Procedure (Subp : Entity_Id) return Boolean; -- Predicate to recognize stubbed procedures and null procedures, which -- can be inlined unconditionally in all cases. + function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean; + -- Return True if E is a return object of a function whose return type is + -- returned on the secondary stack. + + function Is_Special_Return_Object (E : Entity_Id) return Boolean; + -- Return True if E is the return object of a function and is handled in a + -- special way by the expander. In most cases, return objects are handled + -- like any other variables or constants but, in a few special cases, they + -- are further expanded into more elaborate constructs, whose common goal + -- is to elide the copy operation associated with the return. + procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; Function_Call : Node_Id); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bcfb39ce21d..84b0c0e2941 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9166,7 +9166,11 @@ package body Exp_Util is return Present (Expr) and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference - and then Nkind (Parent (Expr)) = N_Simple_Return_Statement; + and then (Nkind (Parent (Expr)) = N_Simple_Return_Statement + or else + (Nkind (Parent (Expr)) = N_Object_Renaming_Declaration + and then + Is_Return_Object (Defining_Entity (Parent (Expr))))); end Is_Related_To_Func_Return; -------------------------------- diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index a012271abf3..59332f93614 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -8473,9 +8473,10 @@ gnat_to_gnu (Node_Id gnat_node) declaration, return the result unmodified because we want to use the return slot optimization in this case. - 5. If this is a reference to an unconstrained array which is used as the - prefix of an attribute reference that requires an lvalue, return the - result unmodified because we want to return the original bounds. + 5. If this is a reference to an unconstrained array which is used either + as the prefix of an attribute reference that requires an lvalue or in + a return statement, then return the result unmodified because we want + to return the original bounds. 6. Finally, if the type of the result is already correct. */ @@ -8539,8 +8540,9 @@ gnat_to_gnu (Node_Id gnat_node) else if (TREE_CODE (TREE_TYPE (gnu_result)) == UNCONSTRAINED_ARRAY_TYPE && Present (Parent (gnat_node)) - && Nkind (Parent (gnat_node)) == N_Attribute_Reference - && lvalue_required_for_attribute_p (Parent (gnat_node))) + && ((Nkind (Parent (gnat_node)) == N_Attribute_Reference + && lvalue_required_for_attribute_p (Parent (gnat_node))) + || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement)) ; else if (TREE_TYPE (gnu_result) != gnu_result_type) diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index e0dba9e6a5c..bc424ab3c3b 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -69,7 +69,6 @@ package Gen_IL.Fields is Address_Warning_Posted, Aggregate_Bounds, Aliased_Present, - Alloc_For_BIP_Return, All_Others, All_Present, Alternatives, @@ -189,6 +188,7 @@ package Gen_IL.Fields is Float_Truncate, Formal_Type_Definition, Forwards_OK, + For_Special_Return_Object, From_Aspect_Specification, From_At_Mod, From_Conditional_Expression, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index ba4539140fe..ec0eba74d06 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -494,7 +494,7 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Expression, Node_Id, Default_Empty), Sy (Subpool_Handle_Name, Node_Id, Default_Empty), Sy (Null_Exclusion_Present, Flag, Default_False), - Sm (Alloc_For_BIP_Return, Flag), + Sm (For_Special_Return_Object, Flag), Sm (Do_Storage_Check, Flag), Sm (Is_Dynamic_Coextension, Flag), Sm (Is_Static_Coextension, Flag), diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index cec5b94b6fc..09fe99f44bc 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -257,8 +257,6 @@ package body Gen_IL.Internals is -- Special cases for the same reason as in the above Image -- function for Opt_Type_Enum. - when Alloc_For_BIP_Return => - return "Alloc_For_BIP_Return"; when Assignment_OK => return "Assignment_OK"; when Backwards_OK => diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index abee91f27fd..5334e486800 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3781,6 +3781,11 @@ package body Sem_Ch3 is -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit -- a compile-time warning if this is not the case. + procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); + -- Check that the return subtype indication properly matches the result + -- subtype of the function in an extended return object declaration, as + -- required by RM 6.5(5.1/2-5.3/2). + function Count_Tasks (T : Entity_Id) return Uint; -- This function is called when a non-generic library level object of a -- task type is declared. Its function is to count the static number of @@ -3954,6 +3959,134 @@ package body Sem_Ch3 is Check_Component (Obj_Typ, Obj_Decl); end Check_For_Null_Excluding_Components; + ------------------------------------- + -- Check_Return_Subtype_Indication -- + ------------------------------------- + + procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is + Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); + Obj_Typ : constant Entity_Id := Etype (Obj_Id); + Func_Id : constant Entity_Id := Return_Applies_To (Scope (Obj_Id)); + R_Typ : constant Entity_Id := Etype (Func_Id); + Indic : constant Node_Id := + Object_Definition (Original_Node (Obj_Decl)); + + procedure Error_No_Match (N : Node_Id); + -- Output error messages for case where types do not statically + -- match. N is the location for the messages. + + -------------------- + -- Error_No_Match -- + -------------------- + + procedure Error_No_Match (N : Node_Id) is + begin + Error_Msg_N + ("subtype must statically match function result subtype", N); + + if not Predicates_Match (Obj_Typ, R_Typ) then + Error_Msg_Node_2 := R_Typ; + Error_Msg_NE + ("\predicate of& does not match predicate of&", + N, Obj_Typ); + end if; + end Error_No_Match; + + -- Start of processing for Check_Return_Subtype_Indication + + begin + -- First, avoid cascaded errors + + if Error_Posted (Obj_Decl) or else Error_Posted (Indic) then + return; + end if; + + -- "return access T" case; check that the return statement also has + -- "access T", and that the subtypes statically match: + -- if this is an access to subprogram the signatures must match. + + if Is_Anonymous_Access_Type (R_Typ) then + if Is_Anonymous_Access_Type (Obj_Typ) then + if Ekind (Designated_Type (Obj_Typ)) /= E_Subprogram_Type + then + if Base_Type (Designated_Type (Obj_Typ)) /= + Base_Type (Designated_Type (R_Typ)) + or else not Subtypes_Statically_Match (Obj_Typ, R_Typ) + then + Error_No_Match (Subtype_Mark (Indic)); + end if; + + else + -- For two anonymous access to subprogram types, the types + -- themselves must be type conformant. + + if not Conforming_Types + (Obj_Typ, R_Typ, Fully_Conformant) + then + Error_No_Match (Indic); + end if; + end if; + + else + Error_Msg_N ("must use anonymous access type", Indic); + end if; + + -- If the return object is of an anonymous access type, then report + -- an error if the function's result type is not also anonymous. + + elsif Is_Anonymous_Access_Type (Obj_Typ) then + pragma Assert (not Is_Anonymous_Access_Type (R_Typ)); + Error_Msg_N + ("anonymous access not allowed for function with named access " + & "result", Indic); + + -- Subtype indication case: check that the return object's type is + -- covered by the result type, and that the subtypes statically match + -- when the result subtype is constrained. Also handle record types + -- with unknown discriminants for which we have built the underlying + -- record view. Coverage is needed to allow specific-type return + -- objects when the result type is class-wide (see AI05-32). + + elsif Covers (Base_Type (R_Typ), Base_Type (Obj_Typ)) + or else (Is_Underlying_Record_View (Base_Type (Obj_Typ)) + and then + Covers + (Base_Type (R_Typ), + Underlying_Record_View (Base_Type (Obj_Typ)))) + then + -- A null exclusion may be present on the return type, on the + -- function specification, on the object declaration or on the + -- subtype itself. + + if Is_Access_Type (R_Typ) + and then + (Can_Never_Be_Null (R_Typ) + or else Null_Exclusion_Present (Parent (Func_Id))) /= + Can_Never_Be_Null (Obj_Typ) + then + Error_No_Match (Indic); + end if; + + -- AI05-103: for elementary types, subtypes must statically match + + if Is_Constrained (R_Typ) or else Is_Access_Type (R_Typ) then + if not Subtypes_Statically_Match (Obj_Typ, R_Typ) then + Error_No_Match (Indic); + end if; + end if; + + -- All remaining cases are illegal + + -- Note: previous versions of this subprogram allowed the return + -- value to be the ancestor of the return type if the return type + -- was a null extension. This was plainly incorrect. + + else + Error_Msg_N + ("wrong type for return_subtype_indication", Indic); + end if; + end Check_Return_Subtype_Indication; + ----------------- -- Count_Tasks -- ----------------- @@ -5047,6 +5180,12 @@ package body Sem_Ch3 is end if; end if; + -- Check specific legality rules for a return object + + if Is_Return_Object (Id) then + Check_Return_Subtype_Indication (N); + end if; + -- Some simple constant-propagation: if the expression is a constant -- string initialized with a literal, share the literal. This avoids -- a run-time copy. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c8c0d80ffcd..da5aa5fe88f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -44,6 +44,7 @@ with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; @@ -733,43 +734,16 @@ package body Sem_Ch4 is end; end if; - -- Check for missing initialization. Skip this check if we already - -- had errors on analyzing the allocator, since in that case these - -- are probably cascaded errors. + -- Check for missing initialization. Skip this check if the allocator + -- is made for a special return object or if we already had errors on + -- analyzing the allocator since, in that case, these are very likely + -- cascaded errors. if not Is_Definite_Subtype (Type_Id) + and then not For_Special_Return_Object (N) and then Serious_Errors_Detected = Sav_Errs then - -- The build-in-place machinery may produce an allocator when - -- the designated type is indefinite but the underlying type is - -- not. In this case the unknown discriminants are meaningless - -- and should not trigger error messages. Check the parent node - -- because the allocator is marked as coming from source. - - if Present (Underlying_Type (Type_Id)) - and then Is_Definite_Subtype (Underlying_Type (Type_Id)) - and then not Comes_From_Source (Parent (N)) - then - null; - - -- An unusual case arises when the parent of a derived type is - -- a limited record extension with unknown discriminants, and - -- its full view has no discriminants. - -- - -- A more general fix might be to create the proper underlying - -- type for such a derived type, but it is a record type with - -- no private attributes, so this required extending the - -- meaning of this attribute. ??? - - elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private - and then Present (Underlying_Type (Etype (Type_Id))) - and then - not Has_Discriminants (Underlying_Type (Etype (Type_Id))) - and then not Comes_From_Source (Parent (N)) - then - null; - - elsif Is_Class_Wide_Type (Type_Id) then + if Is_Class_Wide_Type (Type_Id) then Error_Msg_N ("initialization required in class-wide allocation", N); @@ -842,6 +816,27 @@ package body Sem_Ch4 is Error_Msg_N ("cannot allocate abstract object", E); end if; + Set_Etype (N, Acc_Type); + + -- If this is an allocator for the return stack, then no restriction may + -- be violated since it's just a low-level access to the primary stack. + + if Nkind (Parent (N)) = N_Object_Declaration + and then Is_Entity_Name (Object_Definition (Parent (N))) + and then Is_Access_Type (Entity (Object_Definition (Parent (N)))) + then + declare + Pool : constant Entity_Id := + Associated_Storage_Pool + (Root_Type (Entity (Object_Definition (Parent (N))))); + + begin + if Present (Pool) and then Is_RTE (Pool, RE_RS_Pool) then + goto Leave; + end if; + end; + end if; + if Has_Task (Designated_Type (Acc_Type)) then Check_Restriction (No_Tasking, N); Check_Restriction (Max_Tasks, N); @@ -893,12 +888,11 @@ package body Sem_Ch4 is end if; end if; - Set_Etype (N, Acc_Type); - if not Is_Library_Level_Entity (Acc_Type) then Check_Restriction (No_Local_Allocators, N); end if; + <> if Serious_Errors_Detected > Sav_Errs then Set_Error_Posted (N); Set_Etype (N, Any_Type); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index c1523ae11e2..344b3ebfdb2 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -307,7 +307,8 @@ package body Sem_Ch5 is -- get the actual subtype (needed for the unconstrained case). If the -- operand is the actual in an entry declaration, then within the -- accept statement it is replaced with a local renaming, which may - -- also have an actual subtype. + -- also have an actual subtype. Likewise for a return object that + -- lives on the secondary stack. if Is_Entity_Name (Opnd) and then (Ekind (Entity (Opnd)) in E_Out_Parameter @@ -318,7 +319,8 @@ package body Sem_Ch5 is and then Nkind (Parent (Entity (Opnd))) = N_Object_Renaming_Declaration and then Nkind (Parent (Parent (Entity (Opnd)))) = - N_Accept_Statement)) + N_Accept_Statement) + or else Is_Secondary_Stack_Return_Object (Entity (Opnd))) then Opnd_Type := Get_Actual_Subtype (Opnd); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d567f79b27e..f46ca46fc64 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -746,10 +746,6 @@ package body Sem_Ch6 is -- Ada 2022: Check that the return expression in a No_Return function -- meets the conditions specified by RM 6.5.1(5.1/5). - procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); - -- Check that the return_subtype_indication properly matches the result - -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). - -------------------------------- -- Check_No_Return_Expression -- -------------------------------- @@ -778,135 +774,6 @@ package body Sem_Ch6 is Return_Expr); end Check_No_Return_Expression; - ------------------------------------- - -- Check_Return_Subtype_Indication -- - ------------------------------------- - - procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is - Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); - - R_Stm_Type : constant Entity_Id := Etype (Return_Obj); - -- Subtype given in the extended return statement (must match R_Type) - - Subtype_Ind : constant Node_Id := - Object_Definition (Original_Node (Obj_Decl)); - - procedure Error_No_Match (N : Node_Id); - -- Output error messages for case where types do not statically - -- match. N is the location for the messages. - - -------------------- - -- Error_No_Match -- - -------------------- - - procedure Error_No_Match (N : Node_Id) is - begin - Error_Msg_N - ("subtype must statically match function result subtype", N); - - if not Predicates_Match (R_Stm_Type, R_Type) then - Error_Msg_Node_2 := R_Type; - Error_Msg_NE - ("\predicate of& does not match predicate of&", - N, R_Stm_Type); - end if; - end Error_No_Match; - - -- Start of processing for Check_Return_Subtype_Indication - - begin - -- First, avoid cascaded errors - - if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then - return; - end if; - - -- "return access T" case; check that the return statement also has - -- "access T", and that the subtypes statically match: - -- if this is an access to subprogram the signatures must match. - - if Is_Anonymous_Access_Type (R_Type) then - if Is_Anonymous_Access_Type (R_Stm_Type) then - if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type - then - if Base_Type (Designated_Type (R_Stm_Type)) /= - Base_Type (Designated_Type (R_Type)) - or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) - then - Error_No_Match (Subtype_Mark (Subtype_Ind)); - end if; - - else - -- For two anonymous access to subprogram types, the types - -- themselves must be type conformant. - - if not Conforming_Types - (R_Stm_Type, R_Type, Fully_Conformant) - then - Error_No_Match (Subtype_Ind); - end if; - end if; - - else - Error_Msg_N ("must use anonymous access type", Subtype_Ind); - end if; - - -- If the return object is of an anonymous access type, then report - -- an error if the function's result type is not also anonymous. - - elsif Is_Anonymous_Access_Type (R_Stm_Type) then - pragma Assert (not Is_Anonymous_Access_Type (R_Type)); - Error_Msg_N - ("anonymous access not allowed for function with named access " - & "result", Subtype_Ind); - - -- Subtype indication case: check that the return object's type is - -- covered by the result type, and that the subtypes statically match - -- when the result subtype is constrained. Also handle record types - -- with unknown discriminants for which we have built the underlying - -- record view. Coverage is needed to allow specific-type return - -- objects when the result type is class-wide (see AI05-32). - - elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) - or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) - and then - Covers - (Base_Type (R_Type), - Underlying_Record_View (Base_Type (R_Stm_Type)))) - then - -- A null exclusion may be present on the return type, on the - -- function specification, on the object declaration or on the - -- subtype itself. - - if Is_Access_Type (R_Type) - and then - (Can_Never_Be_Null (R_Type) - or else Null_Exclusion_Present (Parent (Scope_Id))) /= - Can_Never_Be_Null (R_Stm_Type) - then - Error_No_Match (Subtype_Ind); - end if; - - -- AI05-103: for elementary types, subtypes must statically match - - if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then - if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then - Error_No_Match (Subtype_Ind); - end if; - end if; - - -- All remaining cases are illegal - - -- Note: previous versions of this subprogram allowed the return - -- value to be the ancestor of the return type if the return type - -- was a null extension. This was plainly incorrect. - - else - Error_Msg_N - ("wrong type for return_subtype_indication", Subtype_Ind); - end if; - end Check_Return_Subtype_Indication; - --------------------- -- Local Variables -- --------------------- @@ -1016,8 +883,6 @@ package body Sem_Ch6 is Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); Analyze (Obj_Decl); - Check_Return_Subtype_Indication (Obj_Decl); - if Present (HSS) then Analyze (HSS); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4bbec65d6a0..b54ed93a7f7 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5622,7 +5622,7 @@ package body Sem_Res is -- caller does use an allocator, it will be caught at the call site. if No_Pool_Assigned (Typ) - and then not Alloc_For_BIP_Return (N) + and then not For_Special_Return_Object (N) then Error_Msg_N ("allocation from empty storage pool!", N); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 7accb018a69..104ee663c0e 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -842,10 +842,6 @@ package Sinfo is -- known at compile time, this field points to an N_Range node with those -- bounds. Otherwise Empty. - -- Alloc_For_BIP_Return - -- Present in N_Allocator nodes. True if the allocator is one of those - -- generated for a build-in-place return statement. - -- All_Others -- Present in an N_Others_Choice node. This flag is set for an others -- exception where all exceptions are to be caught, even those that are @@ -1344,6 +1340,10 @@ package Sinfo is -- cannot figure it out. If both flags Forwards_OK and Backwards_OK are -- set, it means that the front end can assure no overlap of operands. + -- For_Special_Return_Object + -- Present in N_Allocator nodes. True if the allocator is generated for + -- the initialization of a special return object. + -- From_Aspect_Specification -- Processing of aspect specifications typically results in insertion in -- the tree of corresponding pragma or attribute definition clause nodes. @@ -4777,7 +4777,7 @@ package Sinfo is -- Subpool_Handle_Name (set to Empty if not present) -- Storage_Pool -- Procedure_To_Call - -- Alloc_For_BIP_Return + -- For_Special_Return_Object -- Null_Exclusion_Present -- No_Initialization -- Is_Static_Coextension diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index a9f40887d8a..a0f45c422be 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -269,8 +269,9 @@ package body Treepr is function Image (F : Node_Or_Entity_Field) return String is begin case F is - when F_Alloc_For_BIP_Return => - return "Alloc_For_BIP_Return"; + -- We special case the following; otherwise the compiler will use + -- the usual Mixed_Case convention. + when F_Assignment_OK => return "Assignment_OK"; when F_Backwards_OK =>