Subversion Repositories scarts

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             E X P _ A G G R                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

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

--                                                                          --

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

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

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

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

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

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

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

-- Public License  distributed with GNAT;  see file COPYING.  If not, write --

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

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

--                                                                          --

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

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

--                                                                          --

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

with Atree;    use Atree;

with Checks;   use Checks;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Elists;   use Elists;

with Expander; use Expander;

with Exp_Util; use Exp_Util;

with Exp_Ch3;  use Exp_Ch3;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Ch9;  use Exp_Ch9;

with Exp_Tss;  use Exp_Tss;

with Freeze;   use Freeze;

with Hostparm; use Hostparm;

with Itypes;   use Itypes;

with Lib;      use Lib;

with Nmake;    use Nmake;

with Nlists;   use Nlists;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Ttypes;   use Ttypes;

with Sem;      use Sem;

with Sem_Ch3;  use Sem_Ch3;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

package body Exp_Aggr is

   type Case_Bounds is record

     Choice_Lo   : Node_Id;

     Choice_Hi   : Node_Id;

     Choice_Node : Node_Id;

   end record;

   type Case_Table_Type is array (Nat range <>) of Case_Bounds;

   --  Table type used by Check_Case_Choices procedure

   function Must_Slide

     (Obj_Type : Entity_Id;

      Typ      : Entity_Id) return Boolean;

   --  A static array aggregate in an object declaration can in most cases be

   --  expanded in place. The one exception is when the aggregate is given

   --  with component associations that specify different bounds from those of

   --  the type definition in the object declaration. In this pathological

   --  case the aggregate must slide, and we must introduce an intermediate

   --  temporary to hold it.

   --

   --  The same holds in an assignment to one-dimensional array of arrays,

   --  when a component may be given with bounds that differ from those of the

   --  component type.

   procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);

   --  Sort the Case Table using the Lower Bound of each Choice as the key.

   --  A simple insertion sort is used since the number of choices in a case

   --  statement of variant part will usually be small and probably in near

   --  sorted order.

   function Has_Default_Init_Comps (N : Node_Id) return Boolean;

   --  N is an aggregate (record or array). Checks the presence of default

   --  initialization (<>) in any component (Ada 2005: AI-287)

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

   -- Local subprograms for Record Aggregate Expansion --

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

   procedure Expand_Record_Aggregate

     (N           : Node_Id;

      Orig_Tag    : Node_Id := Empty;

      Parent_Expr : Node_Id := Empty);

   --  This is the top level procedure for record aggregate expansion.

   --  Expansion for record aggregates needs expand aggregates for tagged

   --  record types. Specifically Expand_Record_Aggregate adds the Tag

   --  field in front of the Component_Association list that was created

   --  during resolution by Resolve_Record_Aggregate.

   --

   --    N is the record aggregate node.

   --    Orig_Tag is the value of the Tag that has to be provided for this

   --      specific aggregate. It carries the tag corresponding to the type

   --      of the outermost aggregate during the recursive expansion

   --    Parent_Expr is the ancestor part of the original extension

   --      aggregate

   procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);

   --  N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of

   --  the aggregate. Transform the given aggregate into a sequence of

   --  assignments component per component.

   function Build_Record_Aggr_Code

     (N                             : Node_Id;

      Typ                           : Entity_Id;

      Target                        : Node_Id;

      Flist                         : Node_Id   := Empty;

      Obj                           : Entity_Id := Empty;

      Is_Limited_Ancestor_Expansion : Boolean   := False) return List_Id;

   --  N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type of the

   --  aggregate. Target is an expression containing the location on which the

   --  component by component assignments will take place. Returns the list of

   --  assignments plus all other adjustments needed for tagged and controlled

   --  types. Flist is an expression representing the finalization list on

   --  which to attach the controlled components if any. Obj is present in the

   --  object declaration and dynamic allocation cases, it contains an entity

   --  that allows to know if the value being created needs to be attached to

   --  the final list in case of pragma finalize_Storage_Only.

   --

   --  Is_Limited_Ancestor_Expansion indicates that the function has been

   --  called recursively to expand the limited ancestor to avoid copying it.

   function Has_Mutable_Components (Typ : Entity_Id) return Boolean;

   --  Return true if one of the component is of a discriminated type with

   --  defaults. An aggregate for a type with mutable components must be

   --  expanded into individual assignments.

   procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);

   --  If the type of the aggregate is a type extension with renamed discrimi-

   --  nants, we must initialize the hidden discriminants of the parent.

   --  Otherwise, the target object must not be initialized. The discriminants

   --  are initialized by calling the initialization procedure for the type.

   --  This is incorrect if the initialization of other components has any

   --  side effects. We restrict this call to the case where the parent type

   --  has a variant part, because this is the only case where the hidden

   --  discriminants are accessed, namely when calling discriminant checking

   --  functions of the parent type, and when applying a stream attribute to

   --  an object of the derived type.

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

   -- Local Subprograms for Array Aggregate Expansion --

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

   function Aggr_Size_OK (Typ : Entity_Id) return Boolean;

   --  Very large static aggregates present problems to the back-end, and

   --  are transformed into assignments and loops. This function verifies

   --  that the total number of components of an aggregate is acceptable

   --  for transformation into a purely positional static form. It is called

   --  prior to calling Flatten.

   procedure Convert_Array_Aggr_In_Allocator

     (Decl   : Node_Id;

      Aggr   : Node_Id;

      Target : Node_Id);

   --  If the aggregate appears within an allocator and can be expanded in

   --  place, this routine generates the individual assignments to components

   --  of the designated object. This is an optimization over the general

   --  case, where a temporary is first created on the stack and then used to

   --  construct the allocated object on the heap.

   procedure Convert_To_Positional

     (N                    : Node_Id;

      Max_Others_Replicate : Nat     := 5;

      Handle_Bit_Packed    : Boolean := False);

   --  If possible, convert named notation to positional notation. This

   --  conversion is possible only in some static cases. If the conversion is

   --  possible, then N is rewritten with the analyzed converted aggregate.

   --  The parameter Max_Others_Replicate controls the maximum number of

   --  values corresponding to an others choice that will be converted to

   --  positional notation (the default of 5 is the normal limit, and reflects

   --  the fact that normally the loop is better than a lot of separate

   --  assignments). Note that this limit gets overridden in any case if

   --  either of the restrictions No_Elaboration_Code or No_Implicit_Loops is

   --  set. The parameter Handle_Bit_Packed is usually set False (since we do

   --  not expect the back end to handle bit packed arrays, so the normal case

   --  of conversion is pointless), but in the special case of a call from

   --  Packed_Array_Aggregate_Handled, we set this parameter to True, since

   --  these are cases we handle in there.

   procedure Expand_Array_Aggregate (N : Node_Id);

   --  This is the top-level routine to perform array aggregate expansion.

   --  N is the N_Aggregate node to be expanded.

   function Backend_Processing_Possible (N : Node_Id) return Boolean;

   --  This function checks if array aggregate N can be processed directly

   --  by Gigi. If this is the case True is returned.

   function Build_Array_Aggr_Code

     (N           : Node_Id;

      Ctype       : Entity_Id;

      Index       : Node_Id;

      Into        : Node_Id;

      Scalar_Comp : Boolean;

      Indices     : List_Id := No_List;

      Flist       : Node_Id := Empty) return List_Id;

   --  This recursive routine returns a list of statements containing the

   --  loops and assignments that are needed for the expansion of the array

   --  aggregate N.

   --

   --    N is the (sub-)aggregate node to be expanded into code. This node

   --    has been fully analyzed, and its Etype is properly set.

   --

   --    Index is the index node corresponding to the array sub-aggregate N.

   --

   --    Into is the target expression into which we are copying the aggregate.

   --    Note that this node may not have been analyzed yet, and so the Etype

   --    field may not be set.

   --

   --    Scalar_Comp is True if the component type of the aggregate is scalar.

   --

   --    Indices is the current list of expressions used to index the

   --    object we are writing into.

   --

   --    Flist is an expression representing the finalization list on which

   --    to attach the controlled components if any.

   function Number_Of_Choices (N : Node_Id) return Nat;

   --  Returns the number of discrete choices (not including the others choice

   --  if present) contained in (sub-)aggregate N.

   function Late_Expansion

     (N      : Node_Id;

      Typ    : Entity_Id;

      Target : Node_Id;

      Flist  : Node_Id := Empty;

      Obj    : Entity_Id := Empty) return List_Id;

   --  N is a nested (record or array) aggregate that has been marked with

   --  'Delay_Expansion'. Typ is the expected type of the aggregate and Target

   --  is a (duplicable) expression that will hold the result of the aggregate

   --  expansion. Flist is the finalization list to be used to attach

   --  controlled components. 'Obj' when non empty, carries the original

   --  object being initialized in order to know if it needs to be attached to

   --  the previous parameter which may not be the case in the case where

   --  Finalize_Storage_Only is set. Basically this procedure is used to

   --  implement top-down expansions of nested aggregates. This is necessary

   --  for avoiding temporaries at each level as well as for propagating the

   --  right internal finalization list.

   function Make_OK_Assignment_Statement

     (Sloc       : Source_Ptr;

      Name       : Node_Id;

      Expression : Node_Id) return Node_Id;

   --  This is like Make_Assignment_Statement, except that Assignment_OK

   --  is set in the left operand. All assignments built by this unit

   --  use this routine. This is needed to deal with assignments to

   --  initialized constants that are done in place.

   function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;

   --  Given an array aggregate, this function handles the case of a packed

   --  array aggregate with all constant values, where the aggregate can be

   --  evaluated at compile time. If this is possible, then N is rewritten

   --  to be its proper compile time value with all the components properly

   --  assembled. The expression is analyzed and resolved and True is

   --  returned. If this transformation is not possible, N is unchanged

   --  and False is returned

   function Safe_Slice_Assignment (N : Node_Id) return Boolean;

   --  If a slice assignment has an aggregate with a single others_choice,

   --  the assignment can be done in place even if bounds are not static,

   --  by converting it into a loop over the discrete range of the slice.

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

   -- Aggr_Size_OK --

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

   function Aggr_Size_OK (Typ : Entity_Id) return Boolean is

      Lo   : Node_Id;

      Hi   : Node_Id;

      Indx : Node_Id;

      Siz  : Int;

      Lov  : Uint;

      Hiv  : Uint;

      --  The following constant determines the maximum size of an

      --  aggregate produced by converting named to positional

      --  notation (e.g. from others clauses). This avoids running

      --  away with attempts to convert huge aggregates, which hit

      --  memory limits in the backend.

      --  The normal limit is 5000, but we increase this limit to

      --  2**24 (about 16 million) if Restrictions (No_Elaboration_Code)

      --  or Restrictions (No_Implicit_Loops) is specified, since in

      --  either case, we are at risk of declaring the program illegal

      --  because of this limit.

      Max_Aggr_Size : constant Nat :=

                        5000 + (2 ** 24 - 5000) *

                          Boolean'Pos

                            (Restriction_Active (No_Elaboration_Code)

                               or else

                             Restriction_Active (No_Implicit_Loops));

      function Component_Count (T : Entity_Id) return Int;

      --  The limit is applied to the total number of components that the

      --  aggregate will have, which is the number of static expressions

      --  that will appear in the flattened array. This requires a recursive

      --  computation of the the number of scalar components of the structure.

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

      -- Component_Count --

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

      function Component_Count (T : Entity_Id) return Int is

         Res  : Int := 0;

         Comp : Entity_Id;

      begin

         if Is_Scalar_Type (T) then

            return 1;

         elsif Is_Record_Type (T) then

            Comp := First_Component (T);

            while Present (Comp) loop

               Res := Res + Component_Count (Etype (Comp));

               Next_Component (Comp);

            end loop;

            return Res;

         elsif Is_Array_Type (T) then

            declare

               Lo : constant Node_Id :=

                      Type_Low_Bound (Etype (First_Index (T)));

               Hi : constant Node_Id :=

                      Type_High_Bound (Etype (First_Index (T)));

               Siz  : constant Int := Component_Count (Component_Type (T));

            begin

               if not Compile_Time_Known_Value (Lo)

                 or else not Compile_Time_Known_Value (Hi)

               then

                  return 0;

               else

                  return

                    Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1);

               end if;

            end;

         else

            --  Can only be a null for an access type

            return 1;

         end if;

      end Component_Count;

   --  Start of processing for Aggr_Size_OK

   begin

      Siz  := Component_Count (Component_Type (Typ));

      Indx := First_Index (Typ);

      while Present (Indx) loop

         Lo  := Type_Low_Bound (Etype (Indx));

         Hi  := Type_High_Bound (Etype (Indx));

         --  Bounds need to be known at compile time

         if not Compile_Time_Known_Value (Lo)

           or else not Compile_Time_Known_Value (Hi)

         then

            return False;

         end if;

         Lov := Expr_Value (Lo);

         Hiv := Expr_Value (Hi);

         --  A flat array is always safe

         if Hiv < Lov then

            return True;

         end if;

         declare

            Rng : constant Uint := Hiv - Lov + 1;

         begin

            --  Check if size is too large

            if not UI_Is_In_Int_Range (Rng) then

               return False;

            end if;

            Siz := Siz * UI_To_Int (Rng);

         end;

         if Siz <= 0

           or else Siz > Max_Aggr_Size

         then

            return False;

         end if;

         --  Bounds must be in integer range, for later array construction

         if not UI_Is_In_Int_Range (Lov)

             or else

            not UI_Is_In_Int_Range (Hiv)

         then

            return False;

         end if;

         Next_Index (Indx);

      end loop;

      return True;

   end Aggr_Size_OK;

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

   -- Backend_Processing_Possible --

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

   --  Backend processing by Gigi/gcc is possible only if all the following

   --  conditions are met:

   --    1. N is fully positional

   --    2. N is not a bit-packed array aggregate;

   --    3. The size of N's array type must be known at compile time. Note

   --       that this implies that the component size is also known

   --    4. The array type of N does not follow the Fortran layout convention

   --       or if it does it must be 1 dimensional.

   --    5. The array component type is tagged, which may necessitate

   --       reassignment of proper tags.

   --    6. The array component type might have unaligned bit components

   function Backend_Processing_Possible (N : Node_Id) return Boolean is

      Typ : constant Entity_Id := Etype (N);

      --  Typ is the correct constrained array subtype of the aggregate

      function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;

      --  Recursively checks that N is fully positional, returns true if so

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

      -- Static_Check --

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

      function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is

         Expr : Node_Id;

      begin

         --  Check for component associations

         if Present (Component_Associations (N)) then

            return False;

         end if;

         --  Recurse to check subaggregates, which may appear in qualified

         --  expressions. If delayed, the front-end will have to expand.

         Expr := First (Expressions (N));

         while Present (Expr) loop

            if Is_Delayed_Aggregate (Expr) then

               return False;

            end if;

            if Present (Next_Index (Index))

               and then not Static_Check (Expr, Next_Index (Index))

            then

               return False;

            end if;

            Next (Expr);

         end loop;

         return True;

      end Static_Check;

   --  Start of processing for Backend_Processing_Possible

   begin

      --  Checks 2 (array must not be bit packed)

      if Is_Bit_Packed_Array (Typ) then

         return False;

      end if;

      --  Checks 4 (array must not be multi-dimensional Fortran case)

      if Convention (Typ) = Convention_Fortran

        and then Number_Dimensions (Typ) > 1

      then

         return False;

      end if;

      --  Checks 3 (size of array must be known at compile time)

      if not Size_Known_At_Compile_Time (Typ) then

         return False;

      end if;

      --  Checks 1 (aggregate must be fully positional)

      if not Static_Check (N, First_Index (Typ)) then

         return False;

      end if;

      --  Checks 5 (if the component type is tagged, then we may need

      --    to do tag adjustments; perhaps this should be refined to check for

      --    any component associations that actually need tag adjustment,

      --    along the lines of the test that is carried out in

      --    Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates

      --    with tagged components, but not clear whether it's worthwhile ???;

      --    in the case of the JVM, object tags are handled implicitly)

      if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then

         return False;

      end if;

      --  Checks 6 (component type must not have bit aligned components)

      if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then

         return False;

      end if;

      --  Backend processing is possible

      Set_Compile_Time_Known_Aggregate (N, True);

      Set_Size_Known_At_Compile_Time (Etype (N), True);

      return True;

   end Backend_Processing_Possible;

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

   -- Build_Array_Aggr_Code --

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

   --  The code that we generate from a one dimensional aggregate is

   --  1. If the sub-aggregate contains discrete choices we

   --     (a) Sort the discrete choices

   --     (b) Otherwise for each discrete choice that specifies a range we

   --         emit a loop. If a range specifies a maximum of three values, or

   --         we are dealing with an expression we emit a sequence of

   --         assignments instead of a loop.

   --     (c) Generate the remaining loops to cover the others choice if any

   --  2. If the aggregate contains positional elements we

   --     (a) translate the positional elements in a series of assignments

   --     (b) Generate a final loop to cover the others choice if any.

   --         Note that this final loop has to be a while loop since the case

   --             L : Integer := Integer'Last;

   --             H : Integer := Integer'Last;

   --             A : array (L .. H) := (1, others =>0);

   --         cannot be handled by a for loop. Thus for the following

   --             array (L .. H) := (.. positional elements.., others =>E);

   --         we always generate something like:

   --             J : Index_Type := Index_Of_Last_Positional_Element;

   --             while J < H loop

   --                J := Index_Base'Succ (J)

   --                Tmp (J) := E;

   --             end loop;

   function Build_Array_Aggr_Code

     (N           : Node_Id;

      Ctype       : Entity_Id;

      Index       : Node_Id;

      Into        : Node_Id;

      Scalar_Comp : Boolean;

      Indices     : List_Id := No_List;

      Flist       : Node_Id := Empty) return List_Id

   is

      Loc          : constant Source_Ptr := Sloc (N);

      Index_Base   : constant Entity_Id  := Base_Type (Etype (Index));

      Index_Base_L : constant Node_Id := Type_Low_Bound (Index_Base);

      Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);

      function Add (Val : Int; To : Node_Id) return Node_Id;

      --  Returns an expression where Val is added to expression To, unless

      --  To+Val is provably out of To's base type range. To must be an

      --  already analyzed expression.

      function Empty_Range (L, H : Node_Id) return Boolean;

      --  Returns True if the range defined by L .. H is certainly empty

      function Equal (L, H : Node_Id) return Boolean;

      --  Returns True if L = H for sure

      function Index_Base_Name return Node_Id;

      --  Returns a new reference to the index type name

      function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;

      --  Ind must be a side-effect free expression. If the input aggregate

      --  N to Build_Loop contains no sub-aggregates, then this function

      --  returns the assignment statement:

      --

      --     Into (Indices, Ind) := Expr;

      --

      --  Otherwise we call Build_Code recursively

      --

      --  Ada 2005 (AI-287): In case of default initialized component, Expr

      --  is empty and we generate a call to the corresponding IP subprogram.

      function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;

      --  Nodes L and H must be side-effect free expressions.

      --  If the input aggregate N to Build_Loop contains no sub-aggregates,

      --  This routine returns the for loop statement

      --

      --     for J in Index_Base'(L) .. Index_Base'(H) loop

      --        Into (Indices, J) := Expr;

      --     end loop;

      --

      --  Otherwise we call Build_Code recursively.

      --  As an optimization if the loop covers 3 or less scalar elements we

      --  generate a sequence of assignments.

      function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;

      --  Nodes L and H must be side-effect free expressions.

      --  If the input aggregate N to Build_Loop contains no sub-aggregates,

      --  This routine returns the while loop statement

      --

      --     J : Index_Base := L;

      --     while J < H loop

      --        J := Index_Base'Succ (J);

      --        Into (Indices, J) := Expr;

      --     end loop;

      --

      --  Otherwise we call Build_Code recursively

      function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;

      function Local_Expr_Value               (E : Node_Id) return Uint;

      --  These two Local routines are used to replace the corresponding ones

      --  in sem_eval because while processing the bounds of an aggregate with

      --  discrete choices whose index type is an enumeration, we build static

      --  expressions not recognized by Compile_Time_Known_Value as such since

      --  they have not yet been analyzed and resolved. All the expressions in

      --  question are things like Index_Base_Name'Val (Const) which we can

      --  easily recognize as being constant.

      ---------

      -- Add --

      ---------

      function Add (Val : Int; To : Node_Id) return Node_Id is

         Expr_Pos : Node_Id;

         Expr     : Node_Id;

         To_Pos   : Node_Id;

         U_To     : Uint;

         U_Val    : constant Uint := UI_From_Int (Val);

      begin

         --  Note: do not try to optimize the case of Val = 0, because

         --  we need to build a new node with the proper Sloc value anyway.

         --  First test if we can do constant folding

         if Local_Compile_Time_Known_Value (To) then

            U_To := Local_Expr_Value (To) + Val;

            --  Determine if our constant is outside the range of the index.

            --  If so return an Empty node. This empty node will be caught

            --  by Empty_Range below.

            if Compile_Time_Known_Value (Index_Base_L)

              and then U_To < Expr_Value (Index_Base_L)

            then

               return Empty;

            elsif Compile_Time_Known_Value (Index_Base_H)

              and then U_To > Expr_Value (Index_Base_H)

            then

               return Empty;

            end if;

            Expr_Pos := Make_Integer_Literal (Loc, U_To);

            Set_Is_Static_Expression (Expr_Pos);

            if not Is_Enumeration_Type (Index_Base) then

               Expr := Expr_Pos;

            --  If we are dealing with enumeration return

            --     Index_Base'Val (Expr_Pos)

            else

               Expr :=

                 Make_Attribute_Reference

                   (Loc,

                    Prefix         => Index_Base_Name,

                    Attribute_Name => Name_Val,

                    Expressions    => New_List (Expr_Pos));

            end if;

            return Expr;

         end if;

         --  If we are here no constant folding possible

         if not Is_Enumeration_Type (Index_Base) then

            Expr :=

              Make_Op_Add (Loc,

                           Left_Opnd  => Duplicate_Subexpr (To),

                           Right_Opnd => Make_Integer_Literal (Loc, U_Val));

         --  If we are dealing with enumeration return

         --    Index_Base'Val (Index_Base'Pos (To) + Val)

         else

            To_Pos :=

              Make_Attribute_Reference

                (Loc,

                 Prefix         => Index_Base_Name,

                 Attribute_Name => Name_Pos,

                 Expressions    => New_List (Duplicate_Subexpr (To)));

            Expr_Pos :=

              Make_Op_Add (Loc,

                           Left_Opnd  => To_Pos,

                           Right_Opnd => Make_Integer_Literal (Loc, U_Val));

            Expr :=

              Make_Attribute_Reference

                (Loc,

                 Prefix         => Index_Base_Name,

                 Attribute_Name => Name_Val,

                 Expressions    => New_List (Expr_Pos));

         end if;

         return Expr;

      end Add;

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

      -- Empty_Range --

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

      function Empty_Range (L, H : Node_Id) return Boolean is

         Is_Empty : Boolean := False;

         Low      : Node_Id;

         High     : Node_Id;

      begin

         --  First check if L or H were already detected as overflowing the

         --  index base range type by function Add above. If this is so Add

         --  returns the empty node.

         if No (L) or else No (H) then

            return True;

         end if;

         for J in 1 .. 3 loop

            case J is

               --  L > H    range is empty

               when 1 =>

                  Low  := L;

                  High := H;

               --  B_L > H  range must be empty

               when 2 =>

                  Low  := Index_Base_L;

                  High := H;

               --  L > B_H  range must be empty

               when 3 =>

                  Low  := L;

                  High := Index_Base_H;

            end case;

            if Local_Compile_Time_Known_Value (Low)

              and then Local_Compile_Time_Known_Value (High)

            then

               Is_Empty :=

                 UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High));

            end if;

            exit when Is_Empty;