From bfae1846ce6fb95a064520e4560fbd191abd2f04 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Oct 2010 12:04:58 +0200 Subject: [PATCH] [multiple changes] 2010-10-08 Thomas Quinot * sem_ch4.adb: Minor reformatting. 2010-10-08 Hristian Kirtchev * 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 * 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 * g-dirope.adb (Remove_Dir): Do not change the current directory when doing a recursive remove of a subdirectory. 2010-10-08 Javier Miranda * exp_ch6.ad (Freeze_Subprogram): Factorize code. * exp_disp.adb (Make_Secondary_DT): Factorize code. (Make_DT): Factorize code. From-SVN: r165154 --- gcc/ada/ChangeLog | 60 ++++ gcc/ada/einfo.adb | 15 +- gcc/ada/einfo.ads | 10 - gcc/ada/exp_ch3.adb | 8 +- gcc/ada/exp_ch6.adb | 6 +- gcc/ada/exp_ch9.adb | 688 +++++++++++++++++++++++++++++----------- gcc/ada/exp_disp.adb | 11 +- gcc/ada/g-dirope.adb | 70 ++-- gcc/ada/par-prag.adb | 2 +- gcc/ada/sem_ch3.adb | 206 ++++++++++-- gcc/ada/sem_ch4.adb | 2 +- gcc/ada/sem_ch9.adb | 15 +- gcc/ada/sem_prag.adb | 128 ++++++-- gcc/ada/sem_util.adb | 14 + gcc/ada/sem_util.ads | 7 +- gcc/ada/snames.ads-tmpl | 7 +- 16 files changed, 926 insertions(+), 323 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bfec7bc74df..364f268fc4f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,63 @@ +2010-10-08 Thomas Quinot + + * sem_ch4.adb: Minor reformatting. + +2010-10-08 Hristian Kirtchev + + * 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 + + * 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 + + * g-dirope.adb (Remove_Dir): Do not change the current directory when + doing a recursive remove of a subdirectory. + +2010-10-08 Javier Miranda + + * exp_ch6.ad (Freeze_Subprogram): Factorize code. + * exp_disp.adb (Make_Secondary_DT): Factorize code. + (Make_DT): Factorize code. + 2010-10-08 Robert Dewar * sem_ch4.adb: Minor reformatting. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6fe87a7d4db..7ec3f8dc1b9 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6c1aa2f78b4..074eefc160a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7a00d39c3c3..0995f5a1b04 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index eb30d804ee0..6cfc955ffa5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index a91ec6a4c22..90853ea46e4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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); -- -- _Disp_Requeue -- (, @@ -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 + -- + + -- elsif C = POK_Protected_Procedure then + -- + + -- 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), + -- ) + + 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 (); + + 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), - -- ) + 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; ------------------------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c38bbe8bf5d..af3a0b38536 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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 diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index 294aa7031ee..50e8b478556 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -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; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index e6c34e4dc10..190c9cc1529 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -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 | diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6b008ae8697..18aced728e3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5891e9b14d5..154b5d3376d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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 diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 792a9dad4c5..136dfb353b4 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 721b34db68e..1ad6c67d7f4 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 917104c1f6c..d9991ce3e58 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index aa044514c48..faa363cbcc6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index efba4c6fc34..0425cccc77e 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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,