Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 6                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

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

--                                                                          --

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

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

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

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

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

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

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

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

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

--                                                                          --

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

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

--                                                                          --

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

with Atree;    use Atree;

with Checks;   use Checks;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Elists;   use Elists;

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_Eval; use Sem_Eval;

with Sem_Disp; use Sem_Disp;

with Sem_Dist; use Sem_Dist;

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

   --  Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,

   --  if any, to be done by a build-in-place function. 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).

   procedure Add_Extra_Actual_To_Call

     (Subprogram_Call : Node_Id;

      Extra_Formal    : Entity_Id;

      Extra_Actual    : Node_Id);

   --  Adds Extra_Actual as a named parameter association for the formal

   --  Extra_Formal in Subprogram_Call.

   procedure Add_Final_List_Actual_To_Build_In_Place_Call

     (Function_Call : Node_Id;

      Function_Id   : Entity_Id;

      Acc_Type      : Entity_Id;

      Sel_Comp      : Node_Id := Empty);

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

   --  controlled parts, add an actual parameter that is a pointer to

   --  appropriate finalization list. The finalization list is that of the

   --  current scope, except for "new Acc'(F(...))" in which case it's the

   --  finalization list of the access type returned by the allocator. Acc_Type

   --  is that type in the allocator case; Empty otherwise. If Sel_Comp is

   --  not Empty, then it denotes a selected component and the finalization

   --  list is obtained from the _controller list of the prefix object.

   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.

   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_Actuals (N : Node_Id; Subp : Entity_Id);

   --  For each actual of an in-out or out parameter which is a numeric

   --  (view) conversion of the form T (A), where A denotes a variable,

   --  we insert the declaration:

   --

   --    Temp : T[ := T (A)];

   --

   --  prior to the call. Then we replace the actual with a reference to Temp,

   --  and append the assignment:

   --

   --    A := TypeA (Temp);

   --

   --  after the call. Here TypeA is the actual type of variable A. For out

   --  parameters, the initial declaration has no expression. If A is not an

   --  entity name, we generate instead:

   --

   --    Var  : TypeA renames A;

   --    Temp : T := Var;       --  omitting expression for out parameter.

   --    ...

   --    Var := TypeA (Temp);

   --

   --  For other in-out parameters, we emit the required constraint checks

   --  before and/or after the call.

   --

   --  For all parameter modes, actuals that denote components and slices of

   --  packed arrays are expanded into suitable temporaries.

   --

   --  For non-scalar objects that are possibly unaligned, add call by copy

   --  code (copy in for IN and IN OUT, copy out for OUT and IN OUT).

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

   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 Is_Null_Procedure (Subp : Entity_Id) return Boolean;

   --  Predicate to recognize stubbed procedures and null procedures, which

   --  can be inlined unconditionally in all cases.

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

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

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

   procedure Add_Alloc_Form_Actual_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)

   is

      Loc               : constant Source_Ptr := Sloc (Function_Call);

      Alloc_Form_Actual : Node_Id;

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

   end Add_Alloc_Form_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_Final_List_Actual_To_Build_In_Place_Call --

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

   procedure Add_Final_List_Actual_To_Build_In_Place_Call

     (Function_Call : Node_Id;

      Function_Id   : Entity_Id;

      Acc_Type      : Entity_Id;

      Sel_Comp      : Node_Id := Empty)

   is

      Loc               : constant Source_Ptr := Sloc (Function_Call);

      Final_List        : Node_Id;

      Final_List_Actual : Node_Id;

      Final_List_Formal : Node_Id;

      Is_Ctrl_Result    : constant Boolean :=

                            Needs_Finalization

                              (Underlying_Type (Etype (Function_Id)));

   begin

      --  No such extra parameter is needed if there are no controlled parts.

      --  The test for Needs_Finalization accounts for class-wide results

      --  (which potentially have controlled parts, even if the root type

      --  doesn't), and the test for a tagged result type is needed because

      --  calls to such a function can in general occur in dispatching

      --  contexts, which must be treated the same as a call to class-wide

      --  functions. Both of these situations require that a finalization list

      --  be passed.

      if not Needs_BIP_Final_List (Function_Id) then

         return;

      end if;

      --  Locate implicit finalization list parameter in the called function

      Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List);

      --  Create the actual which is a pointer to the appropriate finalization

      --  list. Acc_Type is present if and only if this call is the

      --  initialization of an allocator. Use the Current_Scope or the

      --  Acc_Type as appropriate.

      if Present (Acc_Type)

        and then (Ekind (Acc_Type) = E_Anonymous_Access_Type

                   or else

                     Present (Associated_Final_Chain (Base_Type (Acc_Type))))

      then

         Final_List := Find_Final_List (Acc_Type);

      --  If Sel_Comp is present and the function result is controlled, then

      --  the finalization list will be obtained from the _controller list of

      --  the selected component's prefix object.

      elsif Present (Sel_Comp) and then Is_Ctrl_Result then

         Final_List := Find_Final_List (Current_Scope, Sel_Comp);

      else

         Final_List := Find_Final_List (Current_Scope);

      end if;

      Final_List_Actual :=

        Make_Attribute_Reference (Loc,

          Prefix         => Final_List,

          Attribute_Name => Name_Unrestricted_Access);

      Analyze_And_Resolve (Final_List_Actual, Etype (Final_List_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, Final_List_Formal, Final_List_Actual);

   end Add_Final_List_Actual_To_Build_In_Place_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)

      --  Note: Master_Actual can be Empty, but only if there are no tasks

   is

      Loc               : constant Source_Ptr := Sloc (Function_Call);

   begin

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

      if not Has_Task (Etype (Function_Id)) then

         return;

      end if;

      --  The master

      declare

         Master_Formal : Node_Id;

      begin

         --  Locate implicit master parameter in the called function

         Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master);

         Analyze_And_Resolve (Master_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, Master_Actual);

      end;

      --  The activation chain

      declare

         Activation_Chain_Actual : Node_Id;

         Activation_Chain_Formal : Node_Id;

      begin

         --  Locate implicit activation chain parameter in the called function

         Activation_Chain_Formal := Build_In_Place_Formal

           (Function_Id, BIP_Activation_Chain);

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

         --  chain

         Activation_Chain_Actual :=

           Make_Attribute_Reference (Loc,

             Prefix         => Make_Identifier (Loc, Name_uChain),

             Attribute_Name => Name_Unrestricted_Access);

         Analyze_And_Resolve

           (Activation_Chain_Actual, Etype (Activation_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, Activation_Chain_Formal, Activation_Chain_Actual);

      end;

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

            return "BIPfinallist";

         when BIP_Master           =>

            return "BIPmaster";

         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

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

      loop

         pragma Assert (Present (Extra_Formal));

         exit when

           Chars (Extra_Formal) =

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

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

         else

            return OK;

         end if;

      end Process;

      function Traverse_Body is new Traverse_Func (Process);

   --  Start of processing for Detect_Infinite_Recursion

   begin

      --  Do not attempt detection in No_Implicit_Conditional mode, since we

      --  won't be able to generate the code to handle the recursion in any

      --  case.

      if Restriction_Active (No_Implicit_Conditionals) then

         return;

      end if;

      --  Otherwise do traversal and quit if we get abandon signal

      if Traverse_Body (N) = Abandon then

         return;

      --  We must have a call, since Has_Recursive_Call was set. If not just

      --  ignore (this is only an error check, so if we have a funny situation,

      --  due to bugs or errors, we do not want to bomb!)

      elsif Is_Empty_Elmt_List (Call_List) then

         return;

      end if;

      --  Here is the case where we detect recursion at compile time