Improve fstack_protector effective target

[official-gcc.git] / gcc / ada / exp_unst.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ U N S T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2014-2017, 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 Debug;    use Debug;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Lib;      use Lib;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Opt;
with Output;   use Output;
with Rtsfind;  use Rtsfind;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Mech; use Sem_Mech;
with Sem_Res;  use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;
with Snames;   use Snames;
with Tbuild;   use Tbuild;
with Uintp;    use Uintp;

package body Exp_Unst is

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id);
   --  Subp is a library-level subprogram which has nested subprograms, and
   --  Subp_Body is the corresponding N_Subprogram_Body node. This procedure
   --  declares the AREC types and objects, adds assignments to the AREC record
   --  as required, defines the xxxPTR types for uplevel referenced objects,
   --  adds the ARECP parameter to all nested subprograms which need it, and
   --  modifies all uplevel references appropriately.

   -----------
   -- Calls --
   -----------

   --  Table to record calls within the nest being analyzed. These are the
   --  calls which may need to have an AREC actual added. This table is built
   --  new for each subprogram nest and cleared at the end of processing each
   --  subprogram nest.

   type Call_Entry is record
      N : Node_Id;
      --  The actual call

      Caller : Entity_Id;
      --  Entity of the subprogram containing the call (can be at any level)

      Callee : Entity_Id;
      --  Entity of the subprogram called (always at level 2 or higher). Note
      --  that in accordance with the basic rules of nesting, the level of To
      --  is either less than or equal to the level of From, or one greater.
   end record;

   package Calls is new Table.Table (
     Table_Component_Type => Call_Entry,
     Table_Index_Type     => Nat,
     Table_Low_Bound      => 1,
     Table_Initial        => 100,
     Table_Increment      => 200,
     Table_Name           => "Unnest_Calls");
   --  Records each call within the outer subprogram and all nested subprograms
   --  that are to other subprograms nested within the outer subprogram. These
   --  are the calls that may need an additional parameter.

   procedure Append_Unique_Call (Call : Call_Entry);
   --  Append a call entry to the Calls table. A check is made to see if the
   --  table already contains this entry and if so it has no effect.

   -----------
   -- Urefs --
   -----------

   --  Table to record explicit uplevel references to objects (variables,
   --  constants, formal parameters). These are the references that will
   --  need rewriting to use the activation table (AREC) pointers. Also
   --  included are implicit and explicit uplevel references to types, but
   --  these do not get rewritten by the front end. This table is built new
   --  for each subprogram nest and cleared at the end of processing each
   --  subprogram nest.

   type Uref_Entry is record
      Ref : Node_Id;
      --  The reference itself. For objects this is always an entity reference
      --  and the referenced entity will have its Is_Uplevel_Referenced_Entity
      --  flag set and will appear in the Uplevel_Referenced_Entities list of
      --  the subprogram declaring this entity.

      Ent : Entity_Id;
      --  The Entity_Id of the uplevel referenced object or type

      Caller : Entity_Id;
      --  The entity for the subprogram immediately containing this entity

      Callee : Entity_Id;
      --  The entity for the subprogram containing the referenced entity. Note
      --  that the level of Callee must be less than the level of Caller, since
      --  this is an uplevel reference.
   end record;

   package Urefs is new Table.Table (
     Table_Component_Type => Uref_Entry,
     Table_Index_Type     => Nat,
     Table_Low_Bound      => 1,
     Table_Initial        => 100,
     Table_Increment      => 200,
     Table_Name           => "Unnest_Urefs");

   ------------------------
   -- Append_Unique_Call --
   ------------------------

   procedure Append_Unique_Call (Call : Call_Entry) is
   begin
      for J in Calls.First .. Calls.Last loop
         if Calls.Table (J) = Call then
            return;
         end if;
      end loop;

      Calls.Append (Call);
   end Append_Unique_Call;

   ---------------
   -- Get_Level --
   ---------------

   function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
      Lev : Nat;
      S   : Entity_Id;

   begin
      Lev := 1;
      S   := Sub;
      loop
         if S = Subp then
            return Lev;
         else
            Lev := Lev + 1;
            S   := Enclosing_Subprogram (S);
         end if;
      end loop;
   end Get_Level;

   ----------------
   -- Subp_Index --
   ----------------

   function Subp_Index (Sub : Entity_Id) return SI_Type is
      E : Entity_Id := Sub;

   begin
      pragma Assert (Is_Subprogram (E));

      if Subps_Index (E) = Uint_0 then
         E := Ultimate_Alias (E);

         if Ekind (E) = E_Function
           and then Rewritten_For_C (E)
           and then Present (Corresponding_Procedure (E))
         then
            E := Corresponding_Procedure (E);
         end if;
      end if;

      pragma Assert (Subps_Index (E) /= Uint_0);
      return SI_Type (UI_To_Int (Subps_Index (E)));
   end Subp_Index;

   -----------------------
   -- Unnest_Subprogram --
   -----------------------

   procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
      function AREC_Name (J : Pos; S : String) return Name_Id;
      --  Returns name for string ARECjS, where j is the decimal value of j

      function Enclosing_Subp (Subp : SI_Type) return SI_Type;
      --  Subp is the index of a subprogram which has a Lev greater than 1.
      --  This function returns the index of the enclosing subprogram which
      --  will have a Lev value one less than this.

      function Img_Pos (N : Pos) return String;
      --  Return image of N without leading blank

      function Upref_Name
        (Ent   : Entity_Id;
         Index : Pos;
         Clist : List_Id) return Name_Id;
      --  This function returns the name to be used in the activation record to
      --  reference the variable uplevel. Clist is the list of components that
      --  have been created in the activation record so far. Normally the name
      --  is just a copy of the Chars field of the entity. The exception is
      --  when the name has already been used, in which case we suffix the name
      --  with the index value Index to avoid duplication. This happens with
      --  declare blocks and generic parameters at least.

      ---------------
      -- AREC_Name --
      ---------------

      function AREC_Name (J : Pos; S : String) return Name_Id is
      begin
         return Name_Find ("AREC" & Img_Pos (J) & S);
      end AREC_Name;

      --------------------
      -- Enclosing_Subp --
      --------------------

      function Enclosing_Subp (Subp : SI_Type) return SI_Type is
         STJ : Subp_Entry renames Subps.Table (Subp);
         Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
      begin
         pragma Assert (STJ.Lev > 1);
         pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
         return Ret;
      end Enclosing_Subp;

      -------------
      -- Img_Pos --
      -------------

      function Img_Pos (N : Pos) return String is
         Buf : String (1 .. 20);
         Ptr : Natural;
         NV  : Nat;

      begin
         Ptr := Buf'Last;
         NV := N;
         while NV /= 0 loop
            Buf (Ptr) := Character'Val (48 + NV mod 10);
            Ptr := Ptr - 1;
            NV := NV / 10;
         end loop;

         return Buf (Ptr + 1 .. Buf'Last);
      end Img_Pos;

      ----------------
      -- Upref_Name --
      ----------------

      function Upref_Name
        (Ent   : Entity_Id;
         Index : Pos;
         Clist : List_Id) return Name_Id
      is
         C : Node_Id;
      begin
         C := First (Clist);
         loop
            if No (C) then
               return Chars (Ent);

            elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
               return
                 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
            else
               Next (C);
            end if;
         end loop;
      end Upref_Name;

   --  Start of processing for Unnest_Subprogram

   begin
      --  Nothing to do inside a generic (all processing is for instance)

      if Inside_A_Generic then
         return;
      end if;

      --  At least for now, do not unnest anything but main source unit

      if not In_Extended_Main_Source_Unit (Subp_Body) then
         return;
      end if;

      --  This routine is called late, after the scope stack is gone. The
      --  following creates a suitable dummy scope stack to be used for the
      --  analyze/expand calls made from this routine.

      Push_Scope (Subp);

      --  First step, we must mark all nested subprograms that require a static
      --  link (activation record) because either they contain explicit uplevel
      --  references (as indicated by Is_Uplevel_Referenced_Entity being set at
      --  this point), or they make calls to other subprograms in the same nest
      --  that require a static link (in which case we set this flag).

      --  This is a recursive definition, and to implement this, we have to
      --  build a call graph for the set of nested subprograms, and then go
      --  over this graph to implement recursively the invariant that if a
      --  subprogram has a call to a subprogram requiring a static link, then
      --  the calling subprogram requires a static link.

      --  First populate the above tables

      Subps_First := Subps.Last + 1;
      Calls.Init;
      Urefs.Init;

      Build_Tables : declare
         Current_Subprogram : Entity_Id;
         --  When we scan a subprogram body, we set Current_Subprogram to the
         --  corresponding entity. This gets recursively saved and restored.

         function Visit_Node (N : Node_Id) return Traverse_Result;
         --  Visit a single node in Subp

         -----------
         -- Visit --
         -----------

         procedure Visit is new Traverse_Proc (Visit_Node);
         --  Used to traverse the body of Subp, populating the tables

         ----------------
         -- Visit_Node --
         ----------------

         function Visit_Node (N : Node_Id) return Traverse_Result is
            Ent    : Entity_Id;
            Caller : Entity_Id;
            Callee : Entity_Id;

            procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean);
            --  Given a type T, checks if it is a static type defined as a type
            --  with no dynamic bounds in sight. If so, the only action is to
            --  set Is_Static_Type True for T. If T is not a static type, then
            --  all types with dynamic bounds associated with T are detected,
            --  and their bounds are marked as uplevel referenced if not at the
            --  library level, and DT is set True.

            procedure Note_Uplevel_Ref
              (E      : Entity_Id;
               Caller : Entity_Id;
               Callee : Entity_Id);
            --  Called when we detect an explicit or implicit uplevel reference
            --  from within Caller to entity E declared in Callee. E can be a
            --  an object or a type.

            -----------------------
            -- Check_Static_Type --
            -----------------------

            procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean) is
               procedure Note_Uplevel_Bound (N : Node_Id);
               --  N is the bound of a dynamic type. This procedure notes that
               --  this bound is uplevel referenced, it can handle references
               --  to entities (typically _FIRST and _LAST entities), and also
               --  attribute references of the form T'name (name is typically
               --  FIRST or LAST) where T is the uplevel referenced bound.

               ------------------------
               -- Note_Uplevel_Bound --
               ------------------------

               procedure Note_Uplevel_Bound (N : Node_Id) is
               begin
                  --  Entity name case

                  if Is_Entity_Name (N) then
                     if Present (Entity (N)) then
                        Note_Uplevel_Ref
                          (E      => Entity (N),
                           Caller => Current_Subprogram,
                           Callee => Enclosing_Subprogram (Entity (N)));
                     end if;

                  --  Attribute case

                  elsif Nkind (N) = N_Attribute_Reference then
                     Note_Uplevel_Bound (Prefix (N));
                  end if;
               end Note_Uplevel_Bound;

            --  Start of processing for Check_Static_Type

            begin
               --  If already marked static, immediate return

               if Is_Static_Type (T) then
                  return;
               end if;

               --  If the type is at library level, always consider it static,
               --  since such uplevel references are irrelevant.

               if Is_Library_Level_Entity (T) then
                  Set_Is_Static_Type (T);
                  return;
               end if;

               --  Otherwise figure out what the story is with this type

               --  For a scalar type, check bounds

               if Is_Scalar_Type (T) then

                  --  If both bounds static, then this is a static type

                  declare
                     LB : constant Node_Id := Type_Low_Bound (T);
                     UB : constant Node_Id := Type_High_Bound (T);

                  begin
                     if not Is_Static_Expression (LB) then
                        Note_Uplevel_Bound (LB);
                        DT := True;
                     end if;

                     if not Is_Static_Expression (UB) then
                        Note_Uplevel_Bound (UB);
                        DT := True;
                     end if;
                  end;

               --  For record type, check all components

               elsif Is_Record_Type (T) then
                  declare
                     C : Entity_Id;
                  begin
                     C := First_Component_Or_Discriminant (T);
                     while Present (C) loop
                        Check_Static_Type (Etype (C), DT);
                        Next_Component_Or_Discriminant (C);
                     end loop;
                  end;

               --  For array type, check index types and component type

               elsif Is_Array_Type (T) then
                  declare
                     IX : Node_Id;
                  begin
                     Check_Static_Type (Component_Type (T), DT);

                     IX := First_Index (T);
                     while Present (IX) loop
                        Check_Static_Type (Etype (IX), DT);
                        Next_Index (IX);
                     end loop;
                  end;

               --  For private type, examine whether full view is static

               elsif Is_Private_Type (T) and then Present (Full_View (T)) then
                  Check_Static_Type (Full_View (T), DT);

                  if Is_Static_Type (Full_View (T)) then
                     Set_Is_Static_Type (T);
                  end if;

               --  For now, ignore other types

               else
                  return;
               end if;

               if not DT then
                  Set_Is_Static_Type (T);
               end if;
            end Check_Static_Type;

            ----------------------
            -- Note_Uplevel_Ref --
            ----------------------

            procedure Note_Uplevel_Ref
              (E      : Entity_Id;
               Caller : Entity_Id;
               Callee : Entity_Id)
            is
            begin
               --  Nothing to do for static type

               if Is_Static_Type (E) then
                  return;
               end if;

               --  Nothing to do if Caller and Callee are the same

               if Caller = Callee then
                  return;

               --  Callee may be a function that returns an array, and that has
               --  been rewritten as a procedure. If caller is that procedure,
               --  nothing to do either.

               elsif Ekind (Callee) = E_Function
                 and then Rewritten_For_C (Callee)
                 and then Corresponding_Procedure (Callee) = Caller
               then
                  return;
               end if;

               --  We have a new uplevel referenced entity

               --  All we do at this stage is to add the uplevel reference to
               --  the table. It's too early to do anything else, since this
               --  uplevel reference may come from an unreachable subprogram
               --  in which case the entry will be deleted.

               Urefs.Append ((N, E, Caller, Callee));
            end Note_Uplevel_Ref;

         --  Start of processing for Visit_Node

         begin
            --  Record a call

            if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)

              --  We are only interested in direct calls, not indirect calls
              --  (where Name (N) is an explicit dereference) at least for now!

              and then Nkind (Name (N)) in N_Has_Entity
            then
               Ent := Entity (Name (N));

               --  We are only interested in calls to subprograms nested
               --  within Subp. Calls to Subp itself or to subprograms that
               --  are outside the nested structure do not affect us.

               if Scope_Within (Ent, Subp) then

                  --  Ignore calls to imported routines

                  if Is_Imported (Ent) then
                     null;

                  --  Here we have a call to keep and analyze

                  else
                     --  Both caller and callee must be subprograms

                     if Is_Subprogram (Ent) then
                        Append_Unique_Call ((N, Current_Subprogram, Ent));
                     end if;
                  end if;
               end if;

            --  Record a 'Access as a (potential) call

            elsif Nkind (N) = N_Attribute_Reference then
               declare
                  Attr : constant Attribute_Id :=
                           Get_Attribute_Id (Attribute_Name (N));
               begin
                  case Attr is
                     when Attribute_Access
                        | Attribute_Unchecked_Access
                        | Attribute_Unrestricted_Access
                     =>
                        Ent := Entity (Prefix (N));

                        --  We are only interested in calls to subprograms
                        --  nested within Subp.

                        if Scope_Within (Ent, Subp) then
                           if Is_Imported (Ent) then
                              null;

                           elsif Is_Subprogram (Ent) then
                              Append_Unique_Call
                                ((N, Current_Subprogram, Ent));
                           end if;
                        end if;

                     when others =>
                        null;
                  end case;
               end;

            --  Record a subprogram. We record a subprogram body that acts as
            --  a spec. Otherwise we record a subprogram declaration, providing
            --  that it has a corresponding body we can get hold of. The case
            --  of no corresponding body being available is ignored for now.

            elsif Nkind (N) = N_Subprogram_Body then
               Ent := Unique_Defining_Entity (N);

               --  Ignore generic subprogram

               if Is_Generic_Subprogram (Ent) then
                  return Skip;
               end if;

               --  Make new entry in subprogram table if not already made

               declare
                  L : constant Nat := Get_Level (Subp, Ent);
               begin
                  Subps.Append
                    ((Ent           => Ent,
                      Bod           => N,
                      Lev           => L,
                      Reachable     => False,
                      Uplevel_Ref   => L,
                      Declares_AREC => False,
                      Uents         => No_Elist,
                      Last          => 0,
                      ARECnF        => Empty,
                      ARECn         => Empty,
                      ARECnT        => Empty,
                      ARECnPT       => Empty,
                      ARECnP        => Empty,
                      ARECnU        => Empty));
                  Set_Subps_Index (Ent, UI_From_Int (Subps.Last));
               end;

               --  We make a recursive call to scan the subprogram body, so
               --  that we can save and restore Current_Subprogram.

               declare
                  Save_CS : constant Entity_Id := Current_Subprogram;
                  Decl    : Node_Id;

               begin
                  Current_Subprogram := Ent;

                  --  Scan declarations

                  Decl := First (Declarations (N));
                  while Present (Decl) loop
                     Visit (Decl);
                     Next (Decl);
                  end loop;

                  --  Scan statements

                  Visit (Handled_Statement_Sequence (N));

                  --  Restore current subprogram setting

                  Current_Subprogram := Save_CS;
               end;

               --  Now at this level, return skipping the subprogram body
               --  descendants, since we already took care of them!

               return Skip;

            --  Record an uplevel reference

            elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then
               Ent := Entity (N);

               --  Only interested in entities declared within our nest

               if not Is_Library_Level_Entity (Ent)
                 and then Scope_Within_Or_Same (Scope (Ent), Subp)

                  --  Skip entities defined in inlined subprograms

                 and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
                 and then

                   --  Constants and variables are interesting

                   (Ekind_In (Ent, E_Constant, E_Variable)

                     --  Formals are interesting, but not if being used as mere
                     --  names of parameters for name notation calls.

                     or else
                       (Is_Formal (Ent)
                         and then not
                          (Nkind (Parent (N)) = N_Parameter_Association
                            and then Selector_Name (Parent (N)) = N))

                     --  Types other than known Is_Static types are interesting

                     or else (Is_Type (Ent)
                               and then not Is_Static_Type (Ent)))
               then
                  --  Here we have a possible interesting uplevel reference

                  if Is_Type (Ent) then
                     declare
                        DT : Boolean := False;

                     begin
                        Check_Static_Type (Ent, DT);

                        if Is_Static_Type (Ent) then
                           return OK;
                        end if;
                     end;
                  end if;

                  Caller := Current_Subprogram;
                  Callee := Enclosing_Subprogram (Ent);

                  if Callee /= Caller and then not Is_Static_Type (Ent) then
                     Note_Uplevel_Ref (Ent, Caller, Callee);
                  end if;
               end if;

            --  If we have a body stub, visit the associated subunit

            elsif Nkind (N) in N_Body_Stub then
               Visit (Library_Unit (N));

            --  Skip generic declarations

            elsif Nkind (N) in N_Generic_Declaration then
               return Skip;

            --  Skip generic package body

            elsif Nkind (N) = N_Package_Body
              and then Present (Corresponding_Spec (N))
              and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
            then
               return Skip;
            end if;

            --  Fall through to continue scanning children of this node

            return OK;
         end Visit_Node;

      --  Start of processing for Build_Tables

      begin
         --  Traverse the body to get subprograms, calls and uplevel references

         Visit (Subp_Body);
      end Build_Tables;

      --  Now do the first transitive closure which determines which
      --  subprograms in the nest are actually reachable.

      Reachable_Closure : declare
         Modified : Boolean;

      begin
         Subps.Table (Subps_First).Reachable := True;

         --  We use a simple minded algorithm as follows (obviously this can
         --  be done more efficiently, using one of the standard algorithms
         --  for efficient transitive closure computation, but this is simple
         --  and most likely fast enough that its speed does not matter).

         --  Repeatedly scan the list of calls. Any time we find a call from
         --  A to B, where A is reachable, but B is not, then B is reachable,
         --  and note that we have made a change by setting Modified True. We
         --  repeat this until we make a pass with no modifications.

         Outer : loop
            Modified := False;
            Inner : for J in Calls.First .. Calls.Last loop
               declare
                  CTJ : Call_Entry renames Calls.Table (J);

                  SINF : constant SI_Type := Subp_Index (CTJ.Caller);
                  SINT : constant SI_Type := Subp_Index (CTJ.Callee);

                  SUBF : Subp_Entry renames Subps.Table (SINF);
                  SUBT : Subp_Entry renames Subps.Table (SINT);

               begin
                  if SUBF.Reachable and then not SUBT.Reachable then
                     SUBT.Reachable := True;
                     Modified := True;
                  end if;
               end;
            end loop Inner;

            exit Outer when not Modified;
         end loop Outer;
      end Reachable_Closure;

      --  Remove calls from unreachable subprograms

      declare
         New_Index : Nat;

      begin
         New_Index := 0;
         for J in Calls.First .. Calls.Last loop
            declare
               CTJ : Call_Entry renames Calls.Table (J);

               SINF : constant SI_Type := Subp_Index (CTJ.Caller);
               SINT : constant SI_Type := Subp_Index (CTJ.Callee);

               SUBF : Subp_Entry renames Subps.Table (SINF);
               SUBT : Subp_Entry renames Subps.Table (SINT);

            begin
               if SUBF.Reachable then
                  pragma Assert (SUBT.Reachable);
                  New_Index := New_Index + 1;
                  Calls.Table (New_Index) := Calls.Table (J);
               end if;
            end;
         end loop;

         Calls.Set_Last (New_Index);
      end;

      --  Remove uplevel references from unreachable subprograms

      declare
         New_Index : Nat;

      begin
         New_Index := 0;
         for J in Urefs.First .. Urefs.Last loop
            declare
               URJ : Uref_Entry renames Urefs.Table (J);

               SINF : constant SI_Type := Subp_Index (URJ.Caller);
               SINT : constant SI_Type := Subp_Index (URJ.Callee);

               SUBF : Subp_Entry renames Subps.Table (SINF);
               SUBT : Subp_Entry renames Subps.Table (SINT);

               S : Entity_Id;

            begin
               --  Keep reachable reference

               if SUBF.Reachable then
                  New_Index := New_Index + 1;
                  Urefs.Table (New_Index) := Urefs.Table (J);

                  --  And since we know we are keeping this one, this is a good
                  --  place to fill in information for a good reference.

                  --  Mark all enclosing subprograms need to declare AREC

                  S := URJ.Caller;
                  loop
                     S := Enclosing_Subprogram (S);

                     --  if we are at the top level, as can happen with
                     --  references to formals in aspects of nested subprogram
                     --  declarations, there are no further subprograms to
                     --  mark as requiring activation records.

                     exit when No (S);
                     Subps.Table (Subp_Index (S)).Declares_AREC := True;
                     exit when S = URJ.Callee;
                  end loop;

                  --  Add to list of uplevel referenced entities for Callee.
                  --  We do not add types to this list, only actual references
                  --  to objects that will be referenced uplevel, and we use
                  --  the flag Is_Uplevel_Referenced_Entity to avoid making
                  --  duplicate entries in the list.

                  if not Is_Uplevel_Referenced_Entity (URJ.Ent) then
                     Set_Is_Uplevel_Referenced_Entity (URJ.Ent);

                     if not Is_Type (URJ.Ent) then
                        Append_New_Elmt (URJ.Ent, SUBT.Uents);
                     end if;
                  end if;

                  --  And set uplevel indication for caller

                  if SUBT.Lev < SUBF.Uplevel_Ref then
                     SUBF.Uplevel_Ref := SUBT.Lev;
                  end if;
               end if;
            end;
         end loop;

         Urefs.Set_Last (New_Index);
      end;

      --  Remove unreachable subprograms from Subps table. Note that we do
      --  this after eliminating entries from the other two tables, since
      --  those elimination steps depend on referencing the Subps table.

      declare
         New_SI : SI_Type;

      begin
         New_SI := Subps_First - 1;
         for J in Subps_First .. Subps.Last loop
            declare
               STJ  : Subp_Entry renames Subps.Table (J);
               Spec : Node_Id;
               Decl : Node_Id;

            begin
               --  Subprogram is reachable, copy and reset index

               if STJ.Reachable then
                  New_SI := New_SI + 1;
                  Subps.Table (New_SI) := STJ;
                  Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));

               --  Subprogram is not reachable

               else
                  --  Clear index, since no longer active

                  Set_Subps_Index (Subps.Table (J).Ent, Uint_0);

                  --  Output debug information if -gnatd.3 set

                  if Debug_Flag_Dot_3 then
                     Write_Str ("Eliminate ");
                     Write_Name (Chars (Subps.Table (J).Ent));
                     Write_Str (" at ");
                     Write_Location (Sloc (Subps.Table (J).Ent));
                     Write_Str (" (not referenced)");
                     Write_Eol;
                  end if;

                  --  Rewrite declaration and body to null statements

                  Spec := Corresponding_Spec (STJ.Bod);

                  if Present (Spec) then
                     Decl := Parent (Declaration_Node (Spec));
                     Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
                  end if;

                  Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
               end if;
            end;
         end loop;

         Subps.Set_Last (New_SI);
      end;

      --  Now it is time for the second transitive closure, which follows calls
      --  and makes sure that A calls B, and B has uplevel references, then A
      --  is also marked as having uplevel references.

      Closure_Uplevel : declare
         Modified : Boolean;

      begin
         --  We use a simple minded algorithm as follows (obviously this can
         --  be done more efficiently, using one of the standard algorithms
         --  for efficient transitive closure computation, but this is simple
         --  and most likely fast enough that its speed does not matter).

         --  Repeatedly scan the list of calls. Any time we find a call from
         --  A to B, where B has uplevel references, make sure that A is marked
         --  as having at least the same level of uplevel referencing.

         Outer2 : loop
            Modified := False;
            Inner2 : for J in Calls.First .. Calls.Last loop
               declare
                  CTJ  : Call_Entry renames Calls.Table (J);
                  SINF : constant SI_Type := Subp_Index (CTJ.Caller);
                  SINT : constant SI_Type := Subp_Index (CTJ.Callee);
                  SUBF : Subp_Entry renames Subps.Table (SINF);
                  SUBT : Subp_Entry renames Subps.Table (SINT);
               begin
                  if SUBT.Lev > SUBT.Uplevel_Ref
                    and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
                  then
                     SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
                     Modified := True;
                  end if;
               end;
            end loop Inner2;

            exit Outer2 when not Modified;
         end loop Outer2;
      end Closure_Uplevel;

      --  We have one more step before the tables are complete. An uplevel
      --  call from subprogram A to subprogram B where subprogram B has uplevel
      --  references is in effect an uplevel reference, and must arrange for
      --  the proper activation link to be passed.

      for J in Calls.First .. Calls.Last loop
         declare
            CTJ : Call_Entry renames Calls.Table (J);

            SINF : constant SI_Type := Subp_Index (CTJ.Caller);
            SINT : constant SI_Type := Subp_Index (CTJ.Callee);

            SUBF : Subp_Entry renames Subps.Table (SINF);
            SUBT : Subp_Entry renames Subps.Table (SINT);

            A : Entity_Id;

         begin
            --  If callee has uplevel references

            if SUBT.Uplevel_Ref < SUBT.Lev

              --  And this is an uplevel call

              and then SUBT.Lev < SUBF.Lev
            then
               --  We need to arrange for finding the uplink

               A := CTJ.Caller;
               loop
                  A := Enclosing_Subprogram (A);
                  Subps.Table (Subp_Index (A)).Declares_AREC := True;
                  exit when A = CTJ.Callee;

                  --  In any case exit when we get to the outer level. This
                  --  happens in some odd cases with generics (in particular
                  --  sem_ch3.adb does not compile without this kludge ???).

                  exit when A = Subp;
               end loop;
            end if;
         end;
      end loop;

      --  The tables are now complete, so we can record the last index in the
      --  Subps table for later reference in Cprint.

      Subps.Table (Subps_First).Last := Subps.Last;

      --  Next step, create the entities for code we will insert. We do this
      --  at the start so that all the entities are defined, regardless of the
      --  order in which we do the code insertions.

      Create_Entities : for J in Subps_First .. Subps.Last loop
         declare
            STJ : Subp_Entry renames Subps.Table (J);
            Loc : constant Source_Ptr := Sloc (STJ.Bod);

         begin
            --  First we create the ARECnF entity for the additional formal for
            --  all subprograms which need an activation record passed.

            if STJ.Uplevel_Ref < STJ.Lev then
               STJ.ARECnF :=
                 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
            end if;

            --  Define the AREC entities for the activation record if needed

            if STJ.Declares_AREC then
               STJ.ARECn   :=
                 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
               STJ.ARECnT  :=
                 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
               STJ.ARECnPT :=
                 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
               STJ.ARECnP  :=
                 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));

               --  Define uplink component entity if inner nesting case

               if Present (STJ.ARECnF) then
                  STJ.ARECnU :=
                    Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
               end if;
            end if;
         end;
      end loop Create_Entities;

      --  Loop through subprograms

      Subp_Loop : declare
         Addr : constant Entity_Id := RTE (RE_Address);

      begin
         for J in Subps_First .. Subps.Last loop
            declare
               STJ : Subp_Entry renames Subps.Table (J);

            begin
               --  First add the extra formal if needed. This applies to all
               --  nested subprograms that require an activation record to be
               --  passed, as indicated by ARECnF being defined.

               if Present (STJ.ARECnF) then

                  --  Here we need the extra formal. We do the expansion and
                  --  analysis of this manually, since it is fairly simple,
                  --  and it is not obvious how we can get what we want if we
                  --  try to use the normal Analyze circuit.

                  Add_Extra_Formal : declare
                     Encl : constant SI_Type := Enclosing_Subp (J);
                     STJE : Subp_Entry renames Subps.Table (Encl);
                     --  Index and Subp_Entry for enclosing routine

                     Form : constant Entity_Id := STJ.ARECnF;
                     --  The formal to be added. Note that n here is one less
                     --  than the level of the subprogram itself (STJ.Ent).

                     procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
                     --  S is an N_Function/Procedure_Specification node, and F
                     --  is the new entity to add to this subprogramn spec as
                     --  the last Extra_Formal.

                     ----------------------
                     -- Add_Form_To_Spec --
                     ----------------------

                     procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
                        Sub : constant Entity_Id := Defining_Entity (S);
                        Ent : Entity_Id;

                     begin
                        --  Case of at least one Extra_Formal is present, set
                        --  ARECnF as the new last entry in the list.

                        if Present (Extra_Formals (Sub)) then
                           Ent := Extra_Formals (Sub);
                           while Present (Extra_Formal (Ent)) loop
                              Ent := Extra_Formal (Ent);
                           end loop;

                           Set_Extra_Formal (Ent, F);

                        --  No Extra formals present

                        else
                           Set_Extra_Formals (Sub, F);
                           Ent := Last_Formal (Sub);

                           if Present (Ent) then
                              Set_Extra_Formal (Ent, F);
                           end if;
                        end if;
                     end Add_Form_To_Spec;

                  --  Start of processing for Add_Extra_Formal

                  begin
                     --  Decorate the new formal entity

                     Set_Scope               (Form, STJ.Ent);
                     Set_Ekind               (Form, E_In_Parameter);
                     Set_Etype               (Form, STJE.ARECnPT);
                     Set_Mechanism           (Form, By_Copy);
                     Set_Never_Set_In_Source (Form, True);
                     Set_Analyzed            (Form, True);
                     Set_Comes_From_Source   (Form, False);

                     --  Case of only body present

                     if Acts_As_Spec (STJ.Bod) then
                        Add_Form_To_Spec (Form, Specification (STJ.Bod));

                     --  Case of separate spec

                     else
                        Add_Form_To_Spec (Form, Parent (STJ.Ent));
                     end if;
                  end Add_Extra_Formal;
               end if;

               --  Processing for subprograms that declare an activation record

               if Present (STJ.ARECn) then

                  --  Local declarations for one such subprogram

                  declare
                     Loc   : constant Source_Ptr := Sloc (STJ.Bod);
                     Clist : List_Id;
                     Comp  : Entity_Id;

                     Decl_ARECnT  : Node_Id;
                     Decl_ARECnPT : Node_Id;
                     Decl_ARECn   : Node_Id;
                     Decl_ARECnP  : Node_Id;
                     --  Declaration nodes for the AREC entities we build

                     Decl_Assign : Node_Id;
                     --  Assigment to set uplink, Empty if none

                     Decls : List_Id;
                     --  List of new declarations we create

                  begin
                     --  Build list of component declarations for ARECnT

                     Clist := Empty_List;

                     --  If we are in a subprogram that has a static link that
                     --  is passed in (as indicated by ARECnF being defined),
                     --  then include ARECnU : ARECmPT where ARECmPT comes from
                     --  the level one higher than the current level, and the
                     --  entity ARECnPT comes from the enclosing subprogram.

                     if Present (STJ.ARECnF) then
                        declare
                           STJE : Subp_Entry
                                    renames Subps.Table (Enclosing_Subp (J));
                        begin
                           Append_To (Clist,
                             Make_Component_Declaration (Loc,
                               Defining_Identifier  => STJ.ARECnU,
                               Component_Definition =>
                                 Make_Component_Definition (Loc,
                                   Subtype_Indication =>
                                     New_Occurrence_Of (STJE.ARECnPT, Loc))));
                        end;
                     end if;

                     --  Add components for uplevel referenced entities

                     if Present (STJ.Uents) then
                        declare
                           Elmt : Elmt_Id;
                           Uent : Entity_Id;

                           Indx : Nat;
                           --  1's origin of index in list of elements. This is
                           --  used to uniquify names if needed in Upref_Name.

                        begin
                           Elmt := First_Elmt (STJ.Uents);
                           Indx := 0;
                           while Present (Elmt) loop
                              Uent := Node (Elmt);
                              Indx := Indx + 1;

                              Comp :=
                                Make_Defining_Identifier (Loc,
                                  Chars => Upref_Name (Uent, Indx, Clist));

                              Set_Activation_Record_Component
                                (Uent, Comp);

                              Append_To (Clist,
                                Make_Component_Declaration (Loc,
                                  Defining_Identifier  => Comp,
                                  Component_Definition =>
                                    Make_Component_Definition (Loc,
                                      Subtype_Indication =>
                                        New_Occurrence_Of (Addr, Loc))));

                              Next_Elmt (Elmt);
                           end loop;
                        end;
                     end if;

                     --  Now we can insert the AREC declarations into the body

                     --    type ARECnT is record .. end record;
                     --    pragma Suppress_Initialization (ARECnT);

                     --  Note that we need to set the Suppress_Initialization
                     --  flag after Decl_ARECnT has been analyzed.

                     Decl_ARECnT :=
                       Make_Full_Type_Declaration (Loc,
                         Defining_Identifier => STJ.ARECnT,
                         Type_Definition     =>
                           Make_Record_Definition (Loc,
                             Component_List =>
                               Make_Component_List (Loc,
                                 Component_Items => Clist)));
                     Decls := New_List (Decl_ARECnT);

                     --  type ARECnPT is access all ARECnT;

                     Decl_ARECnPT :=
                       Make_Full_Type_Declaration (Loc,
                         Defining_Identifier => STJ.ARECnPT,
                         Type_Definition     =>
                           Make_Access_To_Object_Definition (Loc,
                             All_Present        => True,
                             Subtype_Indication =>
                               New_Occurrence_Of (STJ.ARECnT, Loc)));
                     Append_To (Decls, Decl_ARECnPT);

                     --  ARECn : aliased ARECnT;

                     Decl_ARECn :=
                       Make_Object_Declaration (Loc,
                         Defining_Identifier => STJ.ARECn,
                           Aliased_Present   => True,
                           Object_Definition =>
                             New_Occurrence_Of (STJ.ARECnT, Loc));
                     Append_To (Decls, Decl_ARECn);

                     --  ARECnP : constant ARECnPT := ARECn'Access;

                     Decl_ARECnP :=
                       Make_Object_Declaration (Loc,
                         Defining_Identifier => STJ.ARECnP,
                         Constant_Present    => True,
                         Object_Definition   =>
                           New_Occurrence_Of (STJ.ARECnPT, Loc),
                         Expression          =>
                           Make_Attribute_Reference (Loc,
                             Prefix           =>
                               New_Occurrence_Of (STJ.ARECn, Loc),
                             Attribute_Name => Name_Access));
                     Append_To (Decls, Decl_ARECnP);

                     --  If we are in a subprogram that has a static link that
                     --  is passed in (as indicated by ARECnF being defined),
                     --  then generate ARECn.ARECmU := ARECmF where m is
                     --  one less than the current level to set the uplink.

                     if Present (STJ.ARECnF) then
                        Decl_Assign :=
                          Make_Assignment_Statement (Loc,
                            Name       =>
                              Make_Selected_Component (Loc,
                                Prefix        =>
                                  New_Occurrence_Of (STJ.ARECn, Loc),
                                Selector_Name =>
                                  New_Occurrence_Of (STJ.ARECnU, Loc)),
                            Expression =>
                              New_Occurrence_Of (STJ.ARECnF, Loc));
                        Append_To (Decls, Decl_Assign);

                     else
                        Decl_Assign := Empty;
                     end if;

                     Prepend_List_To (Declarations (STJ.Bod), Decls);

                     --  Analyze the newly inserted declarations. Note that we
                     --  do not need to establish the whole scope stack, since
                     --  we have already set all entity fields (so there will
                     --  be no searching of upper scopes to resolve names). But
                     --  we do set the scope of the current subprogram, so that
                     --  newly created entities go in the right entity chain.

                     --  We analyze with all checks suppressed (since we do
                     --  not expect any exceptions).

                     Push_Scope (STJ.Ent);
                     Analyze (Decl_ARECnT,  Suppress => All_Checks);

                     --  Note that we need to call Set_Suppress_Initialization
                     --  after Decl_ARECnT has been analyzed, but before
                     --  analyzing Decl_ARECnP so that the flag is properly
                     --  taking into account.

                     Set_Suppress_Initialization (STJ.ARECnT);

                     Analyze (Decl_ARECnPT, Suppress => All_Checks);
                     Analyze (Decl_ARECn,   Suppress => All_Checks);
                     Analyze (Decl_ARECnP,  Suppress => All_Checks);

                     if Present (Decl_Assign) then
                        Analyze (Decl_Assign, Suppress => All_Checks);
                     end if;

                     Pop_Scope;

                     --  Next step, for each uplevel referenced entity, add
                     --  assignment operations to set the component in the
                     --  activation record.

                     if Present (STJ.Uents) then
                        declare
                           Elmt : Elmt_Id;

                        begin
                           Elmt := First_Elmt (STJ.Uents);
                           while Present (Elmt) loop
                              declare
                                 Ent : constant Entity_Id  := Node (Elmt);
                                 Loc : constant Source_Ptr := Sloc (Ent);
                                 Dec : constant Node_Id    :=
                                         Declaration_Node (Ent);
                                 Ins : Node_Id;
                                 Asn : Node_Id;

                              begin
                                 --  For parameters, we insert the assignment
                                 --  right after the declaration of ARECnP.
                                 --  For all other entities, we insert
                                 --  the assignment immediately after
                                 --  the declaration of the entity.

                                 --  Note: we don't need to mark the entity
                                 --  as being aliased, because the address
                                 --  attribute will mark it as Address_Taken,
                                 --  and that is good enough.

                                 if Is_Formal (Ent) then
                                    Ins := Decl_ARECnP;
                                 else
                                    Ins := Dec;
                                 end if;

                                 --  Build and insert the assignment:
                                 --    ARECn.nam := nam'Address

                                 Asn :=
                                   Make_Assignment_Statement (Loc,
                                     Name       =>
                                       Make_Selected_Component (Loc,
                                         Prefix        =>
                                           New_Occurrence_Of (STJ.ARECn, Loc),
                                         Selector_Name =>
                                           New_Occurrence_Of
                                             (Activation_Record_Component
                                                (Ent),
                                              Loc)),

                                     Expression =>
                                       Make_Attribute_Reference (Loc,
                                         Prefix         =>
                                           New_Occurrence_Of (Ent, Loc),
                                         Attribute_Name => Name_Address));

                                 Insert_After (Ins, Asn);

                                 --  Analyze the assignment statement. We do
                                 --  not need to establish the relevant scope
                                 --  stack entries here, because we have
                                 --  already set the correct entity references,
                                 --  so no name resolution is required, and no
                                 --  new entities are created, so we don't even
                                 --  need to set the current scope.

                                 --  We analyze with all checks suppressed
                                 --  (since we do not expect any exceptions).

                                 Analyze (Asn, Suppress => All_Checks);
                              end;

                              Next_Elmt (Elmt);
                           end loop;
                        end;
                     end if;
                  end;
               end if;
            end;
         end loop;
      end Subp_Loop;

      --  Next step, process uplevel references. This has to be done in a
      --  separate pass, after completing the processing in Sub_Loop because we
      --  need all the AREC declarations generated, inserted, and analyzed so
      --  that the uplevel references can be successfully analyzed.

      Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
         declare
            UPJ : Uref_Entry renames Urefs.Table (J);

         begin
            --  Ignore type references, these are implicit references that do
            --  not need rewriting (e.g. the appearence in a conversion).

            if Is_Type (UPJ.Ent) then
               goto Continue;
            end if;

            --  Also ignore uplevel references to bounds of types that come
            --  from the original type reference.

            if Is_Entity_Name (UPJ.Ref)
              and then Present (Entity (UPJ.Ref))
              and then Is_Type (Entity (UPJ.Ref))
            then
               goto Continue;
            end if;

            --  Rewrite one reference

            Rewrite_One_Ref : declare
               Loc : constant Source_Ptr := Sloc (UPJ.Ref);
               --  Source location for the reference

               Typ : constant Entity_Id := Etype (UPJ.Ent);
               --  The type of the referenced entity

               Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref);
               --  The actual subtype of the reference

               RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
               --  Subp_Index for caller containing reference

               STJR : Subp_Entry renames Subps.Table (RS_Caller);
               --  Subp_Entry for subprogram containing reference

               RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
               --  Subp_Index for subprogram containing referenced entity

               STJE : Subp_Entry renames Subps.Table (RS_Callee);
               --  Subp_Entry for subprogram containing referenced entity

               Pfx  : Node_Id;
               Comp : Entity_Id;
               SI   : SI_Type;

            begin
               --  Ignore if no ARECnF entity for enclosing subprogram which
               --  probably happens as a result of not properly treating
               --  instance bodies. To be examined ???

               --  If this test is omitted, then the compilation of freeze.adb
               --  and inline.adb fail in unnesting mode.

               if No (STJR.ARECnF) then
                  goto Continue;
               end if;

               --  Push the current scope, so that the pointer type Tnn, and
               --  any subsidiary entities resulting from the analysis of the
               --  rewritten reference, go in the right entity chain.

               Push_Scope (STJR.Ent);

               --  Now we need to rewrite the reference. We have a reference
               --  from level STJR.Lev to level STJE.Lev. The general form of
               --  the rewritten reference for entity X is:

               --    Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)

               --  where a,b,c,d .. m =
               --    STJR.Lev - 1,  STJR.Lev - 2, .. STJE.Lev

               pragma Assert (STJR.Lev > STJE.Lev);

               --  Compute the prefix of X. Here are examples to make things
               --  clear (with parens to show groupings, the prefix is
               --  everything except the .X at the end).

               --   level 2 to level 1

               --     AREC1F.X

               --   level 3 to level 1

               --     (AREC2F.AREC1U).X

               --   level 4 to level 1

               --     ((AREC3F.AREC2U).AREC1U).X

               --   level 6 to level 2

               --     (((AREC5F.AREC4U).AREC3U).AREC2U).X

               --  In the above, ARECnF and ARECnU are pointers, so there are
               --  explicit dereferences required for these occurrences.

               Pfx :=
                 Make_Explicit_Dereference (Loc,
                   Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
               SI := RS_Caller;
               for L in STJE.Lev .. STJR.Lev - 2 loop
                  SI := Enclosing_Subp (SI);
                  Pfx :=
                    Make_Explicit_Dereference (Loc,
                      Prefix =>
                        Make_Selected_Component (Loc,
                          Prefix        => Pfx,
                          Selector_Name =>
                            New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
               end loop;

               --  Get activation record component (must exist)

               Comp := Activation_Record_Component (UPJ.Ent);
               pragma Assert (Present (Comp));

               --  Do the replacement

               Rewrite (UPJ.Ref,
                 Make_Attribute_Reference (Loc,
                   Prefix         => New_Occurrence_Of (Atyp, Loc),
                   Attribute_Name => Name_Deref,
                   Expressions    => New_List (
                     Make_Selected_Component (Loc,
                       Prefix        => Pfx,
                       Selector_Name =>
                         New_Occurrence_Of (Comp, Loc)))));

               --  Analyze and resolve the new expression. We do not need to
               --  establish the relevant scope stack entries here, because we
               --  have already set all the correct entity references, so no
               --  name resolution is needed. We have already set the current
               --  scope, so that any new entities created will be in the right
               --  scope.

               --  We analyze with all checks suppressed (since we do not
               --  expect any exceptions)

               Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
               Pop_Scope;
            end Rewrite_One_Ref;
         end;

      <<Continue>>
         null;
      end loop Uplev_Refs;

      --  Finally, loop through all calls adding extra actual for the
      --  activation record where it is required.

      Adjust_Calls : for J in Calls.First .. Calls.Last loop

         --  Process a single call, we are only interested in a call to a
         --  subprogram that actually needs a pointer to an activation record,
         --  as indicated by the ARECnF entity being set. This excludes the
         --  top level subprogram, and any subprogram not having uplevel refs.

         Adjust_One_Call : declare
            CTJ : Call_Entry renames Calls.Table (J);
            STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
            STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));

            Loc : constant Source_Ptr := Sloc (CTJ.N);

            Extra  : Node_Id;
            ExtraP : Node_Id;
            SubX   : SI_Type;
            Act    : Node_Id;

         begin
            if Present (STT.ARECnF)
              and then Nkind (CTJ.N) /= N_Attribute_Reference
            then

               --  CTJ.N is a call to a subprogram which may require a pointer
               --  to an activation record. The subprogram containing the call
               --  is CTJ.From and the subprogram being called is CTJ.To, so we
               --  have a call from level STF.Lev to level STT.Lev.

               --  There are three possibilities:

               --  For a call to the same level, we just pass the activation
               --  record passed to the calling subprogram.

               if STF.Lev = STT.Lev then
                  Extra := New_Occurrence_Of (STF.ARECnF, Loc);

               --  For a call that goes down a level, we pass a pointer to the
               --  activation record constructed within the caller (which may
               --  be the outer-level subprogram, but also may be a more deeply
               --  nested caller).

               elsif STT.Lev = STF.Lev + 1 then
                  Extra := New_Occurrence_Of (STF.ARECnP, Loc);

                  --  Otherwise we must have an upcall (STT.Lev < STF.LEV),
                  --  since it is not possible to do a downcall of more than
                  --  one level.

                  --  For a call from level STF.Lev to level STT.Lev, we
                  --  have to find the activation record needed by the
                  --  callee. This is as follows:

                  --    ARECaF.ARECbU.ARECcU....ARECm

                  --  where a,b,c .. m =
                  --    STF.Lev - 1,  STF.Lev - 2, STF.Lev - 3 .. STT.Lev

               else
                  pragma Assert (STT.Lev < STF.Lev);

                  Extra := New_Occurrence_Of (STF.ARECnF, Loc);
                  SubX  := Subp_Index (CTJ.Caller);
                  for K in reverse STT.Lev .. STF.Lev - 1 loop
                     SubX  := Enclosing_Subp (SubX);
                     Extra :=
                       Make_Selected_Component (Loc,
                         Prefix        => Extra,
                         Selector_Name =>
                           New_Occurrence_Of
                             (Subps.Table (SubX).ARECnU, Loc));
                  end loop;
               end if;

               --  Extra is the additional parameter to be added. Build a
               --  parameter association that we can append to the actuals.

               ExtraP :=
                 Make_Parameter_Association (Loc,
                   Selector_Name             =>
                     New_Occurrence_Of (STT.ARECnF, Loc),
                   Explicit_Actual_Parameter => Extra);

               if No (Parameter_Associations (CTJ.N)) then
                  Set_Parameter_Associations (CTJ.N, Empty_List);
               end if;

               Append (ExtraP, Parameter_Associations (CTJ.N));

               --  We need to deal with the actual parameter chain as well. The
               --  newly added parameter is always the last actual.

               Act := First_Named_Actual (CTJ.N);

               if No (Act) then
                  Set_First_Named_Actual (CTJ.N, Extra);

               --  Here we must follow the chain and append the new entry

               else
                  loop
                     declare
                        PAN : Node_Id;
                        NNA : Node_Id;

                     begin
                        PAN := Parent (Act);
                        pragma Assert (Nkind (PAN) = N_Parameter_Association);
                        NNA := Next_Named_Actual (PAN);

                        if No (NNA) then
                           Set_Next_Named_Actual (PAN, Extra);
                           exit;
                        end if;

                        Act := NNA;
                     end;
                  end loop;
               end if;

               --  Analyze and resolve the new actual. We do not need to
               --  establish the relevant scope stack entries here, because
               --  we have already set all the correct entity references, so
               --  no name resolution is needed.

               --  We analyze with all checks suppressed (since we do not
               --  expect any exceptions, and also we temporarily turn off
               --  Unested_Subprogram_Mode to avoid trying to mark uplevel
               --  references (not needed at this stage, and in fact causes
               --  a bit of recursive chaos).

               Opt.Unnest_Subprogram_Mode := False;
               Analyze_And_Resolve
                 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
               Opt.Unnest_Subprogram_Mode := True;
            end if;
         end Adjust_One_Call;
      end loop Adjust_Calls;

      return;
   end Unnest_Subprogram;

   ------------------------
   -- Unnest_Subprograms --
   ------------------------

   procedure Unnest_Subprograms (N : Node_Id) is
      function Search_Subprograms (N : Node_Id) return Traverse_Result;
      --  Tree visitor that search for outer level procedures with nested
      --  subprograms and invokes Unnest_Subprogram()

      ------------------------
      -- Search_Subprograms --
      ------------------------

      function Search_Subprograms (N : Node_Id) return Traverse_Result is
      begin
         if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
            declare
               Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);

            begin
               --  We are only interested in subprograms (not generic
               --  subprograms), that have nested subprograms.

               if Is_Subprogram (Spec_Id)
                 and then Has_Nested_Subprogram (Spec_Id)
                 and then Is_Library_Level_Entity (Spec_Id)
               then
                  Unnest_Subprogram (Spec_Id, N);
               end if;
            end;
         end if;

         return OK;
      end Search_Subprograms;

      ---------------
      -- Do_Search --
      ---------------

      procedure Do_Search is new Traverse_Proc (Search_Subprograms);
      --  Subtree visitor instantiation

   --  Start of processing for Unnest_Subprograms

   begin
      if not Opt.Unnest_Subprogram_Mode then
         return;
      end if;

      Do_Search (N);
   end Unnest_Subprograms;

end Exp_Unst;