From 0691ed6bd62582c22a33c42aa8f5303815a032af Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 7 Sep 2017 11:33:27 +0200 Subject: [PATCH] [multiple changes] 2017-09-07 Ed Schonberg * par-ch6.adb (P_Subprogram): Improve error message on null procedure with misplaced aspect specification, which the parser first attempts to interpret as a malformed expression function. 2017-09-07 Gary Dismukes * sem_attr.adb (Analyze_Attribute_Old_Result): Allow attributes Result and Old in the case of an expression function. 2017-09-07 Justin Squirek * sem_prag.adb (Process_Atomic_Independent_Shared_Volatile): Propagate Volatile to subcomponents. 2017-09-07 Bob Duff * exp_ch7.adb (Find_Last_Init): Check for the case where a build-in-place function call has been replaced by a 'Reference attribute reference. 2017-09-07 Eric Botcazou * sem_ch7.adb (Has_Referencer): Recurse on Actions of freeze nodes. 2017-09-07 Bob Duff * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration, Make_Build_In_Place_Call_In_Anonymous_Context): Do not use the secondary stack for all functions that return limited tagged types -- just do it for dispatching calls. Misc cleanup. * sem_util.ads, sem_util.adb (Unqual_Conv): New function to remove qualifications and type conversions. Fix various bugs where only a single level of qualification or conversion was removed, so e.g. "T1'(T2'(X))" would incorrectly return "T2'(X)" instead of "X". * checks.adb, exp_util.ads, exp_util.adb, sem_res.adb: Misc related cleanup. 2017-09-07 Ed Schonberg * sem_ch6.adb (setr_Actual_Subtypes): Within a predicate function do not create actual subtypes that may generate further predicate functions. * sem_ch13.adb (Build_Predicate_Functions): Indicate that entity of body is a predicate function as well. (Resolve_Aspect_Expressions, Resolve_Name): For a component association, only the expression needs resolution, not the name. (Resolve_Aspect_Expressions, case Predicates): Construct and analyze the predicate function declaration in the scope of the type, before making the type and its discriminants visible. From-SVN: r251835 --- gcc/ada/ChangeLog | 55 +++++ gcc/ada/exp_ch6.adb | 663 ++++++++++++++++++++++++--------------------------- gcc/ada/exp_ch7.adb | 25 +- gcc/ada/exp_util.adb | 79 +----- gcc/ada/exp_util.ads | 6 - gcc/ada/par-ch6.adb | 29 ++- gcc/ada/sem_attr.adb | 1 + gcc/ada/sem_ch13.adb | 17 +- gcc/ada/sem_ch6.adb | 6 + gcc/ada/sem_ch7.adb | 14 +- gcc/ada/sem_prag.adb | 18 ++ gcc/ada/sem_util.adb | 36 ++- gcc/ada/sem_util.ads | 5 + 13 files changed, 492 insertions(+), 462 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5f7b1bc..7ab4ed4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,58 @@ +2017-09-07 Ed Schonberg + + * par-ch6.adb (P_Subprogram): Improve error message on null + procedure with misplaced aspect specification, which the parser + first attempts to interpret as a malformed expression function. + +2017-09-07 Gary Dismukes + + * sem_attr.adb (Analyze_Attribute_Old_Result): + Allow attributes Result and Old in the case of an expression + function. + +2017-09-07 Justin Squirek + + * sem_prag.adb (Process_Atomic_Independent_Shared_Volatile): Propagate + Volatile to subcomponents. + +2017-09-07 Bob Duff + + * exp_ch7.adb (Find_Last_Init): Check for the + case where a build-in-place function call has been replaced by a + 'Reference attribute reference. + +2017-09-07 Eric Botcazou + + * sem_ch7.adb (Has_Referencer): Recurse on Actions of freeze + nodes. + +2017-09-07 Bob Duff + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration, + Make_Build_In_Place_Call_In_Anonymous_Context): Do not use the + secondary stack for all functions that return limited tagged + types -- just do it for dispatching calls. Misc cleanup. + * sem_util.ads, sem_util.adb (Unqual_Conv): New function to + remove qualifications and type conversions. Fix various bugs + where only a single level of qualification or conversion was + removed, so e.g. "T1'(T2'(X))" would incorrectly return "T2'(X)" + instead of "X". + * checks.adb, exp_util.ads, exp_util.adb, sem_res.adb: Misc related + cleanup. + +2017-09-07 Ed Schonberg + + * sem_ch6.adb (setr_Actual_Subtypes): Within a predicate function + do not create actual subtypes that may generate further predicate + functions. + * sem_ch13.adb (Build_Predicate_Functions): Indicate that entity + of body is a predicate function as well. + (Resolve_Aspect_Expressions, Resolve_Name): For a component + association, only the expression needs resolution, not the name. + (Resolve_Aspect_Expressions, case Predicates): Construct and + analyze the predicate function declaration in the scope of the + type, before making the type and its discriminants visible. + 2017-09-06 Eric Botcazou * gcc-interface/decl.c (warn_on_field_placement): Issue the warning diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d4f9475..39b11f8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -136,6 +136,14 @@ package body Exp_Ch6 is -- the activation Chain. Note: Master_Actual can be Empty, but only if -- there are no tasks. + function Caller_Known_Size + (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; + -- True if result subtype is definite, or has a size that does not require + -- secondary stack usage (i.e. no variant part or components whose type + -- depends on discriminants). In particular, untagged types with only + -- access discriminants do not require secondary stack use. Note we must + -- always use the secondary stack for dispatching-on-result calls. + procedure Check_Overriding_Operation (Subp : Entity_Id); -- Subp is a dispatching operation. Check whether it may override an -- inherited private operation, in which case its DT entry is that of @@ -824,6 +832,18 @@ package body Exp_Ch6 is return New_Body; end Build_Procedure_Body_Form; + ----------------------- + -- Caller_Known_Size -- + ----------------------- + + function Caller_Known_Size + (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean is + begin + return (Is_Definite_Subtype (Underlying_Type (Result_Subt)) + and then No (Controlling_Argument (Func_Call))) + or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); + end Caller_Known_Size; + -------------------------------- -- Check_Overriding_Operation -- -------------------------------- @@ -1631,22 +1651,10 @@ package body Exp_Ch6 is Expr : Node_Id; Obj : Node_Id; Obj_Typ : Entity_Id; - Var : Node_Id; + Var : constant Node_Id := Unqual_Conv (Act); Var_Id : Entity_Id; begin - Var := Act; - - -- Use the expression when the context qualifies a reference in some - -- fashion. - - while Nkind_In (Var, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) - loop - Var := Expression (Var); - end loop; - -- Copy the value of the validation variable back into the object -- being validated. @@ -6796,12 +6804,7 @@ package body Exp_Ch6 is Discrim_Source := Original_Node (Discrim_Source); end if; - while Nkind_In (Discrim_Source, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) - loop - Discrim_Source := Expression (Discrim_Source); - end loop; + Discrim_Source := Unqual_Conv (Discrim_Source); case Nkind (Discrim_Source) is when N_Defining_Identifier => @@ -7099,7 +7102,7 @@ package body Exp_Ch6 is ------------------------------------- function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is - Exp_Node : Node_Id := N; + Exp_Node : constant Node_Id := Unqual_Conv (N); Function_Id : Entity_Id; begin @@ -7119,17 +7122,6 @@ package body Exp_Ch6 is return False; end if; - -- Step past qualification, type conversion (which can occur in actual - -- parameter contexts), and unchecked conversion (which can occur in - -- cases of calls to 'Input). - - if Nkind_In (Exp_Node, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - Exp_Node := Expression (N); - end if; - if Nkind (Exp_Node) /= N_Function_Call then return False; @@ -7771,32 +7763,13 @@ package body Exp_Ch6 is (Function_Call : Node_Id) is Loc : Source_Ptr; - Func_Call : Node_Id := Function_Call; + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Function_Id : Entity_Id; Result_Subt : Entity_Id; Return_Obj_Id : Entity_Id; Return_Obj_Decl : Entity_Id; - Definite : Boolean; - -- True if result subtype is definite, or has a size that does not - -- require secondary stack usage (i.e. no variant part or components - -- whose type depends on discriminants). In particular, untagged types - -- with only access discriminants do not require secondary stack use. - -- Note that if the return type is tagged we must always use the sec. - -- stack because the call may dispatch on result. - begin - -- Step past qualification, type conversion (which can occur in actual - -- parameter contexts), and unchecked conversion (which can occur in - -- cases of calls to 'Input). - - if Nkind_In (Func_Call, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - Func_Call := Expression (Func_Call); - end if; - -- If the call has already been processed to add build-in-place actuals -- then return. One place this can occur is for calls to build-in-place -- functions that occur within a call to a protected operation, where @@ -7824,10 +7797,6 @@ package body Exp_Ch6 is end if; Result_Subt := Etype (Function_Id); - Definite := - (Is_Definite_Subtype (Underlying_Type (Result_Subt)) - and then not Is_Tagged_Type (Result_Subt)) - or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); -- If the build-in-place function returns a controlled object, then the -- object needs to be finalized immediately after the context. Since @@ -7869,7 +7838,7 @@ package body Exp_Ch6 is -- When the result subtype is definite, an object of the subtype is -- declared and an access value designating it is passed as an actual. - elsif Definite then + elsif Caller_Known_Size (Func_Call, Result_Subt) then -- Create a temporary object to hold the function result @@ -7942,7 +7911,7 @@ package body Exp_Ch6 is Function_Call : Node_Id) is Lhs : constant Node_Id := Name (Assign); - Func_Call : Node_Id := Function_Call; + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Func_Id : Entity_Id; Loc : Source_Ptr; Obj_Decl : Node_Id; @@ -7954,15 +7923,6 @@ package body Exp_Ch6 is Target : Node_Id; begin - -- Step past qualification or unchecked conversion (the latter can occur - -- in cases of calls to 'Input). - - if Nkind_In (Func_Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Func_Call := Expression (Func_Call); - end if; - -- If the call has already been processed to add build-in-place actuals -- then return. This should not normally occur in an assignment context, -- but we add the protection as a defensive measure. @@ -8085,7 +8045,7 @@ package body Exp_Ch6 is Caller_Object : Node_Id; Def_Id : Entity_Id; Fmaster_Actual : Node_Id := Empty; - Func_Call : Node_Id := Function_Call; + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Function_Id : Entity_Id; Pool_Actual : Node_Id; Ptr_Typ : Entity_Id; @@ -8094,24 +8054,7 @@ package body Exp_Ch6 is Res_Decl : Node_Id; Result_Subt : Entity_Id; - Definite : Boolean; - -- True if result subtype is definite, or has a size that does not - -- require secondary stack usage (i.e. no variant part or components - -- whose type depends on discriminants). In particular, untagged types - -- with only access discriminants do not require secondary stack use. - -- Note that if the return type is tagged we must always use the sec. - -- stack because the call may dispatch on result. - begin - -- Step past qualification or unchecked conversion (the latter can occur - -- in cases of calls to 'Input). - - if Nkind_In (Func_Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Func_Call := Expression (Func_Call); - end if; - -- If the call has already been processed to add build-in-place actuals -- then return. This should not normally occur in an object declaration, -- but we add the protection as a defensive measure. @@ -8135,327 +8078,341 @@ package body Exp_Ch6 is end if; Result_Subt := Etype (Function_Id); - Definite := - (Is_Definite_Subtype (Underlying_Type (Result_Subt)) - and then not Is_Tagged_Type (Result_Subt)) - or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); - -- Create an access type designating the function's result subtype. We - -- use the type of the original call because it may be a call to an - -- inherited operation, which the expansion has replaced with the parent - -- operation that yields the parent type. Note that this access type - -- must be declared before we establish a transient scope, so that it - -- receives the proper accessibility level. + declare + Definite : constant Boolean := + Caller_Known_Size (Func_Call, Result_Subt); + begin + -- Create an access type designating the function's result subtype. + -- We use the type of the original call because it may be a call to + -- an inherited operation, which the expansion has replaced with the + -- parent operation that yields the parent type. Note that this + -- access type must be declared before we establish a transient + -- scope, so that it receives the proper accessibility level. + + Ptr_Typ := Make_Temporary (Loc, 'A'); + Ptr_Typ_Decl := + 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 (Etype (Function_Call), Loc))); + + -- The access type and its accompanying object must be inserted after + -- the object declaration in the constrained case, so that the + -- function call can be passed access to the object. In the + -- indefinite case, or if the object declaration is for a return + -- object, the access type and object must be inserted before the + -- object, since the object declaration is rewritten to be a renaming + -- of a dereference of the access object. Note: we need to freeze + -- Ptr_Typ explicitly, because the result object is in a different + -- (transient) scope, so won't cause freezing. + + if Definite + and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) + then + Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); + else + Insert_Action (Obj_Decl, Ptr_Typ_Decl); + end if; - Ptr_Typ := Make_Temporary (Loc, 'A'); - Ptr_Typ_Decl := - 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 (Etype (Function_Call), Loc))); - - -- The access type and its accompanying object must be inserted after - -- the object declaration in the constrained case, so that the function - -- call can be passed access to the object. In the indefinite case, - -- or if the object declaration is for a return object, the access type - -- and object must be inserted before the object, since the object - -- declaration is rewritten to be a renaming of a dereference of the - -- access object. Note: we need to freeze Ptr_Typ explicitly, because - -- the result object is in a different (transient) scope, so won't - -- cause freezing. - - if Definite - and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) - then - Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); - else - Insert_Action (Obj_Decl, Ptr_Typ_Decl); - end if; + -- Force immediate freezing of Ptr_Typ because Res_Decl will be + -- elaborated in an inner (transient) scope and thus won't cause + -- freezing by itself. - -- Force immediate freezing of Ptr_Typ because Res_Decl will be - -- elaborated in an inner (transient) scope and thus won't cause - -- freezing by itself. + declare + Ptr_Typ_Freeze_Ref : constant Node_Id := + New_Occurrence_Of (Ptr_Typ, Loc); + begin + Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl); + Freeze_Expression (Ptr_Typ_Freeze_Ref); + end; - declare - Ptr_Typ_Freeze_Ref : constant Node_Id := - New_Occurrence_Of (Ptr_Typ, Loc); - begin - Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl); - Freeze_Expression (Ptr_Typ_Freeze_Ref); - end; + -- If the object is a return object of an enclosing build-in-place + -- function, then the implicit build-in-place parameters of the + -- enclosing function are simply passed along to the called function. + -- (Unfortunately, this won't cover the case of extension aggregates + -- where the ancestor part is a build-in-place indefinite function + -- call that should be passed along the caller's parameters. + -- Currently those get mishandled by reassigning the result of the + -- call to the aggregate return object, when the call result should + -- really be directly built in place in the aggregate and not in a + -- temporary. ???) + + if Is_Return_Object (Defining_Identifier (Obj_Decl)) then + 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). + + if Needs_BIP_Alloc_Form (Encl_Func) then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then + Pool_Actual := + New_Occurrence_Of + (Build_In_Place_Formal + (Encl_Func, BIP_Storage_Pool), Loc); + + -- The build-in-place pool formal is not built on e.g. ZFP - -- If the object is a return object of an enclosing build-in-place - -- function, then the implicit build-in-place parameters of the - -- enclosing function are simply passed along to the called function. - -- (Unfortunately, this won't cover the case of extension aggregates - -- where the ancestor part is a build-in-place indefinite function - -- call that should be passed along the caller's parameters. Currently - -- those get mishandled by reassigning the result of the call to the - -- aggregate return object, when the call result should really be - -- directly built in place in the aggregate and not in a temporary. ???) - - if Is_Return_Object (Defining_Identifier (Obj_Decl)) then - 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). - - if Needs_BIP_Alloc_Form (Encl_Func) then - if RTE_Available (RE_Root_Storage_Pool_Ptr) then - Pool_Actual := - New_Occurrence_Of - (Build_In_Place_Formal (Encl_Func, BIP_Storage_Pool), Loc); + else + Pool_Actual := Empty; + end if; + + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (Function_Call => Func_Call, + Function_Id => Function_Id, + Alloc_Form_Exp => + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), + Pool_Actual => Pool_Actual); - -- The build-in-place pool formal is not built on e.g. ZFP + -- Otherwise, if enclosing function has a definite result subtype, + -- then caller allocation will be used. else - Pool_Actual := Empty; + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); end if; - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Function_Call => Func_Call, - Function_Id => Function_Id, - Alloc_Form_Exp => + if Needs_BIP_Finalization_Master (Encl_Func) then + Fmaster_Actual := New_Occurrence_Of - (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), - Pool_Actual => Pool_Actual); + (Build_In_Place_Formal + (Encl_Func, BIP_Finalization_Master), Loc); + end if; - -- Otherwise, if enclosing function has a definite result subtype, - -- then caller allocation will be used. + -- Retrieve the BIPacc formal from the enclosing function and + -- convert it to the access type of the callee's BIP_Object_Access + -- formal. + + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype + (Build_In_Place_Formal + (Function_Id, BIP_Object_Access)), + Loc), + Expression => + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), + Loc)); + + -- In the definite case, add an implicit actual to the function call + -- that provides access to the declared object. An unchecked + -- conversion to the (specific) result type of the function is + -- inserted to handle the case where the object is declared with a + -- class-wide type. + + elsif Definite then + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), + Expression => New_Occurrence_Of (Obj_Def_Id, Loc)); + + -- When the function has a controlling result, an allocation-form + -- parameter must be passed indicating that the caller is + -- allocating the result object. This is needed because such a + -- function can be called as a dispatching operation and must be + -- treated similarly to functions with indefinite result subtypes. - else Add_Unconstrained_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - end if; - - if Needs_BIP_Finalization_Master (Encl_Func) then - Fmaster_Actual := - New_Occurrence_Of - (Build_In_Place_Formal - (Encl_Func, BIP_Finalization_Master), Loc); - end if; - - -- Retrieve the BIPacc formal from the enclosing function and convert - -- it to the access type of the callee's BIP_Object_Access formal. - - Caller_Object := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype - (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), - Loc), - Expression => - New_Occurrence_Of - (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), - Loc)); - - -- In the definite case, add an implicit actual to the function call - -- that provides access to the declared object. An unchecked conversion - -- to the (specific) result type of the function is inserted to handle - -- the case where the object is declared with a class-wide type. - elsif Definite then - Caller_Object := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), - Expression => New_Occurrence_Of (Obj_Def_Id, Loc)); + -- The allocation for indefinite library-level objects occurs on the + -- heap as opposed to the secondary stack. This accommodates DLLs + -- where the secondary stack is destroyed after each library + -- unload. This is a hybrid mechanism where a stack-allocated object + -- lives on the heap. - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with indefinite result subtypes. + elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl)) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + then + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Global_Heap); + Caller_Object := Empty; - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + -- Create a finalization master for the access result type to + -- ensure that the heap allocation can properly chain the object + -- and later finalize it when the library unit goes out of scope. - -- The allocation for indefinite library-level objects occurs on the - -- heap as opposed to the secondary stack. This accommodates DLLs where - -- the secondary stack is destroyed after each library unload. This is - -- a hybrid mechanism where a stack-allocated object lives on the heap. + if Needs_Finalization (Etype (Func_Call)) then + Build_Finalization_Master + (Typ => Ptr_Typ, + For_Lib_Level => True, + Insertion_Node => Ptr_Typ_Decl); - elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl)) - and then not Restriction_Active (No_Implicit_Heap_Allocations) - then - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Global_Heap); - Caller_Object := Empty; + Fmaster_Actual := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; - -- Create a finalization master for the access result type to ensure - -- that the heap allocation can properly chain the object and later - -- finalize it when the library unit goes out of scope. + -- In other indefinite cases, pass an indication to do the allocation + -- on the secondary stack and set Caller_Object to Empty so that a + -- null value will be passed for the caller's object address. A + -- transient scope is established to ensure eventual cleanup of the + -- result. - if Needs_Finalization (Etype (Func_Call)) then - Build_Finalization_Master - (Typ => Ptr_Typ, - For_Lib_Level => True, - Insertion_Node => Ptr_Typ_Decl); + else + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); + Caller_Object := Empty; - Fmaster_Actual := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), - Attribute_Name => Name_Unrestricted_Access); + Establish_Transient_Scope (Obj_Decl, Sec_Stack => True); end if; - -- In other indefinite cases, pass an indication to do the allocation - -- on the secondary stack and set Caller_Object to Empty so that a null - -- value will be passed for the caller's object address. A transient - -- scope is established to ensure eventual cleanup of the result. - - else - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); - Caller_Object := Empty; + -- Pass along any finalization master actual, which is needed in the + -- case where the called function initializes a return object of an + -- enclosing build-in-place function. - Establish_Transient_Scope (Obj_Decl, Sec_Stack => True); - end if; - - -- Pass along any finalization master actual, which is needed in the - -- case where the called function initializes a return object of an - -- enclosing build-in-place function. - - Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call => Func_Call, - Func_Id => Function_Id, - Master_Exp => Fmaster_Actual); + Add_Finalization_Master_Actual_To_Build_In_Place_Call + (Func_Call => Func_Call, + Func_Id => Function_Id, + Master_Exp => Fmaster_Actual); - if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement - and then Has_Task (Result_Subt) - then - -- Here we're passing along the master that was passed in to this - -- function. + if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement + and then Has_Task (Result_Subt) + then + -- Here we're passing along the master that was passed in to this + -- function. - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, - Master_Actual => - New_Occurrence_Of - (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, + Master_Actual => + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); - else - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); - end if; + else + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); + end if; - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, + Function_Id, + Caller_Object, + Is_Access => Pass_Caller_Acc); - -- Finally, create an access object initialized to a reference to the - -- function call. We know this access value cannot be null, so mark the - -- entity accordingly to suppress the access check. + -- Finally, create an access object initialized to a reference to the + -- function call. We know this access value cannot be null, so mark + -- the entity accordingly to suppress the access check. - Def_Id := Make_Temporary (Loc, 'R', Func_Call); - Set_Etype (Def_Id, Ptr_Typ); - Set_Is_Known_Non_Null (Def_Id); + Def_Id := Make_Temporary (Loc, 'R', Func_Call); + Set_Etype (Def_Id, Ptr_Typ); + Set_Is_Known_Non_Null (Def_Id); - Res_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Def_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), - Expression => - Make_Reference (Loc, Relocate_Node (Func_Call))); + Res_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), + Expression => + Make_Reference (Loc, Relocate_Node (Func_Call))); - Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); + Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); - -- If the result subtype of the called function is definite and is not - -- itself the return expression of an enclosing BIP function, then mark - -- the object as having no initialization. + -- If the result subtype of the called function is definite and is + -- not 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 (Defining_Identifier (Obj_Decl)) - 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 - -- temporary: + if Definite + and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) + 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 + -- temporary: - -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call); + -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call); - -- Since the build-in-place expansion decouples the call from the - -- object declaration, the finalization machinery lacks the context - -- which prompted the generation of the transient block. To resolve - -- this scenario, store the build-in-place call. + -- Since the build-in-place expansion decouples the call from the + -- object declaration, the finalization machinery lacks the + -- context which prompted the generation of the transient + -- block. To resolve this scenario, store the build-in-place call. - if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then - Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); - end if; + if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then + Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); + end if; - Set_Expression (Obj_Decl, Empty); - Set_No_Initialization (Obj_Decl); + Set_Expression (Obj_Decl, Empty); + Set_No_Initialization (Obj_Decl); - -- In case of an indefinite result subtype, or if the call is the - -- return expression of an enclosing BIP function, rewrite the object - -- declaration as an object renaming where the renamed object is a - -- dereference of 'reference: - -- - -- Obj : Subt renames 'Ref.all; + -- In case of an indefinite result subtype, or if the call is the + -- return expression of an enclosing BIP function, rewrite the object + -- declaration as an object renaming where the renamed object is a + -- dereference of 'reference: + -- + -- Obj : Subt renames 'Ref.all; - else - Call_Deref := - Make_Explicit_Dereference (Obj_Loc, - Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); - - Rewrite (Obj_Decl, - Make_Object_Renaming_Declaration (Obj_Loc, - Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), - Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc), - Name => Call_Deref)); - - Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); - - -- If the original entity comes from source, then mark the new - -- entity as needing debug information, even though it's defined - -- by a generated renaming that does not come from source, so that - -- the Materialize_Entity flag will be set on the entity when - -- Debug_Renaming_Declaration is called during analysis. - - if Comes_From_Source (Obj_Def_Id) then - Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); - end if; + else + Call_Deref := + Make_Explicit_Dereference (Obj_Loc, + Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); + + Rewrite (Obj_Decl, + Make_Object_Renaming_Declaration (Obj_Loc, + Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc), + Name => Call_Deref)); + + Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); + + -- If the original entity comes from source, then mark the new + -- entity as needing debug information, even though it's defined + -- by a generated renaming that does not come from source, so that + -- the Materialize_Entity flag will be set on the entity when + -- Debug_Renaming_Declaration is called during analysis. + + if Comes_From_Source (Obj_Def_Id) then + Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); + end if; - Analyze (Obj_Decl); + 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. + -- 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); + 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)); + begin + Set_Chars (Ren_Id, Chars (Obj_Def_Id)); - -- Swap next entity links in preparation for exchanging entities + -- 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)); + 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); + 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 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)); + 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; - end if; + Set_Comes_From_Source (Ren_Id, False); + end; + end if; + end; -- If the object entity has a class-wide Etype, then we need to change -- it to the result subtype of the function call, because otherwise the diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f822545..28950fc 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2763,9 +2763,30 @@ package body Exp_Ch7 is Stmt := Next_Suitable_Statement (Decl); - -- Nothing to do for an object with suppressed initialization + -- For an object with suppressed initialization, we check whether + -- there is in fact no initialization expression. If there is not, + -- then this is an object declaration that has been turned into a + -- different object declaration that calls the build-in-place + -- function in a 'Reference attribute, as in "F(...)'Reference". + -- We search for that later object declaration, so that the + -- Inc_Decl will be inserted after the call. Otherwise, if the + -- call raises an exception, we will finalize the (uninitialized) + -- object, which is wrong. if No_Initialization (Decl) then + if No (Expression (Last_Init)) then + loop + Last_Init := Next (Last_Init); + exit when No (Last_Init); + exit when Nkind (Last_Init) = N_Object_Declaration + and then Nkind (Expression (Last_Init)) = N_Reference + and then Nkind (Prefix (Expression (Last_Init))) = + N_Function_Call + and then Is_Expanded_Build_In_Place_Call + (Prefix (Expression (Last_Init))); + end loop; + end if; + return; -- In all other cases the initialization calls follow the related @@ -2955,7 +2976,7 @@ package body Exp_Ch7 is if No (Finalizer_Insert_Nod) then - -- Insertion after an abort deffered block + -- Insertion after an abort deferred block if Present (Body_Ins) then Finalizer_Insert_Nod := Body_Ins; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index cf6a561..ff1a752 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8274,79 +8274,6 @@ package body Exp_Util is and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); end Is_Non_BIP_Func_Call; - ------------------------------------ - -- Is_Object_Access_BIP_Func_Call -- - ------------------------------------ - - function Is_Object_Access_BIP_Func_Call - (Expr : Node_Id; - Obj_Id : Entity_Id) return Boolean - is - Access_Nam : Name_Id := No_Name; - Actual : Node_Id; - Call : Node_Id; - Formal : Node_Id; - Param : Node_Id; - - begin - -- Build-in-place calls usually appear in 'reference format. Note that - -- the accessibility check machinery may add an extra 'reference due to - -- side effect removal. - - Call := Expr; - while Nkind (Call) = N_Reference loop - Call := Prefix (Call); - end loop; - - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; - - if Is_Build_In_Place_Function_Call (Call) then - - -- Examine all parameter associations of the function call - - Param := First (Parameter_Associations (Call)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier - then - Formal := Selector_Name (Param); - Actual := Explicit_Actual_Parameter (Param); - - -- Construct the name of formal BIPaccess. It is much easier to - -- extract the name of the function using an arbitrary formal's - -- scope rather than the Name field of Call. - - if Access_Nam = No_Name and then Present (Entity (Formal)) then - Access_Nam := - New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Object_Access)); - end if; - - -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been - -- found. - - if Chars (Formal) = Access_Nam - and then Nkind (Actual) = N_Attribute_Reference - and then Attribute_Name (Actual) = Name_Unrestricted_Access - and then Nkind (Prefix (Actual)) = N_Identifier - and then Entity (Prefix (Actual)) = Obj_Id - then - return True; - end if; - end if; - - Next (Param); - end loop; - end if; - - return False; - end Is_Object_Access_BIP_Func_Call; - ---------------------------------- -- Is_Possibly_Unaligned_Object -- ---------------------------------- @@ -8739,11 +8666,7 @@ package body Exp_Util is Call := Prefix (Call); end loop; - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; + Call := Unqual_Conv (Call); if Is_Build_In_Place_Function_Call (Call) then diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 1873cb1..70ae80b 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -774,12 +774,6 @@ package Exp_Util is function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call - function Is_Object_Access_BIP_Func_Call - (Expr : Node_Id; - Obj_Id : Entity_Id) return Boolean; - -- Determine if Expr denotes a build-in-place function which stores its - -- result in the BIPaccess actual parameter whose prefix must match Obj_Id. - function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; -- Node N is an object reference. This function returns True if it is -- possible that the object may not be aligned according to the normal diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index b0f4b93..58c46a9 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.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- -- @@ -810,10 +810,15 @@ package body Ch6 is end if; end if; - -- Fall through if we have a likely expression function + -- Fall through if we have a likely expression function. + -- If the starting keyword is not "function" the error + -- will be reported elsewhere. + + if Func then + Error_Msg_SC + ("expression function must be enclosed in parentheses"); + end if; - Error_Msg_SC - ("expression function must be enclosed in parentheses"); return True; end Likely_Expression_Function; @@ -844,12 +849,20 @@ package body Ch6 is -- This case is correctly processed by the parser because -- the expression function first appears as a subprogram - -- declaration to the parser. + -- declaration to the parser. The starting keyword may + -- not have been "function" in which case the error is + -- on a malformed procedure. if Is_Non_Empty_List (Aspects) then - Error_Msg - ("aspect specifications must come after parenthesized " - & "expression", Sloc (First (Aspects))); + if Func then + Error_Msg ("aspect specifications must come after " + & "parenthesized expression", + Sloc (First (Aspects))); + else + Error_Msg ("aspect specifications must come after " + & "subprogram specification", + Sloc (First (Aspects))); + end if; end if; -- Parse out expression and build expression function diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 991f2b5..feef95a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1394,6 +1394,7 @@ package body Sem_Attr is elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration, N_Entry_Declaration, + N_Expression_Function, N_Generic_Subprogram_Declaration, N_Subprogram_Body, N_Subprogram_Body_Stub, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7ef2834..a99d2ee 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8700,6 +8700,9 @@ package body Sem_Ch13 is FBody : Node_Id; begin + Set_Ekind (SIdB, E_Function); + Set_Is_Predicate_Function (SIdB); + -- The predicate function is shared between views of a type if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then @@ -12664,6 +12667,7 @@ package body Sem_Ch13 is ------------------ function Resolve_Name (N : Node_Id) return Traverse_Result is + Dummy : Traverse_Result; begin if Nkind (N) = N_Selected_Component then if Nkind (Prefix (N)) = N_Identifier @@ -12681,6 +12685,12 @@ package body Sem_Ch13 is Set_Entity (N, Empty); end if; + -- The name is component association needs no resolution. + + elsif Nkind (N) = N_Component_Association then + Dummy := Resolve_Name (Expression (N)); + return Skip; + elsif Nkind (N) = N_Quantified_Expression then return Skip; end if; @@ -12722,14 +12732,19 @@ package body Sem_Ch13 is | Aspect_Static_Predicate => -- Build predicate function specification and preanalyze - -- expression after type replacement. + -- expression after type replacement. The function + -- declaration must be analyzed in the scope of the + -- type, but the expression must see components. if No (Predicate_Function (E)) then + Uninstall_Discriminants_And_Pop_Scope (E); declare FDecl : constant Node_Id := Build_Predicate_Function_Declaration (E); pragma Unreferenced (FDecl); + begin + Push_Scope_And_Install_Discriminants (E); Resolve_Aspect_Expression (Expr); end; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 83ca58a..7e22255 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11588,6 +11588,12 @@ package body Sem_Ch6 is if Ekind (Subp) = E_Procedure and then Is_Null_Init_Proc (Subp) then return; + + -- Within a predicate function we do not want to generate local + -- subtypes that may generate nested predicate functions. + + elsif Is_Subprogram (Subp) and then Is_Predicate_Function (Subp) then + return; end if; -- The subtype declarations may freeze the formals. The body generated diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index f4cd375..f96c073 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -402,6 +402,18 @@ package body Sem_Ch7 is end if; end if; + -- Freeze node + + elsif Nkind (Decl) = N_Freeze_Entity then + declare + Discard : Boolean; + pragma Unreferenced (Discard); + begin + -- Inspect the actions to find references to subprograms + + Discard := Has_Referencer (Actions (Decl)); + end; + -- Exceptions, objects and renamings do not need to be public -- if they are not followed by a construct which can reference -- and export them. The Is_Public flag is reset on top level @@ -484,7 +496,7 @@ package body Sem_Ch7 is -- Local variables - Discard : Boolean := True; + Discard : Boolean; pragma Unreferenced (Discard); -- Start of processing for Hide_Public_Entities diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d0c4387..bb36584 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7138,6 +7138,24 @@ package body Sem_Prag is Set_Treat_As_Volatile (Underlying_Type (E)); end if; + -- Apply Volatile to the composite type's individual components, + -- (RM C.6(8/3)). + + if Prag_Id = Pragma_Volatile + and then Is_Record_Type (Etype (E)) + then + declare + Comp : Entity_Id; + begin + Comp := First_Component (E); + while Present (Comp) loop + Mark_Component_Or_Object (Comp); + + Next_Component (Comp); + end loop; + end; + end if; + -- Deal with the case where the pragma/attribute applies to a -- component or object declaration. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 237d410..3ca92ce 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15734,22 +15734,10 @@ package body Sem_Util is -------------------------------------- function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is - Var : Node_Id; + Var : constant Node_Id := Unqual_Conv (N); Var_Id : Entity_Id; begin - Var := N; - - -- Use the expression when the context qualifies a reference in some - -- fashion. - - while Nkind_In (Var, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) - loop - Var := Expression (Var); - end loop; - Var_Id := Empty; if Is_Entity_Name (Var) then @@ -22497,6 +22485,28 @@ package body Sem_Util is end if; end Unqualify; + ----------------- + -- Unqual_Conv -- + ----------------- + + function Unqual_Conv (Expr : Node_Id) return Node_Id is + begin + -- Recurse to handle unlikely 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_Conv (Expression (Expr)); + + -- Normal case, not a qualified expression + + else + return Expr; + end if; + end Unqual_Conv; + ----------------------- -- Visible_Ancestors -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2c29dde..bc76224 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2571,6 +2571,11 @@ package Sem_Util is -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this -- returns X. If Expr is not a qualified expression, returns Expr. + function Unqual_Conv (Expr : Node_Id) return Node_Id; + pragma Inline (Unqual_Conv); + -- Similar to Unqualify, but removes qualified expressions, type + -- conversions, and unchecked conversions. + function Visible_Ancestors (Typ : Entity_Id) return Elist_Id; -- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors -- of a type extension or private extension declaration. If the full-view -- 2.7.4