diff options
| author | Hristian Kirtchev <kirtchev@adacore.com> | 2011-08-29 14:33:59 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-08-29 16:33:59 +0200 |
| commit | dfbcb149aa59ef88a254489d2c3aa9c105562490 (patch) | |
| tree | a07b86492502d6456c8681c157ab94574bcfd064 /gcc/ada/exp_ch3.adb | |
| parent | 1df4f514fac3b17c52bb283fcc52daf3d19c26e7 (diff) | |
| download | gcc-dfbcb149aa59ef88a254489d2c3aa9c105562490.zip gcc-dfbcb149aa59ef88a254489d2c3aa9c105562490.tar.gz gcc-dfbcb149aa59ef88a254489d2c3aa9c105562490.tar.bz2 | |
exp_ch3.adb (Freeze_Type): Generate an accessibility check which ensures that the level of the subpool...
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* 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
Diffstat (limited to 'gcc/ada/exp_ch3.adb')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 61 |
1 files changed, 57 insertions, 4 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8186530..c0112b1 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 |