OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] universal_access equality and 'Access attributes

Browse Source 
2020-06-19  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	* sem_ch4.adb (Find_Equality_Types.Check_Access_Attribute): New.
	(Find_Equality_Types): Move universal_access related checks at
	the end of the processing and add call to
	Check_Access_Attribute.
This commit is contained in:
Arnaud Charlet 2020-04-26 06:08:29 -04:00 committed by Pierre-Marie de Rodat
parent a5835f3044
commit 7a022cc933
1 changed files with 49 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
gcc/ada/sem_ch4.adb
View File

@ -6540,12 +6540,24 @@ package body Sem_Ch4 is
Op_Id : Entity_Id;
N : Node_Id)
is
Index : Interp_Index := 0;
It : Interp;
Found : Boolean := False;
I_F : Interp_Index;
T_F : Entity_Id;
Scop : Entity_Id := Empty;
Index : Interp_Index := 0;
It : Interp;
Found : Boolean := False;
Is_Universal_Access : Boolean := False;
I_F : Interp_Index;
T_F : Entity_Id;
Scop : Entity_Id := Empty;
procedure Check_Access_Attribute (N : Node_Id);
-- For any object, '[Unchecked_]Access of such object can never be
-- passed as a parameter of a call to the Universal_Access equality
-- operator.
-- This is because the expected type for Obj'Access in a call to
-- the Standard."=" operator whose formals are of type
-- Universal_Access is Universal_Integer, and Universal_Access
-- doesn't have a designated type. For more detail see RM 6.4.1(3)
-- and 3.10.2.
-- This procedure assumes that the context is a universal_access.
function Check_Access_Object_Types
(N : Node_Id; Typ : Entity_Id) return Boolean;
@ -6574,6 +6586,23 @@ package body Sem_Ch4 is
-- and an error can be emitted now, after trying to disambiguate, i.e.
-- applying preference rules.
----------------------------
-- Check_Access_Attribute --
----------------------------
procedure Check_Access_Attribute (N : Node_Id) is
begin
if Nkind (N) = N_Attribute_Reference
and then Nam_In (Attribute_Name (N),
Name_Access,
Name_Unchecked_Access)
then
Error_Msg_N
("access attribute cannot be used as actual for "
& "universal_access equality", N);
end if;
end Check_Access_Attribute;
-------------------------------
-- Check_Access_Object_Types --
-------------------------------
@ -6867,14 +6896,6 @@ package body Sem_Ch4 is
and then (not Universal_Access
or else Check_Access_Object_Types (R, T1))
then
if Universal_Access
and then Is_Access_Subprogram_Type (T1)
and then Nkind (L) /= N_Null
and then Nkind (R) /= N_Null
then
Check_Compatible_Profiles (R, T1);
end if;
if Found
and then Base_Type (T1) /= Base_Type (T_F)
then
@ -6887,12 +6908,14 @@ package body Sem_Ch4 is
else
T_F := It.Typ;
Is_Universal_Access := Universal_Access;
end if;
else
Found := True;
T_F := T1;
I_F := Index;
Is_Universal_Access := Universal_Access;
end if;
if not Analyzed (L) then
@ -6947,6 +6970,18 @@ package body Sem_Ch4 is
Get_Next_Interp (Index, It);
end loop;
end if;
if Is_Universal_Access then
if Is_Access_Subprogram_Type (Etype (L))
and then Nkind (L) /= N_Null
and then Nkind (R) /= N_Null
then
Check_Compatible_Profiles (R, Etype (L));
end if;
Check_Access_Attribute (R);
Check_Access_Attribute (L);
end if;
end Find_Equality_Types;
-------------------------