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;
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
end if;
Analyze (Rnode);
- Set_Associated_Storage_Pool (U_Ent, Pool);
+ Associate_Storage_Pool (U_Ent, Pool);
end;
elsif Is_Entity_Name (Expr) then
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);
projects / gcc.git / commitdiff