Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 9                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Atree;    use Atree;

with Checks;   use Checks;

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_Dbug; use Exp_Dbug;

with Exp_Disp; use Exp_Disp;

with Exp_Sel;  use Exp_Sel;

with Exp_Smem; use Exp_Smem;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Freeze;   use Freeze;

with Hostparm;

with Itypes;   use Itypes;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch11; use Sem_Ch11;

with Sem_Elab; use Sem_Elab;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

package body Exp_Ch9 is

   --  The following constant establishes the upper bound for the index of

   --  an entry family. It is used to limit the allocated size of protected

   --  types with defaulted discriminant of an integer type, when the bound

   --  of some entry family depends on a discriminant. The limitation to

   --  entry families of 128K should be reasonable in all cases, and is a

   --  documented implementation restriction. It will be lifted when protected

   --  entry families are re-implemented as a single ordered queue.

   Entry_Family_Bound : constant Int := 2**16;

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Actual_Index_Expression

     (Sloc  : Source_Ptr;

      Ent   : Entity_Id;

      Index : Node_Id;

      Tsk   : Entity_Id) return Node_Id;

   --  Compute the index position for an entry call. Tsk is the target task. If

   --  the bounds of some entry family depend on discriminants, the expression

   --  computed by this function uses the discriminants of the target task.

   procedure Add_Object_Pointer

     (Loc      : Source_Ptr;

      Conc_Typ : Entity_Id;

      Decls    : List_Id);

   --  Prepend an object pointer declaration to the declaration list Decls.

   --  This object pointer is initialized to a type conversion of the System.

   --  Address pointer passed to entry barrier functions and entry body

   --  procedures.

   procedure Add_Formal_Renamings

     (Spec  : Node_Id;

      Decls : List_Id;

      Ent   : Entity_Id;

      Loc   : Source_Ptr);

   --  Create renaming declarations for the formals, inside the procedure that

   --  implements an entry body. The renamings make the original names of the

   --  formals accessible to gdb, and serve no other purpose.

   --    Spec is the specification of the procedure being built.

   --    Decls is the list of declarations to be enhanced.

   --    Ent is the entity for the original entry body.

   function Build_Accept_Body (Astat : Node_Id) return Node_Id;

   --  Transform accept statement into a block with added exception handler.

   --  Used both for simple accept statements and for accept alternatives in

   --  select statements. Astat is the accept statement.

   function Build_Barrier_Function

     (N   : Node_Id;

      Ent : Entity_Id;

      Pid : Node_Id) return Node_Id;

   --  Build the function body returning the value of the barrier expression

   --  for the specified entry body.

   function Build_Barrier_Function_Specification

     (Loc    : Source_Ptr;

      Def_Id : Entity_Id) return Node_Id;

   --  Build a specification for a function implementing the protected entry

   --  barrier of the specified entry body.

   function Build_Entry_Count_Expression

     (Concurrent_Type : Node_Id;

      Component_List  : List_Id;

      Loc             : Source_Ptr) return Node_Id;

   --  Compute number of entries for concurrent object. This is a count of

   --  simple entries, followed by an expression that computes the length

   --  of the range of each entry family. A single array with that size is

   --  allocated for each concurrent object of the type.

   function Build_Parameter_Block

     (Loc     : Source_Ptr;

      Actuals : List_Id;

      Formals : List_Id;

      Decls   : List_Id) return Entity_Id;

   --  Generate an access type for each actual parameter in the list Actuals.

   --  Create an encapsulating record that contains all the actuals and return

   --  its type. Generate:

   --    type Ann1 is access all <actual1-type>

   --    ...

   --    type AnnN is access all <actualN-type>

   --    type Pnn is record

   --       <formal1> : Ann1;

   --       ...

   --       <formalN> : AnnN;

   --    end record;

   procedure Build_Wrapper_Bodies

     (Loc : Source_Ptr;

      Typ : Entity_Id;

      N   : Node_Id);

   --  Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding

   --  record of a concurrent type. N is the insertion node where all bodies

   --  will be placed. This routine builds the bodies of the subprograms which

   --  serve as an indirection mechanism to overriding primitives of concurrent

   --  types, entries and protected procedures. Any new body is analyzed.

   procedure Build_Wrapper_Specs

     (Loc : Source_Ptr;

      Typ : Entity_Id;

      N   : in out Node_Id);

   --  Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding

   --  record of a concurrent type. N is the insertion node where all specs

   --  will be placed. This routine builds the specs of the subprograms which

   --  serve as an indirection mechanism to overriding primitives of concurrent

   --  types, entries and protected procedures. Any new spec is analyzed.

   function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;

   --  Build the function that translates the entry index in the call

   --  (which depends on the size of entry families) into an index into the

   --  Entry_Bodies_Array, to determine the body and barrier function used

   --  in a protected entry call. A pointer to this function appears in every

   --  protected object.

   function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;

   --  Build subprogram declaration for previous one

   function Build_Protected_Entry

     (N   : Node_Id;

      Ent : Entity_Id;

      Pid : Node_Id) return Node_Id;

   --  Build the procedure implementing the statement sequence of the specified

   --  entry body.

   function Build_Protected_Entry_Specification

     (Loc    : Source_Ptr;

      Def_Id : Entity_Id;

      Ent_Id : Entity_Id) return Node_Id;

   --  Build a specification for the procedure implementing the statements of

   --  the specified entry body. Add attributes associating it with the entry

   --  defining identifier Ent_Id.

   function Build_Protected_Spec

     (N           : Node_Id;

      Obj_Type    : Entity_Id;

      Ident       : Entity_Id;

      Unprotected : Boolean := False) return List_Id;

   --  Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_

   --  Subprogram_Type. Builds signature of protected subprogram, adding the

   --  formal that corresponds to the object itself. For an access to protected

   --  subprogram, there is no object type to specify, so the parameter has

   --  type Address and mode In. An indirect call through such a pointer will

   --  convert the address to a reference to the actual object. The object is

   --  a limited record and therefore a by_reference type.

   function Build_Protected_Subprogram_Body

     (N         : Node_Id;

      Pid       : Node_Id;

      N_Op_Spec : Node_Id) return Node_Id;

   --  This function is used to construct the protected version of a protected

   --  subprogram. Its statement sequence first defers abort, then locks

   --  the associated protected object, and then enters a block that contains

   --  a call to the unprotected version of the subprogram (for details, see

   --  Build_Unprotected_Subprogram_Body). This block statement requires

   --  a cleanup handler that unlocks the object in all cases.

   --  (see Exp_Ch7.Expand_Cleanup_Actions).

   function Build_Selected_Name

     (Prefix      : Entity_Id;

      Selector    : Entity_Id;

      Append_Char : Character := ' ') return Name_Id;

   --  Build a name in the form of Prefix__Selector, with an optional

   --  character appended. This is used for internal subprograms generated

   --  for operations of protected types, including barrier functions.

   --  For the subprograms generated for entry bodies and entry barriers,

   --  the generated name includes a sequence number that makes names

   --  unique in the presence of entry overloading. This is necessary

   --  because entry body procedures and barrier functions all have the

   --  same signature.

   procedure Build_Simple_Entry_Call

     (N       : Node_Id;

      Concval : Node_Id;

      Ename   : Node_Id;

      Index   : Node_Id);

   --  Some comments here would be useful ???

   function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;

   --  This routine constructs a specification for the procedure that we will

   --  build for the task body for task type T. The spec has the form:

   --

   --    procedure tnameB (_Task : access tnameV);

   --

   --  where name is the character name taken from the task type entity that

   --  is passed as the argument to the procedure, and tnameV is the task

   --  value type that is associated with the task type.

   function Build_Unprotected_Subprogram_Body

     (N   : Node_Id;

      Pid : Node_Id) return Node_Id;

   --  This routine constructs the unprotected version of a protected

   --  subprogram body, which is contains all of the code in the

   --  original, unexpanded body. This is the version of the protected

   --  subprogram that is called from all protected operations on the same

   --  object, including the protected version of the same subprogram.

   procedure Collect_Entry_Families

     (Loc          : Source_Ptr;

      Cdecls       : List_Id;

      Current_Node : in out Node_Id;

      Conctyp      : Entity_Id);

   --  For each entry family in a concurrent type, create an anonymous array

   --  type of the right size, and add a component to the corresponding_record.

   function Concurrent_Object

     (Spec_Id  : Entity_Id;

      Conc_Typ : Entity_Id) return Entity_Id;

   --  Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return

   --  the entity associated with the concurrent object in the Protected_Body_

   --  Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity

   --  denotes formal parameter _O, _object or _task.

   function Copy_Result_Type (Res : Node_Id) return Node_Id;

   --  Copy the result type of a function specification, when building the

   --  internal operation corresponding to a protected function, or when

   --  expanding an access to protected function. If the result is an anonymous

   --  access to subprogram itself, we need to create a new signature with the

   --  same parameter names and the same resolved types, but with new entities

   --  for the formals.

   procedure Debug_Private_Data_Declarations (Decls : List_Id);

   --  Decls is a list which may contain the declarations created by Install_

   --  Private_Data_Declarations. All generated entities are marked as needing

   --  debug info and debug nodes are manually generation where necessary. This

   --  step of the expansion must to be done after private data has been moved

   --  to its final resting scope to ensure proper visibility of debug objects.

   function Family_Offset

     (Loc  : Source_Ptr;

      Hi   : Node_Id;

      Lo   : Node_Id;

      Ttyp : Entity_Id;

      Cap  : Boolean) return Node_Id;

   --  Compute (Hi - Lo) for two entry family indices. Hi is the index in

   --  an accept statement, or the upper bound in the discrete subtype of

   --  an entry declaration. Lo is the corresponding lower bound. Ttyp is

   --  the concurrent type of the entry. If Cap is true, the result is

   --  capped according to Entry_Family_Bound.

   function Family_Size

     (Loc  : Source_Ptr;

      Hi   : Node_Id;

      Lo   : Node_Id;

      Ttyp : Entity_Id;

      Cap  : Boolean) return Node_Id;

   --  Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in

   --  a family, and handle properly the superflat case. This is equivalent

   --  to the use of 'Length on the index type, but must use Family_Offset

   --  to handle properly the case of bounds that depend on discriminants.

   --  If Cap is true, the result is capped according to Entry_Family_Bound.

   procedure Extract_Dispatching_Call

     (N        : Node_Id;

      Call_Ent : out Entity_Id;

      Object   : out Entity_Id;

      Actuals  : out List_Id;

      Formals  : out List_Id);

   --  Given a dispatching call, extract the entity of the name of the call,

   --  its object parameter, its actual parameters and the formal parameters

   --  of the overridden interface-level version.

   procedure Extract_Entry

     (N       : Node_Id;

      Concval : out Node_Id;

      Ename   : out Node_Id;

      Index   : out Node_Id);

   --  Given an entry call, returns the associated concurrent object,

   --  the entry name, and the entry family index.

   function Find_Task_Or_Protected_Pragma

     (T : Node_Id;

      P : Name_Id) return Node_Id;

   --  Searches the task or protected definition T for the first occurrence

   --  of the pragma whose name is given by P. The caller has ensured that

   --  the pragma is present in the task definition. A special case is that

   --  when P is Name_uPriority, the call will also find Interrupt_Priority.

   --  ??? Should be implemented with the rep item chain mechanism.

   function Index_Object (Spec_Id : Entity_Id) return Entity_Id;

   --  Given a subprogram identifier, return the entity which is associated

   --  with the protection entry index in the Protected_Body_Subprogram or the

   --  Task_Body_Procedure of Spec_Id. The returned entity denotes formal

   --  parameter _E.

   function Is_Potentially_Large_Family

     (Base_Index : Entity_Id;

      Conctyp    : Entity_Id;

      Lo         : Node_Id;

      Hi         : Node_Id) return Boolean;

   function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;

   --  Determine whether Id is a function or a procedure and is marked as a

   --  private primitive.

   function Null_Statements (Stats : List_Id) return Boolean;

   --  Used to check DO-END sequence. Checks for equivalent of DO NULL; END.

   --  Allows labels, and pragma Warnings/Unreferenced in the sequence as

   --  well to still count as null. Returns True for a null sequence. The

   --  argument is the list of statements from the DO-END sequence.

   function Parameter_Block_Pack

     (Loc     : Source_Ptr;

      Blk_Typ : Entity_Id;

      Actuals : List_Id;

      Formals : List_Id;

      Decls   : List_Id;

      Stmts   : List_Id) return Entity_Id;

   --  Set the components of the generated parameter block with the values of

   --  the actual parameters. Generate aliased temporaries to capture the

   --  values for types that are passed by copy. Otherwise generate a reference

   --  to the actual's value. Return the address of the aggregate block.

   --  Generate:

   --    Jnn1 : alias <formal-type1>;

   --    Jnn1 := <actual1>;

   --    ...

   --    P : Blk_Typ := (

   --      Jnn1'unchecked_access;

   --      <actual2>'reference;

   --      ...);

   function Parameter_Block_Unpack

     (Loc     : Source_Ptr;

      P       : Entity_Id;

      Actuals : List_Id;

      Formals : List_Id) return List_Id;

   --  Retrieve the values of the components from the parameter block and

   --  assign then to the original actual parameters. Generate:

   --    <actual1> := P.<formal1>;

   --    ...

   --    <actualN> := P.<formalN>;

   function Trivial_Accept_OK return Boolean;

   --  If there is no DO-END block for an accept, or if the DO-END block has

   --  only null statements, then it is possible to do the Rendezvous with much

   --  less overhead using the Accept_Trivial routine in the run-time library.

   --  However, this is not always a valid optimization. Whether it is valid or

   --  not depends on the Task_Dispatching_Policy. The issue is whether a full

   --  rescheduling action is required or not. In FIFO_Within_Priorities, such

   --  a rescheduling is required, so this optimization is not allowed. This

   --  function returns True if the optimization is permitted.

   -----------------------------

   -- Actual_Index_Expression --

   -----------------------------

   function Actual_Index_Expression

     (Sloc  : Source_Ptr;

      Ent   : Entity_Id;

      Index : Node_Id;

      Tsk   : Entity_Id) return Node_Id

   is

      Ttyp : constant Entity_Id := Etype (Tsk);

      Expr : Node_Id;

      Num  : Node_Id;

      Lo   : Node_Id;

      Hi   : Node_Id;

      Prev : Entity_Id;

      S    : Node_Id;

      function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;

      --  Compute difference between bounds of entry family

      --------------------------

      -- Actual_Family_Offset --

      --------------------------

      function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is

         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;

         --  Replace a reference to a discriminant with a selected component

         --  denoting the discriminant of the target task.

         -----------------------------

         -- Actual_Discriminant_Ref --

         -----------------------------

         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is

            Typ : constant Entity_Id := Etype (Bound);

            B   : Node_Id;

         begin

            if not Is_Entity_Name (Bound)

              or else Ekind (Entity (Bound)) /= E_Discriminant

            then

               if Nkind (Bound) = N_Attribute_Reference then

                  return Bound;

               else

                  B := New_Copy_Tree (Bound);

               end if;

            else

               B :=

                 Make_Selected_Component (Sloc,

                   Prefix => New_Copy_Tree (Tsk),

                   Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));

               Analyze_And_Resolve (B, Typ);

            end if;

            return

              Make_Attribute_Reference (Sloc,

                Attribute_Name => Name_Pos,

                Prefix => New_Occurrence_Of (Etype (Bound), Sloc),

                Expressions => New_List (B));

         end Actual_Discriminant_Ref;

      --  Start of processing for Actual_Family_Offset

      begin

         return

           Make_Op_Subtract (Sloc,

             Left_Opnd  => Actual_Discriminant_Ref (Hi),

             Right_Opnd => Actual_Discriminant_Ref (Lo));

      end Actual_Family_Offset;

   --  Start of processing for Actual_Index_Expression

   begin

      --  The queues of entries and entry families appear in textual order in

      --  the associated record. The entry index is computed as the sum of the

      --  number of queues for all entries that precede the designated one, to

      --  which is added the index expression, if this expression denotes a

      --  member of a family.

      --  The following is a place holder for the count of simple entries

      Num := Make_Integer_Literal (Sloc, 1);

      --  We construct an expression which is a series of addition operations.

      --  See comments in Entry_Index_Expression, which is identical in

      --  structure.

      if Present (Index) then

         S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));

         Expr :=

           Make_Op_Add (Sloc,

             Left_Opnd  => Num,

             Right_Opnd =>

               Actual_Family_Offset (

                 Make_Attribute_Reference (Sloc,

                   Attribute_Name => Name_Pos,

                   Prefix => New_Reference_To (Base_Type (S), Sloc),

                   Expressions => New_List (Relocate_Node (Index))),

                 Type_Low_Bound (S)));

      else

         Expr := Num;

      end if;

      --  Now add lengths of preceding entries and entry families

      Prev := First_Entity (Ttyp);

      while Chars (Prev) /= Chars (Ent)

        or else (Ekind (Prev) /= Ekind (Ent))

        or else not Sem_Ch6.Type_Conformant (Ent, Prev)

      loop

         if Ekind (Prev) = E_Entry then

            Set_Intval (Num, Intval (Num) + 1);

         elsif Ekind (Prev) = E_Entry_Family then

            S :=

              Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));

            --  The need for the following full view retrieval stems from

            --  this complex case of nested generics and tasking:

            --     generic

            --        type Formal_Index is range <>;

            --        ...

            --     package Outer is

            --        type Index is private;

            --        generic

            --           ...

            --        package Inner is

            --           procedure P;

            --        end Inner;

            --     private

            --        type Index is new Formal_Index range 1 .. 10;

            --     end Outer;

            --     package body Outer is

            --        task type T is

            --           entry Fam (Index);  --  (2)

            --           entry E;

            --        end T;

            --        package body Inner is  --  (3)

            --           procedure P is

            --           begin

            --              T.E;             --  (1)

            --           end P;

            --       end Inner;

            --       ...

            --  We are currently building the index expression for the entry

            --  call "T.E" (1). Part of the expansion must mention the range

            --  of the discrete type "Index" (2) of entry family "Fam".

            --  However only the private view of type "Index" is available to

            --  the inner generic (3) because there was no prior mention of

            --  the type inside "Inner". This visibility requirement is

            --  implicit and cannot be detected during the construction of

            --  the generic trees and needs special handling.

            if In_Instance_Body

              and then Is_Private_Type (S)

              and then Present (Full_View (S))

            then

               S := Full_View (S);

            end if;

            Lo := Type_Low_Bound  (S);

            Hi := Type_High_Bound (S);

            Expr :=

              Make_Op_Add (Sloc,

              Left_Opnd  => Expr,

              Right_Opnd =>

                Make_Op_Add (Sloc,

                  Left_Opnd =>

                    Actual_Family_Offset (Hi, Lo),

                  Right_Opnd =>

                    Make_Integer_Literal (Sloc, 1)));

         --  Other components are anonymous types to be ignored

         else

            null;

         end if;

         Next_Entity (Prev);

      end loop;

      return Expr;

   end Actual_Index_Expression;

   --------------------------

   -- Add_Formal_Renamings --

   --------------------------

   procedure Add_Formal_Renamings

     (Spec  : Node_Id;

      Decls : List_Id;

      Ent   : Entity_Id;

      Loc   : Source_Ptr)

   is

      Ptr : constant Entity_Id :=

              Defining_Identifier

                (Next (First (Parameter_Specifications (Spec))));

      --  The name of the formal that holds the address of the parameter block

      --  for the call.

      Comp   : Entity_Id;

      Decl   : Node_Id;

      Formal : Entity_Id;

      New_F  : Entity_Id;

   begin

      Formal := First_Formal (Ent);

      while Present (Formal) loop

         Comp := Entry_Component (Formal);

         New_F :=

           Make_Defining_Identifier (Sloc (Formal),

             Chars => Chars (Formal));

         Set_Etype (New_F, Etype (Formal));

         Set_Scope (New_F, Ent);

         --  Now we set debug info needed on New_F even though it does not

         --  come from source, so that the debugger will get the right

         --  information for these generated names.

         Set_Debug_Info_Needed (New_F);

         if Ekind (Formal) = E_In_Parameter then

            Set_Ekind (New_F, E_Constant);

         else

            Set_Ekind (New_F, E_Variable);

            Set_Extra_Constrained (New_F, Extra_Constrained (Formal));

         end if;

         Set_Actual_Subtype (New_F, Actual_Subtype (Formal));

         Decl :=

           Make_Object_Renaming_Declaration (Loc,

           Defining_Identifier => New_F,

           Subtype_Mark =>

             New_Reference_To (Etype (Formal), Loc),

           Name =>

             Make_Explicit_Dereference (Loc,

               Make_Selected_Component (Loc,

                 Prefix =>

                   Unchecked_Convert_To (Entry_Parameters_Type (Ent),

                     Make_Identifier (Loc, Chars (Ptr))),

                 Selector_Name =>

                   New_Reference_To (Comp, Loc))));

         Append (Decl, Decls);

         Set_Renamed_Object (Formal, New_F);

         Next_Formal (Formal);

      end loop;

   end Add_Formal_Renamings;

   ------------------------

   -- Add_Object_Pointer --

   ------------------------

   procedure Add_Object_Pointer

     (Loc      : Source_Ptr;

      Conc_Typ : Entity_Id;

      Decls    : List_Id)

   is

      Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);

      Decl    : Node_Id;

      Obj_Ptr : Node_Id;

   begin

      --  Create the renaming declaration for the Protection object of a

      --  protected type. _Object is used by Complete_Entry_Body.

      --  ??? An attempt to make this a renaming was unsuccessful.

      --  Build the entity for the access type

      Obj_Ptr :=

        Make_Defining_Identifier (Loc,

          New_External_Name (Chars (Rec_Typ), 'P'));

      --  Generate:

      --    _object : poVP := poVP!O;

      Decl :=

        Make_Object_Declaration (Loc,

          Defining_Identifier =>

            Make_Defining_Identifier (Loc, Name_uObject),

          Object_Definition =>

            New_Reference_To (Obj_Ptr, Loc),

          Expression =>

            Unchecked_Convert_To (Obj_Ptr,

              Make_Identifier (Loc, Name_uO)));

      Set_Debug_Info_Needed (Defining_Identifier (Decl));

      Prepend_To (Decls, Decl);

      --  Generate:

      --    type poVP is access poV;

      Decl :=

        Make_Full_Type_Declaration (Loc,

          Defining_Identifier =>

            Obj_Ptr,

          Type_Definition =>

            Make_Access_To_Object_Definition (Loc,

          Subtype_Indication =>

            New_Reference_To (Rec_Typ, Loc)));

      Set_Debug_Info_Needed (Defining_Identifier (Decl));

      Prepend_To (Decls, Decl);

   end Add_Object_Pointer;

   -----------------------

   -- Build_Accept_Body --

   -----------------------

   function Build_Accept_Body (Astat : Node_Id) return  Node_Id is

      Loc     : constant Source_Ptr := Sloc (Astat);

      Stats   : constant Node_Id    := Handled_Statement_Sequence (Astat);

      New_S   : Node_Id;

      Hand    : Node_Id;

      Call    : Node_Id;

      Ohandle : Node_Id;

   begin

      --  At the end of the statement sequence, Complete_Rendezvous is called.

      --  A label skipping the Complete_Rendezvous, and all other accept

      --  processing, has already been added for the expansion of requeue

      --  statements. The Sloc is copied from the last statement since it

      --  is really part of this last statement.

      Call :=

        Build_Runtime_Call

          (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);

      Insert_Before (Last (Statements (Stats)), Call);

      Analyze (Call);

      --  If exception handlers are present, then append Complete_Rendezvous

      --  calls to the handlers, and construct the required outer block. As

      --  above, the Sloc is copied from the last statement in the sequence.

      if Present (Exception_Handlers (Stats)) then

         Hand := First (Exception_Handlers (Stats));

         while Present (Hand) loop

            Call :=

              Build_Runtime_Call

                (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);

            Append (Call, Statements (Hand));

            Analyze (Call);

            Next (Hand);

         end loop;

         New_S :=

           Make_Handled_Sequence_Of_Statements (Loc,

             Statements => New_List (

               Make_Block_Statement (Loc,

                 Handled_Statement_Sequence => Stats)));

      else

         New_S := Stats;

      end if;

      --  At this stage we know that the new statement sequence does not

      --  have an exception handler part, so we supply one to call

      --  Exceptional_Complete_Rendezvous. This handler is

      --    when all others =>

      --       Exceptional_Complete_Rendezvous (Get_GNAT_Exception);

      --  We handle Abort_Signal to make sure that we properly catch the abort

      --  case and wake up the caller.

      Ohandle := Make_Others_Choice (Loc);

      Set_All_Others (Ohandle);

      Set_Exception_Handlers (New_S,

        New_List (

          Make_Implicit_Exception_Handler (Loc,

            Exception_Choices => New_List (Ohandle),

            Statements =>  New_List (

              Make_Procedure_Call_Statement (Sloc (Stats),

                Name => New_Reference_To (

                  RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),

                Parameter_Associations => New_List (

                  Make_Function_Call (Sloc (Stats),

                    Name => New_Reference_To (

                      RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));

      Set_Parent (New_S, Astat); -- temp parent for Analyze call