[Ada] Implementation of Ada 2012 AI05-0030: Requeue on synchronized interfaces
Arnaud Charlet
charlet@adacore.com
Fri Oct 8 10:11:00 GMT 2010
This patch integrates the new syntax, legality rules, static semantics, name
resolution rules and runtime mechanism associated with dispatching requeue
statements where the procedure_or_entry_NAME denotes a primitive procedure of a
synchronized interface.
-------------
-- Sources --
-------------
-- by_any.ads
package By_Any is
type Synch_Iface is synchronized interface;
procedure A
(Obj : in out Synch_Iface;
Tar : in out Synch_Iface'Class;
Int : Integer) is abstract;
pragma Implemented (A, By_Any);
protected type Prot_Typ is new Synch_Iface with
procedure A (Tar : in out Synch_Iface'Class; Int : Integer);
end Prot_Typ;
task type Task_Typ is new Synch_Iface with
entry A (Tar : in out Synch_Iface'Class; Int : Integer);
end Task_Typ;
protected type Prot_Requeuer is
entry Do_Requeue (Tar : in out Synch_Iface'Class; Int : Integer);
end Prot_Requeuer;
end By_Any;
-- by_any.adb
with Ada.Text_IO; use Ada.Text_IO;
package body By_Any is
protected body Prot_Typ is
procedure A (Tar : in out Synch_Iface'Class; Int : Integer) is
begin
Put_Line (" Prot_Typ.A" & Int'Img);
end A;
end Prot_Typ;
task body Task_Typ is
begin
accept A (Tar : in out Synch_Iface'Class; Int : Integer) do
Put_Line (" Task_Typ.A" & Int'Img);
end A;
end Task_Typ;
protected body Prot_Requeuer is
entry Do_Requeue
(Tar : in out Synch_Iface'Class;
Int : Integer) when True
is
begin
Put_Line (" Prot_Requeuer.Do_Requeue");
requeue Tar.A;
end Do_Requeue;
end Prot_Requeuer;
end By_Any;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with By_Any; use By_Any;
procedure Main is
begin
declare
Obj : Prot_Typ;
Prot_Req : Prot_Requeuer;
begin
Put_Line ("Requeue protected to protected");
Prot_Req.Do_Requeue (Obj, 1);
end;
declare
Obj : Task_Typ;
Prot_Req : Prot_Requeuer;
begin
Put_Line ("Requeue protected to task");
Prot_Req.Do_Requeue (Obj, 2);
end;
end Main;
-----------------
-- Compilation --
-----------------
gnatmake -q -gnat12 main.adb
--------------------------
-- Execution and output --
--------------------------
./main
Requeue protected to protected
Prot_Requeuer.Do_Requeue
Prot_Typ.A 1
Requeue protected to task
Prot_Requeuer.Do_Requeue
Task_Typ.A 2
Tested on x86_64-pc-linux-gnu, committed on trunk
2010-10-08 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb: Flag 232 (formerly Implemented_By_Entry) is now unused.
(Implemented_By_Entry): Removed.
(Set_Implemented_By_Entry): Removed.
(Write_Entity_Flags): Remove the output for Implemented_By_Entry.
* einfo.ads: Remove flag Implemented_By_Entry and its usage in entities.
(Implemented_By_Entry): Removed along with its associated pragma Inline.
(Set_Implemented_By_Entry): Removed along with its associated pragma
Inline.
* exp_ch9.adb: Alphabetize with and use clauses of Exp_Ch9.
(Build_Dispatching_Call_Equivalent): New routine.
(Build_Dispatching_Requeue): New routine.
(Build_Dispatching_Requeue_To_Any): New routine.
(Build_Normal_Requeue): New routine.
(Build_Skip_Statement): New routine.
(Expand_N_Requeue_Statement): Rewritten. The logic has been split into
several subroutines.
* par-prag.adb: Replace Pragma_Implemented_By_Entry by
Pragma_Implemented.
* sem_ch3.adb (Check_Abstract_Overriding): Perform checks concerning
pragma Implemented.
(Check_Pragma_Implemented): New routines.
(Inherit_Pragma_Implemented): New routine.
* sem_ch9.adb (Analyze_Requeue): Update the predicate which detects a
dispatching requeue.
* sem_prag.adb: Update array Sig_Flags by removing Implemented_By_Entry
and adding Implemented.
(Ada_2012_Pragma): New routine.
(Analyze_Pragma, case Implemented): Perform all necessary checks
concerning pragma Implemented and register the pragma as a
representation item with the procedure_LOCAL_NAME.
(Analyze_Pragma, case Implemented_By_Entry): Removed.
* sem_util.adb (Implementation_Kind): New routine.
* sem_util.ads (Implementation_Kind): New routine.
* snames.ads-tmpl: Remove Name_Implemented_By_Entry and add
Name_Implemented. Remove pragma name Pragma_Implemented_By_Entry and
add Pragma_Implemented. Add special names By_Any, By_Entry and
By_Protected_Procedure.
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 165082)
+++ sem_ch3.adb (working copy)
@@ -8375,6 +8375,155 @@ package body Sem_Ch3 is
Subp : Entity_Id;
Type_Def : Node_Id;
+ procedure Check_Pragma_Implemented (Subp : Entity_Id);
+ -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine
+ -- which has pragma Implemented already set. Check whether Subp's entity
+ -- kind conforms to the implementation kind of the overridden routine.
+
+ procedure Check_Pragma_Implemented
+ (Subp : Entity_Id;
+ Iface_Subp : Entity_Id);
+ -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine
+ -- Iface_Subp and both entities have pragma Implemented already set on
+ -- them. Check whether the two implementation kinds are conforming.
+
+ procedure Inherit_Pragma_Implemented
+ (Subp : Entity_Id;
+ Iface_Subp : Entity_Id);
+ -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface
+ -- subprogram Iface_Subp which has been marked by pragma Implemented.
+ -- Propagate the implementation kind of Iface_Subp to Subp.
+
+ ------------------------------
+ -- Check_Pragma_Implemented --
+ ------------------------------
+
+ procedure Check_Pragma_Implemented (Subp : Entity_Id) is
+ Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
+ Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
+ Contr_Typ : Entity_Id;
+
+ begin
+ -- Subp must have an alias since it is a hidden entity used to link
+ -- an interface subprogram to its overriding counterpart.
+
+ pragma Assert (Present (Alias (Subp)));
+
+ -- Extract the type of the controlling formal
+
+ Contr_Typ := Etype (First_Formal (Alias (Subp)));
+
+ if Is_Concurrent_Record_Type (Contr_Typ) then
+ Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
+ end if;
+
+ -- An interface subprogram whose implementation kind is By_Entry must
+ -- be implemented by an entry.
+
+ if Impl_Kind = Name_By_Entry
+ and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
+ then
+ Error_Msg_Node_2 := Iface_Alias;
+ Error_Msg_NE
+ ("type & must implement abstract subprogram & with an entry",
+ Alias (Subp), Contr_Typ);
+
+ elsif Impl_Kind = Name_By_Protected_Procedure then
+
+ -- An interface subprogram whose implementation kind is By_
+ -- Protected_Procedure cannot be implemented by a primitive
+ -- procedure of a task type.
+
+ if Ekind (Contr_Typ) /= E_Protected_Type then
+ Error_Msg_Node_2 := Contr_Typ;
+ Error_Msg_NE
+ ("interface subprogram & cannot be implemented by a " &
+ "primitive procedure of task type &", Alias (Subp),
+ Iface_Alias);
+
+ -- An interface subprogram whose implementation kind is By_
+ -- Protected_Procedure must be implemented by a procedure.
+
+ elsif Is_Primitive_Wrapper (Alias (Subp))
+ and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
+ then
+ Error_Msg_Node_2 := Iface_Alias;
+ Error_Msg_NE
+ ("type & must implement abstract subprogram & with a " &
+ "procedure", Alias (Subp), Contr_Typ);
+ end if;
+ end if;
+ end Check_Pragma_Implemented;
+
+ ------------------------------
+ -- Check_Pragma_Implemented --
+ ------------------------------
+
+ procedure Check_Pragma_Implemented
+ (Subp : Entity_Id;
+ Iface_Subp : Entity_Id)
+ is
+ Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp);
+ Subp_Kind : constant Name_Id := Implementation_Kind (Subp);
+
+ begin
+ -- Ada 2012 (AI05-0030): The implementation kinds of an overridden
+ -- and overriding subprogram are different. In general this is an
+ -- error except when the implementation kind of the overridden
+ -- subprograms is By_Any.
+
+ if Iface_Kind /= Subp_Kind
+ and then Iface_Kind /= Name_By_Any
+ then
+ if Iface_Kind = Name_By_Entry then
+ Error_Msg_N
+ ("incompatible implementation kind, overridden subprogram " &
+ "is marked By_Entry", Subp);
+ else
+ Error_Msg_N
+ ("incompatible implementation kind, overridden subprogram " &
+ "is marked By_Protected_Procedure", Subp);
+ end if;
+ end if;
+ end Check_Pragma_Implemented;
+
+ --------------------------------
+ -- Inherit_Pragma_Implemented --
+ --------------------------------
+
+ procedure Inherit_Pragma_Implemented
+ (Subp : Entity_Id;
+ Iface_Subp : Entity_Id)
+ is
+ Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp);
+ Loc : constant Source_Ptr := Sloc (Subp);
+ Impl_Prag : Node_Id;
+
+ begin
+ -- Since the implementation kind is stored as a representation item
+ -- rather than a flag, create a pragma node.
+
+ Impl_Prag :=
+ Make_Pragma (Loc,
+ Chars => Name_Implemented,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ New_Reference_To (Subp, Loc)),
+
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc, Iface_Kind))));
+
+ -- The pragma doesn't need to be analyzed because it is internaly
+ -- build. It is safe to directly register it as a rep item since we
+ -- are only interested in the characters of the implementation kind.
+
+ Record_Rep_Item (Subp, Impl_Prag);
+ end Inherit_Pragma_Implemented;
+
+ -- Start of processing for Check_Abstract_Overriding
+
begin
Op_List := Primitive_Operations (T);
@@ -8584,33 +8733,48 @@ package body Sem_Ch3 is
end if;
end if;
- -- Ada 2005 (AI05-0030): Inspect hidden subprograms which provide
- -- the mapping between interface and implementing type primitives.
- -- If the interface alias is marked as Implemented_By_Entry, the
- -- alias must be an entry wrapper.
+ -- Ada 2012 (AI05-0030): Perform some checks related to pragma
+ -- Implemented
- if Ada_Version >= Ada_05
+ -- Subp is an expander-generated procedure which maps an interface
+ -- alias to a protected wrapper. The interface alias is flagged by
+ -- pragma Implemented. Ensure that Subp is a procedure when the
+ -- implementation kind is By_Protected_Procedure or an entry when
+ -- By_Entry.
+
+ if Ada_Version >= Ada_2012
and then Is_Hidden (Subp)
and then Present (Interface_Alias (Subp))
- and then Implemented_By_Entry (Interface_Alias (Subp))
- and then Present (Alias_Subp)
- and then
- (not Is_Primitive_Wrapper (Alias_Subp)
- or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry)
+ and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented)
then
- declare
- Error_Ent : Entity_Id := T;
+ Check_Pragma_Implemented (Subp);
+ end if;
- begin
- if Is_Concurrent_Record_Type (Error_Ent) then
- Error_Ent := Corresponding_Concurrent_Type (Error_Ent);
- end if;
+ -- Subp is an interface primitive which overrides another interface
+ -- primitive marked with pragma Implemented.
- Error_Msg_Node_2 := Interface_Alias (Subp);
- Error_Msg_NE
- ("type & must implement abstract subprogram & with an entry",
- Error_Ent, Error_Ent);
- end;
+ if Ada_Version >= Ada_2012
+ and then Is_Overriding_Operation (Subp)
+ and then Present (Overridden_Operation (Subp))
+ and then Has_Rep_Pragma
+ (Overridden_Operation (Subp), Name_Implemented)
+ then
+ -- If the overriding routine is also marked by Implemented, check
+ -- that the two implementation kinds are conforming.
+
+ if Has_Rep_Pragma (Subp, Name_Implemented) then
+ Check_Pragma_Implemented
+ (Subp => Subp,
+ Iface_Subp => Overridden_Operation (Subp));
+
+ -- Otherwise the overriding routine inherits the implementation
+ -- kind from the overridden subprogram.
+
+ else
+ Inherit_Pragma_Implemented
+ (Subp => Subp,
+ Iface_Subp => Overridden_Operation (Subp));
+ end if;
end if;
Next_Elmt (Elmt);
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 165080)
+++ exp_ch9.adb (working copy)
@@ -29,8 +29,8 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch11; use Exp_Ch11;
with Exp_Ch6; use Exp_Ch6;
+with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Sel; use Exp_Sel;
@@ -8310,8 +8310,10 @@ package body Exp_Ch9 is
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
- -- Ada 2005 (AI05-0030): Dispatching requeue from protected to interface
- -- class-wide type:
+ -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
+ -- marked by pragma Implemented (XXX, By_Entry).
+
+ -- The requeue is inside a protected entry:
-- procedure entE
-- (O : System.Address;
@@ -8347,10 +8349,9 @@ package body Exp_Ch9 is
-- end;
-- end entE;
- -- Ada 2005 (AI05-0030): Dispatching requeue from task to interface
- -- class-wide type:
+ -- The requeue is inside a task entry:
- -- Accept_Call (E, Ann);
+ -- Accept_Call (E, Ann);
-- <start of statement sequence for accept statement>
-- _Disp_Requeue
-- (<interface class-wide object>,
@@ -8370,63 +8371,159 @@ package body Exp_Ch9 is
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
- -- Further details on these expansions can be found in Expand_N_Protected_
- -- Body and Expand_N_Accept_Statement.
+ -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
+ -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
+ -- statement is replaced by a dispatching call with actual parameters taken
+ -- from the inner-most accept statement or entry body.
+
+ -- 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.
+
+ -- declare
+ -- S : constant Offset_Index :=
+ -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
+ -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
+
+ -- begin
+ -- if C = POK_Protected_Entry
+ -- or else C = POK_Task_Entry
+ -- then
+ -- <statements for dispatching requeue>
+
+ -- elsif C = POK_Protected_Procedure then
+ -- <dispatching call equivalent>
+
+ -- else
+ -- raise Program_Error;
+ -- end if;
+ -- end;
procedure Expand_N_Requeue_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Abortable : Node_Id;
- Acc_Stat : Node_Id;
- Conc_Typ : Entity_Id;
- Concval : Node_Id;
- Ename : Node_Id;
- Index : Node_Id;
- Lab_Node : Node_Id;
- New_Param : Node_Id;
- Old_Typ : Entity_Id;
- Params : List_Id;
- Rcall : Node_Id;
- RTS_Call : Entity_Id;
- Self_Param : Node_Id;
- Skip_Stat : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Conc_Typ : Entity_Id;
+ Concval : Node_Id;
+ Ename : Node_Id;
+ Index : Node_Id;
+ Old_Typ : Entity_Id;
+
+ function Build_Dispatching_Call_Equivalent return Node_Id;
+ -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
+ -- the form Concval.Ename. It is statically known that Ename is allowed
+ -- to be implemented by a protected procedure. Create a dispatching call
+ -- equivalent of Concval.Ename taking the actual parameters from the
+ -- inner-most accept statement or entry body.
+
+ function Build_Dispatching_Requeue return Node_Id;
+ -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
+ -- the form Concval.Ename. It is statically known that Ename is allowed
+ -- to be implemented by a protected or a task entry. Create a call to
+ -- primitive _Disp_Requeue which handles the low-level actions.
+
+ 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.
+
+ function Build_Normal_Requeue return Node_Id;
+ -- N denotes a non-dispatching requeue statement to either a task or a
+ -- protected entry. Build the appropriate runtime call to perform the
+ -- action.
+
+ function Build_Skip_Statement (Search : Node_Id) return Node_Id;
+ -- For a protected entry, create a return statement to skip the rest of
+ -- the entry body. Otherwise, create a goto statement to skip the rest
+ -- of a task accept statement. The lookup for the enclosing entry body
+ -- or accept statement starts from Search.
- begin
- Abortable :=
- New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
+ ---------------------------------------
+ -- Build_Dispatching_Call_Equivalent --
+ ---------------------------------------
- -- Extract the components of the entry call
+ function Build_Dispatching_Call_Equivalent return Node_Id is
+ Call_Ent : constant Entity_Id := Entity (Ename);
+ Obj : constant Node_Id := Original_Node (Concval);
+ Acc_Ent : Node_Id;
+ Actuals : List_Id;
+ Formal : Node_Id;
+ Formals : List_Id;
- Extract_Entry (N, Concval, Ename, Index);
- Conc_Typ := Etype (Concval);
+ begin
+ -- Climb the parent chain looking for the inner-most entry body or
+ -- accept statement.
- -- Examine the scope stack in order to find nearest enclosing protected
- -- or task type. This will constitute our invocation source.
+ Acc_Ent := N;
+ while Present (Acc_Ent)
+ and then not Nkind_In (Acc_Ent, N_Accept_Statement,
+ N_Entry_Body)
+ loop
+ Acc_Ent := Parent (Acc_Ent);
+ end loop;
- Old_Typ := Current_Scope;
- while Present (Old_Typ)
- and then not Is_Protected_Type (Old_Typ)
- and then not Is_Task_Type (Old_Typ)
- loop
- Old_Typ := Scope (Old_Typ);
- end loop;
+ -- A requeue statement should be housed inside an entry body or an
+ -- accept statement at some level. If this is not the case, then the
+ -- tree is malformed.
- -- Generate the parameter list for all cases. The abortable flag is
- -- common among dispatching and regular requeue.
+ pragma Assert (Present (Acc_Ent));
- Params := New_List (Abortable);
+ -- Recover the list of formal parameters
- -- Ada 2005 (AI05-0030): We have a dispatching requeue of the form
- -- Concval.Ename where the type of Concval is class-wide concurrent
- -- interface.
+ if Nkind (Acc_Ent) = N_Entry_Body then
+ Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
+ end if;
- if Ada_Version >= Ada_05
- and then Present (Concval)
- and then Is_Class_Wide_Type (Conc_Typ)
- and then Is_Concurrent_Interface (Conc_Typ)
- then
- RTS_Call := Make_Identifier (Loc, Name_uDisp_Requeue);
+ Formals := Parameter_Specifications (Acc_Ent);
+
+ -- Create the actual parameters for the dispatching call. These are
+ -- simply copies of the entry body or accept statement formals in the
+ -- same order as they appear.
+
+ Actuals := No_List;
+
+ if Present (Formals) then
+ Actuals := New_List;
+ Formal := First (Formals);
+ while Present (Formal) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
+ Next (Formal);
+ end loop;
+ end if;
-- Generate:
+ -- Obj.Call_Ent (Actuals);
+
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars (Obj)),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Call_Ent))),
+
+ Parameter_Associations => Actuals);
+ end Build_Dispatching_Call_Equivalent;
+
+ -------------------------------
+ -- Build_Dispatching_Requeue --
+ -------------------------------
+
+ function Build_Dispatching_Requeue return Node_Id is
+ Params : constant List_Id := New_List;
+
+ begin
+ -- Process the "with abort" parameter
+
+ Prepend_To (Params,
+ New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
+
+ -- 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>)
@@ -8435,156 +8532,389 @@ package body Exp_Ch9 is
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))))));
- -- Specific actuals for protected to interface class-wide type
- -- requeue.
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Tag), Concval),
+ Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
+
+ -- Specific actuals for protected to XXX requeue
if Is_Protected_Type (Old_Typ) then
Prepend_To (Params,
Make_Attribute_Reference (Loc, -- _object'Address
Prefix =>
Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
- Attribute_Name =>
- Name_Address));
+ Attribute_Name => Name_Address));
+
Prepend_To (Params, -- True
New_Reference_To (Standard_True, Loc));
- -- Specific actuals for task to interface class-wide type requeue
+ -- Specific actuals for task to XXX requeue
else
pragma Assert (Is_Task_Type (Old_Typ));
Prepend_To (Params, -- null
New_Reference_To (RTE (RE_Null_Address), Loc));
+
Prepend_To (Params, -- False
New_Reference_To (Standard_False, Loc));
end if;
- -- Finally, add the common object parameter
+ -- Add the object parameter
Prepend_To (Params, New_Copy_Tree (Concval));
- -- Regular requeue processing
+ -- Generate:
+ -- _Disp_Requeue (<Params>);
- else
- New_Param := Concurrent_Ref (Concval);
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uDisp_Requeue),
+ Parameter_Associations => Params);
+ end Build_Dispatching_Requeue;
+
+ --------------------------------------
+ -- Build_Dispatching_Requeue_To_Any --
+ --------------------------------------
+
+ function Build_Dispatching_Requeue_To_Any return Node_Id is
+ Call_Ent : constant Entity_Id := Entity (Ename);
+ Obj : constant Node_Id := Original_Node (Concval);
+ Skip : constant Node_Id := Build_Skip_Statement (N);
+ C : Entity_Id;
+ Decls : List_Id;
+ S : Entity_Id;
+ Stmts : List_Id;
+
+ begin
+ Decls := New_List;
+ Stmts := New_List;
+
+ -- Dispatch table slot processing, generate:
+ -- S : Integer;
+
+ S := Build_S (Loc, Decls);
- -- The index expression is common among all four cases
+ -- Call kind processing, generate:
+ -- C : Ada.Tags.Prim_Op_Kind;
+
+ C := Build_C (Loc, Decls);
+
+ -- Generate:
+ -- S := Ada.Tags.Get_Offset_Index
+ -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
+
+ Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
+
+ -- Generate:
+ -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (
+ Find_Prim_Op (Etype (Etype (Obj)),
+ Name_uDisp_Get_Prim_Op_Kind),
+ Loc),
+ Parameter_Associations => New_List (
+ New_Copy_Tree (Obj),
+ New_Reference_To (S, Loc),
+ New_Reference_To (C, Loc))));
+
+ Append_To (Stmts,
+
+ -- if C = POK_Protected_Entry
+ -- or else C = POK_Task_Entry
+ -- then
+
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Or (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
+
+ -- Dispatching requeue equivalent
+
+ Then_Statements => New_List (
+ Build_Dispatching_Requeue,
+ Skip),
+
+ -- elsif C = POK_Protected_Procedure then
+
+ Elsif_Parts => New_List (
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (
+ RTE (RE_POK_Protected_Procedure), Loc)),
+
+ -- Dispatching call equivalent
+
+ Then_Statements => New_List (
+ Build_Dispatching_Call_Equivalent))),
+
+ -- else
+ -- raise Program_Error;
+ -- end if;
+
+ Else_Statements => New_List (
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Explicit_Raise))));
+
+ -- Wrap everything into a block
+
+ return
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+ end Build_Dispatching_Requeue_To_Any;
+
+ --------------------------
+ -- Build_Normal_Requeue --
+ --------------------------
+
+ function Build_Normal_Requeue return Node_Id is
+ Params : constant List_Id := New_List;
+ Param : Node_Id;
+ RT_Call : Node_Id;
+
+ begin
+ -- Process the "with abort" parameter
Prepend_To (Params,
- Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
+ New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
- if Is_Protected_Type (Old_Typ) then
- Self_Param :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
- Attribute_Name =>
- Name_Unchecked_Access);
+ -- Add the index expression to the parameters. It is common among all
+ -- four cases.
- -- Protected to protected requeue
+ Prepend_To (Params,
+ Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
- if Is_Protected_Type (Conc_Typ) then
- RTS_Call :=
- New_Reference_To (RTE (RE_Requeue_Protected_Entry), Loc);
+ if Is_Protected_Type (Old_Typ) then
+ declare
+ Self_Param : Node_Id;
- New_Param :=
+ begin
+ Self_Param :=
Make_Attribute_Reference (Loc,
Prefix =>
- New_Param,
+ Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
Attribute_Name =>
Name_Unchecked_Access);
- -- Protected to task requeue
+ -- Protected to protected requeue
- else
- pragma Assert (Is_Task_Type (Conc_Typ));
- RTS_Call :=
- New_Reference_To (
- RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
- end if;
+ if Is_Protected_Type (Conc_Typ) then
+ RT_Call :=
+ New_Reference_To (
+ RTE (RE_Requeue_Protected_Entry), Loc);
+
+ Param :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Concurrent_Ref (Concval),
+ Attribute_Name =>
+ Name_Unchecked_Access);
- Prepend (New_Param, Params);
- Prepend (Self_Param, Params);
+ -- Protected to task requeue
- else
- pragma Assert (Is_Task_Type (Old_Typ));
+ else pragma Assert (Is_Task_Type (Conc_Typ));
+ RT_Call :=
+ New_Reference_To (
+ RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
+
+ Param := Concurrent_Ref (Concval);
+ end if;
+
+ Prepend_To (Params, Param);
+ Prepend_To (Params, Self_Param);
+ end;
+
+ else pragma Assert (Is_Task_Type (Old_Typ));
-- Task to protected requeue
if Is_Protected_Type (Conc_Typ) then
- RTS_Call :=
+ RT_Call :=
New_Reference_To (
RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
- New_Param :=
+ Param :=
Make_Attribute_Reference (Loc,
Prefix =>
- New_Param,
+ Concurrent_Ref (Concval),
Attribute_Name =>
Name_Unchecked_Access);
-- Task to task requeue
- else
- pragma Assert (Is_Task_Type (Conc_Typ));
- RTS_Call :=
+ else pragma Assert (Is_Task_Type (Conc_Typ));
+ RT_Call :=
New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc);
+
+ Param := Concurrent_Ref (Concval);
end if;
- Prepend (New_Param, Params);
+ Prepend_To (Params, Param);
end if;
- end if;
-
- -- Create the GNARLI or predefined primitive call
- Rcall :=
- Make_Procedure_Call_Statement (Loc,
- Name => RTS_Call,
- Parameter_Associations => Params);
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => RT_Call,
+ Parameter_Associations => Params);
+ end Build_Normal_Requeue;
- Rewrite (N, Rcall);
- Analyze (N);
+ --------------------------
+ -- Build_Skip_Statement --
+ --------------------------
- if Is_Protected_Type (Old_Typ) then
+ function Build_Skip_Statement (Search : Node_Id) return Node_Id is
+ Skip_Stmt : Node_Id;
- -- Build the return statement to skip the rest of the entry body
+ begin
+ -- Build a return statement to skip the rest of the entire body
- Skip_Stat := Make_Simple_Return_Statement (Loc);
+ if Is_Protected_Type (Old_Typ) then
+ Skip_Stmt := Make_Simple_Return_Statement (Loc);
- else
-- If the requeue is within a task, find the end label of the
- -- enclosing accept statement.
+ -- enclosing accept statement and create a goto statement to it.
- Acc_Stat := Parent (N);
- while Nkind (Acc_Stat) /= N_Accept_Statement loop
- Acc_Stat := Parent (Acc_Stat);
- end loop;
+ else
+ declare
+ Acc : Node_Id;
+ Label : Node_Id;
- -- The last statement is the second label, used for completing the
- -- rendezvous the usual way. The label we are looking for is right
- -- before it.
+ begin
+ -- Climb the parent chain looking for the enclosing accept
+ -- statement.
- Lab_Node :=
- Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
+ Acc := Parent (Search);
+ while Present (Acc)
+ and then Nkind (Acc) /= N_Accept_Statement
+ loop
+ Acc := Parent (Acc);
+ end loop;
- pragma Assert (Nkind (Lab_Node) = N_Label);
+ -- The last statement is the second label used for completing
+ -- the rendezvous the usual way. The label we are looking for
+ -- is right before it.
- -- Build the goto statement to skip the rest of the accept
- -- statement.
+ Label :=
+ Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
- Skip_Stat :=
- Make_Goto_Statement (Loc,
- Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
- end if;
+ pragma Assert (Nkind (Label) = N_Label);
+
+ -- Generate a goto statement to skip the rest of the accept
+
+ Skip_Stmt :=
+ Make_Goto_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Identifier (Label)), Loc));
+ end;
+ end if;
+
+ Set_Analyzed (Skip_Stmt);
+
+ return Skip_Stmt;
+ end Build_Skip_Statement;
+
+ -- Start of processing for Expand_N_Requeue_Statement
- Set_Analyzed (Skip_Stat);
+ begin
+ -- Extract the components of the entry call
+
+ Extract_Entry (N, Concval, Ename, Index);
+ Conc_Typ := Etype (Concval);
+
+ -- Examine the scope stack in order to find nearest enclosing protected
+ -- or task type. This will constitute our invocation source.
+
+ Old_Typ := Current_Scope;
+ while Present (Old_Typ)
+ and then not Is_Protected_Type (Old_Typ)
+ and then not Is_Task_Type (Old_Typ)
+ loop
+ Old_Typ := Scope (Old_Typ);
+ end loop;
- Insert_After (N, Skip_Stat);
+ -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
+ -- Concval.Ename where the type of Concval is class-wide concurrent
+ -- interface.
+
+ if Ada_Version >= Ada_2012
+ and then Present (Concval)
+ and then Is_Class_Wide_Type (Conc_Typ)
+ and then Is_Concurrent_Interface (Conc_Typ)
+ then
+ declare
+ Has_Impl : Boolean := False;
+ Impl_Kind : Name_Id := No_Name;
+
+ begin
+ -- Check whether the Ename is flagged by pragma Implemented
+
+ if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
+ Has_Impl := True;
+ Impl_Kind := Implementation_Kind (Entity (Ename));
+ end if;
+
+ -- The procedure_or_entry_NAME is guaranteed to be overridden by
+ -- an entry. Create a call to predefined primitive _Disp_Requeue.
+
+ if Has_Impl
+ and then Impl_Kind = Name_By_Entry
+ then
+ Rewrite (N, Build_Dispatching_Requeue);
+ Analyze (N);
+ Insert_After (N, Build_Skip_Statement (N));
+
+ -- The procedure_or_entry_NAME is guaranteed to be overridden by
+ -- a protected procedure. In this case the requeue is transformed
+ -- into a dispatching call.
+
+ elsif Has_Impl
+ and then Impl_Kind = Name_By_Protected_Procedure
+ then
+ Rewrite (N, Build_Dispatching_Call_Equivalent);
+ 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.
+
+ else
+ Rewrite (N, Build_Dispatching_Requeue_To_Any);
+ Analyze (N);
+ end if;
+ end;
+
+ -- Processing for regular (non-dispatching) requeues
+
+ else
+ Rewrite (N, Build_Normal_Requeue);
+ Analyze (N);
+ Insert_After (N, Build_Skip_Statement (N));
+ end if;
end Expand_N_Requeue_Statement;
-------------------------------
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb (revision 165080)
+++ sem_ch9.adb (working copy)
@@ -1423,18 +1423,17 @@ package body Sem_Ch9 is
Entry_Id := Entity (Entry_Name);
end if;
- -- Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
+ -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
-- target type must be a concurrent interface class-wide type and the
- -- entry name must be a procedure, flagged by pragma Implemented_By_
- -- Entry.
+ -- target must be a procedure, flagged by pragma Implemented.
Is_Disp_Req :=
- Ada_Version >= Ada_05
+ Ada_Version >= Ada_2012
and then Present (Target_Obj)
and then Is_Class_Wide_Type (Etype (Target_Obj))
and then Is_Concurrent_Interface (Etype (Target_Obj))
and then Ekind (Entry_Id) = E_Procedure
- and then Implemented_By_Entry (Entry_Id);
+ and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
-- Resolve entry, and check that it is subtype conformant with the
-- enclosing construct if this construct has formals (RM 9.5.4(5)).
@@ -1462,11 +1461,13 @@ package body Sem_Ch9 is
return;
end if;
- -- Ada 2005 (AI05-0030): Perform type conformance after skipping
+ -- Ada 2012 (AI05-0030): Perform type conformance after skipping
-- the first parameter of Entry_Id since it is the interface
-- controlling formal.
- if Is_Disp_Req then
+ if Ada_Version >= Ada_2012
+ and then Is_Disp_Req
+ then
declare
Enclosing_Formal : Entity_Id;
Target_Formal : Entity_Id;
Index: einfo.adb
===================================================================
--- einfo.adb (revision 165082)
+++ einfo.adb (working copy)
@@ -493,7 +493,6 @@ package body Einfo is
-- Has_Pragma_Inline_Always Flag230
-- Renamed_In_Spec Flag231
- -- Implemented_By_Entry Flag232
-- Has_Pragma_Unmodified Flag233
-- Is_Dispatch_Table_Entity Flag234
-- Is_Trivial_Subprogram Flag235
@@ -512,6 +511,7 @@ package body Einfo is
-- OK_To_Rename Flag247
-- (unused) Flag200
+ -- (unused) Flag232
-----------------------
-- Local subprograms --
@@ -1536,12 +1536,6 @@ package body Einfo is
return Node4 (Id);
end Homonym;
- function Implemented_By_Entry (Id : E) return B is
- begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
- return Flag232 (Id);
- end Implemented_By_Entry;
-
function Interfaces (Id : E) return L is
begin
pragma Assert (Is_Record_Type (Id));
@@ -3958,12 +3952,6 @@ package body Einfo is
Set_Node4 (Id, V);
end Set_Homonym;
- procedure Set_Implemented_By_Entry (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
- Set_Flag232 (Id, V);
- end Set_Implemented_By_Entry;
-
procedure Set_Interfaces (Id : E; V : L) is
begin
pragma Assert (Is_Record_Type (Id));
@@ -6958,7 +6946,6 @@ package body Einfo is
W ("Has_Up_Level_Access", Flag215 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("Has_Xref_Entry", Flag182 (Id));
- W ("Implemented_By_Entry", Flag232 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 165104)
+++ einfo.ads (working copy)
@@ -1806,10 +1806,6 @@ package Einfo is
-- that we still have a concrete type. For entities other than types,
-- returns the entity unchanged.
--- Implemented_By_Entry (Flag232)
--- Applies to functions and procedures. Set if pragma Implemented_By_
--- Entry is applied on the subprogram entity.
-
-- Interfaces (Elist25)
-- Present in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
@@ -5052,7 +5048,6 @@ package Einfo is
-- Has_Postconditions (Flag240)
-- Has_Recursive_Call (Flag143)
-- Has_Subprogram_Descriptor (Flag93)
- -- Implemented_By_Entry (Flag232) (non-generic case only)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
@@ -5311,7 +5306,6 @@ package Einfo is
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Postconditions (Flag240)
-- Has_Subprogram_Descriptor (Flag93)
- -- Implemented_By_Entry (Flag232) (non-generic case only)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
@@ -5928,7 +5922,6 @@ package Einfo is
function Has_Xref_Entry (Id : E) return B;
function Hiding_Loop_Variable (Id : E) return E;
function Homonym (Id : E) return E;
- function Implemented_By_Entry (Id : E) return B;
function In_Package_Body (Id : E) return B;
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
@@ -6490,7 +6483,6 @@ package Einfo is
procedure Set_Has_Xref_Entry (Id : E; V : B := True);
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Homonym (Id : E; V : E);
- procedure Set_Implemented_By_Entry (Id : E; V : B := True);
procedure Set_Interfaces (Id : E; V : L);
procedure Set_In_Package_Body (Id : E; V : B := True);
procedure Set_In_Private_Part (Id : E; V : B := True);
@@ -7150,7 +7142,6 @@ package Einfo is
pragma Inline (Has_Xref_Entry);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Homonym);
- pragma Inline (Implemented_By_Entry);
pragma Inline (Interfaces);
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
@@ -7583,7 +7574,6 @@ package Einfo is
pragma Inline (Set_Has_Xref_Entry);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Homonym);
- pragma Inline (Set_Implemented_By_Entry);
pragma Inline (Set_Interfaces);
pragma Inline (Set_In_Package_Body);
pragma Inline (Set_In_Private_Part);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 165110)
+++ sem_prag.adb (working copy)
@@ -310,7 +310,12 @@ package body Sem_Prag is
procedure Ada_2005_Pragma;
-- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
-- Ada 95 mode, these are implementation defined pragmas, so should be
- -- caught by the No_Implementation_Pragmas restriction
+ -- caught by the No_Implementation_Pragmas restriction.
+
+ procedure Ada_2012_Pragma;
+ -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
+ -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
+ -- should be caught by the No_Implementation_Pragmas restriction.
procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada
@@ -733,6 +738,17 @@ package body Sem_Prag is
end if;
end Ada_2005_Pragma;
+ ---------------------
+ -- Ada_2012_Pragma --
+ ---------------------
+
+ procedure Ada_2012_Pragma is
+ begin
+ if Ada_Version <= Ada_05 then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
+ end Ada_2012_Pragma;
+
--------------------------
-- Check_Ada_83_Warning --
--------------------------
@@ -7979,45 +7995,101 @@ package body Sem_Prag is
end;
end Ident;
- --------------------------
- -- Implemented_By_Entry --
- --------------------------
+ -----------------
+ -- Implemented --
+ -----------------
- -- pragma Implemented_By_Entry (DIRECT_NAME);
+ -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
+ -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
- when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
- Ent : Entity_Id;
+ when Pragma_Implemented => Implemented : declare
+ Proc_Id : Entity_Id;
+ Typ : Entity_Id;
begin
- Ada_2005_Pragma;
- Check_Arg_Count (1);
+ Ada_2012_Pragma;
+ Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
- Ent := Entity (Expression (Arg1));
+ Check_Arg_Is_One_Of
+ (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+
+ -- Extract the name of the local procedure
- -- Pragma Implemented_By_Entry must be applied only to protected
- -- synchronized or task interface primitives.
+ Proc_Id := Entity (Expression (Arg1));
- if (Ekind (Ent) /= E_Function
- and then Ekind (Ent) /= E_Procedure)
- or else not Present (First_Formal (Ent))
- or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
+ -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
+ -- primitive procedure of a synchronized tagged type.
+
+ if Ekind (Proc_Id) = E_Procedure
+ and then Is_Primitive (Proc_Id)
+ and then Present (First_Formal (Proc_Id))
then
- Error_Pragma_Arg
- ("pragma % must be applied to a concurrent interface " &
- "primitive", Arg1);
+ Typ := Etype (First_Formal (Proc_Id));
- else
- if Einfo.Implemented_By_Entry (Ent)
- and then Warn_On_Redundant_Constructs
+ if Is_Tagged_Type (Typ)
+ and then
+
+ -- Check for a protected, a synchronized or a task interface
+
+ ((Is_Interface (Typ)
+ and then Is_Synchronized_Interface (Typ))
+
+ -- Check for a protected type or a task type that implements
+ -- an interface.
+
+ or else
+ (Is_Concurrent_Record_Type (Typ)
+ and then Present (Interfaces (Typ)))
+
+ -- Check for a private record extension with keyword
+ -- "synchronized".
+
+ or else
+ (Ekind_In (Typ, E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private)
+ and then Synchronized_Present (Parent (Typ))))
then
- Error_Pragma ("?duplicate pragma%!");
+ null;
else
- Set_Implemented_By_Entry (Ent);
+ Error_Pragma_Arg
+ ("controlling formal must be of synchronized " &
+ "tagged type", Arg1);
+ return;
end if;
+
+ -- Procedures declared inside a protected type must be accepted
+
+ elsif Ekind (Proc_Id) = E_Procedure
+ and then Is_Protected_Type (Scope (Proc_Id))
+ then
+ null;
+
+ -- The first argument is not a primitive procedure
+
+ else
+ Error_Pragma_Arg
+ ("pragma % must be applied to a primitive procedure", Arg1);
+ return;
end if;
- end Implemented_By_Entry;
+
+ -- Ada 2012 (AI05-0030): Implementation_kind "By_Protected_
+ -- Procedure" cannot be applied to the primitive procedure of a
+ -- task interface.
+
+ if Chars (Arg2) = Name_By_Protected_Procedure
+ and then Is_Interface (Typ)
+ and then Is_Task_Interface (Typ)
+ then
+ Error_Pragma_Arg
+ ("implementation kind By_Protected_Procedure cannot be " &
+ "applied to a task interface primitive", Arg2);
+ return;
+ end if;
+
+ Record_Rep_Item (Proc_Id, N);
+ end Implemented;
-----------------------
-- Implicit_Packing --
@@ -12946,7 +13018,7 @@ package body Sem_Prag is
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
- Pragma_Implemented_By_Entry => -1,
+ Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 165092)
+++ sem_util.adb (working copy)
@@ -5237,6 +5237,20 @@ package body Sem_Util is
end if;
end Has_Tagged_Component;
+ -------------------------
+ -- Implementation_Kind --
+ -------------------------
+
+ function Implementation_Kind (Subp : Entity_Id) return Name_Id is
+ Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
+
+ begin
+ pragma Assert (Present (Impl_Prag));
+
+ return
+ Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
+ end Implementation_Kind;
+
--------------------------
-- Implements_Interface --
--------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 165103)
+++ sem_util.ads (working copy)
@@ -586,11 +586,16 @@ package Sem_Util is
-- component is present. This function is used to check if "=" has to be
-- expanded into a bunch component comparisons.
+ function Implementation_Kind (Subp : Entity_Id) return Name_Id;
+ -- Subp is a subprogram marked with pragma Implemented. Return the specific
+ -- implementation requirement which the pragma imposes. The return value is
+ -- either Name_By_Any, Name_By_Entry or Name_By_Protected_Procedure.
+
function Implements_Interface
(Typ_Ent : Entity_Id;
Iface_Ent : Entity_Id;
Exclude_Parents : Boolean := False) return Boolean;
- -- Returns true if the Typ implements interface Iface
+ -- Returns true if the Typ_Ent implements interface Iface_Ent
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 165082)
+++ par-prag.adb (working copy)
@@ -1123,7 +1123,7 @@ begin
Pragma_Finalize_Storage_Only |
Pragma_Float_Representation |
Pragma_Ident |
- Pragma_Implemented_By_Entry |
+ Pragma_Implemented |
Pragma_Implicit_Packing |
Pragma_Import |
Pragma_Import_Exception |
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 165080)
+++ snames.ads-tmpl (working copy)
@@ -445,7 +445,7 @@ package Snames is
Name_External : constant Name_Id := N + $; -- GNAT
Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT
Name_Ident : constant Name_Id := N + $; -- VMS
- Name_Implemented_By_Entry : constant Name_Id := N + $; -- Ada 05
+ Name_Implemented : constant Name_Id := N + $; -- Ada 12
Name_Import : constant Name_Id := N + $;
Name_Import_Exception : constant Name_Id := N + $; -- VMS
Name_Import_Function : constant Name_Id := N + $; -- GNAT
@@ -594,6 +594,9 @@ package Snames is
Name_Attribute_Name : constant Name_Id := N + $;
Name_Body_File_Name : constant Name_Id := N + $;
Name_Boolean_Entry_Barriers : constant Name_Id := N + $;
+ Name_By_Any : constant Name_Id := N + $;
+ Name_By_Entry : constant Name_Id := N + $;
+ Name_By_Protected_Procedure : constant Name_Id := N + $;
Name_Casing : constant Name_Id := N + $;
Name_Code : constant Name_Id := N + $;
Name_Component : constant Name_Id := N + $;
@@ -1520,7 +1523,7 @@ package Snames is
Pragma_External,
Pragma_Finalize_Storage_Only,
Pragma_Ident,
- Pragma_Implemented_By_Entry,
+ Pragma_Implemented,
Pragma_Import,
Pragma_Import_Exception,
Pragma_Import_Function,
More information about the Gcc-patches
mailing list