-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Establish_Task_Master (N : Node_Id) is
Call : Node_Id;
+
begin
if Restriction_Active (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
- Prepend_To (Declarations (N), Call);
+
+ -- The block may have no declarations, and nevertheless be a task
+ -- master, if it contains a call that may return an object that
+ -- contains tasks.
+
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List (Call));
+ else
+ Prepend_To (Declarations (N), Call);
+ end if;
+
Analyze (Call);
end if;
end Establish_Task_Master;
-- Target.Primitive (Param1, ..., ParamN);
-- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
- -- marked by pragma Implemented (XXX, By_Any) or not marked at all.
+ -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
+ -- at all.
-- declare
-- S : constant Offset_Index :=
function Build_Dispatching_Requeue_To_Any return Node_Id;
-- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
-- the form Concval.Ename. Ename is either marked by pragma Implemented
- -- (XXX, By_Any) or not marked at all. Create a block which determines
- -- at runtime whether Ename denotes an entry or a procedure and perform
- -- the appropriate kind of dispatching select.
+ -- (XXX, By_Any | Optional) or not marked at all. Create a block which
+ -- determines at runtime whether Ename denotes an entry or a procedure
+ -- and perform the appropriate kind of dispatching select.
function Build_Normal_Requeue return Node_Id;
-- N denotes a non-dispatching requeue statement to either a task or a
-- Process the entry wrapper's position in the primary dispatch
-- table parameter. Generate:
- -- Ada.Tags.Get_Offset_Index
- -- (Ada.Tags.Tag (Concval),
- -- <interface dispatch table position of Ename>)
+ -- Ada.Tags.Get_Entry_Index
+ -- (T => To_Tag_Ptr (Obj'Address).all,
+ -- Position =>
+ -- Ada.Tags.Get_Offset_Index
+ -- (Ada.Tags.Tag (Concval),
+ -- <interface dispatch table position of Ename>));
+
+ -- Note that Obj'Address is recursively expanded into a call to
+ -- Base_Address (Obj).
if Tagged_Type_Expansion then
Prepend_To (Params,
Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag), Concval),
- Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
+
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Concval),
+ Attribute_Name => Name_Address))),
+
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag), Concval),
+ Make_Integer_Literal (Loc,
+ DT_Position (Entity (Ename))))))));
-- VM targets
else
Prepend_To (Params,
Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
-
+ Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations => New_List (
- -- Obj_Typ
-
Make_Attribute_Reference (Loc,
Prefix => Concval,
Attribute_Name => Name_Tag),
- -- Tag_Typ
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Etype (Concval), Loc),
- Attribute_Name => Name_Tag),
+ Parameter_Associations => New_List (
+
+ -- Obj_Tag
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Concval,
+ Attribute_Name => Name_Tag),
- -- Position
+ -- Tag_Typ
- Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Etype (Concval), Loc),
+ Attribute_Name => Name_Tag),
+
+ -- Position
+
+ Make_Integer_Literal (Loc,
+ DT_Position (Entity (Ename))))))));
end if;
-- Specific actuals for protected to XXX requeue
-- Generate:
-- _Disp_Requeue (<Params>);
- return
- Make_Procedure_Call_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uDisp_Requeue),
- Parameter_Associations => Params);
+ -- Find entity for Disp_Requeue operation, which belongs to
+ -- the type and may not be directly visible.
+
+ declare
+ Elmt : Elmt_Id;
+ Op : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
+ while Present (Elmt) loop
+ Op := Node (Elmt);
+ exit when Chars (Op) = Name_uDisp_Requeue;
+ Next_Elmt (Elmt);
+ end loop;
+
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Op, Loc),
+ Parameter_Associations => Params);
+ end;
end Build_Dispatching_Requeue;
--------------------------------------
Extract_Entry (N, Concval, Ename, Index);
Conc_Typ := Etype (Concval);
+ -- If the prefix is an access to class-wide type, dereference to get
+ -- object and entry type.
+
+ if Is_Access_Type (Conc_Typ) then
+ Conc_Typ := Designated_Type (Conc_Typ);
+ Rewrite (Concval,
+ Make_Explicit_Dereference (Loc, Relocate_Node (Concval)));
+ Analyze_And_Resolve (Concval, Conc_Typ);
+ end if;
+
-- Examine the scope stack in order to find nearest enclosing protected
-- or task type. This will constitute our invocation source.
Analyze (N);
-- The procedure_or_entry_NAME's implementation kind is either
- -- By_Any or pragma Implemented was not applied at all. In this
- -- case a runtime test determines whether Ename denotes an entry
- -- or a protected procedure and performs the appropriate call.
+ -- By_Any, Optional, or pragma Implemented was not applied at all.
+ -- In this case a runtime test determines whether Ename denotes an
+ -- entry or a protected procedure and performs the appropriate
+ -- call.
else
Rewrite (N, Build_Dispatching_Requeue_To_Any);
OSDN Git Service
