Subversion Repositories openrisc_me

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             E X P _ D I S P                              --

--                                                                          --

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

with Einfo;    use Einfo;

with Elists;   use Elists;

with Errout;   use Errout;

with Exp_Atag; use Exp_Atag;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Dbug; use Exp_Dbug;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Freeze;   use Freeze;

with Itypes;   use Itypes;

with Layout;   use Layout;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Namet;    use Namet;

with Opt;      use Opt;

with Output;   use Output;

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_Ch7;  use Sem_Ch7;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Disp; use Sem_Disp;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Type; use Sem_Type;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

package body Exp_Disp is

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

   -- Local Subprograms --

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

   function Default_Prim_Op_Position (E : Entity_Id) return Uint;

   --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table

   --  of the default primitive operations.

   function Has_DT (Typ : Entity_Id) return Boolean;

   pragma Inline (Has_DT);

   --  Returns true if we generate a dispatch table for tagged type Typ

   function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;

   --  Returns true if Prim is not a predefined dispatching primitive but it is

   --  an alias of a predefined dispatching primitive (i.e. through a renaming)

   function New_Value (From : Node_Id) return Node_Id;

   --  From is the original Expression. New_Value is equivalent to a call

   --  to Duplicate_Subexpr with an explicit dereference when From is an

   --  access parameter.

   function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;

   --  Check if the type has a private view or if the public view appears

   --  in the visible part of a package spec.

   function Prim_Op_Kind

     (Prim : Entity_Id;

      Typ  : Entity_Id) return Node_Id;

   --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim

   --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind

   --  enumeration value.

   function Tagged_Kind (T : Entity_Id) return Node_Id;

   --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference

   --  to an RE_Tagged_Kind enumeration value.

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

   -- Apply_Tag_Checks --

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

   procedure Apply_Tag_Checks (Call_Node : Node_Id) is

      Loc        : constant Source_Ptr := Sloc (Call_Node);

      Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);

      Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));

      Param_List : constant List_Id   := Parameter_Associations (Call_Node);

      Subp            : Entity_Id;

      CW_Typ          : Entity_Id;

      Param           : Node_Id;

      Typ             : Entity_Id;

      Eq_Prim_Op      : Entity_Id := Empty;

   begin

      if No_Run_Time_Mode then

         Error_Msg_CRT ("tagged types", Call_Node);

         return;

      end if;

      --  Apply_Tag_Checks is called directly from the semantics, so we need

      --  a check to see whether expansion is active before proceeding. In

      --  addition, there is no need to expand the call when compiling under

      --  restriction No_Dispatching_Calls; the semantic analyzer has

      --  previously notified the violation of this restriction.

      if not Expander_Active

        or else Restriction_Active (No_Dispatching_Calls)

      then

         return;

      end if;

      --  Set subprogram. If this is an inherited operation that was

      --  overridden, the body that is being called is its alias.

      Subp := Entity (Name (Call_Node));

      if Present (Alias (Subp))

        and then Is_Inherited_Operation (Subp)

        and then No (DTC_Entity (Subp))

      then

         Subp := Alias (Subp);

      end if;

      --  Definition of the class-wide type and the tagged type

      --  If the controlling argument is itself a tag rather than a tagged

      --  object, then use the class-wide type associated with the subprogram's

      --  controlling type. This case can occur when a call to an inherited

      --  primitive has an actual that originated from a default parameter

      --  given by a tag-indeterminate call and when there is no other

      --  controlling argument providing the tag (AI-239 requires dispatching).

      --  This capability of dispatching directly by tag is also needed by the

      --  implementation of AI-260 (for the generic dispatching constructors).

      if Ctrl_Typ = RTE (RE_Tag)

        or else (RTE_Available (RE_Interface_Tag)

                  and then Ctrl_Typ = RTE (RE_Interface_Tag))

      then

         CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));

      --  Class_Wide_Type is applied to the expressions used to initialize

      --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since

      --  there are cases where the controlling type is resolved to a specific

      --  type (such as for designated types of arguments such as CW'Access).

      elsif Is_Access_Type (Ctrl_Typ) then

         CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));

      else

         CW_Typ := Class_Wide_Type (Ctrl_Typ);

      end if;

      Typ := Root_Type (CW_Typ);

      if Ekind (Typ) = E_Incomplete_Type then

         Typ := Non_Limited_View (Typ);

      end if;

      if not Is_Limited_Type (Typ) then

         Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);

      end if;

      --  Dispatching call to C++ primitive

      if Is_CPP_Class (Typ) then

         null;

      --  Dispatching call to Ada primitive

      elsif Present (Param_List) then

         --  Generate the Tag checks when appropriate

         Param := First_Actual (Call_Node);

         while Present (Param) loop

            --  No tag check with itself

            if Param = Ctrl_Arg then

               null;

            --  No tag check for parameter whose type is neither tagged nor

            --  access to tagged (for access parameters)

            elsif No (Find_Controlling_Arg (Param)) then

               null;

            --  No tag check for function dispatching on result if the

            --  Tag given by the context is this one

            elsif Find_Controlling_Arg (Param) = Ctrl_Arg then

               null;

            --  "=" is the only dispatching operation allowed to get

            --  operands with incompatible tags (it just returns false).

            --  We use Duplicate_Subexpr_Move_Checks instead of calling

            --  Relocate_Node because the value will be duplicated to

            --  check the tags.

            elsif Subp = Eq_Prim_Op then

               null;

            --  No check in presence of suppress flags

            elsif Tag_Checks_Suppressed (Etype (Param))

              or else (Is_Access_Type (Etype (Param))

                         and then Tag_Checks_Suppressed

                                    (Designated_Type (Etype (Param))))

            then

               null;

            --  Optimization: no tag checks if the parameters are identical

            elsif Is_Entity_Name (Param)

              and then Is_Entity_Name (Ctrl_Arg)

              and then Entity (Param) = Entity (Ctrl_Arg)

            then

               null;

            --  Now we need to generate the Tag check

            else

               --  Generate code for tag equality check

               --  Perhaps should have Checks.Apply_Tag_Equality_Check???

               Insert_Action (Ctrl_Arg,

                 Make_Implicit_If_Statement (Call_Node,

                   Condition =>

                     Make_Op_Ne (Loc,

                       Left_Opnd =>

                         Make_Selected_Component (Loc,

                           Prefix => New_Value (Ctrl_Arg),

                           Selector_Name =>

                             New_Reference_To

                               (First_Tag_Component (Typ), Loc)),

                       Right_Opnd =>

                         Make_Selected_Component (Loc,

                           Prefix =>

                             Unchecked_Convert_To (Typ, New_Value (Param)),

                           Selector_Name =>

                             New_Reference_To

                               (First_Tag_Component (Typ), Loc))),

                   Then_Statements =>

                     New_List (New_Constraint_Error (Loc))));

            end if;

            Next_Actual (Param);

         end loop;

      end if;

   end Apply_Tag_Checks;

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

   -- Building_Static_DT --

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

   function Building_Static_DT (Typ : Entity_Id) return Boolean is

      Root_Typ : Entity_Id := Root_Type (Typ);

   begin

      --  Handle private types

      if Present (Full_View (Root_Typ)) then

         Root_Typ := Full_View (Root_Typ);

      end if;

      return Static_Dispatch_Tables

        and then Is_Library_Level_Tagged_Type (Typ)

         --  If the type is derived from a CPP class we cannot statically

         --  build the dispatch tables because we must inherit primitives

         --  from the CPP side.

        and then not Is_CPP_Class (Root_Typ);

   end Building_Static_DT;

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

   -- Build_Static_Dispatch_Tables --

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

   procedure Build_Static_Dispatch_Tables (N : Entity_Id) is

      Target_List : List_Id;

      procedure Build_Dispatch_Tables (List : List_Id);

      --  Build the static dispatch table of tagged types found in the list of

      --  declarations. The generated nodes are added at the end of Target_List

      procedure Build_Package_Dispatch_Tables (N : Node_Id);

      --  Build static dispatch tables associated with package declaration N

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

      -- Build_Dispatch_Tables --

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

      procedure Build_Dispatch_Tables (List : List_Id) is

         D : Node_Id;

      begin

         D := First (List);

         while Present (D) loop

            --  Handle nested packages and package bodies recursively. The

            --  generated code is placed on the Target_List established for

            --  the enclosing compilation unit.

            if Nkind (D) = N_Package_Declaration then

               Build_Package_Dispatch_Tables (D);

            elsif Nkind (D) = N_Package_Body then

               Build_Dispatch_Tables (Declarations (D));

            elsif Nkind (D) = N_Package_Body_Stub

              and then Present (Library_Unit (D))

            then

               Build_Dispatch_Tables

                 (Declarations (Proper_Body (Unit (Library_Unit (D)))));

            --  Handle full type declarations and derivations of library

            --  level tagged types

            elsif Nkind_In (D, N_Full_Type_Declaration,

                               N_Derived_Type_Definition)

              and then Is_Library_Level_Tagged_Type (Defining_Entity (D))

              and then Ekind (Defining_Entity (D)) /= E_Record_Subtype

              and then not Is_Private_Type (Defining_Entity (D))

            then

               --  We do not generate dispatch tables for the internal types

               --  created for a type extension with unknown discriminants

               --  The needed information is shared with the source type,

               --  See Expand_N_Record_Extension.

               if Is_Underlying_Record_View (Defining_Entity (D))

                 or else

                  (not Comes_From_Source (Defining_Entity (D))

                     and then

                       Has_Unknown_Discriminants (Etype (Defining_Entity (D)))

                     and then

                       not Comes_From_Source

                             (First_Subtype (Defining_Entity (D))))

               then

                  null;

               else

                  Insert_List_After_And_Analyze (Last (Target_List),

                    Make_DT (Defining_Entity (D)));

               end if;

            --  Handle private types of library level tagged types. We must

            --  exchange the private and full-view to ensure the correct

            --  expansion. If the full view is a synchronized type ignore

            --  the type because the table will be built for the corresponding

            --  record type, that has its own declaration.

            elsif (Nkind (D) = N_Private_Type_Declaration

                     or else Nkind (D) = N_Private_Extension_Declaration)

               and then Present (Full_View (Defining_Entity (D)))

            then

               declare

                  E1 : constant Entity_Id := Defining_Entity (D);

                  E2 : constant Entity_Id := Full_View (E1);

               begin

                  if Is_Library_Level_Tagged_Type (E2)

                    and then Ekind (E2) /= E_Record_Subtype

                    and then not Is_Concurrent_Type (E2)

                  then

                     Exchange_Declarations (E1);

                     Insert_List_After_And_Analyze (Last (Target_List),

                       Make_DT (E1));

                     Exchange_Declarations (E2);

                  end if;

               end;

            end if;

            Next (D);

         end loop;

      end Build_Dispatch_Tables;

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

      -- Build_Package_Dispatch_Tables --

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

      procedure Build_Package_Dispatch_Tables (N : Node_Id) is

         Spec       : constant Node_Id   := Specification (N);

         Id         : constant Entity_Id := Defining_Entity (N);

         Vis_Decls  : constant List_Id   := Visible_Declarations (Spec);

         Priv_Decls : constant List_Id   := Private_Declarations (Spec);

      begin

         Push_Scope (Id);

         if Present (Priv_Decls) then

            Build_Dispatch_Tables (Vis_Decls);

            Build_Dispatch_Tables (Priv_Decls);

         elsif Present (Vis_Decls) then

            Build_Dispatch_Tables (Vis_Decls);

         end if;

         Pop_Scope;

      end Build_Package_Dispatch_Tables;

   --  Start of processing for Build_Static_Dispatch_Tables

   begin

      if not Expander_Active

        or else not Tagged_Type_Expansion

      then

         return;

      end if;

      if Nkind (N) = N_Package_Declaration then

         declare

            Spec       : constant Node_Id := Specification (N);

            Vis_Decls  : constant List_Id := Visible_Declarations (Spec);

            Priv_Decls : constant List_Id := Private_Declarations (Spec);

         begin

            if Present (Priv_Decls)

              and then Is_Non_Empty_List (Priv_Decls)

            then

               Target_List := Priv_Decls;

            elsif not Present (Vis_Decls) then

               Target_List := New_List;

               Set_Private_Declarations (Spec, Target_List);

            else

               Target_List := Vis_Decls;

            end if;

            Build_Package_Dispatch_Tables (N);

         end;

      else pragma Assert (Nkind (N) = N_Package_Body);

         Target_List := Declarations (N);

         Build_Dispatch_Tables (Target_List);

      end if;

   end Build_Static_Dispatch_Tables;

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

   -- Default_Prim_Op_Position --

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

   function Default_Prim_Op_Position (E : Entity_Id) return Uint is

      TSS_Name : TSS_Name_Type;

   begin

      Get_Name_String (Chars (E));

      TSS_Name :=

        TSS_Name_Type

          (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));

      if Chars (E) = Name_uSize then

         return Uint_1;

      elsif Chars (E) = Name_uAlignment then

         return Uint_2;

      elsif TSS_Name = TSS_Stream_Read then

         return Uint_3;

      elsif TSS_Name = TSS_Stream_Write then

         return Uint_4;

      elsif TSS_Name = TSS_Stream_Input then

         return Uint_5;

      elsif TSS_Name = TSS_Stream_Output then

         return Uint_6;

      elsif Chars (E) = Name_Op_Eq then

         return Uint_7;

      elsif Chars (E) = Name_uAssign then

         return Uint_8;

      elsif TSS_Name = TSS_Deep_Adjust then

         return Uint_9;

      elsif TSS_Name = TSS_Deep_Finalize then

         return Uint_10;

      elsif Ada_Version >= Ada_05 then

         if Chars (E) = Name_uDisp_Asynchronous_Select then

            return Uint_11;

         elsif Chars (E) = Name_uDisp_Conditional_Select then

            return Uint_12;

         elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then

            return Uint_13;

         elsif Chars (E) = Name_uDisp_Get_Task_Id then

            return Uint_14;

         elsif Chars (E) = Name_uDisp_Requeue then

            return Uint_15;

         elsif Chars (E) = Name_uDisp_Timed_Select then

            return Uint_16;

         end if;

      end if;

      raise Program_Error;

   end Default_Prim_Op_Position;

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

   -- Expand_Dispatching_Call --

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

   procedure Expand_Dispatching_Call (Call_Node : Node_Id) is

      Loc      : constant Source_Ptr := Sloc (Call_Node);

      Call_Typ : constant Entity_Id  := Etype (Call_Node);

      Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);

      Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));

      Param_List : constant List_Id   := Parameter_Associations (Call_Node);

      Subp            : Entity_Id;

      CW_Typ          : Entity_Id;

      New_Call        : Node_Id;

      New_Call_Name   : Node_Id;

      New_Params      : List_Id := No_List;

      Param           : Node_Id;

      Res_Typ         : Entity_Id;

      Subp_Ptr_Typ    : Entity_Id;

      Subp_Typ        : Entity_Id;

      Typ             : Entity_Id;

      Eq_Prim_Op      : Entity_Id := Empty;

      Controlling_Tag : Node_Id;

      function New_Value (From : Node_Id) return Node_Id;

      --  From is the original Expression. New_Value is equivalent to a call

      --  to Duplicate_Subexpr with an explicit dereference when From is an

      --  access parameter.

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

      -- New_Value --

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

      function New_Value (From : Node_Id) return Node_Id is

         Res : constant Node_Id := Duplicate_Subexpr (From);

      begin

         if Is_Access_Type (Etype (From)) then

            return

              Make_Explicit_Dereference (Sloc (From),

                Prefix => Res);

         else

            return Res;

         end if;

      end New_Value;

      --  Local variables

      New_Node  : Node_Id;

      SCIL_Node : Node_Id;

   --  Start of processing for Expand_Dispatching_Call

   begin

      if No_Run_Time_Mode then

         Error_Msg_CRT ("tagged types", Call_Node);

         return;

      end if;

      --  Expand_Dispatching_Call is called directly from the semantics,

      --  so we need a check to see whether expansion is active before

      --  proceeding. In addition, there is no need to expand the call

      --  if we are compiling under restriction No_Dispatching_Calls;

      --  the semantic analyzer has previously notified the violation

      --  of this restriction.

      if not Expander_Active

        or else Restriction_Active (No_Dispatching_Calls)

      then

         return;

      end if;

      --  Set subprogram. If this is an inherited operation that was

      --  overridden, the body that is being called is its alias.

      Subp := Entity (Name (Call_Node));

      if Present (Alias (Subp))

        and then Is_Inherited_Operation (Subp)

        and then No (DTC_Entity (Subp))

      then

         Subp := Alias (Subp);

      end if;

      --  Definition of the class-wide type and the tagged type

      --  If the controlling argument is itself a tag rather than a tagged

      --  object, then use the class-wide type associated with the subprogram's

      --  controlling type. This case can occur when a call to an inherited

      --  primitive has an actual that originated from a default parameter

      --  given by a tag-indeterminate call and when there is no other

      --  controlling argument providing the tag (AI-239 requires dispatching).

      --  This capability of dispatching directly by tag is also needed by the

      --  implementation of AI-260 (for the generic dispatching constructors).

      if Ctrl_Typ = RTE (RE_Tag)

        or else (RTE_Available (RE_Interface_Tag)

                  and then Ctrl_Typ = RTE (RE_Interface_Tag))

      then

         CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));

      --  Class_Wide_Type is applied to the expressions used to initialize

      --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since

      --  there are cases where the controlling type is resolved to a specific

      --  type (such as for designated types of arguments such as CW'Access).

      elsif Is_Access_Type (Ctrl_Typ) then

         CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));

      else

         CW_Typ := Class_Wide_Type (Ctrl_Typ);

      end if;

      Typ := Root_Type (CW_Typ);

      if Ekind (Typ) = E_Incomplete_Type then

         Typ := Non_Limited_View (Typ);

      end if;

      --  Generate the SCIL node for this dispatching call. The SCIL node for a

      --  dispatching call is inserted in the tree before the call is rewriten

      --  and expanded because the SCIL node must be found by the SCIL backend

      --  BEFORE the expanded nodes associated with the call node are found.

      if Generate_SCIL then

         SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));

         Set_SCIL_Related_Node (SCIL_Node, Call_Node);

         Set_SCIL_Entity       (SCIL_Node, Typ);

         Set_SCIL_Target_Prim  (SCIL_Node, Subp);

         Insert_Action (Call_Node, SCIL_Node);

      end if;

      if not Is_Limited_Type (Typ) then

         Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);

      end if;

      --  Dispatching call to C++ primitive. Create a new parameter list

      --  with no tag checks.

      New_Params := New_List;

      if Is_CPP_Class (Typ) then

         Param := First_Actual (Call_Node);

         while Present (Param) loop

            Append_To (New_Params, Relocate_Node (Param));

            Next_Actual (Param);

         end loop;

      --  Dispatching call to Ada primitive

      elsif Present (Param_List) then

         Apply_Tag_Checks (Call_Node);

         Param := First_Actual (Call_Node);

         while Present (Param) loop

            --  Cases in which we may have generated runtime checks

            if Param = Ctrl_Arg

              or else Subp = Eq_Prim_Op

            then

               Append_To (New_Params,

                 Duplicate_Subexpr_Move_Checks (Param));

            elsif Nkind (Parent (Param)) /= N_Parameter_Association

              or else not Is_Accessibility_Actual (Parent (Param))

            then

               Append_To (New_Params, Relocate_Node (Param));

            end if;

            Next_Actual (Param);

         end loop;

      end if;

      --  Generate the appropriate subprogram pointer type

      if Etype (Subp) = Typ then

         Res_Typ := CW_Typ;

      else

         Res_Typ := Etype (Subp);

      end if;

      Subp_Typ     := Create_Itype (E_Subprogram_Type, Call_Node);

      Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);

      Set_Etype          (Subp_Typ, Res_Typ);

      Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));

      --  Create a new list of parameters which is a copy of the old formal

      --  list including the creation of a new set of matching entities.

      declare

         Old_Formal : Entity_Id := First_Formal (Subp);

         New_Formal : Entity_Id;

         Extra      : Entity_Id := Empty;

      begin

         if Present (Old_Formal) then

            New_Formal := New_Copy (Old_Formal);

            Set_First_Entity (Subp_Typ, New_Formal);

            Param := First_Actual (Call_Node);

            loop

               Set_Scope (New_Formal, Subp_Typ);

               --  Change all the controlling argument types to be class-wide

               --  to avoid a recursion in dispatching.

               if Is_Controlling_Formal (New_Formal) then

                  Set_Etype (New_Formal, Etype (Param));

               end if;

               --  If the type of the formal is an itype, there was code here

               --  introduced in 1998 in revision 1.46, to create a new itype

               --  by copy. This seems useless, and in fact leads to semantic

               --  errors when the itype is the completion of a type derived

               --  from a private type.

               Extra := New_Formal;

               Next_Formal (Old_Formal);

               exit when No (Old_Formal);

               Set_Next_Entity (New_Formal, New_Copy (Old_Formal));

               Next_Entity (New_Formal);

               Next_Actual (Param);

            end loop;

            Set_Next_Entity (New_Formal, Empty);

            Set_Last_Entity (Subp_Typ, Extra);

         end if;

         --  Now that the explicit formals have been duplicated, any extra

         --  formals needed by the subprogram must be created.

         if Present (Extra) then

            Set_Extra_Formal (Extra, Empty);

         end if;

         Create_Extra_Formals (Subp_Typ);