Subversion Repositories openrisc_2011-10-31

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

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

--                                                                          --

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                                                                          --

--                             S E M _ U T I L                              --

--                             S E M _ U T I L                              --

--                                                                          --

--                                                                          --

--                                 B o d y                                  --

--                                 B o d y                                  --

--                                                                          --

--                                                                          --

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

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

--                                                                          --

--                                                                          --

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

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

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

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

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

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

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

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

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

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

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

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

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

--                                                                          --

--                                                                          --

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

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

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

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

--                                                                          --

--                                                                          --

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

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

with Atree;    use Atree;

with Atree;    use Atree;

with Casing;   use Casing;

with Casing;   use Casing;

with Checks;   use Checks;

with Checks;   use Checks;

with Debug;    use Debug;

with Debug;    use Debug;

with Errout;   use Errout;

with Errout;   use Errout;

with Elists;   use Elists;

with Elists;   use Elists;

with Exp_Ch11; use Exp_Ch11;

with Exp_Ch11; use Exp_Ch11;

with Exp_Disp; use Exp_Disp;

with Exp_Disp; use Exp_Disp;

with Exp_Tss;  use Exp_Tss;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Exp_Util; use Exp_Util;

with Fname;    use Fname;

with Fname;    use Fname;

with Freeze;   use Freeze;

with Freeze;   use Freeze;

with Lib;      use Lib;

with Lib;      use Lib;

with Lib.Xref; use Lib.Xref;

with Lib.Xref; use Lib.Xref;

with Nlists;   use Nlists;

with Nlists;   use Nlists;

with Output;   use Output;

with Output;   use Output;

with Opt;      use Opt;

with Opt;      use Opt;

with Rtsfind;  use Rtsfind;

with Rtsfind;  use Rtsfind;

with Scans;    use Scans;

with Scans;    use Scans;

with Scn;      use Scn;

with Scn;      use Scn;

with Sem;      use Sem;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Aux;  use Sem_Aux;

with Sem_Attr; use Sem_Attr;

with Sem_Attr; use Sem_Attr;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Disp; use Sem_Disp;

with Sem_Disp; use Sem_Disp;

with Sem_Eval; use Sem_Eval;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Res;  use Sem_Res;

with Sem_SCIL; use Sem_SCIL;

with Sem_SCIL; use Sem_SCIL;

with Sem_Type; use Sem_Type;

with Sem_Type; use Sem_Type;

with Sinfo;    use Sinfo;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Sinput;   use Sinput;

with Stand;    use Stand;

with Stand;    use Stand;

with Style;

with Style;

with Stringt;  use Stringt;

with Stringt;  use Stringt;

with Targparm; use Targparm;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Tbuild;   use Tbuild;

with Ttypes;   use Ttypes;

with Ttypes;   use Ttypes;

with Uname;    use Uname;

with Uname;    use Uname;

with GNAT.HTable; use GNAT.HTable;

with GNAT.HTable; use GNAT.HTable;

package body Sem_Util is

package body Sem_Util is

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

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

   -- Global_Variables for New_Copy_Tree --

   -- Global_Variables for New_Copy_Tree --

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

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

   --  These global variables are used by New_Copy_Tree. See description

   --  These global variables are used by New_Copy_Tree. See description

   --  of the body of this subprogram for details. Global variables can be

   --  of the body of this subprogram for details. Global variables can be

   --  safely used by New_Copy_Tree, since there is no case of a recursive

   --  safely used by New_Copy_Tree, since there is no case of a recursive

   --  call from the processing inside New_Copy_Tree.

   --  call from the processing inside New_Copy_Tree.

   NCT_Hash_Threshhold : constant := 20;

   NCT_Hash_Threshhold : constant := 20;

   --  If there are more than this number of pairs of entries in the

   --  If there are more than this number of pairs of entries in the

   --  map, then Hash_Tables_Used will be set, and the hash tables will

   --  map, then Hash_Tables_Used will be set, and the hash tables will

   --  be initialized and used for the searches.

   --  be initialized and used for the searches.

   NCT_Hash_Tables_Used : Boolean := False;

   NCT_Hash_Tables_Used : Boolean := False;

   --  Set to True if hash tables are in use

   --  Set to True if hash tables are in use

   NCT_Table_Entries : Nat;

   NCT_Table_Entries : Nat;

   --  Count entries in table to see if threshhold is reached

   --  Count entries in table to see if threshhold is reached

   NCT_Hash_Table_Setup : Boolean := False;

   NCT_Hash_Table_Setup : Boolean := False;

   --  Set to True if hash table contains data. We set this True if we

   --  Set to True if hash table contains data. We set this True if we

   --  setup the hash table with data, and leave it set permanently

   --  setup the hash table with data, and leave it set permanently

   --  from then on, this is a signal that second and subsequent users

   --  from then on, this is a signal that second and subsequent users

   --  of the hash table must clear the old entries before reuse.

   --  of the hash table must clear the old entries before reuse.

   subtype NCT_Header_Num is Int range 0 .. 511;

   subtype NCT_Header_Num is Int range 0 .. 511;

   --  Defines range of headers in hash tables (512 headers)

   --  Defines range of headers in hash tables (512 headers)

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

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

   -- Local Subprograms --

   -- Local Subprograms --

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

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

   function Build_Component_Subtype

   function Build_Component_Subtype

     (C   : List_Id;

     (C   : List_Id;

      Loc : Source_Ptr;

      Loc : Source_Ptr;

      T   : Entity_Id) return Node_Id;

      T   : Entity_Id) return Node_Id;

   --  This function builds the subtype for Build_Actual_Subtype_Of_Component

   --  This function builds the subtype for Build_Actual_Subtype_Of_Component

   --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,

   --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,

   --  Loc is the source location, T is the original subtype.

   --  Loc is the source location, T is the original subtype.

   function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;

   function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;

   --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type

   --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type

   --  with discriminants whose default values are static, examine only the

   --  with discriminants whose default values are static, examine only the

   --  components in the selected variant to determine whether all of them

   --  components in the selected variant to determine whether all of them

   --  have a default.

   --  have a default.

   function Has_Null_Extension (T : Entity_Id) return Boolean;

   function Has_Null_Extension (T : Entity_Id) return Boolean;

   --  T is a derived tagged type. Check whether the type extension is null.

   --  T is a derived tagged type. Check whether the type extension is null.

   --  If the parent type is fully initialized, T can be treated as such.

   --  If the parent type is fully initialized, T can be treated as such.

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

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

   --  Abstract_Interface_List --

   --  Abstract_Interface_List --

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

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

   function Abstract_Interface_List (Typ : Entity_Id) return List_Id is

   function Abstract_Interface_List (Typ : Entity_Id) return List_Id is

      Nod : Node_Id;

      Nod : Node_Id;

   begin

   begin

      if Is_Concurrent_Type (Typ) then

      if Is_Concurrent_Type (Typ) then

         --  If we are dealing with a synchronized subtype, go to the base

         --  If we are dealing with a synchronized subtype, go to the base

         --  type, whose declaration has the interface list.

         --  type, whose declaration has the interface list.

         --  Shouldn't this be Declaration_Node???

         --  Shouldn't this be Declaration_Node???

         Nod := Parent (Base_Type (Typ));

         Nod := Parent (Base_Type (Typ));

         if Nkind (Nod) = N_Full_Type_Declaration then

         if Nkind (Nod) = N_Full_Type_Declaration then

            return Empty_List;

            return Empty_List;

         end if;

         end if;

      elsif Ekind (Typ) = E_Record_Type_With_Private then

      elsif Ekind (Typ) = E_Record_Type_With_Private then

         if Nkind (Parent (Typ)) = N_Full_Type_Declaration then

         if Nkind (Parent (Typ)) = N_Full_Type_Declaration then

            Nod := Type_Definition (Parent (Typ));

            Nod := Type_Definition (Parent (Typ));

         elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then

         elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then

            if Present (Full_View (Typ)) then

            if Present (Full_View (Typ)) then

               Nod := Type_Definition (Parent (Full_View (Typ)));

               Nod := Type_Definition (Parent (Full_View (Typ)));

            --  If the full-view is not available we cannot do anything else

            --  If the full-view is not available we cannot do anything else

            --  here (the source has errors).

            --  here (the source has errors).

            else

            else

               return Empty_List;

               return Empty_List;

            end if;

            end if;

         --  Support for generic formals with interfaces is still missing ???

         --  Support for generic formals with interfaces is still missing ???

         elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then

         elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then

            return Empty_List;

            return Empty_List;

         else

         else

            pragma Assert

            pragma Assert

              (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);

              (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);

            Nod := Parent (Typ);

            Nod := Parent (Typ);

         end if;

         end if;

      elsif Ekind (Typ) = E_Record_Subtype then

      elsif Ekind (Typ) = E_Record_Subtype then

         Nod := Type_Definition (Parent (Etype (Typ)));

         Nod := Type_Definition (Parent (Etype (Typ)));

      elsif Ekind (Typ) = E_Record_Subtype_With_Private then

      elsif Ekind (Typ) = E_Record_Subtype_With_Private then

         --  Recurse, because parent may still be a private extension. Also

         --  Recurse, because parent may still be a private extension. Also

         --  note that the full view of the subtype or the full view of its

         --  note that the full view of the subtype or the full view of its

         --  base type may (both) be unavailable.

         --  base type may (both) be unavailable.

         return Abstract_Interface_List (Etype (Typ));

         return Abstract_Interface_List (Etype (Typ));

      else pragma Assert ((Ekind (Typ)) = E_Record_Type);

      else pragma Assert ((Ekind (Typ)) = E_Record_Type);

         if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then

         if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then

            Nod := Formal_Type_Definition (Parent (Typ));

            Nod := Formal_Type_Definition (Parent (Typ));

         else

         else

            Nod := Type_Definition (Parent (Typ));

            Nod := Type_Definition (Parent (Typ));

         end if;

         end if;

      end if;

      end if;

      return Interface_List (Nod);

      return Interface_List (Nod);

   end Abstract_Interface_List;

   end Abstract_Interface_List;

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

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

   -- Add_Access_Type_To_Process --

   -- Add_Access_Type_To_Process --

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

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

   procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is

   procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is

      L : Elist_Id;

      L : Elist_Id;

   begin

   begin

      Ensure_Freeze_Node (E);

      Ensure_Freeze_Node (E);

      L := Access_Types_To_Process (Freeze_Node (E));

      L := Access_Types_To_Process (Freeze_Node (E));

      if No (L) then

      if No (L) then

         L := New_Elmt_List;

         L := New_Elmt_List;

         Set_Access_Types_To_Process (Freeze_Node (E), L);

         Set_Access_Types_To_Process (Freeze_Node (E), L);

      end if;

      end if;

      Append_Elmt (A, L);

      Append_Elmt (A, L);

   end Add_Access_Type_To_Process;

   end Add_Access_Type_To_Process;

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

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

   -- Add_Global_Declaration --

   -- Add_Global_Declaration --

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

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

   procedure Add_Global_Declaration (N : Node_Id) is

   procedure Add_Global_Declaration (N : Node_Id) is

      Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));

      Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));

   begin

   begin

      if No (Declarations (Aux_Node)) then

      if No (Declarations (Aux_Node)) then

         Set_Declarations (Aux_Node, New_List);

         Set_Declarations (Aux_Node, New_List);

      end if;

      end if;

      Append_To (Declarations (Aux_Node), N);

      Append_To (Declarations (Aux_Node), N);

      Analyze (N);

      Analyze (N);

   end Add_Global_Declaration;

   end Add_Global_Declaration;

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

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

   -- Alignment_In_Bits --

   -- Alignment_In_Bits --

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

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

   function Alignment_In_Bits (E : Entity_Id) return Uint is

   function Alignment_In_Bits (E : Entity_Id) return Uint is

   begin

   begin

      return Alignment (E) * System_Storage_Unit;

      return Alignment (E) * System_Storage_Unit;

   end Alignment_In_Bits;

   end Alignment_In_Bits;

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

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

   -- Apply_Compile_Time_Constraint_Error --

   -- Apply_Compile_Time_Constraint_Error --

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

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

   procedure Apply_Compile_Time_Constraint_Error

   procedure Apply_Compile_Time_Constraint_Error

     (N      : Node_Id;

     (N      : Node_Id;

      Msg    : String;

      Msg    : String;

      Reason : RT_Exception_Code;

      Reason : RT_Exception_Code;

      Ent    : Entity_Id  := Empty;

      Ent    : Entity_Id  := Empty;

      Typ    : Entity_Id  := Empty;

      Typ    : Entity_Id  := Empty;

      Loc    : Source_Ptr := No_Location;

      Loc    : Source_Ptr := No_Location;

      Rep    : Boolean    := True;

      Rep    : Boolean    := True;

      Warn   : Boolean    := False)

      Warn   : Boolean    := False)

   is

   is

      Stat   : constant Boolean := Is_Static_Expression (N);

      Stat   : constant Boolean := Is_Static_Expression (N);

      R_Stat : constant Node_Id :=

      R_Stat : constant Node_Id :=

                 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);

                 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);

      Rtyp   : Entity_Id;

      Rtyp   : Entity_Id;

   begin

   begin

      if No (Typ) then

      if No (Typ) then

         Rtyp := Etype (N);

         Rtyp := Etype (N);

      else

      else

         Rtyp := Typ;

         Rtyp := Typ;

      end if;

      end if;

      Discard_Node

      Discard_Node

        (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));

        (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));

      if not Rep then

      if not Rep then

         return;

         return;

      end if;

      end if;

      --  Now we replace the node by an N_Raise_Constraint_Error node

      --  Now we replace the node by an N_Raise_Constraint_Error node

      --  This does not need reanalyzing, so set it as analyzed now.

      --  This does not need reanalyzing, so set it as analyzed now.

      Rewrite (N, R_Stat);

      Rewrite (N, R_Stat);

      Set_Analyzed (N, True);

      Set_Analyzed (N, True);

      Set_Etype (N, Rtyp);

      Set_Etype (N, Rtyp);

      Set_Raises_Constraint_Error (N);

      Set_Raises_Constraint_Error (N);

      --  Now deal with possible local raise handling

      --  Now deal with possible local raise handling

      Possible_Local_Raise (N, Standard_Constraint_Error);

      Possible_Local_Raise (N, Standard_Constraint_Error);

      --  If the original expression was marked as static, the result is

      --  If the original expression was marked as static, the result is

      --  still marked as static, but the Raises_Constraint_Error flag is

      --  still marked as static, but the Raises_Constraint_Error flag is

      --  always set so that further static evaluation is not attempted.

      --  always set so that further static evaluation is not attempted.

      if Stat then

      if Stat then

         Set_Is_Static_Expression (N);

         Set_Is_Static_Expression (N);

      end if;

      end if;

   end Apply_Compile_Time_Constraint_Error;

   end Apply_Compile_Time_Constraint_Error;

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

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

   -- Build_Actual_Subtype --

   -- Build_Actual_Subtype --

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

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

   function Build_Actual_Subtype

   function Build_Actual_Subtype

     (T : Entity_Id;

     (T : Entity_Id;

      N : Node_Or_Entity_Id) return Node_Id

      N : Node_Or_Entity_Id) return Node_Id

   is

   is

      Loc : Source_Ptr;

      Loc : Source_Ptr;

      --  Normally Sloc (N), but may point to corresponding body in some cases

      --  Normally Sloc (N), but may point to corresponding body in some cases

      Constraints : List_Id;

      Constraints : List_Id;

      Decl        : Node_Id;

      Decl        : Node_Id;

      Discr       : Entity_Id;

      Discr       : Entity_Id;

      Hi          : Node_Id;

      Hi          : Node_Id;

      Lo          : Node_Id;

      Lo          : Node_Id;

      Subt        : Entity_Id;

      Subt        : Entity_Id;

      Disc_Type   : Entity_Id;

      Disc_Type   : Entity_Id;

      Obj         : Node_Id;

      Obj         : Node_Id;

   begin

   begin

      Loc := Sloc (N);

      Loc := Sloc (N);

      if Nkind (N) = N_Defining_Identifier then

      if Nkind (N) = N_Defining_Identifier then

         Obj := New_Reference_To (N, Loc);

         Obj := New_Reference_To (N, Loc);

         --  If this is a formal parameter of a subprogram declaration, and

         --  If this is a formal parameter of a subprogram declaration, and

         --  we are compiling the body, we want the declaration for the

         --  we are compiling the body, we want the declaration for the

         --  actual subtype to carry the source position of the body, to

         --  actual subtype to carry the source position of the body, to

         --  prevent anomalies in gdb when stepping through the code.

         --  prevent anomalies in gdb when stepping through the code.

         if Is_Formal (N) then

         if Is_Formal (N) then

            declare

            declare

               Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));

               Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));

            begin

            begin

               if Nkind (Decl) = N_Subprogram_Declaration

               if Nkind (Decl) = N_Subprogram_Declaration

                 and then Present (Corresponding_Body (Decl))

                 and then Present (Corresponding_Body (Decl))

               then

               then

                  Loc := Sloc (Corresponding_Body (Decl));

                  Loc := Sloc (Corresponding_Body (Decl));

               end if;

               end if;

            end;

            end;

         end if;

         end if;

      else

      else

         Obj := N;

         Obj := N;

      end if;

      end if;

      if Is_Array_Type (T) then

      if Is_Array_Type (T) then

         Constraints := New_List;

         Constraints := New_List;

         for J in 1 .. Number_Dimensions (T) loop

         for J in 1 .. Number_Dimensions (T) loop

            --  Build an array subtype declaration with the nominal subtype and

            --  Build an array subtype declaration with the nominal subtype and

            --  the bounds of the actual. Add the declaration in front of the

            --  the bounds of the actual. Add the declaration in front of the

            --  local declarations for the subprogram, for analysis before any

            --  local declarations for the subprogram, for analysis before any

            --  reference to the formal in the body.

            --  reference to the formal in the body.

            Lo :=

            Lo :=

              Make_Attribute_Reference (Loc,

              Make_Attribute_Reference (Loc,

                Prefix         =>

                Prefix         =>

                  Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),

                  Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),

                Attribute_Name => Name_First,

                Attribute_Name => Name_First,

                Expressions    => New_List (

                Expressions    => New_List (

                  Make_Integer_Literal (Loc, J)));

                  Make_Integer_Literal (Loc, J)));

            Hi :=

            Hi :=

              Make_Attribute_Reference (Loc,

              Make_Attribute_Reference (Loc,

                Prefix         =>

                Prefix         =>

                  Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),

                  Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),

                Attribute_Name => Name_Last,

                Attribute_Name => Name_Last,

                Expressions    => New_List (

                Expressions    => New_List (

                  Make_Integer_Literal (Loc, J)));

                  Make_Integer_Literal (Loc, J)));

            Append (Make_Range (Loc, Lo, Hi), Constraints);

            Append (Make_Range (Loc, Lo, Hi), Constraints);

         end loop;

         end loop;

      --  If the type has unknown discriminants there is no constrained

      --  If the type has unknown discriminants there is no constrained

      --  subtype to build. This is never called for a formal or for a

      --  subtype to build. This is never called for a formal or for a

      --  lhs, so returning the type is ok ???

      --  lhs, so returning the type is ok ???

      elsif Has_Unknown_Discriminants (T) then

      elsif Has_Unknown_Discriminants (T) then

         return T;

         return T;

      else

      else

         Constraints := New_List;

         Constraints := New_List;

         --  Type T is a generic derived type, inherit the discriminants from

         --  Type T is a generic derived type, inherit the discriminants from

         --  the parent type.

         --  the parent type.

         if Is_Private_Type (T)

         if Is_Private_Type (T)

           and then No (Full_View (T))

           and then No (Full_View (T))

            --  T was flagged as an error if it was declared as a formal

            --  T was flagged as an error if it was declared as a formal

            --  derived type with known discriminants. In this case there

            --  derived type with known discriminants. In this case there

            --  is no need to look at the parent type since T already carries

            --  is no need to look at the parent type since T already carries

            --  its own discriminants.

            --  its own discriminants.

           and then not Error_Posted (T)

           and then not Error_Posted (T)

         then

         then

            Disc_Type := Etype (Base_Type (T));

            Disc_Type := Etype (Base_Type (T));

         else

         else

            Disc_Type := T;

            Disc_Type := T;

         end if;

         end if;

         Discr := First_Discriminant (Disc_Type);

         Discr := First_Discriminant (Disc_Type);

         while Present (Discr) loop

         while Present (Discr) loop

            Append_To (Constraints,

            Append_To (Constraints,

              Make_Selected_Component (Loc,

              Make_Selected_Component (Loc,

                Prefix =>

                Prefix =>

                  Duplicate_Subexpr_No_Checks (Obj),

                  Duplicate_Subexpr_No_Checks (Obj),

                Selector_Name => New_Occurrence_Of (Discr, Loc)));

                Selector_Name => New_Occurrence_Of (Discr, Loc)));

            Next_Discriminant (Discr);

            Next_Discriminant (Discr);

         end loop;

         end loop;

      end if;

      end if;

      Subt :=

      Subt :=

        Make_Defining_Identifier (Loc,

        Make_Defining_Identifier (Loc,

          Chars => New_Internal_Name ('S'));

          Chars => New_Internal_Name ('S'));

      Set_Is_Internal (Subt);

      Set_Is_Internal (Subt);

      Decl :=

      Decl :=

        Make_Subtype_Declaration (Loc,

        Make_Subtype_Declaration (Loc,

          Defining_Identifier => Subt,

          Defining_Identifier => Subt,

          Subtype_Indication =>

          Subtype_Indication =>

            Make_Subtype_Indication (Loc,

            Make_Subtype_Indication (Loc,

              Subtype_Mark => New_Reference_To (T,  Loc),

              Subtype_Mark => New_Reference_To (T,  Loc),

              Constraint  =>

              Constraint  =>

                Make_Index_Or_Discriminant_Constraint (Loc,

                Make_Index_Or_Discriminant_Constraint (Loc,

                  Constraints => Constraints)));

                  Constraints => Constraints)));

      Mark_Rewrite_Insertion (Decl);

      Mark_Rewrite_Insertion (Decl);

      return Decl;

      return Decl;

   end Build_Actual_Subtype;

   end Build_Actual_Subtype;

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

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

   -- Build_Actual_Subtype_Of_Component --

   -- Build_Actual_Subtype_Of_Component --

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

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

   function Build_Actual_Subtype_Of_Component

   function Build_Actual_Subtype_Of_Component

     (T : Entity_Id;

     (T : Entity_Id;

      N : Node_Id) return Node_Id

      N : Node_Id) return Node_Id

   is

   is

      Loc       : constant Source_Ptr := Sloc (N);

      Loc       : constant Source_Ptr := Sloc (N);

      P         : constant Node_Id    := Prefix (N);

      P         : constant Node_Id    := Prefix (N);

      D         : Elmt_Id;

      D         : Elmt_Id;

      Id        : Node_Id;

      Id        : Node_Id;

      Indx_Type : Entity_Id;

      Indx_Type : Entity_Id;

      Deaccessed_T : Entity_Id;

      Deaccessed_T : Entity_Id;

      --  This is either a copy of T, or if T is an access type, then it is

      --  This is either a copy of T, or if T is an access type, then it is

      --  the directly designated type of this access type.

      --  the directly designated type of this access type.

      function Build_Actual_Array_Constraint return List_Id;

      function Build_Actual_Array_Constraint return List_Id;

      --  If one or more of the bounds of the component depends on

      --  If one or more of the bounds of the component depends on

      --  discriminants, build  actual constraint using the discriminants

      --  discriminants, build  actual constraint using the discriminants

      --  of the prefix.

      --  of the prefix.

      function Build_Actual_Record_Constraint return List_Id;

      function Build_Actual_Record_Constraint return List_Id;

      --  Similar to previous one, for discriminated components constrained

      --  Similar to previous one, for discriminated components constrained

      --  by the discriminant of the enclosing object.

      --  by the discriminant of the enclosing object.

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

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

      -- Build_Actual_Array_Constraint --

      -- Build_Actual_Array_Constraint --

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

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

      function Build_Actual_Array_Constraint return List_Id is

      function Build_Actual_Array_Constraint return List_Id is

         Constraints : constant List_Id := New_List;

         Constraints : constant List_Id := New_List;

         Indx        : Node_Id;

         Indx        : Node_Id;

         Hi          : Node_Id;

         Hi          : Node_Id;

         Lo          : Node_Id;

         Lo          : Node_Id;

         Old_Hi      : Node_Id;

         Old_Hi      : Node_Id;

         Old_Lo      : Node_Id;

         Old_Lo      : Node_Id;

      begin

      begin

         Indx := First_Index (Deaccessed_T);

         Indx := First_Index (Deaccessed_T);

         while Present (Indx) loop

         while Present (Indx) loop

            Old_Lo := Type_Low_Bound  (Etype (Indx));

            Old_Lo := Type_Low_Bound  (Etype (Indx));

            Old_Hi := Type_High_Bound (Etype (Indx));

            Old_Hi := Type_High_Bound (Etype (Indx));

            if Denotes_Discriminant (Old_Lo) then

            if Denotes_Discriminant (Old_Lo) then

               Lo :=

               Lo :=

                 Make_Selected_Component (Loc,

                 Make_Selected_Component (Loc,

                   Prefix => New_Copy_Tree (P),

                   Prefix => New_Copy_Tree (P),

                   Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));

                   Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));

            else

            else

               Lo := New_Copy_Tree (Old_Lo);

               Lo := New_Copy_Tree (Old_Lo);

               --  The new bound will be reanalyzed in the enclosing

               --  The new bound will be reanalyzed in the enclosing

               --  declaration. For literal bounds that come from a type

               --  declaration. For literal bounds that come from a type

               --  declaration, the type of the context must be imposed, so

               --  declaration, the type of the context must be imposed, so

               --  insure that analysis will take place. For non-universal

               --  insure that analysis will take place. For non-universal

               --  types this is not strictly necessary.

               --  types this is not strictly necessary.

               Set_Analyzed (Lo, False);

               Set_Analyzed (Lo, False);

            end if;

            end if;

            if Denotes_Discriminant (Old_Hi) then

            if Denotes_Discriminant (Old_Hi) then

               Hi :=

               Hi :=

                 Make_Selected_Component (Loc,

                 Make_Selected_Component (Loc,

                   Prefix => New_Copy_Tree (P),

                   Prefix => New_Copy_Tree (P),

                   Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));

                   Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));

            else

            else

               Hi := New_Copy_Tree (Old_Hi);

               Hi := New_Copy_Tree (Old_Hi);

               Set_Analyzed (Hi, False);

               Set_Analyzed (Hi, False);

            end if;

            end if;

            Append (Make_Range (Loc, Lo, Hi), Constraints);

            Append (Make_Range (Loc, Lo, Hi), Constraints);

            Next_Index (Indx);

            Next_Index (Indx);

         end loop;

         end loop;

         return Constraints;

         return Constraints;

      end Build_Actual_Array_Constraint;

      end Build_Actual_Array_Constraint;

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

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

      -- Build_Actual_Record_Constraint --

      -- Build_Actual_Record_Constraint --

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

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

      function Build_Actual_Record_Constraint return List_Id is

      function Build_Actual_Record_Constraint return List_Id is

         Constraints : constant List_Id := New_List;

         Constraints : constant List_Id := New_List;

         D           : Elmt_Id;

         D           : Elmt_Id;

         D_Val       : Node_Id;

         D_Val       : Node_Id;

      begin

      begin

         D := First_Elmt (Discriminant_Constraint (Deaccessed_T));

         D := First_Elmt (Discriminant_Constraint (Deaccessed_T));

         while Present (D) loop

         while Present (D) loop

            if Denotes_Discriminant (Node (D)) then

            if Denotes_Discriminant (Node (D)) then

               D_Val :=  Make_Selected_Component (Loc,

               D_Val :=  Make_Selected_Component (Loc,

                 Prefix => New_Copy_Tree (P),

                 Prefix => New_Copy_Tree (P),

                Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));

                Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));

            else

            else

               D_Val := New_Copy_Tree (Node (D));

               D_Val := New_Copy_Tree (Node (D));

            end if;

            end if;

            Append (D_Val, Constraints);

            Append (D_Val, Constraints);

            Next_Elmt (D);

            Next_Elmt (D);

         end loop;

         end loop;

         return Constraints;

         return Constraints;

      end Build_Actual_Record_Constraint;

      end Build_Actual_Record_Constraint;

   --  Start of processing for Build_Actual_Subtype_Of_Component

   --  Start of processing for Build_Actual_Subtype_Of_Component

   begin

   begin

      --  Why the test for Spec_Expression mode here???

      --  Why the test for Spec_Expression mode here???

      if In_Spec_Expression then

      if In_Spec_Expression then

         return Empty;

         return Empty;

      --  More comments for the rest of this body would be good ???

      --  More comments for the rest of this body would be good ???

      elsif Nkind (N) = N_Explicit_Dereference then

      elsif Nkind (N) = N_Explicit_Dereference then

         if Is_Composite_Type (T)

         if Is_Composite_Type (T)

           and then not Is_Constrained (T)

           and then not Is_Constrained (T)

           and then not (Is_Class_Wide_Type (T)

           and then not (Is_Class_Wide_Type (T)

                          and then Is_Constrained (Root_Type (T)))

                          and then Is_Constrained (Root_Type (T)))

           and then not Has_Unknown_Discriminants (T)

           and then not Has_Unknown_Discriminants (T)

         then

         then

            --  If the type of the dereference is already constrained, it

            --  If the type of the dereference is already constrained, it

            --  is an actual subtype.

            --  is an actual subtype.

            if Is_Array_Type (Etype (N))

            if Is_Array_Type (Etype (N))

              and then Is_Constrained (Etype (N))

              and then Is_Constrained (Etype (N))

            then

            then

               return Empty;

               return Empty;

            else

            else

               Remove_Side_Effects (P);

               Remove_Side_Effects (P);

               return Build_Actual_Subtype (T, N);

               return Build_Actual_Subtype (T, N);

            end if;

            end if;

         else

         else

            return Empty;

            return Empty;

         end if;

         end if;

      end if;

      end if;

      if Ekind (T) = E_Access_Subtype then

      if Ekind (T) = E_Access_Subtype then

         Deaccessed_T := Designated_Type (T);

         Deaccessed_T := Designated_Type (T);

      else

      else

         Deaccessed_T := T;

         Deaccessed_T := T;

      end if;

      end if;

      if Ekind (Deaccessed_T) = E_Array_Subtype then

      if Ekind (Deaccessed_T) = E_Array_Subtype then

         Id := First_Index (Deaccessed_T);

         Id := First_Index (Deaccessed_T);

         while Present (Id) loop

         while Present (Id) loop

            Indx_Type := Underlying_Type (Etype (Id));

            Indx_Type := Underlying_Type (Etype (Id));

            if Denotes_Discriminant (Type_Low_Bound  (Indx_Type))

            if Denotes_Discriminant (Type_Low_Bound  (Indx_Type))

                 or else

                 or else

               Denotes_Discriminant (Type_High_Bound (Indx_Type))

               Denotes_Discriminant (Type_High_Bound (Indx_Type))

            then

            then

               Remove_Side_Effects (P);

               Remove_Side_Effects (P);

               return

               return

                 Build_Component_Subtype

                 Build_Component_Subtype

                   (Build_Actual_Array_Constraint, Loc, Base_Type (T));

                   (Build_Actual_Array_Constraint, Loc, Base_Type (T));

            end if;

            end if;

            Next_Index (Id);

            Next_Index (Id);

         end loop;

         end loop;

      elsif Is_Composite_Type (Deaccessed_T)

      elsif Is_Composite_Type (Deaccessed_T)

        and then Has_Discriminants (Deaccessed_T)

        and then Has_Discriminants (Deaccessed_T)

        and then not Has_Unknown_Discriminants (Deaccessed_T)

        and then not Has_Unknown_Discriminants (Deaccessed_T)

      then

      then

         D := First_Elmt (Discriminant_Constraint (Deaccessed_T));

         D := First_Elmt (Discriminant_Constraint (Deaccessed_T));

         while Present (D) loop

         while Present (D) loop

            if Denotes_Discriminant (Node (D)) then

            if Denotes_Discriminant (Node (D)) then

               Remove_Side_Effects (P);

               Remove_Side_Effects (P);

               return

               return

                 Build_Component_Subtype (

                 Build_Component_Subtype (

                   Build_Actual_Record_Constraint, Loc, Base_Type (T));

                   Build_Actual_Record_Constraint, Loc, Base_Type (T));

            end if;

            end if;

            Next_Elmt (D);

            Next_Elmt (D);

         end loop;

         end loop;

      end if;

      end if;

      --  If none of the above, the actual and nominal subtypes are the same

      --  If none of the above, the actual and nominal subtypes are the same

      return Empty;

      return Empty;

   end Build_Actual_Subtype_Of_Component;

   end Build_Actual_Subtype_Of_Component;

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

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

   -- Build_Component_Subtype --

   -- Build_Component_Subtype --

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

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

   function Build_Component_Subtype

   function Build_Component_Subtype

     (C   : List_Id;

     (C   : List_Id;

      Loc : Source_Ptr;

      Loc : Source_Ptr;

      T   : Entity_Id) return Node_Id

      T   : Entity_Id) return Node_Id

   is

   is

      Subt : Entity_Id;

      Subt : Entity_Id;

      Decl : Node_Id;

      Decl : Node_Id;

   begin

   begin

      --  Unchecked_Union components do not require component subtypes

      --  Unchecked_Union components do not require component subtypes

      if Is_Unchecked_Union (T) then

      if Is_Unchecked_Union (T) then

         return Empty;

         return Empty;

      end if;

      end if;

      Subt :=

      Subt :=

        Make_Defining_Identifier (Loc,

        Make_Defining_Identifier (Loc,

          Chars => New_Internal_Name ('S'));

          Chars => New_Internal_Name ('S'));

      Set_Is_Internal (Subt);

      Set_Is_Internal (Subt);

      Decl :=

      Decl :=

        Make_Subtype_Declaration (Loc,

        Make_Subtype_Declaration (Loc,

          Defining_Identifier => Subt,

          Defining_Identifier => Subt,

          Subtype_Indication =>

          Subtype_Indication =>

            Make_Subtype_Indication (Loc,

            Make_Subtype_Indication (Loc,

              Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),

              Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),

              Constraint  =>

              Constraint  =>

                Make_Index_Or_Discriminant_Constraint (Loc,

                Make_Index_Or_Discriminant_Constraint (Loc,

                  Constraints => C)));

                  Constraints => C)));

      Mark_Rewrite_Insertion (Decl);

      Mark_Rewrite_Insertion (Decl);

      return Decl;

      return Decl;

   end Build_Component_Subtype;

   end Build_Component_Subtype;

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

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

   -- Build_Default_Subtype --

   -- Build_Default_Subtype --

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

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

   function Build_Default_Subtype

   function Build_Default_Subtype

     (T : Entity_Id;

     (T : Entity_Id;

      N : Node_Id) return Entity_Id

      N : Node_Id) return Entity_Id

   is

   is

      Loc  : constant Source_Ptr := Sloc (N);

      Loc  : constant Source_Ptr := Sloc (N);

      Disc : Entity_Id;

      Disc : Entity_Id;

   begin

   begin

      if not Has_Discriminants (T) or else Is_Constrained (T) then

      if not Has_Discriminants (T) or else Is_Constrained (T) then

         return T;

         return T;

      end if;

      end if;

      Disc := First_Discriminant (T);

      Disc := First_Discriminant (T);

      if No (Discriminant_Default_Value (Disc)) then

      if No (Discriminant_Default_Value (Disc)) then