Index: sem_util.adb =================================================================== --- sem_util.adb (revision 160959) +++ sem_util.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -9493,15 +9494,112 @@ package body Sem_Util is then return Object_Access_Level (Expression (Obj)); - -- Function results are objects, so we get either the access level of - -- the function or, in the case of an indirect call, the level of the - -- access-to-subprogram type. - elsif Nkind (Obj) = N_Function_Call then - if Is_Entity_Name (Name (Obj)) then - return Subprogram_Access_Level (Entity (Name (Obj))); - else - return Type_Access_Level (Etype (Prefix (Name (Obj)))); + + -- Function results are objects, so we get either the access level of + -- the function or, in the case of an indirect call, the level of the + -- access-to-subprogram type. (This code is used for Ada 95, but it + -- looks wrong, because it seems that we should be checking the level + -- of the call itself, even for Ada 95. However, using the Ada 2005 + -- version of the code causes regressions in several tests that are + -- compiled with -gnat95. ???) + + if Ada_Version < Ada_05 then + if Is_Entity_Name (Name (Obj)) then + return Subprogram_Access_Level (Entity (Name (Obj))); + else + return Type_Access_Level (Etype (Prefix (Name (Obj)))); + end if; + + -- For Ada 2005, the level of the result object of a function call is + -- defined to be the level of the call's innermost enclosing master. + -- We determine that by querying the depth of the innermost enclosing + -- dynamic scope. + + else + Return_Master_Scope_Depth_Of_Call : declare + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint; + -- Returns the scope depth of the given node's innermost + -- enclosing dynamic scope (effectively the accessibility + -- level of the innermost enclosing master). + + ---------------------------------- + -- Innermost_Master_Scope_Depth -- + ---------------------------------- + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint + is + Node_Par : Node_Id := Parent (N); + + begin + -- Locate the nearest enclosing node (by traversing Parents) + -- that Defining_Entity can be applied to, and return the + -- depth of that entity's nearest enclosing dynamic scope. + + while Present (Node_Par) loop + case Nkind (Node_Par) is + when N_Component_Declaration | + N_Entry_Declaration | + N_Formal_Object_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Loop_Parameter_Specification | + N_Object_Declaration | + N_Protected_Type_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subtype_Declaration | + N_Function_Specification | + N_Procedure_Specification | + N_Task_Type_Declaration | + N_Body_Stub | + N_Generic_Instantiation | + N_Proper_Body | + N_Implicit_Label_Declaration | + N_Package_Declaration | + N_Single_Task_Declaration | + N_Subprogram_Declaration | + N_Generic_Declaration | + N_Renaming_Declaration | + N_Block_Statement | + N_Formal_Subprogram_Declaration | + N_Abstract_Subprogram_Declaration | + N_Entry_Body | + N_Exception_Declaration | + N_Formal_Package_Declaration | + N_Number_Declaration | + N_Package_Specification | + N_Parameter_Specification | + N_Single_Protected_Declaration | + N_Subunit => + + return Scope_Depth + (Nearest_Dynamic_Scope + (Defining_Entity (Node_Par))); + + when others => + null; + end case; + + Node_Par := Parent (Node_Par); + end loop; + + pragma Assert (False); + + -- Should never reach the following return + + return Scope_Depth (Current_Scope) + 1; + end Innermost_Master_Scope_Depth; + + -- Start of processing for Return_Master_Scope_Depth_Of_Call + + begin + return Innermost_Master_Scope_Depth (Obj); + end Return_Master_Scope_Depth_Of_Call; end if; -- For convenience we handle qualified expressions, even though