[Ada] Ada2020: AI12-0107 convention of By_Protected_Procedure
gcc/ada/ * exp_attr.adb (Has_By_Protected_Procedure_Prefixed_View): New subprogram. (Expand_Access_To_Protected_Op): Adding support for prefixed class-wide view with By_Protected_Procedure convention. * sem_attr.adb (Get_Convention): New subprogram. (Get_Kind): Adapted to use Get_Convention. * sem_ch4.adb (Try_By_Protected_Procedure_Prefixed_View): New subprogram. (Analyze_Selected_Component): Invoke Try_By_Protected_Procedure_Prefixed_View. * sem_util.ads (Is_By_Protected_Procedure): New subprogram. * sem_util.adb (Is_By_Protected_Procedure): New subprogram.
This commit is contained in:
Javier Miranda
Pierre-Marie de Rodat
parent
e4a99831f4
commit
d9206abba7
@ -941,7 +941,30 @@ package body Exp_Attr is
|
||||
is
|
||||
-- The value of the attribute_reference is a record containing two
|
||||
-- fields: an access to the protected object, and an access to the
|
||||
-- subprogram itself. The prefix is a selected component.
|
||||
-- subprogram itself. The prefix is an identifier or a selected
|
||||
-- component.
|
||||
|
||||
function Has_By_Protected_Procedure_Prefixed_View return Boolean;
|
||||
-- Determine whether Pref denotes the prefixed class-wide interface
|
||||
-- view of a procedure with synchronization kind By_Protected_Procedure.
|
||||
|
||||
----------------------------------------------
|
||||
-- Has_By_Protected_Procedure_Prefixed_View --
|
||||
----------------------------------------------
|
||||
|
||||
function Has_By_Protected_Procedure_Prefixed_View return Boolean is
|
||||
begin
|
||||
return Nkind (Pref) = N_Selected_Component
|
||||
and then Nkind (Prefix (Pref)) in N_Has_Entity
|
||||
and then Present (Entity (Prefix (Pref)))
|
||||
and then Is_Class_Wide_Type (Etype (Entity (Prefix (Pref))))
|
||||
and then (Is_Synchronized_Interface (Etype (Entity (Prefix (Pref))))
|
||||
or else
|
||||
Is_Protected_Interface (Etype (Entity (Prefix (Pref)))))
|
||||
and then Is_By_Protected_Procedure (Entity (Selector_Name (Pref)));
|
||||
end Has_By_Protected_Procedure_Prefixed_View;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Agg : Node_Id;
|
||||
@ -1015,6 +1038,23 @@ package body Exp_Attr is
|
||||
Attribute_Name => Name_Address);
|
||||
end if;
|
||||
|
||||
elsif Has_By_Protected_Procedure_Prefixed_View then
|
||||
Obj_Ref :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => Relocate_Node (Prefix (Pref)),
|
||||
Attribute_Name => Name_Address);
|
||||
|
||||
-- Analyze the object address with expansion disabled. Required
|
||||
-- because its expansion would displace the pointer to the object,
|
||||
-- which is not correct at this stage since the object type is a
|
||||
-- class-wide interface type and we are dispatching a call to a
|
||||
-- thunk (which would erroneously displace the pointer again).
|
||||
|
||||
Expander_Mode_Save_And_Set (False);
|
||||
Analyze (Obj_Ref);
|
||||
Set_Analyzed (Obj_Ref);
|
||||
Expander_Mode_Restore;
|
||||
|
||||
-- Case where the prefix is not an entity name. Find the
|
||||
-- version of the protected operation to be called from
|
||||
-- outside the protected object.
|
||||
@ -1031,26 +1071,64 @@ package body Exp_Attr is
|
||||
Attribute_Name => Name_Address);
|
||||
end if;
|
||||
|
||||
Sub_Ref :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => Sub,
|
||||
Attribute_Name => Name_Access);
|
||||
if Has_By_Protected_Procedure_Prefixed_View then
|
||||
declare
|
||||
Ctrl_Tag : Node_Id := Duplicate_Subexpr (Prefix (Pref));
|
||||
Prim_Addr : Node_Id;
|
||||
Subp : constant Entity_Id := Entity (Selector_Name (Pref));
|
||||
Typ : constant Entity_Id :=
|
||||
Etype (Etype (Entity (Prefix (Pref))));
|
||||
begin
|
||||
-- The target subprogram is a thunk; retrieve its address from
|
||||
-- its secondary dispatch table slot.
|
||||
|
||||
-- We set the type of the access reference to the already generated
|
||||
-- access_to_subprogram type, and declare the reference analyzed, to
|
||||
-- prevent further expansion when the enclosing aggregate is analyzed.
|
||||
Build_Get_Prim_Op_Address (Loc,
|
||||
Typ => Typ,
|
||||
Tag_Node => Ctrl_Tag,
|
||||
Position => DT_Position (Subp),
|
||||
New_Node => Prim_Addr);
|
||||
|
||||
Set_Etype (Sub_Ref, Acc);
|
||||
Set_Analyzed (Sub_Ref);
|
||||
-- Mark the access to the target subprogram as an access to the
|
||||
-- dispatch table and perform an unchecked type conversion to such
|
||||
-- access type. This is required to allow the backend to properly
|
||||
-- identify and handle the access to the dispatch table slot on
|
||||
-- targets where the dispatch table contains descriptors (instead
|
||||
-- of pointers).
|
||||
|
||||
Agg :=
|
||||
Make_Aggregate (Loc,
|
||||
Expressions => New_List (Obj_Ref, Sub_Ref));
|
||||
Set_Is_Dispatch_Table_Entity (Acc);
|
||||
Sub_Ref := Unchecked_Convert_To (Acc, Prim_Addr);
|
||||
Analyze (Sub_Ref);
|
||||
|
||||
-- Sub_Ref has been marked as analyzed, but we still need to make sure
|
||||
-- Sub is correctly frozen.
|
||||
Agg :=
|
||||
Make_Aggregate (Loc,
|
||||
Expressions => New_List (Obj_Ref, Sub_Ref));
|
||||
end;
|
||||
|
||||
Freeze_Before (N, Entity (Sub));
|
||||
-- Common case
|
||||
|
||||
else
|
||||
Sub_Ref :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => Sub,
|
||||
Attribute_Name => Name_Access);
|
||||
|
||||
-- We set the type of the access reference to the already generated
|
||||
-- access_to_subprogram type, and declare the reference analyzed,
|
||||
-- to prevent further expansion when the enclosing aggregate is
|
||||
-- analyzed.
|
||||
|
||||
Set_Etype (Sub_Ref, Acc);
|
||||
Set_Analyzed (Sub_Ref);
|
||||
|
||||
Agg :=
|
||||
Make_Aggregate (Loc,
|
||||
Expressions => New_List (Obj_Ref, Sub_Ref));
|
||||
|
||||
-- Sub_Ref has been marked as analyzed, but we still need to make
|
||||
-- sure Sub is correctly frozen.
|
||||
|
||||
Freeze_Before (N, Entity (Sub));
|
||||
end if;
|
||||
|
||||
Rewrite (N, Agg);
|
||||
Analyze_And_Resolve (N, E_T);
|
||||
|
||||
@ -650,7 +650,8 @@ package body Sem_Attr is
|
||||
-- tracked value. If the scope is a loop or block, indicate that
|
||||
-- value tracking is disabled for the enclosing subprogram.
|
||||
|
||||
function Get_Kind (E : Entity_Id) return Entity_Kind;
|
||||
function Get_Convention (E : Entity_Id) return Convention_Id;
|
||||
function Get_Kind (E : Entity_Id) return Entity_Kind;
|
||||
-- Distinguish between access to regular/protected subprograms
|
||||
|
||||
------------------------
|
||||
@ -666,13 +667,33 @@ package body Sem_Attr is
|
||||
end if;
|
||||
end Check_Local_Access;
|
||||
|
||||
--------------------
|
||||
-- Get_Convention --
|
||||
--------------------
|
||||
|
||||
function Get_Convention (E : Entity_Id) return Convention_Id is
|
||||
begin
|
||||
-- Restrict handling by_protected_procedure access subprograms
|
||||
-- to source entities; required to avoid building access to
|
||||
-- subprogram types with convention protected when building
|
||||
-- dispatch tables.
|
||||
|
||||
if Comes_From_Source (P)
|
||||
and then Is_By_Protected_Procedure (E)
|
||||
then
|
||||
return Convention_Protected;
|
||||
else
|
||||
return Convention (E);
|
||||
end if;
|
||||
end Get_Convention;
|
||||
|
||||
--------------
|
||||
-- Get_Kind --
|
||||
--------------
|
||||
|
||||
function Get_Kind (E : Entity_Id) return Entity_Kind is
|
||||
begin
|
||||
if Convention (E) = Convention_Protected then
|
||||
if Get_Convention (E) = Convention_Protected then
|
||||
return E_Access_Protected_Subprogram_Type;
|
||||
else
|
||||
return E_Access_Subprogram_Type;
|
||||
@ -717,7 +738,7 @@ package body Sem_Attr is
|
||||
Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
|
||||
Set_Is_Public (Acc_Type, False);
|
||||
Set_Etype (Acc_Type, Acc_Type);
|
||||
Set_Convention (Acc_Type, Convention (Entity (P)));
|
||||
Set_Convention (Acc_Type, Get_Convention (Entity (P)));
|
||||
Set_Directly_Designated_Type (Acc_Type, Entity (P));
|
||||
Set_Etype (N, Acc_Type);
|
||||
Freeze_Before (N, Acc_Type);
|
||||
@ -732,7 +753,7 @@ package body Sem_Attr is
|
||||
Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
|
||||
Set_Is_Public (Acc_Type, False);
|
||||
Set_Etype (Acc_Type, Acc_Type);
|
||||
Set_Convention (Acc_Type, Convention (It.Nam));
|
||||
Set_Convention (Acc_Type, Get_Convention (It.Nam));
|
||||
Set_Directly_Designated_Type (Acc_Type, It.Nam);
|
||||
Add_One_Interp (N, Acc_Type, Acc_Type);
|
||||
Freeze_Before (N, Acc_Type);
|
||||
|
||||
@ -4476,6 +4476,13 @@ package body Sem_Ch4 is
|
||||
-- Check whether prefix includes a dereference, explicit or implicit,
|
||||
-- at any recursive level.
|
||||
|
||||
function Try_By_Protected_Procedure_Prefixed_View return Boolean;
|
||||
-- Return True if N is an access attribute whose prefix is a prefixed
|
||||
-- class-wide (synchronized or protected) interface view for which some
|
||||
-- interpretation is a procedure with synchronization kind By_Protected
|
||||
-- _Procedure, and collect all its interpretations (since it may be an
|
||||
-- overloaded interface primitive); otherwise return False.
|
||||
|
||||
--------------------------------
|
||||
-- Find_Component_In_Instance --
|
||||
--------------------------------
|
||||
@ -4597,6 +4604,65 @@ package body Sem_Ch4 is
|
||||
end if;
|
||||
end Has_Dereference;
|
||||
|
||||
----------------------------------------------
|
||||
-- Try_By_Protected_Procedure_Prefixed_View --
|
||||
----------------------------------------------
|
||||
|
||||
function Try_By_Protected_Procedure_Prefixed_View return Boolean is
|
||||
Candidate : Node_Id := Empty;
|
||||
Elmt : Elmt_Id;
|
||||
Prim : Node_Id;
|
||||
|
||||
begin
|
||||
if Nkind (Parent (N)) = N_Attribute_Reference
|
||||
and then Nam_In (Attribute_Name (Parent (N)),
|
||||
Name_Access,
|
||||
Name_Unchecked_Access,
|
||||
Name_Unrestricted_Access)
|
||||
and then Is_Class_Wide_Type (Prefix_Type)
|
||||
and then (Is_Synchronized_Interface (Prefix_Type)
|
||||
or else Is_Protected_Interface (Prefix_Type))
|
||||
then
|
||||
-- If we have not found yet any interpretation then mark this
|
||||
-- one as the first interpretation (cf. Add_One_Interp).
|
||||
|
||||
if No (Etype (Sel)) then
|
||||
Set_Etype (Sel, Any_Type);
|
||||
end if;
|
||||
|
||||
Elmt := First_Elmt (Primitive_Operations (Etype (Prefix_Type)));
|
||||
while Present (Elmt) loop
|
||||
Prim := Node (Elmt);
|
||||
|
||||
if Chars (Prim) = Chars (Sel)
|
||||
and then Is_By_Protected_Procedure (Prim)
|
||||
then
|
||||
Candidate := New_Copy (Prim);
|
||||
|
||||
-- Skip the controlling formal; required to check type
|
||||
-- conformance of the target access to protected type
|
||||
-- (see Conforming_Types).
|
||||
|
||||
Set_First_Entity (Candidate,
|
||||
Next_Entity (First_Entity (Prim)));
|
||||
|
||||
Add_One_Interp (Sel, Candidate, Etype (Prim));
|
||||
Set_Etype (N, Etype (Prim));
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Propagate overloaded attribute
|
||||
|
||||
if Present (Candidate) and then Is_Overloaded (Sel) then
|
||||
Set_Is_Overloaded (N);
|
||||
end if;
|
||||
|
||||
return Present (Candidate);
|
||||
end Try_By_Protected_Procedure_Prefixed_View;
|
||||
|
||||
-- Start of processing for Analyze_Selected_Component
|
||||
|
||||
begin
|
||||
@ -4892,6 +4958,9 @@ package body Sem_Ch4 is
|
||||
return;
|
||||
end if;
|
||||
|
||||
elsif Try_By_Protected_Procedure_Prefixed_View then
|
||||
return;
|
||||
|
||||
elsif Try_Object_Operation (N) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
@ -14565,6 +14565,17 @@ package body Sem_Util is
|
||||
Is_RTE (Root_Type (Under), RO_WW_Super_String));
|
||||
end Is_Bounded_String;
|
||||
|
||||
-------------------------------
|
||||
-- Is_By_Protected_Procedure --
|
||||
-------------------------------
|
||||
|
||||
function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is
|
||||
begin
|
||||
return Ekind (Id) = E_Procedure
|
||||
and then Present (Get_Rep_Pragma (Id, Name_Implemented))
|
||||
and then Implementation_Kind (Id) = Name_By_Protected_Procedure;
|
||||
end Is_By_Protected_Procedure;
|
||||
|
||||
---------------------
|
||||
-- Is_CCT_Instance --
|
||||
---------------------
|
||||
|
||||
@ -1640,6 +1640,10 @@ package Sem_Util is
|
||||
-- True if T is a bounded string type. Used to make sure "=" composes
|
||||
-- properly for bounded string types.
|
||||
|
||||
function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean;
|
||||
-- Determine whether entity Id denotes a procedure with synchronization
|
||||
-- kind By_Protected_Procedure.
|
||||
|
||||
function Is_Constant_Bound (Exp : Node_Id) return Boolean;
|
||||
-- Exp is the expression for an array bound. Determines whether the
|
||||
-- bound is a compile-time known value, or a constant entity, or an
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user