From 3fc40cd783cb149d7d6c328def33606ec17ab15f Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Mon, 9 Oct 2017 20:47:26 +0000 Subject: [PATCH] [multiple changes] 2017-10-09 Hristian Kirtchev * sem_unit.adb (Find_Enclosing_Scope): Do not treat a block statement as a scoping construct when it is byproduct of exception handling. 2017-10-09 Hristian Kirtchev * sinfo.ads: Update table Is_Syntactic_Field to reflect the nature of semantic field Target of node N_Call_Marker. 2017-10-09 Ed Schonberg * sem_res.adb (Resolve_Allocator): Reject properly an allocator that attempts to copy a limited value, when the allocator is the expression in an expression function. 2017-10-09 Joel Brobecker * doc/share/conf.py: Tell the style checker that this is a Python fragment, and therefore that pyflakes should not be run to validate this file. 2017-10-09 Eric Botcazou * einfo.ads (Is_Boolean_Type): Add pragma Inline. (Is_Entity_Name): Likewise. (Is_String_Type): Likewise. * sem_type.adb (Full_View_Covers): Do not test Is_Private_Type here and remove useless comparisons on the base types. (Covers): Use simple tests for Standard_Void_Type. Move up cheap tests on T2. Always test Is_Private_Type before Full_View_Covers. 2017-10-09 Bob Duff * exp_ch4.adb: Minor refactoring. From-SVN: r253568 --- gcc/ada/ChangeLog | 36 ++++++++ gcc/ada/doc/share/conf.py | 1 + gcc/ada/einfo.ads | 3 + gcc/ada/exp_aggr.adb | 53 +++++++----- gcc/ada/exp_ch3.adb | 26 +++--- gcc/ada/exp_ch4.adb | 145 ++++++++++++++++---------------- gcc/ada/exp_ch5.adb | 12 +-- gcc/ada/exp_ch6.adb | 115 ++++++++++++------------- gcc/ada/exp_util.adb | 5 +- gcc/ada/sem_aggr.adb | 23 ++--- gcc/ada/sem_ch13.adb | 23 +++-- gcc/ada/sem_ch3.adb | 18 ++-- gcc/ada/sem_ch5.adb | 172 +++++++++++++++++++++----------------- gcc/ada/sem_ch7.adb | 20 +++-- gcc/ada/sem_res.adb | 10 ++- gcc/ada/sem_type.adb | 45 +++++----- gcc/ada/sem_util.adb | 33 +++++--- gcc/ada/sinfo.ads | 2 +- 18 files changed, 418 insertions(+), 324 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2e799e1ef1d..6b70bf1352b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2017-10-09 Hristian Kirtchev + + * sem_unit.adb (Find_Enclosing_Scope): Do not treat a block statement + as a scoping construct when it is byproduct of exception handling. + +2017-10-09 Hristian Kirtchev + + * sinfo.ads: Update table Is_Syntactic_Field to reflect the nature of + semantic field Target of node N_Call_Marker. + +2017-10-09 Ed Schonberg + + * sem_res.adb (Resolve_Allocator): Reject properly an allocator that + attempts to copy a limited value, when the allocator is the expression + in an expression function. + +2017-10-09 Joel Brobecker + + * doc/share/conf.py: Tell the style checker that this is a Python + fragment, and therefore that pyflakes should not be run to validate + this file. + +2017-10-09 Eric Botcazou + + * einfo.ads (Is_Boolean_Type): Add pragma Inline. + (Is_Entity_Name): Likewise. + (Is_String_Type): Likewise. + * sem_type.adb (Full_View_Covers): Do not test Is_Private_Type here + and remove useless comparisons on the base types. + (Covers): Use simple tests for Standard_Void_Type. Move up cheap tests + on T2. Always test Is_Private_Type before Full_View_Covers. + +2017-10-09 Bob Duff + + * exp_ch4.adb: Minor refactoring. + 2017-10-09 Javier Miranda * sem_ch3.adb (Replace_Components): Browse the list of discriminants, diff --git a/gcc/ada/doc/share/conf.py b/gcc/ada/doc/share/conf.py index 173648b26ea..e6fafcfaec0 100644 --- a/gcc/ada/doc/share/conf.py +++ b/gcc/ada/doc/share/conf.py @@ -1,4 +1,5 @@ # -*- coding: utf-8 -*- +# Style_Check:Python_Fragment (meaning no pyflakes check) # # GNAT build configuration file diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7ad4cfa88af..d20440bcbf2 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -9470,9 +9470,12 @@ package Einfo is pragma Inline (Base_Type); pragma Inline (Is_Base_Type); + pragma Inline (Is_Boolean_Type); pragma Inline (Is_Controlled); + pragma Inline (Is_Entity_Name); pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Packed_Array); + pragma Inline (Is_String_Type); pragma Inline (Is_Subprogram_Or_Generic_Subprogram); pragma Inline (Is_Volatile); pragma Inline (Is_Wrapper_Package); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 972f6d58c4c..9faed933b9f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4125,25 +4125,6 @@ package body Exp_Aggr is -- Convert_To_Assignments -- ---------------------------- - function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is - P : Node_Id := Parent (N); - begin - while Nkind (P) = N_Qualified_Expression loop - P := Parent (P); - end loop; - - if Nkind (P) = N_Simple_Return_Statement then - null; - elsif Nkind (Parent (P)) = N_Extended_Return_Statement then - P := Parent (P); - else - return False; - end if; - - return Is_Build_In_Place_Function - (Return_Applies_To (Return_Statement_Entity (P))); - end Is_Build_In_Place_Aggregate_Return; - procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); T : Entity_Id; @@ -4176,8 +4157,9 @@ package body Exp_Aggr is Unc_Decl := not Is_Entity_Name (Object_Definition (Parent_Node)) or else (Nkind (N) = N_Aggregate - and then Has_Discriminants - (Entity (Object_Definition (Parent_Node)))) + and then + Has_Discriminants + (Entity (Object_Definition (Parent_Node)))) or else Is_Class_Wide_Type (Entity (Object_Definition (Parent_Node))); end if; @@ -6671,8 +6653,8 @@ package body Exp_Aggr is -- individual assignments to the given components. procedure Expand_N_Extension_Aggregate (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); A : constant Node_Id := Ancestor_Part (N); + Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); begin @@ -7476,6 +7458,33 @@ package body Exp_Aggr is return False; end Has_Default_Init_Comps; + ---------------------------------------- + -- Is_Build_In_Place_Aggregate_Return -- + ---------------------------------------- + + function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is + P : Node_Id := Parent (N); + + begin + while Nkind (P) = N_Qualified_Expression loop + P := Parent (P); + end loop; + + if Nkind (P) = N_Simple_Return_Statement then + null; + + elsif Nkind (Parent (P)) = N_Extended_Return_Statement then + P := Parent (P); + + else + return False; + end if; + + return + Is_Build_In_Place_Function + (Return_Applies_To (Return_Statement_Entity (P))); + end Is_Build_In_Place_Aggregate_Return; + -------------------------- -- Is_Delayed_Aggregate -- -------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 84a07db47c1..29e79dcead9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1712,7 +1712,8 @@ package body Exp_Ch3 is Set_Tag : Entity_Id := Empty; function Build_Assignment - (Id : Entity_Id; Default : Node_Id) return List_Id; + (Id : Entity_Id; + Default : Node_Id) return List_Id; -- Build an assignment statement that assigns the default expression to -- its corresponding record component if defined. The left-hand side of -- the assignment is marked Assignment_OK so that initialization of @@ -1785,10 +1786,11 @@ package body Exp_Ch3 is ---------------------- function Build_Assignment - (Id : Entity_Id; Default : Node_Id) return List_Id + (Id : Entity_Id; + Default : Node_Id) return List_Id is Default_Loc : constant Source_Ptr := Sloc (Default); - Typ : constant Entity_Id := Underlying_Type (Etype (Id)); + Typ : constant Entity_Id := Underlying_Type (Etype (Id)); Adj_Call : Node_Id; Exp : Node_Id := Default; @@ -1871,7 +1873,7 @@ package body Exp_Ch3 is if Kind = N_Attribute_Reference and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access, - Name_Unrestricted_Access) + Name_Unrestricted_Access) and then Is_Entity_Name (Prefix (Default)) and then Is_Type (Entity (Prefix (Default))) and then Entity (Prefix (Default)) = Rec_Type @@ -1915,9 +1917,8 @@ package body Exp_Ch3 is Expression => Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of - (Node - (First_Elmt - (Access_Disp_Table (Underlying_Type (Typ)))), + (Node (First_Elmt (Access_Disp_Table (Underlying_Type + (Typ)))), Default_Loc)))); end if; @@ -6328,7 +6329,7 @@ package body Exp_Ch3 is elsif Nkind (Expr_Q) = N_Reference and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q)) and then not Is_Expanded_Build_In_Place_Call - (Unqual_Conv (Prefix (Expr_Q))) + (Unqual_Conv (Prefix (Expr_Q))) then Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q)); @@ -6611,7 +6612,8 @@ package body Exp_Ch3 is -- allocated in place, delay checks until assignments are -- made, because the discriminants are not initialized. - if Nkind (Expr) = N_Allocator and then No_Initialization (Expr) + if Nkind (Expr) = N_Allocator + and then No_Initialization (Expr) then null; @@ -6649,9 +6651,9 @@ package body Exp_Ch3 is if Is_Build_In_Place_Result_Type (Typ) and then Nkind (Parent (N)) = N_Extended_Return_Statement - and then not Is_Definite_Subtype - (Etype (Return_Applies_To - (Return_Statement_Entity (Parent (N))))) + and then + not Is_Definite_Subtype (Etype (Return_Applies_To + (Return_Statement_Entity (Parent (N))))) then null; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0fe189b8a40..770341ce9eb 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5451,12 +5451,10 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (N); Actions : List_Id; - Cnn : Entity_Id; Decl : Node_Id; Expr : Node_Id; New_If : Node_Id; New_N : Node_Id; - Ptr_Typ : Entity_Id; begin -- Check for MINIMIZED/ELIMINATED overflow mode @@ -5560,65 +5558,66 @@ package body Exp_Ch4 is Process_If_Case_Statements (N, Then_Actions (N)); Process_If_Case_Statements (N, Else_Actions (N)); - -- Generate: - -- type Ann is access all Typ; - - Ptr_Typ := Make_Temporary (Loc, 'A'); - - Insert_Action (N, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); + declare + Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N); + Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + begin + -- Generate: + -- type Ann is access all Typ; - -- Generate: - -- Cnn : Ann; + Insert_Action (N, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); - Cnn := Make_Temporary (Loc, 'C', N); + -- Generate: + -- Cnn : Ann; - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Cnn, - Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); - -- Generate: - -- if Cond then - -- Cnn := 'Unrestricted_Access; - -- else - -- Cnn := 'Unrestricted_Access; - -- end if; + -- Generate: + -- if Cond then + -- Cnn := 'Unrestricted_Access; + -- else + -- Cnn := 'Unrestricted_Access; + -- end if; - New_If := - Make_Implicit_If_Statement (N, - Condition => Relocate_Node (Cond), - Then_Statements => New_List ( - Make_Assignment_Statement (Sloc (Thenx), - Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), - Expression => - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Thenx), - Attribute_Name => Name_Unrestricted_Access))), + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Thenx), + Attribute_Name => Name_Unrestricted_Access))), - Else_Statements => New_List ( - Make_Assignment_Statement (Sloc (Elsex), - Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), - Expression => - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Elsex), - Attribute_Name => Name_Unrestricted_Access)))); + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Elsex), + Attribute_Name => Name_Unrestricted_Access)))); - -- Preserve the original context for which the if statement is being - -- generated. This is needed by the finalization machinery to prevent - -- the premature finalization of controlled objects found within the - -- if statement. + -- Preserve the original context for which the if statement is + -- being generated. This is needed by the finalization machinery + -- to prevent the premature finalization of controlled objects + -- found within the if statement. - Set_From_Conditional_Expression (New_If); + Set_From_Conditional_Expression (New_If); - New_N := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Cnn, Loc)); + New_N := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Cnn, Loc)); + end; -- If the result is an unconstrained array and the if expression is in a -- context other than the initializing expression of the declaration of @@ -5677,31 +5676,33 @@ package body Exp_Ch4 is -- and replace the if expression by a reference to Cnn - Cnn := Make_Temporary (Loc, 'C', N); - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Cnn, - Object_Definition => New_Occurrence_Of (Typ, Loc)); + declare + Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Typ, Loc)); - New_If := - Make_Implicit_If_Statement (N, - Condition => Relocate_Node (Cond), + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), - Then_Statements => New_List ( - Make_Assignment_Statement (Sloc (Thenx), - Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), - Expression => Relocate_Node (Thenx))), + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => Relocate_Node (Thenx))), - Else_Statements => New_List ( - Make_Assignment_Statement (Sloc (Elsex), - Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), - Expression => Relocate_Node (Elsex)))); + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => Relocate_Node (Elsex)))); - Set_Assignment_OK (Name (First (Then_Statements (New_If)))); - Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + Set_Assignment_OK (Name (First (Then_Statements (New_If)))); + Set_Assignment_OK (Name (First (Else_Statements (New_If)))); - New_N := New_Occurrence_Of (Cnn, Loc); + New_N := New_Occurrence_Of (Cnn, Loc); + end; -- Regular path using Expression_With_Actions diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index d7587eb7aec..9d2f652f119 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -175,15 +175,16 @@ package body Exp_Ch5 is Advance : out Node_Id; New_Loop : out Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Stats : constant List_Id := Statements (N); - Typ : constant Entity_Id := Base_Type (Etype (Container)); + Loc : constant Source_Ptr := Sloc (N); + Stats : constant List_Id := Statements (N); + Typ : constant Entity_Id := Base_Type (Etype (Container)); + + Has_Element_Op : constant Entity_Id := + Get_Iterable_Type_Primitive (Typ, Name_Has_Element); First_Op : Entity_Id; Next_Op : Entity_Id; - Has_Element_Op : constant Entity_Id := - Get_Iterable_Type_Primitive (Typ, Name_Has_Element); begin -- Use the proper set of primitives depending on the direction of -- iteration. The legality of a reverse iteration has been checked @@ -196,7 +197,6 @@ package body Exp_Ch5 is else First_Op := Get_Iterable_Type_Primitive (Typ, Name_First); Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Next); - null; end if; -- Declaration for Cursor diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1b648ff6ad4..6c27741d37c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2251,10 +2251,12 @@ package body Exp_Ch6 is procedure Expand_Call (N : Node_Id) is Post_Call : List_Id; + begin - pragma Assert - (Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement, - N_Entry_Call_Statement)); + pragma Assert (Nkind_In (N, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement)); + Expand_Call_Helper (N, Post_Call); Insert_Post_Call_Actions (N, Post_Call); end Expand_Call; @@ -4333,8 +4335,8 @@ package body Exp_Ch6 is if not Is_Build_In_Place_Function_Call (Call_Node) and then (No (First_Formal (Subp)) - or else - not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) + or else + not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) then Expand_Ctrl_Function_Call (Call_Node); @@ -4343,15 +4345,14 @@ package body Exp_Ch6 is -- intermediate result after its use. elsif Is_Build_In_Place_Function_Call (Call_Node) - and then - Nkind_In (Parent (Unqual_Conv (Call_Node)), - N_Attribute_Reference, - N_Function_Call, - N_Indexed_Component, - N_Object_Renaming_Declaration, - N_Procedure_Call_Statement, - N_Selected_Component, - N_Slice) + and then Nkind_In (Parent (Unqual_Conv (Call_Node)), + N_Attribute_Reference, + N_Function_Call, + N_Indexed_Component, + N_Object_Renaming_Declaration, + N_Procedure_Call_Statement, + N_Selected_Component, + N_Slice) then Establish_Transient_Scope (Call_Node, Sec_Stack => True); end if; @@ -6447,8 +6448,8 @@ package body Exp_Ch6 is pragma Assert (Comes_From_Extended_Return_Statement (N) - or else not Is_Build_In_Place_Function_Call (Exp) - or else Is_Build_In_Place_Function (Scope_Id)); + or else not Is_Build_In_Place_Function_Call (Exp) + or else Is_Build_In_Place_Function (Scope_Id)); if not Comes_From_Extended_Return_Statement (N) and then Is_Build_In_Place_Function (Scope_Id) @@ -7325,11 +7326,7 @@ package body Exp_Ch6 is raise Program_Error; end if; - declare - Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); - begin - return Result; - end; + return Is_Build_In_Place_Function (Function_Id); end Is_Build_In_Place_Function_Call; ----------------------- @@ -7765,7 +7762,7 @@ package body Exp_Ch6 is Return_Obj_Access := Make_Temporary (Loc, 'R'); Set_Etype (Return_Obj_Access, Acc_Type); Set_Can_Never_Be_Null (Acc_Type, False); - -- It gets initialized to null, so we can't have that. + -- It gets initialized to null, so we can't have that -- When the result subtype is constrained, the return object is -- allocated on the caller side, and access to it is passed to the @@ -8101,10 +8098,10 @@ package body Exp_Ch6 is (Assign : Node_Id; Function_Call : Node_Id) is - Lhs : constant Node_Id := Name (Assign); - Func_Call : constant Node_Id := Unqual_Conv (Function_Call); - Func_Id : Entity_Id; + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); + Lhs : constant Node_Id := Name (Assign); Loc : constant Source_Ptr := Sloc (Function_Call); + Func_Id : Entity_Id; Obj_Decl : Node_Id; Obj_Id : Entity_Id; Ptr_Typ : Entity_Id; @@ -8178,8 +8175,9 @@ package body Exp_Ch6 is -- Add a conversion if it's the wrong type if Etype (New_Expr) /= Ptr_Typ then - New_Expr := Make_Unchecked_Type_Conversion (Loc, - New_Occurrence_Of (Ptr_Typ, Loc), New_Expr); + New_Expr := + Make_Unchecked_Type_Conversion (Loc, + New_Occurrence_Of (Ptr_Typ, Loc), New_Expr); end if; Obj_Id := Make_Temporary (Loc, 'R', New_Expr); @@ -8207,6 +8205,10 @@ package body Exp_Ch6 is function Get_Function_Id (Func_Call : Node_Id) return Entity_Id; -- Get the value of Function_Id, below + --------------------- + -- Get_Function_Id -- + --------------------- + function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is begin if Is_Entity_Name (Name (Func_Call)) then @@ -8220,22 +8222,23 @@ package body Exp_Ch6 is end if; end Get_Function_Id; - Func_Call : constant Node_Id := Unqual_Conv (Function_Call); - Function_Id : constant Entity_Id := Get_Function_Id (Func_Call); - Result_Subt : constant Entity_Id := Etype (Function_Id); + -- Local variables - Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); - Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id); - Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); - Loc : constant Source_Ptr := Sloc (Function_Call); - Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); + Function_Id : constant Entity_Id := Get_Function_Id (Func_Call); + Loc : constant Source_Ptr := Sloc (Function_Call); + Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); + Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); + Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id); + Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); + Result_Subt : constant Entity_Id := Etype (Function_Id); Call_Deref : Node_Id; Caller_Object : Node_Id; Def_Id : Entity_Id; + Designated_Type : Entity_Id; Fmaster_Actual : Node_Id := Empty; Pool_Actual : Node_Id; - Designated_Type : Entity_Id; Ptr_Typ : Entity_Id; Ptr_Typ_Decl : Node_Id; Pass_Caller_Acc : Boolean := False; @@ -8243,7 +8246,7 @@ package body Exp_Ch6 is Definite : constant Boolean := Caller_Known_Size (Func_Call, Result_Subt) - and then not Is_Class_Wide_Type (Obj_Typ); + and then not Is_Class_Wide_Type (Obj_Typ); -- In the case of "X : T'Class := F(...);", where F returns a -- Caller_Known_Size (specific) tagged type, we treat it as -- indefinite, because the code for the Definite case below sets the @@ -8300,9 +8303,7 @@ package body Exp_Ch6 is -- the result object is in a different (transient) scope, so won't cause -- freezing. - if Definite - and then not Is_Return_Object (Obj_Def_Id) - then + if Definite and then not Is_Return_Object (Obj_Def_Id) then Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); else Insert_Action (Obj_Decl, Ptr_Typ_Decl); @@ -8330,8 +8331,8 @@ package body Exp_Ch6 is Pass_Caller_Acc := True; -- When the enclosing function has a BIP_Alloc_Form formal then we - -- pass it along to the callee (such as when the enclosing - -- function has an unconstrained or tagged result type). + -- pass it along to the callee (such as when the enclosing function + -- has an unconstrained or tagged result type). if Needs_BIP_Alloc_Form (Encl_Func) then if RTE_Available (RE_Root_Storage_Pool_Ptr) then @@ -8376,9 +8377,8 @@ package body Exp_Ch6 is Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of - (Etype - (Build_In_Place_Formal - (Function_Id, BIP_Object_Access)), + (Etype (Build_In_Place_Formal + (Function_Id, BIP_Object_Access)), Loc), Expression => New_Occurrence_Of @@ -8487,8 +8487,8 @@ package body Exp_Ch6 is Set_Etype (Def_Id, Ptr_Typ); Set_Is_Known_Non_Null (Def_Id); - if Nkind_In - (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion) + if Nkind_In (Function_Call, N_Type_Conversion, + N_Unchecked_Type_Conversion) then Res_Decl := Make_Object_Declaration (Loc, @@ -8496,9 +8496,9 @@ package body Exp_Ch6 is Constant_Present => True, Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), Expression => - Make_Unchecked_Type_Conversion (Loc, - New_Occurrence_Of (Ptr_Typ, Loc), - Make_Reference (Loc, Relocate_Node (Func_Call)))); + Make_Unchecked_Type_Conversion (Loc, + New_Occurrence_Of (Ptr_Typ, Loc), + Make_Reference (Loc, Relocate_Node (Func_Call)))); else Res_Decl := Make_Object_Declaration (Loc, @@ -8515,9 +8515,8 @@ package body Exp_Ch6 is -- itself the return expression of an enclosing BIP function, then mark -- the object as having no initialization. - if Definite - and then not Is_Return_Object (Obj_Def_Id) - then + if Definite and then not Is_Return_Object (Obj_Def_Id) then + -- The related object declaration is encased in a transient block -- because the build-in-place function call contains at least one -- nested function call that produces a controlled transient @@ -8552,9 +8551,9 @@ package body Exp_Ch6 is Rewrite (Obj_Decl, Make_Object_Renaming_Declaration (Obj_Loc, Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), - Subtype_Mark => + Subtype_Mark => New_Occurrence_Of (Designated_Type, Obj_Loc), - Name => Call_Deref)); + Name => Call_Deref)); -- At this point, Defining_Identifier (Obj_Decl) is no longer equal -- to Obj_Def_Id. @@ -9261,7 +9260,7 @@ package body Exp_Ch6 is then On_Object_Declaration := True; return - Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr)))); + 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. @@ -9294,7 +9293,9 @@ package body Exp_Ch6 is begin if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then - -- Can happen for X'Elab_Spec in the binder-generated file. + + -- Can happen for X'Elab_Spec in the binder-generated file + return Empty; end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 6fa8d211919..b1ab606f055 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -651,9 +651,8 @@ package body Exp_Util is -- stack. elsif Is_RTE (Pool_Id, RE_SS_Pool) - or else - (Nkind (Expr) = N_Allocator - and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool)) + or else (Nkind (Expr) = N_Allocator + and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool)) then return; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index b2bd32c6b82..677d59999dd 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3019,17 +3019,20 @@ package body Sem_Aggr is return False; end Valid_Ancestor_Type; + ------------------------------ + -- Transform_BIP_Assignment -- + ------------------------------ + procedure Transform_BIP_Assignment (Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A); - Obj_Decl : constant Node_Id := - Make_Object_Declaration - (Loc, - Defining_Identifier => Def_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => A, - Has_Init_Expression => True); + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => A, + Has_Init_Expression => True); begin Set_Etype (Def_Id, Typ); Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 701aa088ae9..564ff0dfc0a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -13193,17 +13193,16 @@ package body Sem_Ch13 is or else No (First_Formal (Entity (N))) or else Etype (First_Formal (Entity (N))) /= Typ then - Error_Msg_N ("iterable primitive must be local function name " - & "whose first formal is an iterable type", N); + Error_Msg_N + ("iterable primitive must be local function name whose first " + & "formal is an iterable type", N); return; end if; Ent := Entity (N); - F1 := First_Formal (Ent); + F1 := First_Formal (Ent); - if Nam = Name_First - or else Nam = Name_Last - then + if Nam = Name_First or else Nam = Name_Last then -- First or Last (Container) => Cursor @@ -13242,6 +13241,7 @@ package body Sem_Ch13 is -- Has_Element (Container, Cursor) => Boolean F2 := Next_Formal (F1); + if Etype (F2) /= Cursor or else Etype (Ent) /= Standard_Boolean or else Present (Next_Formal (F2)) @@ -13258,15 +13258,14 @@ package body Sem_Ch13 is then Error_Msg_N ("no match for Element iterable primitive", N); end if; - null; else raise Program_Error; end if; else - -- Overloaded case: find subprogram with proper signature. - -- Caller will report error if no match is found. + -- Overloaded case: find subprogram with proper signature. Caller + -- will report error if no match is found. declare I : Interp_Index; @@ -14108,10 +14107,8 @@ package body Sem_Ch13 is elsif No (Has_Element_Id) then Error_Msg_N ("match for Has_Element primitive not found", ASN); - elsif No (Element_Id) - or else No (Last_Id) - then - null; -- Optional. + elsif No (Element_Id) or else No (Last_Id) then + null; -- optional end if; end Validate_Iterable_Aspect; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index dd0ff2a9b02..c163aab8e78 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10255,10 +10255,11 @@ package body Sem_Ch3 is Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); if Has_Discrs - and then not Is_Empty_Elmt_List (Elist) - and then not For_Access + and then not Is_Empty_Elmt_List (Elist) + and then not For_Access then Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); + elsif not For_Access then Set_Cloned_Subtype (Def_Id, T); end if; @@ -10288,11 +10289,10 @@ package body Sem_Ch3 is -- Add_Global_Declaration in this case. This can happen if we have a -- build-in-place library function. - if (Nkind (Nod) in N_Entity - and then Is_Compilation_Unit (Nod)) + if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod)) or else (Nkind (Nod) = N_Defining_Program_Unit_Name - and then Is_Compilation_Unit (Defining_Identifier (Nod))) + and then Is_Compilation_Unit (Defining_Identifier (Nod))) then Add_Global_Declaration (IR); else @@ -11828,14 +11828,14 @@ package body Sem_Ch3 is else Error_Msg_N - ("illegal context for call" - & " to function with limited result", Exp); + ("illegal context for call to function with limited " + & "result", Exp); end if; else Error_Msg_N - ("initialization of limited object requires aggregate " - & "or function call", Exp); + ("initialization of limited object requires aggregate or " + & "function call", Exp); end if; end if; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b06bff77cff..8c92669876c 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -141,72 +141,6 @@ package body Sem_Ch5 is -- assignment statements that are really initializations. These are -- marked No_Ctrl_Actions. - function Should_Transform_BIP_Assignment - (Typ : Entity_Id) return Boolean - is - Result : Boolean; - begin - if Expander_Active - and then not Is_Limited_View (Typ) - and then Is_Build_In_Place_Result_Type (Typ) - and then not No_Ctrl_Actions (N) - then - -- This function is called early, before name resolution is - -- complete, so we have to deal with things that might turn into - -- function calls later. N_Function_Call and N_Op nodes are the - -- obvious case. An N_Identifier or N_Expanded_Name is a - -- parameterless function call if it denotes a function. - -- Finally, an attribute reference can be a function call. - - case Nkind (Unqual_Conv (Rhs)) is - when N_Function_Call | N_Op => - Result := True; - when N_Identifier | N_Expanded_Name => - case Ekind (Entity (Unqual_Conv (Rhs))) is - when E_Function | E_Operator => - Result := True; - when others => - Result := False; - end case; - when N_Attribute_Reference => - Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input; - -- T'Input will turn into a call whose result type is T - when others => - Result := False; - end case; - else - Result := False; - end if; - return Result; - end Should_Transform_BIP_Assignment; - - procedure Transform_BIP_Assignment (Typ : Entity_Id) is - -- Tranform "X : [constant] T := F (...);" into: - -- - -- Temp : constant T := F (...); - -- X := Temp; - - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); - Obj_Decl : constant Node_Id := - Make_Object_Declaration - (Loc, - Defining_Identifier => Def_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Rhs, - Has_Init_Expression => True); - begin - Set_Etype (Def_Id, Typ); - Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); - - -- At this point, Rhs is no longer equal to Expression (N), so: - - Rhs := Expression (N); - - Insert_Action (N, Obj_Decl); - end Transform_BIP_Assignment; - ------------------------------- -- Diagnose_Non_Variable_Lhs -- ------------------------------- @@ -314,6 +248,7 @@ package body Sem_Ch5 is Opnd_Type : in out Entity_Id) is Decl : Node_Id; + begin Require_Entity (Opnd); @@ -331,9 +266,9 @@ package body Sem_Ch5 is or else (Ekind (Entity (Opnd)) = E_Variable and then Nkind (Parent (Entity (Opnd))) = - N_Object_Renaming_Declaration + N_Object_Renaming_Declaration and then Nkind (Parent (Parent (Entity (Opnd)))) = - N_Accept_Statement)) + N_Accept_Statement)) then Opnd_Type := Get_Actual_Subtype (Opnd); @@ -364,6 +299,93 @@ package body Sem_Ch5 is end if; end Set_Assignment_Type; + ------------------------------------- + -- Should_Transform_BIP_Assignment -- + ------------------------------------- + + function Should_Transform_BIP_Assignment + (Typ : Entity_Id) return Boolean + is + Result : Boolean; + + begin + if Expander_Active + and then not Is_Limited_View (Typ) + and then Is_Build_In_Place_Result_Type (Typ) + and then not No_Ctrl_Actions (N) + then + -- This function is called early, before name resolution is + -- complete, so we have to deal with things that might turn into + -- function calls later. N_Function_Call and N_Op nodes are the + -- obvious case. An N_Identifier or N_Expanded_Name is a + -- parameterless function call if it denotes a function. + -- Finally, an attribute reference can be a function call. + + case Nkind (Unqual_Conv (Rhs)) is + when N_Function_Call + | N_Op + => + Result := True; + + when N_Expanded_Name + | N_Identifier + => + case Ekind (Entity (Unqual_Conv (Rhs))) is + when E_Function + | E_Operator + => + Result := True; + + when others => + Result := False; + end case; + + when N_Attribute_Reference => + Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input; + -- T'Input will turn into a call whose result type is T + + when others => + Result := False; + end case; + else + Result := False; + end if; + + return Result; + end Should_Transform_BIP_Assignment; + + ------------------------------ + -- Transform_BIP_Assignment -- + ------------------------------ + + procedure Transform_BIP_Assignment (Typ : Entity_Id) is + + -- Tranform "X : [constant] T := F (...);" into: + -- + -- Temp : constant T := F (...); + -- X := Temp; + + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Rhs, + Has_Init_Expression => True); + + begin + Set_Etype (Def_Id, Typ); + Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); + + -- At this point, Rhs is no longer equal to Expression (N), so: + + Rhs := Expression (N); + + Insert_Action (N, Obj_Decl); + end Transform_BIP_Assignment; + -- Local variables T1 : Entity_Id; @@ -524,13 +546,14 @@ package body Sem_Ch5 is end if; end if; - -- Deal with build-in-place calls for nonlimited types. - -- We don't do this later, because resolving the rhs - -- tranforms it incorrectly for build-in-place. + -- Deal with build-in-place calls for nonlimited types. We don't do this + -- later, because resolving the rhs tranforms it incorrectly for build- + -- in-place. if Should_Transform_BIP_Assignment (Typ => T1) then Transform_BIP_Assignment (Typ => T1); end if; + pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); -- The resulting assignment type is T1, so now we will resolve the left @@ -538,8 +561,6 @@ package body Sem_Ch5 is Resolve (Lhs, T1); - -- Cases where Lhs is not a variable - -- Cases where Lhs is not a variable. In an instance or an inlined body -- no need for further check because assignment was legal in template. @@ -1941,8 +1962,9 @@ package body Sem_Ch5 is if Is_Array_Type (Typ) or else Is_Reversible_Iterator (Typ) or else - (Present (Find_Aspect (Typ, Aspect_Iterable)) - and then Present + (Present (Find_Aspect (Typ, Aspect_Iterable)) + and then + Present (Get_Iterable_Type_Primitive (Typ, Name_Previous))) then null; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index f9a590095a0..dc00cf9f249 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -281,14 +281,6 @@ package body Sem_Ch7 is -- If we haven't already traversed Node, then mark it and traverse -- it. - procedure Scan_Subprogram_Refs (Node : Node_Id) is - begin - if not Traversed_Table.Get (Node) then - Traversed_Table.Set (Node, True); - Traverse_And_Scan_Subprogram_Refs (Node); - end if; - end Scan_Subprogram_Refs; - -------------------- -- Has_Referencer -- -------------------- @@ -533,6 +525,18 @@ package body Sem_Ch7 is return OK; end Scan_Subprogram_Ref; + -------------------------- + -- Scan_Subprogram_Refs -- + -------------------------- + + procedure Scan_Subprogram_Refs (Node : Node_Id) is + begin + if not Traversed_Table.Get (Node) then + Traversed_Table.Set (Node, True); + Traverse_And_Scan_Subprogram_Refs (Node); + end if; + end Scan_Subprogram_Refs; + -- Local variables Discard : Boolean; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3ef0b7b066d..68c1a0892a6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4834,10 +4834,18 @@ package body Sem_Res is -- are explicitly marked as coming from source but do not need to be -- checked for limited initialization. To exclude this case, ensure -- that the parent of the allocator is a source node. + -- The return statement constructed for an Expression_Function does + -- not come from source but requires a limited check. if Is_Limited_Type (Etype (E)) and then Comes_From_Source (N) - and then Comes_From_Source (Parent (N)) + and then + (Comes_From_Source (Parent (N)) + or else + (Ekind (Current_Scope) = E_Function + and then Nkind + (Original_Node (Unit_Declaration_Node (Current_Scope))) + = N_Expression_Function)) and then not In_Instance_Body then if not OK_For_Limited_Init (Etype (E), Expression (E)) then diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index c70d892bf0b..05315852511 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -761,15 +761,19 @@ package body Sem_Type is function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is begin - return - Is_Private_Type (Typ1) - and then - ((Present (Full_View (Typ1)) - and then Covers (Full_View (Typ1), Typ2)) - or else (Present (Underlying_Full_View (Typ1)) - and then Covers (Underlying_Full_View (Typ1), Typ2)) - or else Base_Type (Typ1) = Typ2 - or else Base_Type (Typ2) = Typ1); + if Present (Full_View (Typ1)) + and then Covers (Full_View (Typ1), Typ2) + then + return True; + + elsif Present (Underlying_Full_View (Typ1)) + and then Covers (Underlying_Full_View (Typ1), Typ2) + then + return True; + + else + return False; + end if; end Full_View_Covers; ----------------- @@ -825,7 +829,7 @@ package body Sem_Type is -- Standard_Void_Type is a special entity that has some, but not all, -- properties of types. - if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then + if T1 = Standard_Void_Type or else T2 = Standard_Void_Type then return False; end if; @@ -892,8 +896,8 @@ package body Sem_Type is or else (T2 = Universal_Real and then Is_Real_Type (T1)) or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1)) or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1)) - or else (T2 = Any_String and then Is_String_Type (T1)) or else (T2 = Any_Character and then Is_Character_Type (T1)) + or else (T2 = Any_String and then Is_String_Type (T1)) or else (T2 = Any_Access and then Is_Access_Type (T1)) then return True; @@ -916,9 +920,9 @@ package body Sem_Type is -- task_type or protected_type that implements the interface. elsif Ada_Version >= Ada_2005 + and then Is_Concurrent_Type (T2) and then Is_Class_Wide_Type (T1) and then Is_Interface (Etype (T1)) - and then Is_Concurrent_Type (T2) and then Interface_Present_In_Ancestor (Typ => BT2, Iface => Etype (T1)) then @@ -928,9 +932,9 @@ package body Sem_Type is -- object T2 implementing T1. elsif Ada_Version >= Ada_2005 + and then Is_Tagged_Type (T2) and then Is_Class_Wide_Type (T1) and then Is_Interface (Etype (T1)) - and then Is_Tagged_Type (T2) then if Interface_Present_In_Ancestor (Typ => T2, Iface => Etype (T1)) @@ -1183,19 +1187,16 @@ package body Sem_Type is -- whether a partial and a full view match. Verify that types are -- legal, to prevent cascaded errors. - elsif In_Instance - and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1)) - then - return True; - - elsif Is_Type (T2) - and then Is_Generic_Actual_Type (T2) + elsif Is_Private_Type (T1) + and then (In_Instance + or else (Is_Type (T2) and then Is_Generic_Actual_Type (T2))) and then Full_View_Covers (T1, T2) then return True; - elsif Is_Type (T1) - and then Is_Generic_Actual_Type (T1) + elsif Is_Private_Type (T2) + and then (In_Instance + or else (Is_Type (T1) and then Is_Generic_Actual_Type (T1))) and then Full_View_Covers (T2, T1) then return True; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2e64e826301..f003ef5a8ac 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7929,13 +7929,21 @@ package body Sem_Util is -- Special cases - -- Blocks, loops, and return statements have artificial scopes + -- Blocks carry either a source or an internally-generated scope, + -- unless the block is a byproduct of exception handling. - when N_Block_Statement - | N_Loop_Statement - => + when N_Block_Statement => + if not Exception_Junk (Par) then + return Entity (Identifier (Par)); + end if; + + -- Loops carry an internally-generated scope + + when N_Loop_Statement => return Entity (Identifier (Par)); + -- Extended return statements carry an internally-generated scope + when N_Extended_Return_Statement => return Return_Statement_Entity (Par); @@ -19511,13 +19519,13 @@ package body Sem_Util is N := Next (Actual_Id); if Nkind (N) = N_Parameter_Association then + -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. - if Nkind_In (Parent (Actual_Id), - N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) then return First_Named_Actual (Parent (Actual_Id)); else @@ -23257,16 +23265,15 @@ package body Sem_Util is return "unknown subprogram"; end if; - if Nkind (Ent) = N_Defining_Program_Unit_Name then - - -- If the subprogram is a child unit, use its simple name to - -- start the construction of the fully qualified name. + -- If the subprogram is a child unit, use its simple name to start the + -- construction of the fully qualified name. + if Nkind (Ent) = N_Defining_Program_Unit_Name then Append_Entity_Name (Buf, Defining_Identifier (Ent)); - else Append_Entity_Name (Buf, Ent); end if; + return +Buf; end Subprogram_Name; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 05ac1a30859..247d127982d 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -13009,7 +13009,7 @@ package Sinfo is 5 => False), -- SCIL_Tag_Value (Node5-Sem) N_Call_Marker => - (1 => True, -- Target (Node1-Sem) + (1 => False, -- Target (Node1-Sem) 2 => False, -- unused 3 => False, -- unused 4 => False, -- unused -- 2.30.2