Subversion Repositories scarts

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 9                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, 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 2,  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 COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- 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_Smem; use Exp_Smem;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Freeze;   use Freeze;

with Hostparm;

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_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch11; use Sem_Ch11;

with Sem_Elab; use Sem_Elab;

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 Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

package body Exp_Ch9 is

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

   -- Select_Expansion_Utilities --

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

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

   --  The following package contains helper routines used in the expansion of

   --  dispatching asynchronous, conditional and timed selects.

   package Select_Expansion_Utilities is

      function Build_Abort_Block

        (Loc         : Source_Ptr;

         Abr_Blk_Ent : Entity_Id;

         Cln_Blk_Ent : Entity_Id;

         Blk         : Node_Id) return Node_Id;

      --  Generate:

      --    begin

      --       Blk

      --    exception

      --       when Abort_Signal => Abort_Undefer;

      --    end;

      --  Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is

      --  the name of the encapsulated cleanup block, Blk is the actual

      --  block node.

      function Build_B

        (Loc   : Source_Ptr;

         Decls : List_Id) return Entity_Id;

      --  Generate:

      --    B : Boolean := False;

      --  Append the object declaration to the list and return the name of

      --  the object.

      function Build_C

        (Loc   : Source_Ptr;

         Decls : List_Id) return Entity_Id;

      --  Generate:

      --    C : Ada.Tags.Prim_Op_Kind;

      --  Append the object declaration to the list and return the name of

      --  the object.

      function Build_Cleanup_Block

        (Loc       : Source_Ptr;

         Blk_Ent   : Entity_Id;

         Stmts     : List_Id;

         Clean_Ent : Entity_Id) return Node_Id;

      --  Generate:

      --    declare

      --       procedure _clean is

      --       begin

      --          ...

      --       end _clean;

      --    begin

      --       Stmts

      --    at end

      --       _clean;

      --    end;

      --  Blk_Ent is the name of the generated block, Stmts is the list

      --  of encapsulated statements and Clean_Ent is the parameter to

      --  the _clean procedure.

      function Build_S

        (Loc      : Source_Ptr;

         Decls    : List_Id;

         Obj      : Entity_Id;

         Call_Ent : Entity_Id) return Entity_Id;

      --  Generate:

      --    S : constant Integer :=

      --          Ada.Tags.Get_Offset_Index (

      --            Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj),

      --            DT_Position (Call_Ent));

      --  where Obj is the pointer to a secondary table, Call_Ent is the

      --  entity of the dispatching call name. Append the object declaration

      --  to the list and return its defining identifier.

   end Select_Expansion_Utilities;

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

   -- Body for Select_Expansion_Utilities --

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

   package body Select_Expansion_Utilities is

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

      -- Build_Abort_Block --

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

      function Build_Abort_Block

        (Loc         : Source_Ptr;

         Abr_Blk_Ent : Entity_Id;

         Cln_Blk_Ent : Entity_Id;

         Blk         : Node_Id) return Node_Id

      is

      begin

         return

           Make_Block_Statement (Loc,

             Identifier   => New_Reference_To (Abr_Blk_Ent, Loc),

             Declarations => No_List,

             Handled_Statement_Sequence =>

               Make_Handled_Sequence_Of_Statements (Loc,

                 Statements =>

                   New_List (

                     Make_Implicit_Label_Declaration (Loc,

                       Defining_Identifier =>

                         Cln_Blk_Ent,

                       Label_Construct =>

                         Blk),

                     Blk),

                 Exception_Handlers =>

                   New_List (

                     Make_Exception_Handler (Loc,

                       Exception_Choices =>

                         New_List (

                           New_Reference_To (Stand.Abort_Signal, Loc)),

                       Statements =>

                         New_List (

                           Make_Procedure_Call_Statement (Loc,

                             Name =>

                               New_Reference_To (RTE (

                                 RE_Abort_Undefer), Loc),

                             Parameter_Associations => No_List))))));

      end Build_Abort_Block;

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

      -- Build_B --

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

      function Build_B

        (Loc   : Source_Ptr;

         Decls : List_Id) return Entity_Id

      is

         B : constant Entity_Id := Make_Defining_Identifier (Loc,

                                     Chars => New_Internal_Name ('B'));

      begin

         Append_To (Decls,

           Make_Object_Declaration (Loc,

             Defining_Identifier =>

               B,

             Object_Definition =>

               New_Reference_To (Standard_Boolean, Loc),

             Expression =>

               New_Reference_To (Standard_False, Loc)));

         return B;

      end Build_B;

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

      -- Build_C --

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

      function Build_C

        (Loc   : Source_Ptr;

         Decls : List_Id) return Entity_Id

      is

         C : constant Entity_Id := Make_Defining_Identifier (Loc,

                                     Chars => New_Internal_Name ('C'));

      begin

         Append_To (Decls,

           Make_Object_Declaration (Loc,

             Defining_Identifier =>

               C,

             Object_Definition =>

               New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));

         return C;

      end Build_C;

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

      -- Build_Cleanup_Block --

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

      function Build_Cleanup_Block

        (Loc       : Source_Ptr;

         Blk_Ent   : Entity_Id;

         Stmts     : List_Id;

         Clean_Ent : Entity_Id) return Node_Id

      is

         Cleanup_Block : constant Node_Id :=

                           Make_Block_Statement (Loc,

                             Identifier   => New_Reference_To (Blk_Ent, Loc),

                             Declarations => No_List,

                             Handled_Statement_Sequence =>

                               Make_Handled_Sequence_Of_Statements (Loc,

                                 Statements => Stmts),

                             Is_Asynchronous_Call_Block => True);

      begin

         Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);

         return Cleanup_Block;

      end Build_Cleanup_Block;

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

      -- Build_S --

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

      function Build_S

        (Loc      : Source_Ptr;

         Decls    : List_Id;

         Obj      : Entity_Id;

         Call_Ent : Entity_Id) return Entity_Id

      is

         S : constant Entity_Id := Make_Defining_Identifier (Loc,

                                     Chars => New_Internal_Name ('S'));

      begin

         Append_To (Decls,

           Make_Object_Declaration (Loc,

             Defining_Identifier => S,

             Constant_Present    => True,

             Object_Definition   =>

               New_Reference_To (Standard_Integer, Loc),

             Expression          =>

               Make_Function_Call (Loc,

                 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),

                 Parameter_Associations => New_List (

                   Unchecked_Convert_To (RTE (RE_Interface_Tag), Obj),

                   Make_Integer_Literal (Loc, DT_Position (Call_Ent))))));

         return S;

      end Build_S;

   end Select_Expansion_Utilities;

   package SEU renames Select_Expansion_Utilities;

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

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

     (Decls : List_Id;

      Pid   : Entity_Id;

      Loc   : Source_Ptr);

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

     (Def_Id : Entity_Id;

      Loc    : Source_Ptr) return Node_Id;

   --  Build a specification for a function implementing

   --  the protected entry barrier of the specified entry body.

   function Build_Corresponding_Record

     (N    : Node_Id;

      Ctyp : Node_Id;

      Loc  : Source_Ptr) return Node_Id;

   --  Common to tasks and protected types. Copy discriminant specifications,

   --  build record declaration. N is the type declaration, Ctyp is the

   --  concurrent entity (task type or protected type).

   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.

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

   function Build_Wrapper_Body

     (Loc      : Source_Ptr;

      Proc_Nam : Entity_Id;

      Obj_Typ  : Entity_Id;

      Formals  : List_Id) return Node_Id;

   --  Ada 2005 (AI-345): Build the body that wraps a primitive operation

   --  associated with a protected or task type. This is required to implement

   --  dispatching calls through interfaces. Proc_Nam is the entry name to be

   --  wrapped, Obj_Typ is the type of the newly added formal parameter to

   --  handle object notation, Formals are the original entry formals that will

   --  be explicitly replicated.

   function Build_Wrapper_Spec

     (Loc      : Source_Ptr;

      Proc_Nam : Entity_Id;

      Obj_Typ  : Entity_Id;

      Formals  : List_Id) return Node_Id;

   --  Ada 2005 (AI-345): Build the specification of a primitive operation

   --  associated with a protected or task type. This is required implement

   --  dispatching calls through interfaces. Proc_Nam is the entry name to be

   --  wrapped, Obj_Typ is the type of the newly added formal parameter to

   --  handle object notation, Formals are the original entry formals that will

   --  be explicitly replicated.

   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

     (Def_Id : Entity_Id;

      Ent_Id : Entity_Id;

      Loc    : Source_Ptr) return Node_Id;

   --  Build a specification for a procedure implementing

   --  the statement sequence of the specified entry body.

   --  Add attributes associating it with the entry defining identifier

   --  Ent_Id.

   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_Protected_Spec

     (N           : Node_Id;

      Obj_Type    : Entity_Id;

      Unprotected : Boolean := False;

      Ident       : Entity_Id) 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 additional

   --  parameter has type Address and mode In. An indirect call through such

   --  a pointer converts the address to a reference to the actual object.

   --  The object is a limited record and therefore a by_reference type.

   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 Family_Offset

     (Loc  : Source_Ptr;

      Hi   : Node_Id;

      Lo   : Node_Id;

      Ttyp : Entity_Id) 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.

   function Family_Size

     (Loc  : Source_Ptr;

      Hi   : Node_Id;

      Lo   : Node_Id;

      Ttyp : Entity_Id) 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.

   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 overriden 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_Constant_Declaration

     (N        : Node_Id;

      Index_Id : Entity_Id;

      Prot     : Entity_Id) return List_Id;

   --  For an entry family and its barrier function, we define a local entity

   --  that maps the index in the call into the entry index into the object:

   --

   --     I : constant Index_Type := Index_Type'Val (

   --       E - <<index of first family member>> +

   --       Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));

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

   procedure Update_Prival_Subtypes (N : Node_Id);

   --  The actual subtypes of the privals will differ from the type of the

   --  private declaration in the original protected type, if the protected

   --  type has discriminants or if the prival has constrained components.

   --  This is because the privals are generated out of sequence w.r.t. the

   --  analysis of a protected body. After generating the bodies for protected

   --  operations, we set correctly the type of all references to privals, by

   --  means of a recursive tree traversal, which is heavy-handed but

   --  correct.

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

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

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

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

   procedure Add_Discriminal_Declarations

     (Decls : List_Id;

      Typ   : Entity_Id;

      Name  : Name_Id;

      Loc   : Source_Ptr)

   is

      D     : Entity_Id;

   begin

      if Has_Discriminants (Typ) then

         D := First_Discriminant (Typ);

         while Present (D) loop

            Prepend_To (Decls,

              Make_Object_Renaming_Declaration (Loc,

                Defining_Identifier => Discriminal (D),

                Subtype_Mark => New_Reference_To (Etype (D), Loc),

                Name =>

                  Make_Selected_Component (Loc,

                    Prefix        => Make_Identifier (Loc, Name),

                    Selector_Name => Make_Identifier (Loc, Chars (D)))));

            Next_Discriminant (D);

         end loop;

      end if;

   end Add_Discriminal_Declarations;

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

   -- Add_Object_Pointer --

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

   procedure Add_Object_Pointer

     (Decls : List_Id;

      Pid   : Entity_Id;

      Loc   : Source_Ptr)

   is

      Decl    : Node_Id;

      Obj_Ptr : Node_Id;

   begin

      --  Prepend the declaration of _object. This must be first in the

      --  declaration list, since it is used by the discriminal and

      --  prival declarations.

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

      --

      --     type poVP is access poV;

      --     _object : poVP := poVP!O;

      Obj_Ptr :=

        Make_Defining_Identifier (Loc,

          Chars =>