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