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

[multiple changes]

Browse Source 
2010-10-08  Thomas Quinot  <quinot@adacore.com>

	* sem_ch4.adb: Minor reformatting.

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.

2010-10-08  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_Freeeze_Record_Type): Code cleanup: remove local
	variable Has_Static_DT by invocation of function Building_Static_DT.

2010-10-08  Vincent Celier  <celier@adacore.com>

	* g-dirope.adb (Remove_Dir): Do not change the current directory when
	doing a recursive remove of a subdirectory.

2010-10-08  Javier Miranda  <miranda@adacore.com>

	* exp_ch6.ad (Freeze_Subprogram): Factorize code.
	* exp_disp.adb (Make_Secondary_DT): Factorize code.
	(Make_DT): Factorize code.

From-SVN: r165154
This commit is contained in:
Arnaud Charlet 2010-10-08 12:04:58 +02:00
parent 40b93859aa
commit bfae1846ce
16 changed files with 926 additions and 323 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
gcc/ada/ChangeLog
View File

@ -1,3 +1,63 @@
2010-10-08 Thomas Quinot <quinot@adacore.com>
* sem_ch4.adb: Minor reformatting.
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.
2010-10-08 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Expand_Freeeze_Record_Type): Code cleanup: remove local
variable Has_Static_DT by invocation of function Building_Static_DT.
2010-10-08 Vincent Celier <celier@adacore.com>
* g-dirope.adb (Remove_Dir): Do not change the current directory when
doing a recursive remove of a subdirectory.
2010-10-08 Javier Miranda <miranda@adacore.com>
* exp_ch6.ad (Freeze_Subprogram): Factorize code.
* exp_disp.adb (Make_Secondary_DT): Factorize code.
(Make_DT): Factorize code.
2010-10-08 Robert Dewar <dewar@adacore.com>
* sem_ch4.adb: Minor reformatting.

15
gcc/ada/einfo.adb
View File

@ -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));

10
gcc/ada/einfo.ads
View File

@ -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);

8
gcc/ada/exp_ch3.adb
View File

@ -5863,7 +5863,6 @@ package body Exp_Ch3 is
Type_Decl : constant Node_Id := Parent (Def_Id);
Comp : Entity_Id;
Comp_Typ : Entity_Id;
Has_Static_DT : Boolean := False;
Predef_List : List_Id;
Flist : Entity_Id := Empty;
@ -5982,9 +5981,6 @@ package body Exp_Ch3 is
-- just use it.
if Is_Tagged_Type (Def_Id) then
Has_Static_DT :=
Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Def_Id);
-- Add the _Tag component
@ -6004,7 +6000,7 @@ package body Exp_Ch3 is
Set_CPP_Constructors (Def_Id);
else
if not Has_Static_DT then
if not Building_Static_DT (Def_Id) then
-- Usually inherited primitives are not delayed but the first
-- Ada extension of a CPP_Class is an exception since the
@ -6116,7 +6112,7 @@ package body Exp_Ch3 is
-- Dispatch tables of library level tagged types are built
-- later (see Analyze_Declarations).
if not Has_Static_DT then
if not Building_Static_DT (Def_Id) then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
end if;

6
gcc/ada/exp_ch6.adb
View File

@ -4998,10 +4998,8 @@ package body Exp_Ch6 is
-- Generate code to register the primitive in non statically
-- allocated dispatch tables
elsif not Static_Dispatch_Tables
or else not
Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp)))
then
elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then
-- When a primitive is frozen, enter its name in its dispatch
-- table slot.

688
gcc/ada/exp_ch9.adb
View File

@ -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,30 +8371,475 @@ 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.
---------------------------------------
-- Build_Dispatching_Call_Equivalent --
---------------------------------------
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;
begin
-- Climb the parent chain looking for the inner-most entry body or
-- accept statement.
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;
-- 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.
pragma Assert (Present (Acc_Ent));
-- Recover the list of formal parameters
if Nkind (Acc_Ent) = N_Entry_Body then
Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
end if;
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>)
Prepend_To (Params,
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 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));
Prepend_To (Params, -- True
New_Reference_To (Standard_True, Loc));
-- 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;
-- Add the object parameter
Prepend_To (Params, New_Copy_Tree (Concval));
-- Generate:
-- _Disp_Requeue (<Params>);
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);
-- 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,
New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
-- Add the index expression to the parameters. It is common among all
-- four cases.
Prepend_To (Params,
Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
if Is_Protected_Type (Old_Typ) then
declare
Self_Param : Node_Id;
begin
Self_Param :=
Make_Attribute_Reference (Loc,
Prefix =>
Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
Attribute_Name =>
Name_Unchecked_Access);
-- Protected to protected requeue
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);
-- Protected to task requeue
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
RT_Call :=
New_Reference_To (
RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
Param :=
Make_Attribute_Reference (Loc,
Prefix =>
Concurrent_Ref (Concval),
Attribute_Name =>
Name_Unchecked_Access);
-- Task to task requeue
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_To (Params, Param);
end if;
return
Make_Procedure_Call_Statement (Loc,
Name => RT_Call,
Parameter_Associations => Params);
end Build_Normal_Requeue;
--------------------------
-- Build_Skip_Statement --
--------------------------
function Build_Skip_Statement (Search : Node_Id) return Node_Id is
Skip_Stmt : Node_Id;
begin
-- Build a return statement to skip the rest of the entire body
if Is_Protected_Type (Old_Typ) then
Skip_Stmt := Make_Simple_Return_Statement (Loc);
-- If the requeue is within a task, find the end label of the
-- enclosing accept statement and create a goto statement to it.
else
declare
Acc : Node_Id;
Label : Node_Id;
begin
-- Climb the parent chain looking for the enclosing accept
-- statement.
Acc := Parent (Search);
while Present (Acc)
and then Nkind (Acc) /= N_Accept_Statement
loop
Acc := Parent (Acc);
end loop;
-- 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.
Label :=
Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
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
begin
Abortable :=
New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
-- Extract the components of the entry call
Extract_Entry (N, Concval, Ename, Index);
@ -8410,181 +8856,65 @@ package body Exp_Ch9 is
Old_Typ := Scope (Old_Typ);
end loop;
-- Generate the parameter list for all cases. The abortable flag is
-- common among dispatching and regular requeue.
Params := New_List (Abortable);
-- Ada 2005 (AI05-0030): We have a dispatching requeue of the form
-- 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_05
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
RTS_Call := Make_Identifier (Loc, Name_uDisp_Requeue);
declare
Has_Impl : Boolean := False;
Impl_Kind : Name_Id := No_Name;
-- Generate:
-- Ada.Tags.Get_Offset_Index
-- (Ada.Tags.Tag (Concval),
-- <interface dispatch table position of Ename>)
begin
-- Check whether the Ename is flagged by pragma Implemented
Prepend_To (Params,
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.
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));
Prepend_To (Params, -- True
New_Reference_To (Standard_True, Loc));
-- Specific actuals for task to interface class-wide type 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
Prepend_To (Params, New_Copy_Tree (Concval));
-- Regular requeue processing
else
New_Param := Concurrent_Ref (Concval);
-- The index expression is common among all four cases
Prepend_To (Params,
Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
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);
-- Protected to protected requeue
if Is_Protected_Type (Conc_Typ) then
RTS_Call :=
New_Reference_To (RTE (RE_Requeue_Protected_Entry), Loc);
New_Param :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Param,
Attribute_Name =>
Name_Unchecked_Access);
-- Protected to task requeue
else
pragma Assert (Is_Task_Type (Conc_Typ));
RTS_Call :=
New_Reference_To (
RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
Has_Impl := True;
Impl_Kind := Implementation_Kind (Entity (Ename));
end if;
Prepend (New_Param, Params);
Prepend (Self_Param, Params);
-- The procedure_or_entry_NAME is guaranteed to be overridden by
-- an entry. Create a call to predefined primitive _Disp_Requeue.
else
pragma Assert (Is_Task_Type (Old_Typ));
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));
-- Task to protected requeue
-- 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.
if Is_Protected_Type (Conc_Typ) then
RTS_Call :=
New_Reference_To (
RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
elsif Has_Impl
and then Impl_Kind = Name_By_Protected_Procedure
then
Rewrite (N, Build_Dispatching_Call_Equivalent);
Analyze (N);
New_Param :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Param,
Attribute_Name =>
Name_Unchecked_Access);
-- Task to task requeue
-- 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
pragma Assert (Is_Task_Type (Conc_Typ));
RTS_Call :=
New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc);
Rewrite (N, Build_Dispatching_Requeue_To_Any);
Analyze (N);
end if;
end;
Prepend (New_Param, Params);
end if;
end if;
-- Create the GNARLI or predefined primitive call
Rcall :=
Make_Procedure_Call_Statement (Loc,
Name => RTS_Call,
Parameter_Associations => Params);
Rewrite (N, Rcall);
Analyze (N);
if Is_Protected_Type (Old_Typ) then
-- Build the return statement to skip the rest of the entry body
Skip_Stat := Make_Simple_Return_Statement (Loc);
-- Processing for regular (non-dispatching) requeues
else
-- If the requeue is within a task, find the end label of the
-- enclosing accept statement.
Acc_Stat := Parent (N);
while Nkind (Acc_Stat) /= N_Accept_Statement loop
Acc_Stat := Parent (Acc_Stat);
end loop;
-- 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.
Lab_Node :=
Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
pragma Assert (Nkind (Lab_Node) = N_Label);
-- Build the goto statement to skip the rest of the accept
-- statement.
Skip_Stat :=
Make_Goto_Statement (Loc,
Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
Rewrite (N, Build_Normal_Requeue);
Analyze (N);
Insert_After (N, Build_Skip_Statement (N));
end if;
Set_Analyzed (Skip_Stat);
Insert_After (N, Skip_Stat);
end Expand_N_Requeue_Statement;
-------------------------------

11
gcc/ada/exp_disp.adb
View File

@ -4060,8 +4060,7 @@ package body Exp_Disp is
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
elsif Is_Abstract_Type (Typ)
or else not Static_Dispatch_Tables
or else not Is_Library_Level_Tagged_Type (Typ)
or else not Building_Static_DT (Typ)
then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
@ -5614,9 +5613,7 @@ package body Exp_Disp is
if Nb_Prim = 0 then
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
elsif not Static_Dispatch_Tables
or else not Is_Library_Level_Tagged_Type (Typ)
then
elsif not Building_Static_DT (Typ) then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
end loop;
@ -5768,9 +5765,7 @@ package body Exp_Disp is
-- because the whole dispatch table (including inherited primitives) has
-- been already built.
if Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
then
if Building_Static_DT (Typ) then
null;
-- If the ancestor is a CPP_Class type we inherit the dispatch tables

70
gcc/ada/g-dirope.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2009, AdaCore --
-- Copyright (C) 1998-2010, AdaCore --
-- --
-- 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- --
@ -719,11 +719,10 @@ package body GNAT.Directory_Operations is
Recursive : Boolean := False)
is
C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
Last : Integer;
Str : String (1 .. Filename_Max);
Success : Boolean;
Working_Dir : Dir_Type;
Current_Dir : Dir_Type;
begin
-- Remove the directory only if it is empty
@ -736,51 +735,40 @@ package body GNAT.Directory_Operations is
-- Remove directory and all files and directories that it may contain
else
-- Substantial comments needed. See RH for revision 1.50 ???
Open (Current_Dir, Dir_Name);
begin
Change_Dir (Dir_Name);
Open (Working_Dir, ".");
loop
Read (Current_Dir, Str, Last);
exit when Last = 0;
loop
Read (Working_Dir, Str, Last);
exit when Last = 0;
if GNAT.OS_Lib.Is_Directory
(Dir_Name & Dir_Separator & Str (1 .. Last))
then
if Str (1 .. Last) /= "."
and then
Str (1 .. Last) /= ".."
then
-- Recursive call to remove a subdirectory and all its
-- files.
if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
if Str (1 .. Last) /= "."
and then
Str (1 .. Last) /= ".."
then
Remove_Dir (Str (1 .. Last), True);
end if;
else
GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
if not Success then
Change_Dir (Current_Dir);
raise Directory_Error;
end if;
Remove_Dir
(Dir_Name & Dir_Separator & Str (1 .. Last),
True);
end if;
end loop;
Change_Dir (Current_Dir);
Close (Working_Dir);
Remove_Dir (Dir_Name);
else
GNAT.OS_Lib.Delete_File
(Dir_Name & Dir_Separator & Str (1 .. Last),
Success);
exception
when others =>
if not Success then
raise Directory_Error;
end if;
end if;
end loop;
-- An exception occurred. We must make sure the current working
-- directory is unchanged.
Change_Dir (Current_Dir);
-- What if the Change_Dir raises an exception itself, shouldn't
-- that be protected? ???
raise;
end;
Close (Current_Dir);
Remove_Dir (Dir_Name);
end if;
end Remove_Dir;

2
gcc/ada/par-prag.adb
View File

@ -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 |

206
gcc/ada/sem_ch3.adb
View File

@ -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);

2
gcc/ada/sem_ch4.adb
View File

@ -507,7 +507,7 @@ package body Sem_Ch4 is
-- be a null object, and we can insert an unconditional raise
-- before the allocator.
-- Ada2012 (AI-104): a not null indication here is altogether
-- Ada 2012 (AI-104): A not null indication here is altogether
-- illegal.
if Can_Never_Be_Null (Type_Id) then

15
gcc/ada/sem_ch9.adb
View File

@ -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;

128
gcc/ada/sem_prag.adb
View File

@ -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);
-- Pragma Implemented_By_Entry must be applied only to protected
-- synchronized or task interface primitives.
-- Extract the name of the local procedure
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)))
Proc_Id := Entity (Expression (Arg1));
-- 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));
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
null;
else
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
if Einfo.Implemented_By_Entry (Ent)
and then Warn_On_Redundant_Constructs
then
Error_Pragma ("?duplicate pragma%!");
else
Set_Implemented_By_Entry (Ent);
end if;
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,

14
gcc/ada/sem_util.adb
View File

@ -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 --
--------------------------

7
gcc/ada/sem_util.ads
View File

@ -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

7
gcc/ada/snames.ads-tmpl
View File

@ -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,