From d0f6dd47fd7744835f6f2dde4394a5c7a41fe895 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sat, 30 May 2020 14:04:33 -0400 Subject: [PATCH] [Ada] ACATS 4.1P [BDB4001] - 13.11.4(22-23/3) not enforced gcc/ada/ * exp_ch3.adb (Freeze_Type): Remove warning in expander, replaced by a corresponding error in sem_ch13.adb. Replace RTE_Available by RTU_Loaded to avoid adding unnecessary dependencies. * sem_ch13.adb (Associate_Storage_Pool): New procedure. (Analyze_Attribute_Definition_Clause [Attribute_Simple_Storage_Pool| Attribute_Storage_Pool]): Call Associate_Storage_Pool to add proper legality checks on subpools. --- gcc/ada/exp_ch3.adb | 55 ++++++++--------------- gcc/ada/sem_ch13.adb | 121 +++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 137 insertions(+), 39 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 705da58..d90bbad 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8148,61 +8148,44 @@ package body Exp_Ch3 is elsif Ada_Version >= Ada_2012 and then Present (Associated_Storage_Pool (Def_Id)) - - -- Omit this check for the case of a configurable run-time that - -- does not provide package System.Storage_Pools.Subpools. - - and then RTE_Available (RE_Root_Storage_Pool_With_Subpools) + and then RTU_Loaded (System_Storage_Pools_Subpools) 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); 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 Is_Class_Wide_Type (Etype (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: + -- 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_Occurrence_Of (Pool, Loc), - Right_Opnd => - New_Occurrence_Of - (Class_Wide_Type (RSPWS), Loc)), - - Then_Statements => New_List ( - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)))); - end if; + Append_Freeze_Action (Def_Id, + Make_If_Statement (Loc, + Condition => + Make_In (Loc, + Left_Opnd => New_Occurrence_Of (Pool, Loc), + Right_Opnd => + New_Occurrence_Of + (Class_Wide_Type + (RTE + (RE_Root_Storage_Pool_With_Subpools)), + Loc)), + Then_Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)))); end if; end; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5c3cc48..7445536 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7044,6 +7044,121 @@ package body Sem_Ch13 is Pool : Entity_Id; T : Entity_Id; + procedure Associate_Storage_Pool + (Ent : Entity_Id; Pool : Entity_Id); + -- Associate Pool to Ent and perform legality checks on subpools + + ---------------------------- + -- Associate_Storage_Pool -- + ---------------------------- + + procedure Associate_Storage_Pool + (Ent : Entity_Id; Pool : Entity_Id) + is + function Object_From (Pool : Entity_Id) return Entity_Id; + -- Return the entity of which Pool is a part of + + ----------------- + -- Object_From -- + ----------------- + + function Object_From + (Pool : Entity_Id) return Entity_Id + is + N : Node_Id := Pool; + begin + if Present (Renamed_Object (Pool)) then + N := Renamed_Object (Pool); + end if; + + while Present (N) loop + case Nkind (N) is + when N_Defining_Identifier => + return N; + + when N_Identifier | N_Expanded_Name => + return Entity (N); + + when N_Indexed_Component | N_Selected_Component | + N_Explicit_Dereference + => + N := Prefix (N); + + when N_Type_Conversion => + N := Expression (N); + + when others => + -- ??? we probably should handle more cases but + -- this is good enough in practice for this check + -- on a corner case. + + return Empty; + end case; + end loop; + + return Empty; + end Object_From; + + Obj : Entity_Id; + + begin + Set_Associated_Storage_Pool (Ent, Pool); + + -- Check RM 13.11.4(22-23/3): a specification of a storage pool + -- is illegal if the storage pool supports subpools and: + -- (A) The access type is a general access type. + -- (B) The access type is statically deeper than the storage + -- pool object; + -- (C) The storage pool object is a part of a formal parameter; + -- (D) The storage pool object is a part of the dereference of + -- a non-library level general access type; + + if Ada_Version >= Ada_2012 + and then RTU_Loaded (System_Storage_Pools_Subpools) + and then + Is_Ancestor (RTE (RE_Root_Storage_Pool_With_Subpools), + Etype (Pool)) + then + -- check (A) + + if Ekind (Etype (Ent)) = E_General_Access_Type then + Error_Msg_N + ("subpool cannot be used on general access type", Ent); + end if; + + -- check (B) + + if Type_Access_Level (Ent) > Object_Access_Level (Pool) then + Error_Msg_N + ("subpool access type has deeper accessibility " + & "level than pool", Ent); + return; + end if; + + Obj := Object_From (Pool); + + -- check (C) + + if Present (Obj) and then Ekind (Obj) in Formal_Kind then + Error_Msg_N + ("subpool cannot be part of a parameter", Ent); + return; + end if; + + -- check (D) + + if Present (Obj) + and then Ekind (Etype (Obj)) = E_General_Access_Type + and then not Is_Library_Level_Entity (Etype (Obj)) + then + Error_Msg_N + ("subpool cannot be part of the dereference of a " & + "nested general access type", Ent); + return; + end if; + end if; + end Associate_Storage_Pool; + begin if Ekind (U_Ent) = E_Access_Subprogram_Type then Error_Msg_N @@ -7167,7 +7282,7 @@ package body Sem_Ch13 is end if; Analyze (Rnode); - Set_Associated_Storage_Pool (U_Ent, Pool); + Associate_Storage_Pool (U_Ent, Pool); end; elsif Is_Entity_Name (Expr) then @@ -7189,14 +7304,14 @@ package body Sem_Ch13 is Pool := Entity (Expression (Renamed_Object (Pool))); end if; - Set_Associated_Storage_Pool (U_Ent, Pool); + Associate_Storage_Pool (U_Ent, Pool); elsif Nkind (Expr) = N_Type_Conversion and then Is_Entity_Name (Expression (Expr)) and then Nkind (Original_Node (Expr)) = N_Attribute_Reference then Pool := Entity (Expression (Expr)); - Set_Associated_Storage_Pool (U_Ent, Pool); + Associate_Storage_Pool (U_Ent, Pool); else Error_Msg_N ("incorrect reference to a Storage Pool", Expr); -- 2.7.4