From c5a913d3fd22769d66d480c2487edcf1d50644c5 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 1 Apr 2020 19:13:06 +0200 Subject: [PATCH] [Ada] Implement AI12-0343 Return Statement Checks 2020-06-15 Eric Botcazou gcc/ada/ * einfo.ads (Return_Applies_To): Document special usage for E_Block. * einfo.adb (Write_Field8_Name): Write it for E_Block too. * exp_ch4.adb (Expand_N_Type_Conversion): Remove implementation of the check prescribed by AI05-0073. * exp_ch6.adb (Apply_CW_Accessibility_Check): New procedure to apply the check prescribed by AI95-344 extracted from... (Expand_N_Extended_Return_Statement): Apply the check prescribed by AI95-344 to the expression, if present. Suppress only access checks when analyzing the rewritten result. (Expand_Simple_Function_Return): ...here. Rename local variable. Call Apply_CW_Accessibility_Check to apply the check prescribed by AI95-344, but do not do it for the simple return statement generated by the expansion of an extended return statement. Apply the check prescribed by AI05-0073 to all functions returning anonymous access type designating a specific tagged type, but not if the expression was null or tag checks are suppressed for the type, and use Not In operator rather than comparing the tags explicitly. * sem.adb (Analyze): Handle all Suppress values. * sem_ch6.adb (Analyze_Function_Return): Do not explicitly apply predicate checks in the case of an extended return statement. Do not apply an implicit conversion to the anonymous access result type in the case of the simple return statement generated by the expansion of an extended return statement. (New_Overloaded_Entity): Small comment tweak. * treepr.adb (Print_Node): Fix typo in flag string. --- gcc/ada/einfo.adb | 4 +- gcc/ada/einfo.ads | 5 + gcc/ada/exp_ch4.adb | 89 +++--------- gcc/ada/exp_ch6.adb | 336 +++++++++++++++++++++++++------------------- gcc/ada/sem.adb | 2 +- gcc/ada/sem_ch6.adb | 18 ++- gcc/ada/treepr.adb | 2 +- 7 files changed, 231 insertions(+), 225 deletions(-) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index eb6ae1728a0..4b664316ace 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -10185,7 +10185,9 @@ package body Einfo is when E_Abstract_State => Write_Str ("Refinement_Constituents"); - when E_Return_Statement => + when E_Block + | E_Return_Statement + => Write_Str ("Return_Applies_To"); when others => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 35efe5919f0..1ca0faf6d91 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4184,6 +4184,10 @@ package Einfo is -- RM-6.5(4/2). Note that a (simple) return statement within an -- extended_return_statement applies to the extended_return_statement, -- even though it causes the whole function to return. +-- Also defined in special E_Block entities built as E_Return_Statement +-- for extended return statements and attached to the block statement +-- by Expand_N_Extended_Return_Statement before being turned into an +-- E_Block by semantic analysis. -- Return_Present (Flag54) -- Defined in function and generic function entities. Set if the @@ -5917,6 +5921,7 @@ package Einfo is -- (plus type attributes) -- E_Block + -- Return_Applies_To (Node8) -- Block_Node (Node11) -- First_Entity (Node17) -- Last_Entity (Node20) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 27410ffe934..ba83a097f15 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12040,7 +12040,6 @@ package body Exp_Ch4 is Tagged_Conversion : declare Actual_Op_Typ : Entity_Id; Actual_Targ_Typ : Entity_Id; - Make_Conversion : Boolean := False; Root_Op_Typ : Entity_Id; procedure Make_Tag_Check (Targ_Typ : Entity_Id); @@ -12124,78 +12123,26 @@ package body Exp_Ch4 is goto Done; end if; - if not Tag_Checks_Suppressed (Actual_Targ_Typ) then + -- Create a runtime tag check for a downward CW type conversion - -- Create a runtime tag check for a downward class-wide type - -- conversion. - - if Is_Class_Wide_Type (Actual_Op_Typ) - and then Actual_Op_Typ /= Actual_Targ_Typ - and then Root_Op_Typ /= Actual_Targ_Typ - and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ, - Use_Full_View => True) - then + if Is_Class_Wide_Type (Actual_Op_Typ) + and then Actual_Op_Typ /= Actual_Targ_Typ + and then Root_Op_Typ /= Actual_Targ_Typ + and then Is_Ancestor + (Root_Op_Typ, Actual_Targ_Typ, Use_Full_View => True) + and then not Tag_Checks_Suppressed (Actual_Targ_Typ) + then + declare + Conv : Node_Id; + begin Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ)); - Make_Conversion := True; - end if; - - -- AI05-0073: If the result subtype of the function is defined - -- by an access_definition designating a specific tagged type - -- T, a check is made that the result value is null or the tag - -- of the object designated by the result value identifies T. - -- Constraint_Error is raised if this check fails. - - if Nkind (Parent (N)) = N_Simple_Return_Statement then - declare - Func : Entity_Id; - Func_Typ : Entity_Id; - - begin - -- Climb scope stack looking for the enclosing function - - Func := Current_Scope; - while Present (Func) - and then Ekind (Func) /= E_Function - loop - Func := Scope (Func); - end loop; - - -- The function's return subtype must be defined using - -- an access definition. - - if Nkind (Result_Definition (Parent (Func))) = - N_Access_Definition - then - Func_Typ := Directly_Designated_Type (Etype (Func)); - - -- The return subtype denotes a specific tagged type, - -- in other words, a non class-wide type. - - if Is_Tagged_Type (Func_Typ) - and then not Is_Class_Wide_Type (Func_Typ) - then - Make_Tag_Check (Actual_Targ_Typ); - Make_Conversion := True; - end if; - end if; - end; - end if; - - -- We have generated a tag check for either a class-wide type - -- conversion or for AI05-0073. - - if Make_Conversion then - declare - Conv : Node_Id; - begin - Conv := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), - Expression => Relocate_Node (Expression (N))); - Rewrite (N, Conv); - Analyze_And_Resolve (N, Target_Type); - end; - end if; + Conv := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Expression (N))); + Rewrite (N, Conv); + Analyze_And_Resolve (N, Target_Type); + end; end if; end Tagged_Conversion; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1dd4493c785..d679a8a9c83 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -137,6 +137,16 @@ package body Exp_Ch6 is -- the activation Chain. Note: Master_Actual can be Empty, but only if -- there are no tasks. + procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); + -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check + -- that the level of the return expression's underlying type is not deeper + -- than the level of the master enclosing the function. Always generate the + -- check when the type of the return expression is class-wide, when it's a + -- type conversion, or when it's a formal parameter. Otherwise suppress the + -- check in the case where the return expression has a specific type whose + -- level is known not to be statically deeper than the result type of the + -- function. + function Caller_Known_Size (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; @@ -610,6 +620,115 @@ package body Exp_Ch6 is Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); end Add_Task_Actuals_To_Build_In_Place_Call; + ---------------------------------- + -- Apply_CW_Accessibility_Check -- + ---------------------------------- + + procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Exp); + + begin + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + and then not Scope_Suppress.Suppress (Accessibility_Check) + and then + (Is_Class_Wide_Type (Etype (Exp)) + or else Nkind_In (Exp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + or else (Is_Entity_Name (Exp) + and then Is_Formal (Entity (Exp))) + or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > + Scope_Depth (Enclosing_Dynamic_Scope (Func))) + then + declare + Tag_Node : Node_Id; + + begin + -- Ada 2005 (AI-251): In class-wide interface objects we displace + -- "this" to reference the base of the object. This is required to + -- get access to the TSD of the object. + + if Is_Class_Wide_Type (Etype (Exp)) + and then Is_Interface (Etype (Exp)) + then + -- If the expression is an explicit dereference then we can + -- directly displace the pointer to reference the base of + -- the object. + + if Nkind (Exp) = N_Explicit_Dereference then + Tag_Node := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Duplicate_Subexpr (Prefix (Exp))))))); + + -- Similar case to the previous one but the expression is a + -- renaming of an explicit dereference. + + elsif Nkind (Exp) = N_Identifier + and then Present (Renamed_Object (Entity (Exp))) + and then Nkind (Renamed_Object (Entity (Exp))) + = N_Explicit_Dereference + then + Tag_Node := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Duplicate_Subexpr + (Prefix + (Renamed_Object (Entity (Exp))))))))); + + -- Common case: obtain the address of the actual object and + -- displace the pointer to reference the base of the object. + + else + Tag_Node := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Exp), + Attribute_Name => Name_Address))))); + end if; + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Exp), + Attribute_Name => Name_Tag); + end if; + + -- CodePeer does not do anything useful with + -- Ada.Tags.Type_Specific_Data components. + + if not CodePeer_Mode then + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Func)))), + Reason => PE_Accessibility_Check_Failed)); + end if; + end; + end if; + end Apply_CW_Accessibility_Check; + ----------------------- -- BIP_Formal_Suffix -- ----------------------- @@ -5282,6 +5401,17 @@ package body Exp_Ch6 is Is_Build_In_Place_Function_Call (Exp)); null; end if; + + -- Ada 2005 (AI95-344): If the result type is class-wide, then insert + -- a check that the level of the return expression's underlying type + -- is not deeper than the level of the master enclosing the function. + + -- AI12-043: The check is made immediately after the return object + -- is created. + + if Present (Exp) and then Is_Class_Wide_Type (Ret_Typ) then + Apply_CW_Accessibility_Check (Exp, Func_Id); + end if; else Exp := Empty; end if; @@ -6034,7 +6164,14 @@ package body Exp_Ch6 is Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); - Analyze (N, Suppress => All_Checks); + + -- AI12-043: The checks of 6.5(8.1/3) and 6.5(21/3) are made immediately + -- before an object is returned. A predicate that applies to the return + -- subtype is checked immediately before an object is returned. + + -- Suppress access checks to avoid generating extra checks for b-i-p. + + Analyze (N, Suppress => Access_Check); end Expand_N_Extended_Return_Statement; ---------------------------- @@ -7006,7 +7143,7 @@ package body Exp_Ch6 is Exp : Node_Id := Expression (N); pragma Assert (Present (Exp)); - Exptyp : constant Entity_Id := Etype (Exp); + Exp_Typ : constant Entity_Id := Etype (Exp); -- The type of the expression (not necessarily the same as R_Type) Subtype_Ind : Node_Id; @@ -7039,12 +7176,13 @@ package body Exp_Ch6 is end Check_Against_Result_Level; -- Start of processing for Expand_Simple_Function_Return + begin if Is_Class_Wide_Type (R_Type) - and then not Is_Class_Wide_Type (Exptyp) + and then not Is_Class_Wide_Type (Exp_Typ) and then Nkind (Exp) /= N_Type_Conversion then - Subtype_Ind := New_Occurrence_Of (Exptyp, Loc); + Subtype_Ind := New_Occurrence_Of (Exp_Typ, Loc); else Subtype_Ind := New_Occurrence_Of (R_Type, Loc); @@ -7054,7 +7192,7 @@ package body Exp_Ch6 is -- altogether to prevent tag overwriting. if Is_Class_Wide_Type (R_Type) - and then not Is_Class_Wide_Type (Exptyp) + and then not Is_Class_Wide_Type (Exp_Typ) and then Nkind (Exp) = N_Type_Conversion then Exp := Expression (Exp); @@ -7115,7 +7253,7 @@ package body Exp_Ch6 is -- handled by means of simple return statements. This leaves their -- expansion simple and clean. - and then not Is_Thunk (Current_Scope) + and then not Is_Thunk (Scope_Id) then declare Return_Object_Entity : constant Entity_Id := @@ -7150,18 +7288,14 @@ package body Exp_Ch6 is -- barrier functions for protected types, which turn the condition into -- a return statement. - if Is_Boolean_Type (Exptyp) - and then Nonzero_Is_True (Exptyp) - then + if Is_Boolean_Type (Exp_Typ) and then Nonzero_Is_True (Exp_Typ) then Adjust_Condition (Exp); - Adjust_Result_Type (Exp, Exptyp); + Adjust_Result_Type (Exp, Exp_Typ); end if; -- Do validity check if enabled for returns - if Validity_Checks_On - and then Validity_Check_Returns - then + if Validity_Checks_On and then Validity_Check_Returns then Ensure_Valid (Exp); end if; @@ -7171,7 +7305,7 @@ package body Exp_Ch6 is -- only done for scalars. -- ??? - if Is_Scalar_Type (Exptyp) then + if Is_Scalar_Type (Exp_Typ) then Rewrite (Exp, Convert_To (R_Type, Exp)); -- The expression is resolved to ensure that the conversion gets @@ -7187,7 +7321,7 @@ package body Exp_Ch6 is -- it requires a cleanup scope for the secondary stack case). if Is_Build_In_Place_Function (Scope_Id) - or else Is_Limited_Interface (Exptyp) + or else Is_Limited_Interface (Exp_Typ) then null; @@ -7195,13 +7329,13 @@ package body Exp_Ch6 is -- the object is returned by reference and the maximum functionality -- required is just to displace the pointer. - elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then + elsif Is_Thunk (Scope_Id) and then Is_Interface (Exp_Typ) then null; -- If the call is within a thunk and the type is a limited view, the -- backend will eventually see the non-limited view of the type. - elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then + elsif Is_Thunk (Scope_Id) and then Is_Incomplete_Type (Exp_Typ) then return; -- A return statement from an ignored Ghost function does not use the @@ -7220,7 +7354,7 @@ package body Exp_Ch6 is -- cause a temporary with maximum size to be created. declare - Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); + Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exp_Typ)); Decl : Node_Id; Ent : Entity_Id; begin @@ -7257,10 +7391,10 @@ package body Exp_Ch6 is -- for array types if the constrained status of the target type is -- different from that of the expression. - if Requires_Transient_Scope (Exptyp) + if Requires_Transient_Scope (Exp_Typ) and then - (not Is_Array_Type (Exptyp) - or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) + (not Is_Array_Type (Exp_Typ) + or else Is_Constrained (Exp_Typ) = Is_Constrained (R_Type) or else CW_Or_Has_Controlled_Part (Utyp)) and then Nkind (Exp) = N_Function_Call then @@ -7432,125 +7566,27 @@ package body Exp_Ch6 is end; end if; - -- Ada 2005 (AI-344): If the result type is class-wide, then insert + -- Ada 2005 (AI95-344): If the result type is class-wide, then insert -- a check that the level of the return expression's underlying type -- is not deeper than the level of the master enclosing the function. - -- Always generate the check when the type of the return expression - -- is class-wide, when it's a type conversion, or when it's a formal - -- parameter. Otherwise, suppress the check in the case where the - -- return expression has a specific type whose level is known not to - -- be statically deeper than the function's result type. + + -- AI12-043: The check is made immediately after the return object is + -- created. This means that we do not apply it to the simple return + -- generated by the expansion of an extended return statement. -- No runtime check needed in interface thunks since it is performed -- by the target primitive associated with the thunk. - -- Note: accessibility check is skipped in the VM case, since there - -- does not seem to be any practical way to implement this check. - - elsif Ada_Version >= Ada_2005 - and then Tagged_Type_Expansion - and then Is_Class_Wide_Type (R_Type) - and then not Is_Thunk (Current_Scope) - and then not Scope_Suppress.Suppress (Accessibility_Check) - and then - (Is_Class_Wide_Type (Etype (Exp)) - or else Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) - or else (Is_Entity_Name (Exp) - and then Is_Formal (Entity (Exp))) - or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) + elsif Is_Class_Wide_Type (R_Type) + and then not Comes_From_Extended_Return_Statement (N) + and then not Is_Thunk (Scope_Id) then - declare - Tag_Node : Node_Id; + Apply_CW_Accessibility_Check (Exp, Scope_Id); - begin - -- Ada 2005 (AI-251): In class-wide interface objects we displace - -- "this" to reference the base of the object. This is required to - -- get access to the TSD of the object. - - if Is_Class_Wide_Type (Etype (Exp)) - and then Is_Interface (Etype (Exp)) - then - -- If the expression is an explicit dereference then we can - -- directly displace the pointer to reference the base of - -- the object. - - if Nkind (Exp) = N_Explicit_Dereference then - Tag_Node := - Make_Explicit_Dereference (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Address), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), - Duplicate_Subexpr (Prefix (Exp))))))); - - -- Similar case to the previous one but the expression is a - -- renaming of an explicit dereference. - - elsif Nkind (Exp) = N_Identifier - and then Present (Renamed_Object (Entity (Exp))) - and then Nkind (Renamed_Object (Entity (Exp))) - = N_Explicit_Dereference - then - Tag_Node := - Make_Explicit_Dereference (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Address), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), - Duplicate_Subexpr - (Prefix - (Renamed_Object (Entity (Exp))))))))); - - -- Common case: obtain the address of the actual object and - -- displace the pointer to reference the base of the object. - - else - Tag_Node := - Make_Explicit_Dereference (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Base_Address), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Exp), - Attribute_Name => Name_Address))))); - end if; - else - Tag_Node := - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Exp), - Attribute_Name => Name_Tag); - end if; - - -- CodePeer does not do anything useful with - -- Ada.Tags.Type_Specific_Data components. - - if not CodePeer_Mode then - Insert_Action (Exp, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), - Right_Opnd => - Make_Integer_Literal (Loc, - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), - Reason => PE_Accessibility_Check_Failed)); - end if; - end; - - -- AI05-0073: If function has a controlling access result, check that - -- the tag of the return value, if it is not null, matches designated - -- type of return type. + -- Ada 2012 (AI05-0073): If the result subtype of the function is + -- defined by an access_definition designating a specific tagged + -- type T, a check is made that the result value is null or the tag + -- of the object designated by the result value identifies T. -- The return expression is referenced twice in the code below, so it -- must be made free of side effects. Given that different compilers @@ -7558,8 +7594,16 @@ package body Exp_Ch6 is -- perform a copy. elsif Ekind (R_Type) = E_Anonymous_Access_Type - and then Has_Controlling_Result (Scope_Id) + and then Is_Tagged_Type (Designated_Type (R_Type)) + and then not Is_Class_Wide_Type (Designated_Type (R_Type)) + and then Nkind (Original_Node (Exp)) /= N_Null + and then not Tag_Checks_Suppressed (Designated_Type (R_Type)) then + -- Generate: + -- [Constraint_Error + -- when Exp /= null + -- and then Exp.all not in Designated_Type] + Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => @@ -7569,17 +7613,13 @@ package body Exp_Ch6 is Left_Opnd => Duplicate_Subexpr (Exp), Right_Opnd => Make_Null (Loc)), - Right_Opnd => Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Exp), - Selector_Name => Make_Identifier (Loc, Name_uTag)), - - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Designated_Type (R_Type), Loc), - Attribute_Name => Name_Tag))), + Right_Opnd => + Make_Not_In (Loc, + Left_Opnd => + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr (Exp)), + Right_Opnd => + New_Occurrence_Of (Designated_Type (R_Type), Loc))), Reason => CE_Tag_Check_Failed), Suppress => All_Checks); @@ -7595,9 +7635,9 @@ package body Exp_Ch6 is Object_Access_Level (Entity (Ultimate_Prefix (Prefix (Exp)))))); end if; - -- AI05-0234: RM 6.5(21/3). Check access discriminants to - -- ensure that the function result does not outlive an - -- object designated by one of it discriminants. + -- AI05-0234: Check unconstrained access discriminants to ensure + -- that the result does not outlive an object designated by one + -- of its discriminants (RM 6.5(21/3)). if Present (Extra_Accessibility_Of_Result (Scope_Id)) and then Has_Unconstrained_Access_Discriminants (R_Type) @@ -7843,7 +7883,7 @@ package body Exp_Ch6 is and then Comes_From_Extended_Return_Statement (N) and then Nkind (Expression (N)) = N_Identifier and then Is_Interface (Utyp) - and then Utyp /= Underlying_Type (Exptyp) + and then Utyp /= Underlying_Type (Exp_Typ) then Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); Analyze_And_Resolve (Exp); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 39542ec7e7c..44aac6346dc 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -819,7 +819,7 @@ package body Sem is Scope_Suppress.Suppress := Svs; end; - elsif Suppress = Overflow_Check then + else declare Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8ded5ad0553..8ff017a8572 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1250,20 +1250,31 @@ package body Sem_Ch6 is -- The return value is converted to the return type of the function, -- which implies a predicate check if the return type is predicated. + -- We do not apply the check for an extended return statement because + -- Analyze_Object_Declaration has already done it on Obj_Decl above. -- We do not apply the check to a case expression because it will -- be expanded into a series of return statements, each of which -- will receive a predicate check. - if Nkind (Expr) /= N_Case_Expression then + if Nkind (N) /= N_Extended_Return_Statement + and then Nkind (Expr) /= N_Case_Expression + then Apply_Predicate_Check (Expr, R_Type); end if; -- Ada 2005 (AI-318-02): When the result type is an anonymous access -- type, apply an implicit conversion of the expression to that type -- to force appropriate static and run-time accessibility checks. + -- But we want to apply the checks to an extended return statement + -- only once, i.e. not to the simple return statement generated at + -- the end of its expansion because, prior to leaving the function, + -- the accessibility level of the return object changes to be a level + -- determined by the point of call (RM 3.10.2(10.8/3). if Ada_Version >= Ada_2005 and then Ekind (R_Type) = E_Anonymous_Access_Type + and then (Nkind (N) = N_Extended_Return_Statement + or else not Comes_From_Extended_Return_Statement (N)) then Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); Analyze_And_Resolve (Expr, R_Type); @@ -10614,8 +10625,9 @@ package body Sem_Ch6 is ("\move subprogram to the visible part" & " (RM 3.9.3(10))", S); - -- AI05-0073: extend this test to the case of a - -- function with a controlling access result. + -- Ada 2012 (AI05-0073): Extend this check to the case + -- of a function whose result subtype is defined by an + -- access_definition designating specific tagged type. elsif Ekind (Etype (S)) = E_Anonymous_Access_Type and then Is_Tagged_Type (Designated_Type (Etype (S))) diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index ffd0231d11b..b84af01d40f 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1164,7 +1164,7 @@ package body Treepr is if Raises_Constraint_Error (N) then Print_Str (Prefix_Str_Char); - Print_Str ("Raise_Constraint_Error = True"); + Print_Str ("Raises_Constraint_Error = True"); Print_Eol; end if; -- 2.30.2