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;
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.
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.
+
+ Build_Get_Prim_Op_Address (Loc,
+ Typ => Typ,
+ Tag_Node => Ctrl_Tag,
+ Position => DT_Position (Subp),
+ New_Node => Prim_Addr);
+
+ -- 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).
+
+ Set_Is_Dispatch_Table_Entity (Acc);
+ Sub_Ref := Unchecked_Convert_To (Acc, Prim_Addr);
+ Analyze (Sub_Ref);
+
+ Agg :=
+ Make_Aggregate (Loc,
+ Expressions => New_List (Obj_Ref, Sub_Ref));
+ end;
+
+ -- Common case
- -- 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.
+ else
+ Sub_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Sub,
+ Attribute_Name => Name_Access);
- Set_Etype (Sub_Ref, Acc);
- Set_Analyzed (Sub_Ref);
+ -- 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.
- Agg :=
- Make_Aggregate (Loc,
- Expressions => New_List (Obj_Ref, Sub_Ref));
+ Set_Etype (Sub_Ref, Acc);
+ Set_Analyzed (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));
- Freeze_Before (N, Entity (Sub));
+ -- 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);
-- 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
------------------------
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;
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);
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);
-- 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 --
--------------------------------
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
return;
end if;
+ elsif Try_By_Protected_Procedure_Prefixed_View then
+ return;
+
elsif Try_Object_Operation (N) then
return;
end if;
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 --
---------------------
-- 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
projects / gcc.git / commitdiff