From: Arnaud Charlet Date: Fri, 8 Sep 2017 10:02:50 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4ac62786d6fb3b28c157fe9e6292842aa201d904;p=gcc.git [multiple changes] 2017-09-08 Javier Miranda * exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New subprogram. (Make_Build_In_Place_Iface_Call_In_Anonymous_Context): New subprogram. (Make_Build_In_Place_Iface_Call_In_Object_Declaration): New subprogram. (Unqual_BIP_Iface_Function_Call): New subprogram. * exp_ch6.adb (Replace_Renaming_Declaration_Id): New subprogram containing code that was previously inside Make_Build_In_Place_Call_In_Object_Declaration since it is also required for one of the new subprograms. (Expand_Actuals): Invoke Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Expand_N_Extended_Return_Statement): Extend the cases covered by an assertion on expected BIP object declarations. (Make_Build_In_Place_Call_In_Assignment): Removing unused code; found working on this ticket. (Make_Build_In_Place_Call_In_Object_Declaration): Move the code that replaces the internal name of the renaming declaration into the new subprogram Replace_Renaming_Declaration_Id. (Make_Build_In_Place_Iface_Call_In_Allocator): New subprogram. (Make_Build_In_Place_Iface_Call_In_Anonymous_Context): New subprogram. (Make_Build_In_Place_Iface_Call_In_Object_Declaration): New subprogram. (Unqual_BIP_Iface_Function_Call): New subprogram. * exp_ch3.adb (Expand_N_Object_Declaration): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Object_Declaration. * exp_attr.adb (Expand_N_Attribute_Reference): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context. * exp_ch4.adb (Expand_Allocator_Expression): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Allocator. (Expand_N_Indexed_Component): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context. (Expand_N_Selected_Component): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context. (Expand_N_Slice): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context. * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Invoke the new subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context. 2017-09-08 Javier Miranda * exp_disp.adb (Expand_Interface_Conversion): Fix handling of access to interface types. Remove also the accessibility check. 2017-09-08 Eric Botcazou * sem_ch6.adb (Freeze_Expr_Types): Really freeze all the types that are referenced by the expression. (Analyze_Expression_Function): Call Freeze_Expr_Types for a completion instead of manually freezing the type of the expression. (Analyze_Subprogram_Body_Helper): Do not call Freeze_Expr_Types here. 2017-09-08 Ed Schonberg * exp_prag.adb (Replace_Discriminals_Of_Protected_Op): New procedure, auxiliary to Expand_Pragma_Check, to handle references to the discriminants of a protected type within a precondition of a protected operation. This is needed because the original precondition has been analyzed in the context of the protected declaration, but in the body of the operation references to the discriminants have been replaved by references to the discriminants of the target object, and these references are only created when expanding the protected body. From-SVN: r251879 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 97a59e422b3..c3c48a535e8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,73 @@ +2017-09-08 Javier Miranda + + * exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New + subprogram. + (Make_Build_In_Place_Iface_Call_In_Anonymous_Context): New subprogram. + (Make_Build_In_Place_Iface_Call_In_Object_Declaration): New + subprogram. + (Unqual_BIP_Iface_Function_Call): New subprogram. + * exp_ch6.adb (Replace_Renaming_Declaration_Id): New + subprogram containing code that was previously inside + Make_Build_In_Place_Call_In_Object_Declaration since it is also + required for one of the new subprograms. + (Expand_Actuals): + Invoke Make_Build_In_Place_Iface_Call_In_Anonymous_Context + (Expand_N_Extended_Return_Statement): Extend the + cases covered by an assertion on expected BIP object + declarations. + (Make_Build_In_Place_Call_In_Assignment): + Removing unused code; found working on this ticket. + (Make_Build_In_Place_Call_In_Object_Declaration): Move the code + that replaces the internal name of the renaming declaration + into the new subprogram Replace_Renaming_Declaration_Id. + (Make_Build_In_Place_Iface_Call_In_Allocator): New subprogram. + (Make_Build_In_Place_Iface_Call_In_Anonymous_Context): + New subprogram. + (Make_Build_In_Place_Iface_Call_In_Object_Declaration): New + subprogram. + (Unqual_BIP_Iface_Function_Call): New subprogram. + * exp_ch3.adb (Expand_N_Object_Declaration): Invoke the new + subprogram Make_Build_In_Place_Iface_Call_In_Object_Declaration. + * exp_attr.adb (Expand_N_Attribute_Reference): Invoke the new + subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context. + * exp_ch4.adb (Expand_Allocator_Expression): Invoke the new + subprogram Make_Build_In_Place_Iface_Call_In_Allocator. + (Expand_N_Indexed_Component): Invoke the new subprogram + Make_Build_In_Place_Iface_Call_In_Anonymous_Context. + (Expand_N_Selected_Component): Invoke the new subprogram + Make_Build_In_Place_Iface_Call_In_Anonymous_Context. + (Expand_N_Slice): Invoke the new subprogram + Make_Build_In_Place_Iface_Call_In_Anonymous_Context. + * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): + Invoke the new subprogram + Make_Build_In_Place_Iface_Call_In_Anonymous_Context. + +2017-09-08 Javier Miranda + + * exp_disp.adb (Expand_Interface_Conversion): Fix handling of + access to interface types. Remove also the accessibility check. + +2017-09-08 Eric Botcazou + + * sem_ch6.adb (Freeze_Expr_Types): Really freeze + all the types that are referenced by the expression. + (Analyze_Expression_Function): Call Freeze_Expr_Types for + a completion instead of manually freezing the type of the + expression. + (Analyze_Subprogram_Body_Helper): Do not call Freeze_Expr_Types here. + +2017-09-08 Ed Schonberg + + * exp_prag.adb (Replace_Discriminals_Of_Protected_Op): + New procedure, auxiliary to Expand_Pragma_Check, to handle + references to the discriminants of a protected type within a + precondition of a protected operation. This is needed because + the original precondition has been analyzed in the context of + the protected declaration, but in the body of the operation + references to the discriminants have been replaved by references + to the discriminants of the target object, and these references + are only created when expanding the protected body. + 2017-09-08 Yannick Moy * sem_prag.adb (Analyze_Pragma): Issue more precise error messages on diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 265ec9c43ea..435f8167245 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -9293,15 +9293,15 @@ package body Einfo is function Underlying_Type (Id : E) return E is begin - -- For record_with_private the underlying type is always the direct - -- full view. Never try to take the full view of the parent it - -- doesn't make sense. + -- For record_with_private the underlying type is always the direct full + -- view. Never try to take the full view of the parent it does not make + -- sense. if Ekind (Id) = E_Record_Type_With_Private then return Full_View (Id); - -- If we have a class-wide type that comes from the limited view then - -- we return the Underlying_Type of its nonlimited view. + -- If we have a class-wide type that comes from the limited view then we + -- return the Underlying_Type of its nonlimited view. elsif Ekind (Id) = E_Class_Wide_Type and then From_Limited_With (Id) @@ -9311,8 +9311,8 @@ package body Einfo is elsif Ekind (Id) in Incomplete_Or_Private_Kind then - -- If we have an incomplete or private type with a full view, - -- then we return the Underlying_Type of this full view. + -- If we have an incomplete or private type with a full view, then we + -- return the Underlying_Type of this full view. if Present (Full_View (Id)) then if Id = Full_View (Id) then @@ -9347,10 +9347,9 @@ package body Einfo is elsif Etype (Id) /= Id then return Underlying_Type (Etype (Id)); - -- Otherwise we have an incomplete or private type that has - -- no full view, which means that we have not encountered the - -- completion, so return Empty to indicate the underlying type - -- is not yet known. + -- Otherwise we have an incomplete or private type that has no full + -- view, which means that we have not encountered the completion, so + -- return Empty to indicate the underlying type is not yet known. else return Empty; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ebd55d8b528..bd354d555f0 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1761,6 +1761,15 @@ package body Exp_Attr is and then Is_Build_In_Place_Function_Call (Pref) then Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + + -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix + -- containing build-in-place function calls whose returned object covers + -- interface types. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (Pref)) + then + Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); end if; -- If prefix is a protected type name, this is a reference to the diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e5519613f0d..b41754b1e54 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6243,6 +6243,24 @@ package body Exp_Ch3 is return; + -- Ada 2005 (AI-318-02): Specialization of the previous case for + -- expressions containing a build-in-place function call whose + -- returned object covers interface types, and Expr_Q has calls to + -- Ada.Tags.Displace to displace the pointer to the returned build- + -- in-place object to reference the secondary dispatch table of a + -- covered interface type. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) + then + Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q); + + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. + + return; + -- Ada 2005 (AI-251): Rewrite the expression that initializes a -- class-wide interface object to ensure that we copy the full -- object, unless we are targetting a VM where interfaces are handled diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e2e58c97a96..91050fe6950 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -804,6 +804,20 @@ package body Exp_Ch4 is Make_Build_In_Place_Call_In_Allocator (N, Exp); Apply_Accessibility_Check (N, Built_In_Place => True); return; + + -- Ada 2005 (AI-318-02): Specialization of the previous case for + -- expressions containing a build-in-place function call whose + -- returned object covers interface types, and Expr has calls to + -- Ada.Tags.Displace to displace the pointer to the returned build- + -- in-place object to reference the secondary dispatch table of a + -- covered interface type. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (Exp)) + then + Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp); + Apply_Accessibility_Check (N, Built_In_Place => True); + return; end if; -- Actions inserted before: @@ -6562,6 +6576,15 @@ package body Exp_Ch4 is and then Is_Build_In_Place_Function_Call (P) then Make_Build_In_Place_Call_In_Anonymous_Context (P); + + -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix + -- containing build-in-place function calls whose returned object covers + -- interface types. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (P)) + then + Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); end if; -- If the prefix is an access type, then we unconditionally rewrite if @@ -10201,6 +10224,15 @@ package body Exp_Ch4 is and then Is_Build_In_Place_Function_Call (P) then Make_Build_In_Place_Call_In_Anonymous_Context (P); + + -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix + -- containing build-in-place function calls whose returned object covers + -- interface types. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (P)) + then + Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); end if; -- Gigi cannot handle unchecked conversions that are the prefix of a @@ -10558,6 +10590,15 @@ package body Exp_Ch4 is and then Is_Build_In_Place_Function_Call (Pref) then Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + + -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix + -- containing build-in-place function calls whose returned object covers + -- interface types. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (Pref)) + then + Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref); end if; -- The remaining case to be handled is packed slices. We can leave diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 8762367dd18..c3d00659fee 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4829,8 +4829,7 @@ package body Exp_Ch5 is end if; else - - -- Initial value is smallest value in predicate. + -- Initial value is smallest value in predicate if Is_Itype (Ltype) then D := @@ -4891,14 +4890,14 @@ package body Exp_Ch5 is end if; S := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Loop_Id, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ltype, Loc), - Attribute_Name => Name_Next, - Expressions => New_List ( - New_Occurrence_Of (Loop_Id, Loc)))); + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Loop_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ltype, Loc), + Attribute_Name => Name_Next, + Expressions => New_List ( + New_Occurrence_Of (Loop_Id, Loc)))); Set_Suppress_Assignment_Checks (S); end; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 423de144bbc..a36e51f7785 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -30,6 +30,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Elists; use Elists; +with Expander; use Expander; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; with Exp_Ch2; use Exp_Ch2; @@ -45,6 +46,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Inline; use Inline; +with Itypes; use Itypes; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -245,6 +247,19 @@ package body Exp_Ch6 is -- Insert the Post_Call list previously produced by routine Expand_Actuals -- or Expand_Call_Helper into the tree. + procedure Replace_Renaming_Declaration_Id + (New_Decl : Node_Id; + Orig_Decl : Node_Id); + -- Replace the internal identifier of the new renaming declaration New_Decl + -- with the identifier of its original declaration Orig_Decl exchanging the + -- entities containing their defining identifiers to ensure the correct + -- replacement of the object declaration by the object renaming declaration + -- to avoid homograph conflicts (since the object declaration's defining + -- identifier was already entered in the current scope). The Next_Entity + -- links of the two entities are also swapped since the entities are part + -- of the return scope's entity list and the list structure would otherwise + -- be corrupted. The homonym chain is preserved as well. + procedure Rewrite_Function_Call_For_C (N : Node_Id); -- When generating C code, replace a call to a function that returns an -- array into the generated procedure with an additional out parameter. @@ -1878,6 +1893,13 @@ package body Exp_Ch6 is if Is_Build_In_Place_Function_Call (Actual) then Make_Build_In_Place_Call_In_Anonymous_Context (Actual); + + -- Ada 2005 (AI-318-02): Specialization of the previous case for + -- actuals containing build-in-place function calls whose returned + -- object covers interface types. + + elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then + Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual); end if; Apply_Constraint_Check (Actual, E_Formal); @@ -4793,8 +4815,19 @@ package body Exp_Ch6 is then pragma Assert (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration - and then Is_Build_In_Place_Function_Call - (Expression (Original_Node (Ret_Obj_Decl)))); + and then + + -- It is a regular BIP object declaration + + (Is_Build_In_Place_Function_Call + (Expression (Original_Node (Ret_Obj_Decl))) + + -- It is a BIP object declaration that displaces the pointer + -- to the object to reference a convered interface type. + + or else + Present (Unqual_BIP_Iface_Function_Call + (Expression (Original_Node (Ret_Obj_Decl)))))); -- Return the build-in-place result by reference @@ -7952,7 +7985,6 @@ package body Exp_Ch6 is Ptr_Typ_Decl : Node_Id; New_Expr : Node_Id; Result_Subt : Entity_Id; - Target : Node_Id; begin -- If the call has already been processed to add build-in-place actuals @@ -8038,26 +8070,6 @@ package body Exp_Ch6 is Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); Rewrite (Assign, Make_Null_Statement (Loc)); - - -- Retrieve the target of the assignment - - if Nkind (Lhs) = N_Selected_Component then - Target := Selector_Name (Lhs); - elsif Nkind (Lhs) = N_Type_Conversion then - Target := Expression (Lhs); - else - Target := Lhs; - end if; - - -- If we are assigning to a return object or this is an expression of - -- an extension aggregate, the target should either be an identifier - -- or a simple expression. All other cases imply a different scenario. - - if Nkind (Target) in N_Has_Entity then - Target := Entity (Target); - else - return; - end if; end Make_Build_In_Place_Call_In_Assignment; ---------------------------------------------------- @@ -8406,44 +8418,8 @@ package body Exp_Ch6 is end if; Analyze (Obj_Decl); - - -- Replace the internal identifier of the renaming declaration's - -- entity with identifier of the original object entity. We also - -- have to exchange the entities containing their defining - -- identifiers to ensure the correct replacement of the object - -- declaration by the object renaming declaration to avoid - -- homograph conflicts (since the object declaration's defining - -- identifier was already entered in current scope). The - -- Next_Entity links of the two entities also have to be swapped - -- since the entities are part of the return scope's entity list - -- and the list structure would otherwise be corrupted. Finally, - -- the homonym chain must be preserved as well. - - declare - Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl); - Next_Id : constant Entity_Id := Next_Entity (Ren_Id); - - begin - Set_Chars (Ren_Id, Chars (Obj_Def_Id)); - - -- Swap next entity links in preparation for exchanging - -- entities. - - Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id)); - Set_Next_Entity (Obj_Def_Id, Next_Id); - Set_Homonym (Ren_Id, Homonym (Obj_Def_Id)); - - Exchange_Entities (Ren_Id, Obj_Def_Id); - - -- Preserve source indication of original declaration, so that - -- xref information is properly generated for the right entity. - - Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl)); - Preserve_Comes_From_Source - (Obj_Def_Id, Original_Node (Obj_Decl)); - - Set_Comes_From_Source (Ren_Id, False); - end; + Replace_Renaming_Declaration_Id + (Obj_Decl, Original_Node (Obj_Decl)); end if; end; @@ -8460,6 +8436,185 @@ package body Exp_Ch6 is end if; end Make_Build_In_Place_Call_In_Object_Declaration; + ------------------------------------------------- + -- Make_Build_In_Place_Iface_Call_In_Allocator -- + ------------------------------------------------- + + procedure Make_Build_In_Place_Iface_Call_In_Allocator + (Allocator : Node_Id; + Function_Call : Node_Id) + is + BIP_Func_Call : constant Node_Id := + Unqual_BIP_Iface_Function_Call (Function_Call); + Loc : constant Source_Ptr := Sloc (Function_Call); + + Anon_Type : Entity_Id; + Tmp_Decl : Node_Id; + Tmp_Id : Entity_Id; + + begin + -- No action of the call has already been processed + + if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then + return; + end if; + + Tmp_Id := Make_Temporary (Loc, 'D'); + + -- Insert a temporary before N initialized with the BIP function call + -- without its enclosing type conversions and analyze it without its + -- expansion. This temporary facilitates us reusing the BIP machinery, + -- which takes care of adding the extra build-in-place actuals and + -- transforms this object declaration into an object renaming + -- declaration. + + Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); + Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); + Set_Etype (Anon_Type, Anon_Type); + + Tmp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp_Id, + Object_Definition => New_Occurrence_Of (Anon_Type, Loc), + Expression => + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (BIP_Func_Call), Loc), + Expression => New_Copy_Tree (BIP_Func_Call)))); + + Expander_Mode_Save_And_Set (False); + Insert_Action (Allocator, Tmp_Decl); + Expander_Mode_Restore; + + Make_Build_In_Place_Call_In_Allocator + (Allocator => Expression (Tmp_Decl), + Function_Call => Expression (Expression (Tmp_Decl))); + + Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc)); + end Make_Build_In_Place_Iface_Call_In_Allocator; + + --------------------------------------------------------- + -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context -- + --------------------------------------------------------- + + procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context + (Function_Call : Node_Id) + is + BIP_Func_Call : constant Node_Id := + Unqual_BIP_Iface_Function_Call (Function_Call); + Loc : constant Source_Ptr := Sloc (Function_Call); + + Tmp_Decl : Node_Id; + Tmp_Id : Entity_Id; + + begin + -- No action of the call has already been processed + + if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then + return; + end if; + + pragma Assert (Needs_Finalization (Etype (BIP_Func_Call))); + + -- Insert a temporary before the call initialized with function call to + -- reuse the BIP machinery which takes care of adding the extra build-in + -- place actuals and transforms this object declaration into an object + -- renaming declaration. + + Tmp_Id := Make_Temporary (Loc, 'D'); + + Tmp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp_Id, + Object_Definition => + New_Occurrence_Of (Etype (Function_Call), Loc), + Expression => Relocate_Node (Function_Call)); + + Expander_Mode_Save_And_Set (False); + Insert_Action (Function_Call, Tmp_Decl); + Expander_Mode_Restore; + + Make_Build_In_Place_Iface_Call_In_Object_Declaration + (Obj_Decl => Tmp_Decl, + Function_Call => Expression (Tmp_Decl)); + end Make_Build_In_Place_Iface_Call_In_Anonymous_Context; + + ---------------------------------------------------------- + -- Make_Build_In_Place_Iface_Call_In_Object_Declaration -- + ---------------------------------------------------------- + + procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration + (Obj_Decl : Node_Id; + Function_Call : Node_Id) + is + BIP_Func_Call : constant Node_Id := + Unqual_BIP_Iface_Function_Call (Function_Call); + Loc : constant Source_Ptr := Sloc (Function_Call); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + + Tmp_Decl : Node_Id; + Tmp_Id : Entity_Id; + + begin + -- No action of the call has already been processed + + if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then + return; + end if; + + Tmp_Id := Make_Temporary (Loc, 'D'); + + -- Insert a temporary before N initialized with the BIP function call + -- without its enclosing type conversions and analyze it without its + -- expansion. This temporary facilitates us reusing the BIP machinery, + -- which takes care of adding the extra build-in-place actuals and + -- transforms this object declaration into an object renaming + -- declaration. + + Tmp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp_Id, + Object_Definition => + New_Occurrence_Of (Etype (BIP_Func_Call), Loc), + Expression => New_Copy_Tree (BIP_Func_Call)); + + Expander_Mode_Save_And_Set (False); + Insert_Action (Obj_Decl, Tmp_Decl); + Expander_Mode_Restore; + + Make_Build_In_Place_Call_In_Object_Declaration + (Obj_Decl => Tmp_Decl, + Function_Call => Expression (Tmp_Decl)); + + pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration); + + -- Replace the original build-in-place function call by a reference to + -- the resulting temporary object renaming declaration. In this way, + -- all the interface conversions performed in the original Function_Call + -- on the build-in-place object are preserved. + + Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc)); + + -- Replace the original object declaration by an internal object + -- renaming declaration. This leaves the generated code more clean (the + -- build-in-place function call in an object renaming declaration and + -- displacements of the pointer to the build-in-place object in another + -- renaming declaration) and allows us to invoke the routine that takes + -- care of replacing the identifier of the renaming declaration (routine + -- originally developed for the regular build-in-place management). + + Rewrite (Obj_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc), + Name => Function_Call)); + Analyze (Obj_Decl); + + Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl)); + end Make_Build_In_Place_Iface_Call_In_Object_Declaration; + -------------------------------------------- -- Make_CPP_Constructor_Call_In_Allocator -- -------------------------------------------- @@ -8713,6 +8868,41 @@ package body Exp_Ch6 is end if; end Needs_Result_Accessibility_Level; + ------------------------------------- + -- Replace_Renaming_Declaration_Id -- + ------------------------------------- + + procedure Replace_Renaming_Declaration_Id + (New_Decl : Node_Id; + Orig_Decl : Node_Id) + is + New_Id : constant Entity_Id := Defining_Entity (New_Decl); + Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl); + + begin + Set_Chars (New_Id, Chars (Orig_Id)); + + -- Swap next entity links in preparation for exchanging entities + + declare + Next_Id : constant Entity_Id := Next_Entity (New_Id); + begin + Set_Next_Entity (New_Id, Next_Entity (Orig_Id)); + Set_Next_Entity (Orig_Id, Next_Id); + end; + + Set_Homonym (New_Id, Homonym (Orig_Id)); + Exchange_Entities (New_Id, Orig_Id); + + -- Preserve source indication of original declaration, so that xref + -- information is properly generated for the right entity. + + Preserve_Comes_From_Source (New_Decl, Orig_Decl); + Preserve_Comes_From_Source (Orig_Id, Orig_Decl); + + Set_Comes_From_Source (New_Id, False); + end Replace_Renaming_Declaration_Id; + --------------------------------- -- Rewrite_Function_Call_For_C -- --------------------------------- @@ -8866,4 +9056,100 @@ package body Exp_Ch6 is end loop; end Set_Enclosing_Sec_Stack_Return; + ------------------------------------ + -- Unqual_BIP_Iface_Function_Call -- + ------------------------------------ + + function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is + Has_Pointer_Displacement : Boolean := False; + On_Object_Declaration : Boolean := False; + -- Remember if processing the renaming expressions on recursion we have + -- traversed an object declaration, since we can traverse many object + -- declaration renamings but just one regular object declaration. + + function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id; + -- Search for a build-in-place function call skipping any qualification + -- including qualified expressions, type conversions, references, calls + -- to displace the pointer to the object, and renamings. Return Empty if + -- no build-in-place function call is found. + + ------------------------------ + -- Unqual_BIP_Function_Call -- + ------------------------------ + + function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is + begin + -- Recurse to handle case of multiple levels of qualification and/or + -- conversion. + + if Nkind_In (Expr, N_Qualified_Expression, + N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + return Unqual_BIP_Function_Call (Expression (Expr)); + + -- Recurse to handle case of multiple levels of references and + -- explicit dereferences. + + elsif Nkind_In (Expr, N_Attribute_Reference, + N_Explicit_Dereference, + N_Reference) + then + return Unqual_BIP_Function_Call (Prefix (Expr)); + + -- Recurse on object renamings + + elsif Nkind (Expr) = N_Identifier + and then Ekind_In (Entity (Expr), E_Constant, E_Variable) + and then Nkind (Parent (Entity (Expr))) = + N_Object_Renaming_Declaration + and then Present (Renamed_Object (Entity (Expr))) + then + return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr))); + + -- Recurse on the initializing expression of the first reference of + -- an object declaration. + + elsif not On_Object_Declaration + and then Nkind (Expr) = N_Identifier + and then Ekind_In (Entity (Expr), E_Constant, E_Variable) + and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration + and then Present (Expression (Parent (Entity (Expr)))) + then + On_Object_Declaration := True; + return + Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr)))); + + -- Recurse to handle calls to displace the pointer to the object to + -- reference a secondary dispatch table. + + elsif Nkind (Expr) = N_Function_Call + and then Nkind (Name (Expr)) in N_Has_Entity + and then RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_Displace) + and then Is_RTE (Entity (Name (Expr)), RE_Displace) + then + Has_Pointer_Displacement := True; + return + Unqual_BIP_Function_Call (First (Parameter_Associations (Expr))); + + -- Normal case: check if the inner expression is a BIP function call + -- and the pointer to the object is displaced. + + elsif Has_Pointer_Displacement + and then Is_Build_In_Place_Function_Call (Expr) + then + return Expr; + + else + return Empty; + end if; + end Unqual_BIP_Function_Call; + + -- Start of processing for Unqual_BIP_Iface_Function_Call + + begin + return Unqual_BIP_Function_Call (Expr); + end Unqual_BIP_Iface_Function_Call; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 249bf14a10b..c4fc3bc8588 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -185,6 +185,40 @@ package Exp_Ch6 is -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression -- node applied to such a function call. + procedure Make_Build_In_Place_Iface_Call_In_Allocator + (Allocator : Node_Id; + Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs as the expression initializing an allocator, by passing access + -- to the allocated object as an additional parameter of the function call. + -- Function_Call must denote an expression containing a BIP function call + -- and an enclosing call to Ada.Tags.Displace to displace the pointer to + -- the returned BIP object to reference the secondary dispatch table of + -- an interface. + + procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context + (Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs in a context that does not provide a separate object. A temporary + -- object is created to act as the return object and an access to the + -- temporary is passed as an additional parameter of the call. This occurs + -- in contexts such as subprogram call actuals and object renamings. + -- Function_Call must denote an expression containing a BIP function call + -- and an enclosing call to Ada.Tags.Displace to displace the pointer to + -- the returned BIP object to reference the secondary dispatch table of + -- an interface. + + procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration + (Obj_Decl : Node_Id; + Function_Call : Node_Id); + -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that + -- occurs as the expression initializing an object declaration by passsing + -- access to the declared object as an additional parameter of the function + -- call. Function_Call must denote an expression containing a BIP function + -- call and an enclosing call to Ada.Tags.Displace to displace the pointer + -- to the returned BIP object to reference the secondary dispatch table of + -- an interface. + procedure Make_CPP_Constructor_Call_In_Allocator (Allocator : Node_Id; Function_Call : Node_Id); @@ -211,4 +245,12 @@ package Exp_Ch6 is -- parameter to identify the accessibility level of the function result -- "determined by the point of call". + function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id; + -- Return the inner BIP function call removing any qualification from Expr + -- including qualified expressions, type conversions, references, unchecked + -- conversions and calls to displace the pointer to the object, if Expr is + -- an expression containing a call displacing the pointer to the BIP object + -- to reference the secondary dispatch table of an interface; otherwise + -- return Empty. + end Exp_Ch6; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 7af33b36168..ba0f7c291c1 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -185,6 +185,15 @@ package body Exp_Ch8 is and then Is_Build_In_Place_Function_Call (Nam) then Make_Build_In_Place_Call_In_Anonymous_Context (Nam); + + -- Ada 2005 (AI-318-02): Specialization of previous case for renaming + -- containing build-in-place function calls whose returned object covers + -- interface types. + + elsif Ada_Version >= Ada_2005 + and then Present (Unqual_BIP_Iface_Function_Call (Nam)) + then + Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam); end if; -- Create renaming entry for debug information. Mark the entity as diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 872ac6488b6..d6d806941b5 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1214,10 +1214,10 @@ package body Exp_Disp is E : Entity_Id := Typ; begin - -- Handle access to class-wide interface types + -- Handle access types if Is_Access_Type (E) then - E := Etype (Directly_Designated_Type (E)); + E := Directly_Designated_Type (E); end if; -- Handle class-wide types. This conversion can appear explicitly in @@ -1522,11 +1522,6 @@ package body Exp_Disp is if Is_Access_Type (Etype (Expression (N))) then - Apply_Accessibility_Check - (N => Expression (N), - Typ => Etype (N), - Insert_Node => N); - -- Generate: Func (Address!(Expression)) Rewrite (N, diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 7ed11362fd5..c60f75a71f9 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -320,6 +320,84 @@ package body Exp_Prag is -- Assert_Failure, so that coverage analysis tools can relate the -- call to the failed check. + procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id); + -- Discriminants of the enclosing protected object may be referenced + -- in the expression of a precondition of a protected operation. + -- In the body of the operation these references must be replaced by + -- the discriminal created for them, which area renamings of the + -- discriminants of the object that is the target of the operation. + -- This replacement is done by visibility when the references appear + -- in the subprogram body, but in the case of a condition which appears + -- on the specification of the subprogram it has be done separately + -- because the condition has been replaced by a Check pragma and + -- analyzed earlier, before the creation of the discriminal renaming + -- declarations that are added to the subprogram body. + + ------------------------------------------ + -- Replace_Discriminals_Of_Protected_Op -- + ------------------------------------------ + + procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is + function Find_Corresponding_Discriminal (E : Entity_Id) + return Entity_Id; + -- Find the local entity that renames a discriminant of the + -- enclosing protected type, and has a matching name. + + ------------------------------------ + -- find_Corresponding_Discriminal -- + ------------------------------------ + + function Find_Corresponding_Discriminal (E : Entity_Id) + return Entity_Id + is + R : Entity_Id; + + begin + R := First_Entity (Current_Scope); + + while Present (R) loop + if Nkind (Parent (R)) = N_Object_Renaming_Declaration + and then Present (Discriminal_Link (R)) + and then Chars (Discriminal_Link (R)) = Chars (E) + then + return R; + end if; + + Next_Entity (R); + end loop; + + return Empty; + end Find_Corresponding_Discriminal; + + function Replace_Discr_Ref (N : Node_Id) return Traverse_Result; + -- Replace a reference to a discriminant of the original protected + -- type by the local renaming declaration of the discriminant of + -- the target object. + + ----------------------- + -- Replace_Discr_Ref -- + ----------------------- + + function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is + R : Entity_Id; + + begin + if Is_Entity_Name (N) + and then Present (Discriminal_Link (Entity (N))) + then + R := Find_Corresponding_Discriminal (Entity (N)); + Rewrite (N, New_Occurrence_Of (R, Sloc (N))); + end if; + return OK; + end Replace_Discr_Ref; + + procedure Replace_Discriminant_References is + new Traverse_Proc (Replace_Discr_Ref); + + begin + Replace_Discriminant_References (Expr); + end Replace_Discriminals_Of_Protected_Op; + begin -- Nothing to do if pragma is ignored @@ -456,6 +534,16 @@ package body Exp_Prag is end; end if; + -- For a precondition, replace references to discriminants of a + -- protected type with the local discriminals. + + if Is_Protected_Type (Scope (Current_Scope)) + and then Has_Discriminants (Scope (Current_Scope)) + and then From_Aspect_Specification (N) + then + Replace_Discriminals_Of_Protected_Op (Cond); + end if; + -- Now rewrite as an if statement Rewrite (N, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 9c6ea2b6acc..05e075917ab 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3406,14 +3406,15 @@ package body Exp_Util is if Present (Priv_Typ) then Typ_Decl := Declaration_Node (Priv_Typ); - -- Derived types with the full view as parent do not have a partial - -- view. Insert the invariant procedure after the derived type. -- Anonymous arrays in object declarations have no explicit declaration -- so use the related object declaration as the insertion point. elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then Typ_Decl := Associated_Node_For_Itype (Work_Typ); + -- Derived types with the full view as parent do not have a partial + -- view. Insert the invariant procedure after the derived type. + else Typ_Decl := Declaration_Node (Full_Typ); end if; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index ca9986d20da..aa99201ec9f 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1179,29 +1179,29 @@ package body Inline is -- types. function Has_Some_Contract (Id : Entity_Id) return Boolean; - -- Returns True if subprogram Id has any contract (Pre, Post, - -- Global, Depends, etc.) The presence of Extensions_Visible - -- or Volatile_Function is also considered as a contract here. + -- Return True if subprogram Id has any contract. The presence of + -- Extensions_Visible or Volatile_Function is also considered as a + -- contract here. function Is_Unit_Subprogram (Id : Entity_Id) return Boolean; - -- Returns True if subprogram Id defines a compilation unit + -- Return True if subprogram Id defines a compilation unit -- Shouldn't this be in Sem_Aux??? function In_Package_Spec (Id : Node_Id) return Boolean; - -- Returns True if subprogram Id is defined in the package - -- specification, either its visible or private part. + -- Return True if subprogram Id is defined in the package specification, + -- either its visible or private part. --------------------------------------------------- -- Has_Formal_With_Discriminant_Dependent_Fields -- --------------------------------------------------- function Has_Formal_With_Discriminant_Dependent_Fields - (Id : Entity_Id) return Boolean is - + (Id : Entity_Id) return Boolean + is function Has_Discriminant_Dependent_Component (Typ : Entity_Id) return Boolean; - -- Determine whether unconstrained record type Typ has at least - -- one component that depends on a discriminant. + -- Determine whether unconstrained record type Typ has at least one + -- component that depends on a discriminant. ------------------------------------------ -- Has_Discriminant_Dependent_Component -- @@ -1213,8 +1213,8 @@ package body Inline is Comp : Entity_Id; begin - -- Inspect all components of the record type looking for one - -- that depends on a discriminant. + -- Inspect all components of the record type looking for one that + -- depends on a discriminant. Comp := First_Component (Typ); while Present (Comp) loop diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 7cdf9e8ea67..4f7016d2690 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6284,7 +6284,6 @@ package body Sem_Ch4 is procedure Try_One_Interp (T1 : Entity_Id) is begin - -- If the operator is an expanded name, then the type of the operand -- must be defined in the corresponding scope. If the type is -- universal, the context will impose the correct type. Note that we @@ -6480,8 +6479,8 @@ package body Sem_Ch4 is -- Note that we avoid returning if we are currently within a -- generic instance due to the fact that the generic package -- declaration has already been successfully analyzed and - -- Defined_In_Scope expects the base type to be defined within the - -- instance which will never be the case. + -- Defined_In_Scope expects the base type to be defined within + -- the instance which will never be the case. if Defined_In_Scope (T1, Scop) or else In_Instance diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index dc98ad55d7d..54b02e4fa6c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -267,18 +267,214 @@ package body Sem_Ch6 is LocX : constant Source_Ptr := Sloc (Expr); Spec : constant Node_Id := Specification (N); + procedure Freeze_Expr_Types (Spec_Id : Entity_Id); + -- N is an expression function that is a completion and Spec_Id its + -- defining entity. Freeze before N all the types referenced by the + -- expression of the function. + + ----------------------- + -- Freeze_Expr_Types -- + ----------------------- + + procedure Freeze_Expr_Types (Spec_Id : Entity_Id) is + function Cloned_Expression return Node_Id; + -- Build a duplicate of the expression of the return statement that + -- has no defining entities shared with the original expression. + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; + -- Freeze all types referenced in the subtree rooted at Node + + ----------------------- + -- Cloned_Expression -- + ----------------------- + + function Cloned_Expression return Node_Id is + function Clone_Id (Node : Node_Id) return Traverse_Result; + -- Tree traversal routine that clones the defining identifier of + -- iterator and loop parameter specification nodes. + + ---------------- + -- Check_Node -- + ---------------- + + function Clone_Id (Node : Node_Id) return Traverse_Result is + begin + if Nkind_In (Node, N_Iterator_Specification, + N_Loop_Parameter_Specification) + then + Set_Defining_Identifier (Node, + New_Copy (Defining_Identifier (Node))); + end if; + + return OK; + end Clone_Id; + + procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); + + -- Local variable + + Dup_Expr : constant Node_Id := New_Copy_Tree (Expr); + + -- Start of processing for Cloned_Expression + + begin + -- We must duplicate the expression with semantic information to + -- inherit the decoration of global entities in generic instances. + -- Set the parent of the new node to be the parent of the original + -- to get the proper context, which is needed for complete error + -- reporting and for semantic analysis. + + Set_Parent (Dup_Expr, Parent (Expr)); + + -- Replace the defining identifier of iterators and loop param + -- specifications by a clone to ensure that the cloned expression + -- and the original expression don't have shared identifiers; + -- otherwise, as part of the preanalysis of the expression, these + -- shared identifiers may be left decorated with itypes which + -- will not be available in the tree passed to the backend. + + Clone_Def_Ids (Dup_Expr); + + return Dup_Expr; + end Cloned_Expression; + + ---------------------- + -- Freeze_Type_Refs -- + ---------------------- + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is + + procedure Check_And_Freeze_Type (Typ : Entity_Id); + -- Check that Typ is fully declared and freeze it if so + + --------------------------- + -- Check_And_Freeze_Type -- + --------------------------- + + procedure Check_And_Freeze_Type (Typ : Entity_Id) is + begin + -- Skip Itypes created by the preanalysis + + if Is_Itype (Typ) + and then Scope_Within_Or_Same (Scope (Typ), Spec_Id) + then + return; + end if; + + -- This provides a better error message than generating + -- primitives whose compilation fails much later. Refine + -- the error message if possible. + + Check_Fully_Declared (Typ, Node); + + if Error_Posted (Node) then + if Has_Private_Component (Typ) + and then not Is_Private_Type (Typ) + then + Error_Msg_NE + ("\type& has private component", Node, Typ); + end if; + + else + Freeze_Before (N, Typ); + end if; + end Check_And_Freeze_Type; + + -- Start of processing for Freeze_Type_Refs + + begin + -- Check that a type referenced by an entity can be frozen + + if Is_Entity_Name (Node) and then Present (Entity (Node)) then + Check_And_Freeze_Type (Etype (Entity (Node))); + + -- Check that the enclosing record type can be frozen + + if Ekind_In (Entity (Node), E_Component, E_Discriminant) then + Check_And_Freeze_Type (Scope (Entity (Node))); + end if; + + -- Freezing an access type does not freeze the designated type, + -- but freezing conversions between access to interfaces requires + -- that the interface types themselves be frozen, so that dispatch + -- table entities are properly created. + + -- Unclear whether a more general rule is needed ??? + + elsif Nkind (Node) = N_Type_Conversion + and then Is_Access_Type (Etype (Node)) + and then Is_Interface (Designated_Type (Etype (Node))) + then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); + end if; + + -- No point in posting several errors on the same expression + + if Serious_Errors_Detected > 0 then + return Abandon; + else + return OK; + end if; + end Freeze_Type_Refs; + + procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); + + -- Local variables + + Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id); + Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id); + Dup_Expr : constant Node_Id := Cloned_Expression; + + -- Start of processing for Freeze_Expr_Types + + begin + -- Preanalyze a duplicate of the expression to have available the + -- minimum decoration needed to locate referenced unfrozen types + -- without adding any decoration to the function expression. This + -- preanalysis is performed with errors disabled to avoid reporting + -- spurious errors on Ghost entities (since the expression is not + -- fully analyzed). + + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); + Ignore_Errors_Enable := Ignore_Errors_Enable + 1; + + Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id)); + + Ignore_Errors_Enable := Ignore_Errors_Enable - 1; + End_Scope; + + -- Restore certain attributes of Spec_Id since the preanalysis may + -- have introduced itypes to this scope, thus modifying attributes + -- First_Entity and Last_Entity. + + Set_First_Entity (Spec_Id, Saved_First_Entity); + Set_Last_Entity (Spec_Id, Saved_Last_Entity); + + if Present (Last_Entity (Spec_Id)) then + Set_Next_Entity (Last_Entity (Spec_Id), Empty); + end if; + + -- Freeze all types referenced in the expression + + Freeze_References (Dup_Expr); + end Freeze_Expr_Types; + + -- Local variables + Asp : Node_Id; - Def_Id : Entity_Id; New_Body : Node_Id; New_Spec : Node_Id; Orig_N : Node_Id; Ret : Node_Id; - Ret_Type : Entity_Id; - Prev : Entity_Id; + Def_Id : Entity_Id; + Prev : Entity_Id; -- If the expression is a completion, Prev is the entity whose -- declaration is completed. Def_Id is needed to analyze the spec. + -- Start of processing for Analyze_Expression_Function + begin -- This is one of the occasions on which we transform the tree during -- semantic analysis. If this is a completion, transform the expression @@ -319,7 +515,7 @@ package body Sem_Ch6 is end if; end if; - Ret := Make_Simple_Return_Statement (LocX, Expression (N)); + Ret := Make_Simple_Return_Statement (LocX, Expr); New_Body := Make_Subprogram_Body (Loc, @@ -361,47 +557,21 @@ package body Sem_Ch6 is -- to be inlined. elsif Present (Prev) - and then Comes_From_Source (Parent (Prev)) + and then Is_Overloadable (Prev) and then not Is_Formal_Subprogram (Prev) + and then Comes_From_Source (Parent (Prev)) then Set_Has_Completion (Prev, False); Set_Is_Inlined (Prev); - Ret_Type := Etype (Prev); - -- An expression function which acts as a completion freezes the - -- expression. This means freezing the return type, and if it is - -- an access type, freezing its designated type as well. + -- AI12-0103: Expression functions that are a completion freeze their + -- expression but don't freeze anything else (unlike regular bodies). -- Note that we cannot defer this freezing to the analysis of the -- expression itself, because a freeze node might appear in a nested -- scope, leading to an elaboration order issue in gigi. - Freeze_Before (N, Ret_Type); - - -- An entity can only be frozen if it is complete, so if the type - -- is still unfrozen it must still be incomplete in some way, e.g. - -- a private type without a full view, or a type derived from such - -- in an enclosing scope. Except in a generic context (where the - -- type may be a generic formal or derived from such), such use of - -- an incomplete type is an error. On the other hand, if this is a - -- limited view of a type, the type is declared in another unit and - -- frozen there. We must be in a context seeing the nonlimited view - -- of the type, which will be installed when the body is compiled. - - if not Is_Frozen (Ret_Type) - and then not Is_Generic_Type (Root_Type (Ret_Type)) - and then not Inside_A_Generic - then - if From_Limited_With (Ret_Type) - and then Present (Non_Limited_View (Ret_Type)) - then - null; - else - Error_Msg_NE - ("premature use of private type&", - Result_Definition (Specification (N)), Ret_Type); - end if; - end if; + Freeze_Expr_Types (Def_Id); -- For navigation purposes, indicate that the function is a body @@ -2273,11 +2443,6 @@ package body Sem_Ch6 is -- limited views with the non-limited ones. Return the list of changes -- to be used to undo the transformation. - procedure Freeze_Expr_Types (Spec_Id : Entity_Id); - -- AI12-0103: N is the body associated with an expression function that - -- is a completion, and Spec_Id is its defining entity. Freeze before N - -- all the types referenced by the expression of the function. - function Is_Private_Concurrent_Primitive (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id is a primitive of a concurrent @@ -3003,180 +3168,6 @@ package body Sem_Ch6 is return Result; end Exchange_Limited_Views; - ----------------------- - -- Freeze_Expr_Types -- - ----------------------- - - procedure Freeze_Expr_Types (Spec_Id : Entity_Id) is - function Cloned_Expression return Node_Id; - -- Build a duplicate of the expression of the return statement that - -- has no defining entities shared with the original expression. - - function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; - -- Freeze all types referenced in the subtree rooted at Node - - ----------------------- - -- Cloned_Expression -- - ----------------------- - - function Cloned_Expression return Node_Id is - function Clone_Id (Node : Node_Id) return Traverse_Result; - -- Tree traversal routine that clones the defining identifier of - -- iterator and loop parameter specification nodes. - - ---------------- - -- Check_Node -- - ---------------- - - function Clone_Id (Node : Node_Id) return Traverse_Result is - begin - if Nkind_In (Node, N_Iterator_Specification, - N_Loop_Parameter_Specification) - then - Set_Defining_Identifier (Node, - New_Copy (Defining_Identifier (Node))); - end if; - - return OK; - end Clone_Id; - - ------------------- - -- Clone_Def_Ids -- - ------------------- - - procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id); - - -- Local variables - - Return_Stmt : constant Node_Id := - First - (Statements (Handled_Statement_Sequence (N))); - Dup_Expr : Node_Id; - - -- Start of processing for Cloned_Expression - - begin - pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement); - - -- We must duplicate the expression with semantic information to - -- inherit the decoration of global entities in generic instances. - -- Set the parent of the new node to be the parent of the original - -- to get the proper context, which is needed for complete error - -- reporting and for semantic analysis. - - Dup_Expr := New_Copy_Tree (Expression (Return_Stmt)); - Set_Parent (Dup_Expr, Return_Stmt); - - -- Replace the defining identifier of iterators and loop param - -- specifications by a clone to ensure that the cloned expression - -- and the original expression don't have shared identifiers; - -- otherwise, as part of the preanalysis of the expression, these - -- shared identifiers may be left decorated with itypes which - -- will not be available in the tree passed to the backend. - - Clone_Def_Ids (Dup_Expr); - - return Dup_Expr; - end Cloned_Expression; - - ---------------------- - -- Freeze_Type_Refs -- - ---------------------- - - function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is - begin - if Nkind (Node) = N_Identifier - and then Present (Entity (Node)) - then - if Is_Type (Entity (Node)) then - Freeze_Before (N, Entity (Node)); - - elsif Ekind_In (Entity (Node), E_Component, - E_Discriminant) - then - declare - Rec : constant Entity_Id := Scope (Entity (Node)); - begin - - -- Check that the enclosing record type can be frozen. - -- This provides a better error message than generating - -- primitives whose compilation fails much later. Refine - -- the error message if possible. - - Check_Fully_Declared (Rec, Node); - - if Error_Posted (Node) then - if Has_Private_Component (Rec) then - Error_Msg_NE - ("\type& has private component", Node, Rec); - end if; - - else - Freeze_Before (N, Rec); - end if; - end; - end if; - - -- Freezing an access type does not freeze the designated type, - -- but freezing conversions between access to interfaces requires - -- that the interface types themselves be frozen, so that dispatch - -- table entities are properly created. - - -- Unclear whether a more general rule is needed ??? - - elsif Nkind (Node) = N_Type_Conversion - and then Is_Access_Type (Etype (Node)) - and then Is_Interface (Designated_Type (Etype (Node))) - then - Freeze_Before (N, Designated_Type (Etype (Node))); - end if; - - return OK; - end Freeze_Type_Refs; - - procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); - - -- Local variables - - Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id); - Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id); - Dup_Expr : constant Node_Id := Cloned_Expression; - - -- Start of processing for Freeze_Expr_Types - - begin - -- Preanalyze a duplicate of the expression to have available the - -- minimum decoration needed to locate referenced unfrozen types - -- without adding any decoration to the function expression. This - -- preanalysis is performed with errors disabled to avoid reporting - -- spurious errors on Ghost entities (since the expression is not - -- fully analyzed). - - Push_Scope (Spec_Id); - Install_Formals (Spec_Id); - Ignore_Errors_Enable := Ignore_Errors_Enable + 1; - - Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id)); - - Ignore_Errors_Enable := Ignore_Errors_Enable - 1; - End_Scope; - - -- Restore certain attributes of Spec_Id since the preanalysis may - -- have introduced itypes to this scope, thus modifying attributes - -- First_Entity and Last_Entity. - - Set_First_Entity (Spec_Id, Saved_First_Entity); - Set_Last_Entity (Spec_Id, Saved_Last_Entity); - - if Present (Last_Entity (Spec_Id)) then - Set_Next_Entity (Last_Entity (Spec_Id), Empty); - end if; - - -- Freeze all types referenced in the expression - - Freeze_References (Dup_Expr); - end Freeze_Expr_Types; - ------------------------------------- -- Is_Private_Concurrent_Primitive -- ------------------------------------- @@ -3627,17 +3618,6 @@ package body Sem_Ch6 is then Set_Has_Delayed_Freeze (Spec_Id); Freeze_Before (N, Spec_Id); - - -- AI12-0103: At the occurrence of an expression function - -- declaration that is a completion, its expression causes - -- freezing. - - if Has_Completion (Spec_Id) - and then Nkind (N) = N_Subprogram_Body - and then Was_Expression_Function (N) - then - Freeze_Expr_Types (Spec_Id); - end if; end if; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 373fcdad1b9..0dc5f08d88b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17924,7 +17924,7 @@ package body Sem_Prag is then declare Name : constant String := - Get_Name_String (Chars (Variant)); + Get_Name_String (Chars (Variant)); begin -- It is a common mistake to write "Increasing" for -- "Increases" or "Decreasing" for "Decreases". Recognize