From dfbcb149aa59ef88a254489d2c3aa9c105562490 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Mon, 29 Aug 2011 14:33:59 +0000 Subject: [PATCH] exp_ch3.adb (Freeze_Type): Generate an accessibility check which ensures that the level of the subpool... 2011-08-29 Hristian Kirtchev * exp_ch3.adb (Freeze_Type): Generate an accessibility check which ensures that the level of the subpool access type is not deeper than that of the pool object. * sem_util.adb (Object_Access_Level): Expand to handle defining identifiers. * sem_res.adb (Resolve_Allocator): Add a guard to avoid examining the subpool handle name of a rewritten allocator. From-SVN: r178250 --- gcc/ada/ChangeLog | 10 ++++++++ gcc/ada/exp_ch3.adb | 61 +++++++++++++++++++++++++++++++++++++++++--- gcc/ada/sem_res.adb | 5 +++- gcc/ada/sem_util.adb | 10 ++++++-- 4 files changed, 79 insertions(+), 7 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b2f77e1fabb..acc215bcc9b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2011-08-29 Hristian Kirtchev + + * exp_ch3.adb (Freeze_Type): Generate an accessibility check which + ensures that the level of the subpool access type is not deeper than + that of the pool object. + * sem_util.adb (Object_Access_Level): Expand to handle defining + identifiers. + * sem_res.adb (Resolve_Allocator): Add a guard to avoid examining the + subpool handle name of a rewritten allocator. + 2011-08-29 Robert Dewar * impunit.adb, exp_ch4.adb, s-finmas.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 818653062f2..c0112b1d9b3 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6605,12 +6605,65 @@ package body Exp_Ch3 is -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" -- ---> Storage Pool is the specified one - elsif Present (Associated_Storage_Pool (Def_Id)) then + -- When compiling in Ada 2012 mode, ensure that the accessibility + -- level of the subpool access type is not deeper than that of the + -- pool_with_subpools. - -- Nothing to do the associated storage pool has been attached - -- when analyzing the representation clause. + elsif Ada_Version >= Ada_2012 + and then Present (Associated_Storage_Pool (Def_Id)) + then + declare + Loc : constant Source_Ptr := Sloc (Def_Id); + Pool : constant Entity_Id := + Associated_Storage_Pool (Def_Id); + RSPWS : constant Entity_Id := + RTE (RE_Root_Storage_Pool_With_Subpools); - null; + begin + -- It is known that the accessibility level of the access + -- type is deeper than that of the pool. + + if Type_Access_Level (Def_Id) > Object_Access_Level (Pool) + and then not Accessibility_Checks_Suppressed (Def_Id) + and then not Accessibility_Checks_Suppressed (Pool) + then + -- Static case: the pool is known to be a descendant of + -- Root_Storage_Pool_With_Subpools. + + if Is_Ancestor (RSPWS, Etype (Pool)) then + Error_Msg_N + ("?subpool access type has deeper accessibility " & + "level than pool", Def_Id); + + Append_Freeze_Action (Def_Id, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + + -- Dynamic case: when the pool is of a class-wide type, + -- it may or may not support subpools depending on the + -- path of derivation. Generate: + -- + -- if Def_Id in RSPWS'Class then + -- raise Program_Error; + -- end if; + + elsif Is_Class_Wide_Type (Etype (Pool)) then + Append_Freeze_Action (Def_Id, + Make_If_Statement (Loc, + Condition => + Make_In (Loc, + Left_Opnd => + New_Reference_To (Pool, Loc), + Right_Opnd => + New_Reference_To + (Class_Wide_Type (RSPWS), Loc)), + + Then_Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)))); + end if; + end if; + end; end if; -- For access-to-controlled types (including class-wide types and diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0b04142f9a9..3670221e0bb 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4397,9 +4397,12 @@ package body Sem_Res is -- Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task -- or a type containing tasks on a subpool since the deallocation of - -- the subpool may lead to undefined task behavior. + -- the subpool may lead to undefined task behavior. Perform the check + -- only when the allocator has not been converted into a Program_Error + -- due to a previous error. if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Allocator and then Present (Subpool_Handle_Name (N)) and then Has_Task (Desig_T) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index eab20bf9efe..6f2ac14283d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10696,8 +10696,14 @@ package body Sem_Util is -- Start of processing for Object_Access_Level begin - if Is_Entity_Name (Obj) then - E := Entity (Obj); + if Nkind (Obj) = N_Defining_Identifier + or else Is_Entity_Name (Obj) + then + if Nkind (Obj) = N_Defining_Identifier then + E := Obj; + else + E := Entity (Obj); + end if; if Is_Prival (E) then E := Prival_Link (E); -- 2.34.1