Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 6                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, 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 Errout;   use Errout;

with Elists;   use Elists;

with Exp_Aggr; use Exp_Aggr;

with Exp_Atag; use Exp_Atag;

with Exp_Ch2;  use Exp_Ch2;

with Exp_Ch3;  use Exp_Ch3;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Ch9;  use Exp_Ch9;

with Exp_Dbug; use Exp_Dbug;

with Exp_Disp; use Exp_Disp;

with Exp_Dist; use Exp_Dist;

with Exp_Intr; use Exp_Intr;

with Exp_Pakd; use Exp_Pakd;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Exp_VFpt; use Exp_VFpt;

with Fname;    use Fname;

with Freeze;   use Freeze;

with Inline;   use Inline;

with Lib;      use Lib;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch12; use Sem_Ch12;

with Sem_Ch13; use Sem_Ch13;

with Sem_Dim;  use Sem_Dim;

with Sem_Disp; use Sem_Disp;

with Sem_Dist; use Sem_Dist;

with Sem_Eval; use Sem_Eval;

with Sem_Mech; use Sem_Mech;

with Sem_Res;  use Sem_Res;

with Sem_SCIL; use Sem_SCIL;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

with Validsw;  use Validsw;

package body Exp_Ch6 is

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

   -- Local Subprograms --

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

   procedure Add_Access_Actual_To_Build_In_Place_Call

     (Function_Call : Node_Id;

      Function_Id   : Entity_Id;

      Return_Object : Node_Id;

      Is_Access     : Boolean := False);

   --  Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the

   --  object name given by Return_Object and add the attribute to the end of

   --  the actual parameter list associated with the build-in-place function

   --  call denoted by Function_Call. However, if Is_Access is True, then

   --  Return_Object is already an access expression, in which case it's passed

   --  along directly to the build-in-place function. Finally, if Return_Object

   --  is empty, then pass a null literal as the actual.

   procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call

     (Function_Call  : Node_Id;

      Function_Id    : Entity_Id;

      Alloc_Form     : BIP_Allocation_Form := Unspecified;

      Alloc_Form_Exp : Node_Id             := Empty;

      Pool_Actual    : Node_Id             := Make_Null (No_Location));

   --  Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place

   --  function call that returns a caller-unknown-size result (BIP_Alloc_Form

   --  and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it,

   --  otherwise pass a literal corresponding to the Alloc_Form parameter

   --  (which must not be Unspecified in that case). Pool_Actual is the

   --  parameter to pass to BIP_Storage_Pool.

   procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call

     (Func_Call  : Node_Id;

      Func_Id    : Entity_Id;

      Ptr_Typ    : Entity_Id := Empty;

      Master_Exp : Node_Id   := Empty);

   --  Ada 2005 (AI-318-02): If the result type of a build-in-place call needs

   --  finalization actions, add an actual parameter which is a pointer to the

   --  finalization master of the caller. If Master_Exp is not Empty, then that

   --  will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this

   --  will result in an automatic "null" value for the actual.

   procedure Add_Task_Actuals_To_Build_In_Place_Call

     (Function_Call : Node_Id;

      Function_Id   : Entity_Id;

      Master_Actual : Node_Id);

   --  Ada 2005 (AI-318-02): For a build-in-place call, if the result type

   --  contains tasks, add two actual parameters: the master, and a pointer to

   --  the caller's activation chain. Master_Actual is the actual parameter

   --  expression to pass for the master. In most cases, this is the current

   --  master (_master). The two exceptions are: If the function call is the

   --  initialization expression for an allocator, we pass the master of the

   --  access type. If the function call is the initialization expression for a

   --  return object, we pass along the master passed in by the caller. The

   --  activation chain to pass is always the local one. Note: Master_Actual

   --  can be Empty, but only if there are no tasks.

   procedure Check_Overriding_Operation (Subp : Entity_Id);

   --  Subp is a dispatching operation. Check whether it may override an

   --  inherited private operation, in which case its DT entry is that of

   --  the hidden operation, not the one it may have received earlier.

   --  This must be done before emitting the code to set the corresponding

   --  DT to the address of the subprogram. The actual placement of Subp in

   --  the proper place in the list of primitive operations is done in

   --  Declare_Inherited_Private_Subprograms, which also has to deal with

   --  implicit operations. This duplication is unavoidable for now???

   procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id);

   --  This procedure is called only if the subprogram body N, whose spec

   --  has the given entity Spec, contains a parameterless recursive call.

   --  It attempts to generate runtime code to detect if this a case of

   --  infinite recursion.

   --

   --  The body is scanned to determine dependencies. If the only external

   --  dependencies are on a small set of scalar variables, then the values

   --  of these variables are captured on entry to the subprogram, and if

   --  the values are not changed for the call, we know immediately that

   --  we have an infinite recursion.

   procedure Expand_Ctrl_Function_Call (N : Node_Id);

   --  N is a function call which returns a controlled object. Transform the

   --  call into a temporary which retrieves the returned object from the

   --  secondary stack using 'reference.

   procedure Expand_Inlined_Call

    (N         : Node_Id;

     Subp      : Entity_Id;

     Orig_Subp : Entity_Id);

   --  If called subprogram can be inlined by the front-end, retrieve the

   --  analyzed body, replace formals with actuals and expand call in place.

   --  Generate thunks for actuals that are expressions, and insert the

   --  corresponding constant declarations before the call. If the original

   --  call is to a derived operation, the return type is the one of the

   --  derived operation, but the body is that of the original, so return

   --  expressions in the body must be converted to the desired type (which

   --  is simply not noted in the tree without inline expansion).

   procedure Expand_Non_Function_Return (N : Node_Id);

   --  Called by Expand_N_Simple_Return_Statement in case we're returning from

   --  a procedure body, entry body, accept statement, or extended return

   --  statement. Note that all non-function returns are simple return

   --  statements.

   function Expand_Protected_Object_Reference

     (N    : Node_Id;

      Scop : Entity_Id) return Node_Id;

   procedure Expand_Protected_Subprogram_Call

     (N    : Node_Id;

      Subp : Entity_Id;

      Scop : Entity_Id);

   --  A call to a protected subprogram within the protected object may appear

   --  as a regular call. The list of actuals must be expanded to contain a

   --  reference to the object itself, and the call becomes a call to the

   --  corresponding protected subprogram.

   function Has_Unconstrained_Access_Discriminants

     (Subtyp : Entity_Id) return Boolean;

   --  Returns True if the given subtype is unconstrained and has one

   --  or more access discriminants.

   procedure Expand_Simple_Function_Return (N : Node_Id);

   --  Expand simple return from function. In the case where we are returning

   --  from a function body this is called by Expand_N_Simple_Return_Statement.

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

   -- Add_Access_Actual_To_Build_In_Place_Call --

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

   procedure Add_Access_Actual_To_Build_In_Place_Call

     (Function_Call : Node_Id;

      Function_Id   : Entity_Id;

      Return_Object : Node_Id;

      Is_Access     : Boolean := False)

   is

      Loc            : constant Source_Ptr := Sloc (Function_Call);

      Obj_Address    : Node_Id;

      Obj_Acc_Formal : Entity_Id;

   begin

      --  Locate the implicit access parameter in the called function

      Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access);

      --  If no return object is provided, then pass null

      if not Present (Return_Object) then

         Obj_Address := Make_Null (Loc);

         Set_Parent (Obj_Address, Function_Call);

      --  If Return_Object is already an expression of an access type, then use

      --  it directly, since it must be an access value denoting the return

      --  object, and couldn't possibly be the return object itself.

      elsif Is_Access then

         Obj_Address := Return_Object;

         Set_Parent (Obj_Address, Function_Call);

      --  Apply Unrestricted_Access to caller's return object

      else

         Obj_Address :=

            Make_Attribute_Reference (Loc,

              Prefix         => Return_Object,

              Attribute_Name => Name_Unrestricted_Access);

         Set_Parent (Return_Object, Obj_Address);

         Set_Parent (Obj_Address, Function_Call);

      end if;

      Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));

      --  Build the parameter association for the new actual and add it to the

      --  end of the function's actuals.

      Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);

   end Add_Access_Actual_To_Build_In_Place_Call;

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

   -- Add_Unconstrained_Actuals_To_Build_In_Place_Call --

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

   procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call

     (Function_Call  : Node_Id;

      Function_Id    : Entity_Id;

      Alloc_Form     : BIP_Allocation_Form := Unspecified;

      Alloc_Form_Exp : Node_Id             := Empty;

      Pool_Actual    : Node_Id             := Make_Null (No_Location))

   is

      Loc               : constant Source_Ptr := Sloc (Function_Call);

      Alloc_Form_Actual : Node_Id;

      Alloc_Form_Formal : Node_Id;

      Pool_Formal       : Node_Id;

   begin

      --  The allocation form generally doesn't need to be passed in the case

      --  of a constrained result subtype, since normally the caller performs

      --  the allocation in that case. However this formal is still needed in

      --  the case where the function has a tagged result, because generally

      --  such functions can be called in a dispatching context and such calls

      --  must be handled like calls to class-wide functions.

      if Is_Constrained (Underlying_Type (Etype (Function_Id)))

        and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))

      then

         return;

      end if;

      --  Locate the implicit allocation form parameter in the called function.

      --  Maybe it would be better for each implicit formal of a build-in-place

      --  function to have a flag or a Uint attribute to identify it. ???

      Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form);

      if Present (Alloc_Form_Exp) then

         pragma Assert (Alloc_Form = Unspecified);

         Alloc_Form_Actual := Alloc_Form_Exp;

      else

         pragma Assert (Alloc_Form /= Unspecified);

         Alloc_Form_Actual :=

           Make_Integer_Literal (Loc,

             Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form)));

      end if;

      Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal));

      --  Build the parameter association for the new actual and add it to the

      --  end of the function's actuals.

      Add_Extra_Actual_To_Call

        (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);

      --  Pass the Storage_Pool parameter. This parameter is omitted on

      --  .NET/JVM/ZFP as those targets do not support pools.

      if VM_Target = No_VM

        and then RTE_Available (RE_Root_Storage_Pool_Ptr)

      then

         Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);

         Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));

         Add_Extra_Actual_To_Call

           (Function_Call, Pool_Formal, Pool_Actual);

      end if;

   end Add_Unconstrained_Actuals_To_Build_In_Place_Call;

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

   -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --

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

   procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call

     (Func_Call  : Node_Id;

      Func_Id    : Entity_Id;

      Ptr_Typ    : Entity_Id := Empty;

      Master_Exp : Node_Id   := Empty)

   is

   begin

      if not Needs_BIP_Finalization_Master (Func_Id) then

         return;

      end if;

      declare

         Formal : constant Entity_Id :=

                    Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);

         Loc    : constant Source_Ptr := Sloc (Func_Call);

         Actual    : Node_Id;

         Desig_Typ : Entity_Id;

      begin

         --  If there is a finalization master actual, such as the implicit

         --  finalization master of an enclosing build-in-place function,

         --  then this must be added as an extra actual of the call.

         if Present (Master_Exp) then

            Actual := Master_Exp;

         --  Case where the context does not require an actual master

         elsif No (Ptr_Typ) then

            Actual := Make_Null (Loc);

         else

            Desig_Typ := Directly_Designated_Type (Ptr_Typ);

            --  Check for a library-level access type whose designated type has

            --  supressed finalization. Such an access types lack a master.

            --  Pass a null actual to the callee in order to signal a missing

            --  master.

            if Is_Library_Level_Entity (Ptr_Typ)

              and then Finalize_Storage_Only (Desig_Typ)

            then

               Actual := Make_Null (Loc);

            --  Types in need of finalization actions

            elsif Needs_Finalization (Desig_Typ) then

               --  The general mechanism of creating finalization masters for

               --  anonymous access types is disabled by default, otherwise

               --  finalization masters will pop all over the place. Such types

               --  use context-specific masters.

               if Ekind (Ptr_Typ) = E_Anonymous_Access_Type

                 and then No (Finalization_Master (Ptr_Typ))

               then

                  Build_Finalization_Master

                    (Typ        => Ptr_Typ,

                     Ins_Node   => Associated_Node_For_Itype (Ptr_Typ),

                     Encl_Scope => Scope (Ptr_Typ));

               end if;

               --  Access-to-controlled types should always have a master

               pragma Assert (Present (Finalization_Master (Ptr_Typ)));

               Actual :=

                 Make_Attribute_Reference (Loc,

                   Prefix =>

                     New_Reference_To (Finalization_Master (Ptr_Typ), Loc),

                   Attribute_Name => Name_Unrestricted_Access);

            --  Tagged types

            else

               Actual := Make_Null (Loc);

            end if;

         end if;

         Analyze_And_Resolve (Actual, Etype (Formal));

         --  Build the parameter association for the new actual and add it to

         --  the end of the function's actuals.

         Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);

      end;

   end Add_Finalization_Master_Actual_To_Build_In_Place_Call;

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

   -- Add_Extra_Actual_To_Call --

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

   procedure Add_Extra_Actual_To_Call

     (Subprogram_Call : Node_Id;

      Extra_Formal    : Entity_Id;

      Extra_Actual    : Node_Id)

   is

      Loc         : constant Source_Ptr := Sloc (Subprogram_Call);

      Param_Assoc : Node_Id;

   begin

      Param_Assoc :=

        Make_Parameter_Association (Loc,

          Selector_Name             => New_Occurrence_Of (Extra_Formal, Loc),

          Explicit_Actual_Parameter => Extra_Actual);

      Set_Parent (Param_Assoc, Subprogram_Call);

      Set_Parent (Extra_Actual, Param_Assoc);

      if Present (Parameter_Associations (Subprogram_Call)) then

         if Nkind (Last (Parameter_Associations (Subprogram_Call))) =

              N_Parameter_Association

         then

            --  Find last named actual, and append

            declare

               L : Node_Id;

            begin

               L := First_Actual (Subprogram_Call);

               while Present (L) loop

                  if No (Next_Actual (L)) then

                     Set_Next_Named_Actual (Parent (L), Extra_Actual);

                     exit;

                  end if;

                  Next_Actual (L);

               end loop;

            end;

         else

            Set_First_Named_Actual (Subprogram_Call, Extra_Actual);

         end if;

         Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call));

      else

         Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc));

         Set_First_Named_Actual (Subprogram_Call, Extra_Actual);

      end if;

   end Add_Extra_Actual_To_Call;

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

   -- Add_Task_Actuals_To_Build_In_Place_Call --

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

   procedure Add_Task_Actuals_To_Build_In_Place_Call

     (Function_Call : Node_Id;

      Function_Id   : Entity_Id;

      Master_Actual : Node_Id)

   is

      Loc           : constant Source_Ptr := Sloc (Function_Call);

      Result_Subt   : constant Entity_Id :=

                        Available_View (Etype (Function_Id));

      Actual        : Node_Id;

      Chain_Actual  : Node_Id;

      Chain_Formal  : Node_Id;

      Master_Formal : Node_Id;

   begin

      --  No such extra parameters are needed if there are no tasks

      if not Has_Task (Result_Subt) then

         return;

      end if;

      Actual := Master_Actual;

      --  Use a dummy _master actual in case of No_Task_Hierarchy

      if Restriction_Active (No_Task_Hierarchy) then

         Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc);

      --  In the case where we use the master associated with an access type,

      --  the actual is an entity and requires an explicit reference.

      elsif Nkind (Actual) = N_Defining_Identifier then

         Actual := New_Reference_To (Actual, Loc);

      end if;

      --  Locate the implicit master parameter in the called function

      Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master);

      Analyze_And_Resolve (Actual, Etype (Master_Formal));

      --  Build the parameter association for the new actual and add it to the

      --  end of the function's actuals.

      Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);

      --  Locate the implicit activation chain parameter in the called function

      Chain_Formal :=

        Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);

      --  Create the actual which is a pointer to the current activation chain

      Chain_Actual :=

        Make_Attribute_Reference (Loc,

          Prefix         => Make_Identifier (Loc, Name_uChain),

          Attribute_Name => Name_Unrestricted_Access);

      Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));

      --  Build the parameter association for the new actual and add it to the

      --  end of the function's actuals.

      Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);

   end Add_Task_Actuals_To_Build_In_Place_Call;

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

   -- BIP_Formal_Suffix --

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

   function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is

   begin

      case Kind is

         when BIP_Alloc_Form          =>

            return "BIPalloc";

         when BIP_Storage_Pool        =>

            return "BIPstoragepool";

         when BIP_Finalization_Master =>

            return "BIPfinalizationmaster";

         when BIP_Task_Master         =>

            return "BIPtaskmaster";

         when BIP_Activation_Chain    =>

            return "BIPactivationchain";

         when BIP_Object_Access       =>

            return "BIPaccess";

      end case;

   end BIP_Formal_Suffix;

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

   -- Build_In_Place_Formal --

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

   function Build_In_Place_Formal

     (Func : Entity_Id;

      Kind : BIP_Formal_Kind) return Entity_Id

   is

      Formal_Name  : constant Name_Id :=

                       New_External_Name

                         (Chars (Func), BIP_Formal_Suffix (Kind));

      Extra_Formal : Entity_Id := Extra_Formals (Func);

   begin

      --  Maybe it would be better for each implicit formal of a build-in-place

      --  function to have a flag or a Uint attribute to identify it. ???

      --  The return type in the function declaration may have been a limited

      --  view, and the extra formals for the function were not generated at

      --  that point. At the point of call the full view must be available and

      --  the extra formals can be created.

      if No (Extra_Formal) then

         Create_Extra_Formals (Func);

         Extra_Formal := Extra_Formals (Func);

      end if;

      loop

         pragma Assert (Present (Extra_Formal));

         exit when Chars (Extra_Formal) = Formal_Name;

         Next_Formal_With_Extras (Extra_Formal);

      end loop;

      return Extra_Formal;

   end Build_In_Place_Formal;

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

   -- Check_Overriding_Operation --

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

   procedure Check_Overriding_Operation (Subp : Entity_Id) is

      Typ     : constant Entity_Id := Find_Dispatching_Type (Subp);

      Op_List : constant Elist_Id  := Primitive_Operations (Typ);

      Op_Elmt : Elmt_Id;

      Prim_Op : Entity_Id;

      Par_Op  : Entity_Id;

   begin

      if Is_Derived_Type (Typ)

        and then not Is_Private_Type (Typ)

        and then In_Open_Scopes (Scope (Etype (Typ)))

        and then Is_Base_Type (Typ)

      then

         --  Subp overrides an inherited private operation if there is an

         --  inherited operation with a different name than Subp (see

         --  Derive_Subprogram) whose Alias is a hidden subprogram with the

         --  same name as Subp.

         Op_Elmt := First_Elmt (Op_List);

         while Present (Op_Elmt) loop

            Prim_Op := Node (Op_Elmt);

            Par_Op  := Alias (Prim_Op);

            if Present (Par_Op)

              and then not Comes_From_Source (Prim_Op)

              and then Chars (Prim_Op) /= Chars (Par_Op)

              and then Chars (Par_Op) = Chars (Subp)

              and then Is_Hidden (Par_Op)

              and then Type_Conformant (Prim_Op, Subp)

            then

               Set_DT_Position (Subp, DT_Position (Prim_Op));

            end if;

            Next_Elmt (Op_Elmt);

         end loop;

      end if;

   end Check_Overriding_Operation;

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

   -- Detect_Infinite_Recursion --

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

   procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      Var_List : constant Elist_Id := New_Elmt_List;

      --  List of globals referenced by body of procedure

      Call_List : constant Elist_Id := New_Elmt_List;

      --  List of recursive calls in body of procedure

      Shad_List : constant Elist_Id := New_Elmt_List;

      --  List of entity id's for entities created to capture the value of

      --  referenced globals on entry to the procedure.

      Scop : constant Uint := Scope_Depth (Spec);

      --  This is used to record the scope depth of the current procedure, so

      --  that we can identify global references.

      Max_Vars : constant := 4;

      --  Do not test more than four global variables

      Count_Vars : Natural := 0;

      --  Count variables found so far

      Var  : Entity_Id;

      Elm  : Elmt_Id;

      Ent  : Entity_Id;

      Call : Elmt_Id;

      Decl : Node_Id;

      Test : Node_Id;

      Elm1 : Elmt_Id;

      Elm2 : Elmt_Id;

      Last : Node_Id;

      function Process (Nod : Node_Id) return Traverse_Result;

      --  Function to traverse the subprogram body (using Traverse_Func)

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

      -- Process --

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

      function Process (Nod : Node_Id) return Traverse_Result is

      begin

         --  Procedure call

         if Nkind (Nod) = N_Procedure_Call_Statement then

            --  Case of one of the detected recursive calls

            if Is_Entity_Name (Name (Nod))

              and then Has_Recursive_Call (Entity (Name (Nod)))

              and then Entity (Name (Nod)) = Spec

            then

               Append_Elmt (Nod, Call_List);

               return Skip;

            --  Any other procedure call may have side effects

            else

               return Abandon;

            end if;

         --  A call to a pure function can always be ignored

         elsif Nkind (Nod) = N_Function_Call

           and then Is_Entity_Name (Name (Nod))

           and then Is_Pure (Entity (Name (Nod)))

         then

            return Skip;

         --  Case of an identifier reference

         elsif Nkind (Nod) = N_Identifier then

            Ent := Entity (Nod);

            --  If no entity, then ignore the reference

            --  Not clear why this can happen. To investigate, remove this

            --  test and look at the crash that occurs here in 3401-004 ???

            if No (Ent) then

               return Skip;

            --  Ignore entities with no Scope, again not clear how this

            --  can happen, to investigate, look at 4108-008 ???

            elsif No (Scope (Ent)) then

               return Skip;

            --  Ignore the reference if not to a more global object

            elsif Scope_Depth (Scope (Ent)) >= Scop then

               return Skip;

            --  References to types, exceptions and constants are always OK

            elsif Is_Type (Ent)

              or else Ekind (Ent) = E_Exception

              or else Ekind (Ent) = E_Constant

            then

               return Skip;

            --  If other than a non-volatile scalar variable, we have some

            --  kind of global reference (e.g. to a function) that we cannot

            --  deal with so we forget the attempt.

            elsif Ekind (Ent) /= E_Variable

              or else not Is_Scalar_Type (Etype (Ent))

              or else Treat_As_Volatile (Ent)

            then

               return Abandon;

            --  Otherwise we have a reference to a global scalar

            else

               --  Loop through global entities already detected

               Elm := First_Elmt (Var_List);

               loop

                  --  If not detected before, record this new global reference

                  if No (Elm) then

                     Count_Vars := Count_Vars + 1;

                     if Count_Vars <= Max_Vars then

                        Append_Elmt (Entity (Nod), Var_List);

                     else

                        return Abandon;

                     end if;

                     exit;

                  --  If recorded before, ignore

                  elsif Node (Elm) = Entity (Nod) then

                     return Skip;

                  --  Otherwise keep looking

                  else

                     Next_Elmt (Elm);

                  end if;

               end loop;

               return Skip;

            end if;

         --  For all other node kinds, recursively visit syntactic children