Geek Gadgets 1/ADE-1.bin/ade-dist/gnat-2.06-src.tgz/tar.out/fsf/gnat/ada/sem_ch3.adb

Text File | 1996-09-28 | 243KB | 6,981 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              S E M _ C H 3                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.674 $                            --
--                                                                          --
--        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
--                                                                          --
-- 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, 675 Mass Ave, Cambridge, MA 02139, USA. --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Checks;   use Checks;
with Elists;   use Elists;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Expander; use Expander;
with Exp_Ch3;  use Exp_Ch3;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Features; use Features;
with Freeze;   use Freeze;
with Itypes;   use Itypes;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Opt;      use Opt;
with Output;   use Output;
with Rtsfind;  use Rtsfind;
with Sem;      use Sem;
with Sem_Ch5;  use Sem_Ch5;
with Sem_Ch6;  use Sem_Ch6;
with Sem_Ch7;  use Sem_Ch7;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Res;  use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Stand;    use Stand;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Tbuild;   use Tbuild;
with Ttypes;   use Ttypes;
with Uintp;    use Uintp;
with Urealp;   use Urealp;

package body Sem_Ch3 is

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

   procedure Build_Derived_Array_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : in out Entity_Id);
   --  Subsidiary procedure to Build_Derived_Type. For a derived array type,
   --  create an implicit base if the parent type is constrained or if the
   --  subtype indication has a constraint.

   procedure Build_Derived_Enumeration_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id);
   --  Subsidiary procedure to Build_Derived_Type. For a derived enumeration
   --  type, we must create a new list of literals. Types derived from
   --  Character and Wide_Character are special-cased.

   procedure Build_Derived_Numeric_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id);
   --  Subsidiary procedure to Build_Derived_Type. For numeric types, create
   --  an anonymous base type, and propagate constraint to subtype if needed.

   procedure Build_Derived_Record_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id);
   --  Subsidiary procedure to Build_derived_Type. For non tagged record types,
   --  copy the declaration of the parent, so that the derived type has its own
   --  declaration tree, discriminants, and possibly its own representation.

   procedure Build_Derived_Tagged_Type
     (N            : Node_Id;
      Type_Def     : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id);
   --  Used for building Tagged Extensions, either private or not. N is the
   --  type declaration node, Type_Def is the type definition node. For private
   --  extensions this is the same node.

   procedure Build_Derived_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : in out Entity_Id);
   --  The attributes of a derived type are a copy of the attributes of
   --  the parent type. In some cases, additional entities (copies of
   --  components of the parent type) must also be created.

   function Build_Discriminant_Constraints
     (T           : Entity_Id;
      Def         : Node_Id;
      Related_Nod : Node_Id)
      return        Elist_Id;
   --  Validate discriminant constraints, and build list of expressions in
   --  order of discriminant declarations. Used for subtypes and for derived
   --  types of record types.

   procedure Check_Delta_Expression (E : Node_Id);
   --  Check that the expression represented by E is suitable for use as
   --  a delta expression, i.e. it is of real type and is static.

   procedure Check_Digits_Expression (E : Node_Id);
   --  Check that the expression represented by E is suitable for use as
   --  a digits expression, i.e. it is of integer type, positive and static.

   procedure Check_Incomplete (T : Entity_Id);
   --  Called to verify that an incomplete type is not used prematurely

   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
   --  Validate the initialization of an object declaration. T is the
   --  required type, and Exp is the initialization expression.

   procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id);
   --  If T is the full declaration of an incomplete or private type, check
   --  the conformance of the discriminants, otherwise process them.

   procedure Check_Real_Bound (Bound : Node_Id);
   --  Check given bound for being of real type and static. If not, post an
   --  appropriate message, and rewrite the bound with the real literal zero.

   procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
   --  Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag
   --  of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false);

   procedure Constant_Redeclaration (Id : Entity_Id; N : Node_Id);
   --  Processes full declaration of deferred constant. Id is the entity for
   --  the redeclaration, and N is the N_Object_Declaration node. The caller
   --  has not done an Enter_Name or Set_Ekind on this entity.

   procedure Create_Constrained_Components
     (Subt        : Entity_Id;
      Decl_Node   : Node_Id;
      Typ         : Entity_Id;
      Parent_Rec  : Entity_Id;
      Constraints : Elist_Id);
   --  Build entity list for a constrained record type. If a component depends
   --  on a discriminant, replace its subtype using the discriminant values in
   --  the discriminant constraint.

   procedure Constrain_Access
     (Def_Id      : in out Entity_Id;
      S           : Node_Id;
      Related_Nod : Node_Id);
   --  Apply a list of constraints to an access type. If Def_If is emtpy,
   --  it is an anonymous type created for a subtype indication. In that
   --  case it is created in the procedure and attached to Related_Nod.

   procedure Constrain_Array
     (Def_Id      : in out Entity_Id;
      SI          : Node_Id;
      Related_Nod : Node_Id;
      Related_Id  : Entity_Id;
      Suffix      : Character);
   --  Apply a list of index constraints to an unconstrained array type. The
   --  first parameter is the entity for the resulting subtype. A value of
   --  Empty for Def_Id indicates that an implicit type must be created, but
   --  creation is delayed (and must be done by this procedure) because other
   --  subsidiary implicit types must be created first (which is why Def_Id
   --  is an in/out parameter). Related_Nod gives the place where this type has
   --  to be inserted in the tree. The last two arguments are used to create
   --  its external name if needed.

   procedure Constrain_Concurrent
     (Def_Id      : in out Entity_Id;
      SI          : Node_Id;
      Related_Nod : Node_Id;
      Related_Id  : Entity_Id;
      Suffix      : Character);
   --  Apply list of discriminant constraints to an unconstrained concurrent
   --  type. The first parameter is the entity for the resulting subtype. A
   --  value of Empty for Def_Id indicates that an implicit type must be
   --  created, but creation is delayed (and must be done by this procedure)
   --  because other subsidiary implicit types must be created first (which is
   --  why Def_Id is an in/out parameter).  Related_Nod gives the place where
   --  this type has to be inserted in the tree. The last two arguments are
   --  used to create its external name if needed.

   procedure Constrain_Decimal
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id);
   --  Constrain a decimal fixed point type with a digits constraint and range
   --  constraint if present, and build E_Decimal_Fixed_Point_Subtype entity.

   procedure Constrain_Discriminated_Type
   (Def_Id      : Entity_Id;
    S           : Node_Id;
    Related_Nod : Node_Id);
   --  Process discriminant constraints of composite type. Verify that values
   --  have been provided for all discriminants, that the original type is
   --  unconstrained, and that the types of the supplied expressions match
   --  the discriminant types.

   procedure Constrain_Enumeration
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id);
   --  Constrain an enumeration type with a range constraint. This is
   --  identical to Constrain_Integer, but for the Ekind of the
   --  resulting subtype.

   procedure Constrain_Float
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id);
   --  Constrain a floating point type with either a digits constraint
   --  and/or a range constraint, building a E_Floating_Point_Subtype.

   procedure Constrain_Index
     (Index        : Node_Id;
      S            : Node_Id;
      Related_Nod  : Node_Id;
      Related_Id   : Entity_Id;
      Suffix       : Character;
      Suffix_Index : Nat);
   --  Process an index constraint in a constrained array declaration.
   --  The constraint can be a subtype name, or a range with or without
   --  an explicit subtype mark. The index is the corresponding index of the
   --  unconstrained array. The three last parameters are used to build the
   --  name for the implicit type that is created.

   procedure Constrain_Integer
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id);
   --  Build subtype of a signed or modular integer type.

   procedure Constrain_Ordinary_Fixed
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id);
   --  Constrain an ordinary fixed point type with a range constraint, and
   --  build an E_Ordinary_Fixed_Point_Subtype entity.

   procedure Copy_And_Swap (Privat, Full : Entity_Id);
   --  Copy the Privat entity into the entity of its full declaration
   --  then swap the 2 entities in such a manner that the former private
   --  type is now seen as a full type.

   procedure Copy_Private_To_Full (Priv, Full : Entity_Id);
   --  Initialize the full view declaration with the relevant fields
   --  from the private view.

   procedure Decimal_Fixed_Point_Type_Declaration
     (T   : Entity_Id;
      Def : Node_Id);
   --  Create a new decimal fixed point type, and apply the constraint to
   --  obtain a subtype of this new type.

   procedure Derive_Subprograms (Parent_Type, Derived_Type : Entity_Id);
   --  To complete type derivation, collect or retrieve the primitive
   --  operations of the parent type, and replace the subsidiary subtypes
   --  with the derived type, to build the specs of the inherited ops.

   procedure Complete_Private_Subtype
     (Priv        : Entity_Id;
      Full        : Entity_Id;
      Full_Base   : Entity_Id;
      Related_Nod : Node_Id);
   --  Complete the implicit full view of a private subtype by setting
   --  the appropriate semantic fields. If the full view of the parent is
   --  a record type, build constrained components of subtype.

   procedure Derived_Standard_Character
     (N             : Node_Id;
      Parent_Type   : Entity_Id;
      Derived_Type  : Entity_Id);
   --  Subsidiary procedure to Build_Derived_Enumeration_Type which handles
   --  derivations from types Standard.Character and Standard.Wide_Character.

   procedure Derived_Type_Declaration (T : in out Entity_Id; N : Node_Id);
   --  Process derived type declaration

   procedure Discriminant_Redeclaration (T : Entity_Id; D_List : List_Id);
   --  Verify conformance of discriminant part on redeclarations of types

   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
   --  Insert each literal in symbol table, as an overloadable identifier
   --  Each enumeration type is mapped into a sequence of integers, and
   --  each literal is defined as a constant with integer value. If any
   --  of the literals are character literals, the type is a character
   --  type, which means that strings are legal aggregates for arrays of
   --  components of the type.

   procedure Expand_Others_Choice
     (Case_Table     : Case_Table_Type;
      Others_Choice  : Node_Id;
      Choice_Type    : Entity_Id);
   --  In the case of a variant part of a record type that has an OTHERS
   --  choice, this procedure expands the OTHERS into the actual choices
   --  that it represents. This new list of choice nodes is attached to
   --  the OTHERS node via the Others_Discrete_Choices field. The Case_Table
   --  contains all choices that have been given explicitly in the variant.

   function Find_Type_Of_Object
     (Obj_Def     : Node_Id;
      Related_Nod : Node_Id)
      return        Entity_Id;
   --  Get type entity for object referenced by Obj_Def, attaching the
   --  implicit types generated to Related_Nod

   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
   --  Create a new float, and apply the constraint to obtain subtype of it

   function Inherit_Components
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id)
      return         Elist_Id;
   --  Used by derived types and type extensions to copy components of Parent.
   --  The returned value is an association list:
   --  (old_component => new_component).

   function In_Visible_Part (Scope_Id : Entity_Id) return Boolean;
   --  Determine whether a declaration occurs within the visible part of a
   --  package specification. The package must be on the scope stack, and the
   --  corresponding private part must not.

   function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
   --  Predicate that determines if the expressions Lo and Hi represent a
   --  "Ada null range". The nodes passed are assumed to be static.

   function Is_Valid_Constraint_Kind
     (T_Kind          : Type_Kind;
      Constraint_Kind : Node_Kind)
      return Boolean;
   --  Returns True if it is legal to apply the given kind of constraint
   --  to the given kind of type (index constraint to an array type,
   --  for example).

   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
   --  Create new modular type. Verify that modulus is in  bounds and is
   --  a power of two (implementation restriction).

   procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
   --  Create an abbreviated declaration for an operator in order to
   --  materialize minimally operators on derived types.

   procedure Ordinary_Fixed_Point_Type_Declaration
     (T   : Entity_Id;
      Def : Node_Id);
   --  Create a new ordinary fixed point type, and apply the constraint
   --  to obtain subtype of it.

   procedure Prepare_Private_Subtype_Completion
     (Id          : Entity_Id;
      Related_Nod : Node_Id);
   --  Id is a subtype of some private type. Creates the full declaration
   --  associated with Id whenever possible, i.e. when the full declaration
   --  of the base type is already known. Records each subtype into
   --  Private_Dependents of the base type.

   procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id);
   --  Process some semantic actions when the full view of a private type is
   --  encountered and analyzed. The first action is to create the full views
   --  of the dependant private subtypes. The second action is to recopy the
   --  primitive operations of the private view (in the tagged case).

   procedure Process_Range_Expr_In_Decl
     (R           : Node_Id;
      T           : Entity_Id;
      Related_Nod : Node_Id);
   --  Process a range expression that appears in a declaration context. The
   --  range is analyzed and resolved with the base type of the given type,
   --  and an appropriate check for expressions in non-static contexts made
   --  on the bounds. R is analyzed and resolved using T, so the caller should
   --  if necessary link R into the tree before the call, and in particular in
   --  the case of a subtype declaration, it is appropriate to set the parent
   --  pointer of R so that the types get properly frozen.

   procedure Process_Real_Range_Specification (Def : Node_Id);
   --  Given the type definition for a real type, this procedure processes
   --  and checks the real range specification of this type definition if
   --  one is present. If errors are found, error messages are posted, and
   --  the Real_Range_Specification of Def is reset to Empty.

   procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id);
   --  Def is a record type definition node. This procedure analyzes the
   --  components in this record type definition. T is the entity for
   --  the enclosing type. It is provided so that its Has_Tasks flag
   --  can be set if any of the component have Has_Tasks set.

   procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id);
   --  Process non-tagged record type declaration

   procedure Set_Scalar_Range_For_Subtype
     (Def_Id      : Entity_Id;
      R           : Node_Id;
      Subt        : Node_Id;
      Related_Nod : Node_Id);
   --  This routine is used to set the scalar range field for a subtype
   --  given Def_Id, the entity for the subtype, and R, the range expression
   --  for the scalar range. Subt provides the parent subtype to be used
   --  to analyze, resolve, and check the given range.


   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
   --  Create a new signed integer entity, and apply the constraint to obtain
   --  the required first named subtype of this type.

   procedure Tagged_Record_Type_Declaration (T : Entity_Id; N : Node_Id);
   --  Process tagged record type declaration. T is the typ being defined,
   --  N is the declaration node.

   --------------------------
   -- Analyze_Declarations --
   --------------------------

   procedure Analyze_Declarations (L : List_Id) is
      D           : Node_Id;
      Next_Node   : Node_Id;
      Freeze_From : Entity_Id := Empty;

   begin
      D := First (L);
      while Present (D) loop

         --  Complete analysis of declaration

         Analyze (D);
         Next_Node := Next (D);

         if No (Freeze_From) then
            Freeze_From := First_Entity (Current_Scope);
         end if;

         --  At the end of a declarative part, freeze remaining entities
         --  declared in it. The end of the visible declarations of a
         --  package specification is not the end of a declarative part
         --  if private declarations are present. The end of a package
         --  declaration is a freezing point only if it a library package.
         --  A task definition or protected type definition is not a freeze
         --  point either. Finally, we do not freeze entities in generic
         --  scopes, because there is no code generated for them and freeze
         --  nodes will be generated for the instance.
         --  The end of a package instantiation is not a freeze point, but
         --  for now we make it one, because the generic body is inserted
         --  (currently) immediately after. Generic instantiations will not
         --  be a freeze point once delayed freezing of bodies is implemented.
         --  (This is needed in any case for early instantiations ???).

         if No (Next_Node) then
            if Nkind (Parent (L)) = N_Component_List
              or else Nkind (Parent (L)) = N_Task_Definition
              or else Nkind (Parent (L)) = N_Protected_Definition
            then
               null;

            elsif Ekind (Current_Scope) = E_Generic_Package then
               null;

            elsif Nkind (Parent (L)) /= N_Package_Specification then
               Freeze_All (Freeze_From, D);
               Freeze_From := Last_Entity (Current_Scope);

            elsif Scope (Current_Scope) /= Standard_Standard
              and then not Is_Child_Unit (Current_Scope)
              and then No (Generic_Parent (Parent (L)))
            then
               null;

            elsif L /= Visible_Declarations (Parent (L))
               or else No (Private_Declarations (Parent (L)))
               or else Is_Empty_List (Private_Declarations (Parent (L)))
            then
               Freeze_All (Freeze_From, D);
               Freeze_From := Last_Entity (Current_Scope);
            end if;

         --  If next node is a body then freeze all types before the body.
         --  An exception occurs for expander generated bodies, which can
         --  be recognized by their already being analyzed. The expander
         --  ensures that all types needed by these bodies have been frozen
         --  but it is not necessary to freeze all types (and would be wrong
         --  since it would not correspond to an RM defined freeze point).

         elsif not Analyzed (Next_Node)
           and then (Nkind (Next_Node) = N_Subprogram_Body
             or else Nkind (Next_Node) = N_Entry_Body
             or else Nkind (Next_Node) = N_Package_Body
             or else Nkind (Next_Node) = N_Protected_Body
             or else Nkind (Next_Node) = N_Task_Body
             or else Nkind (Next_Node) in N_Body_Stub)
         then
            Freeze_All (Freeze_From, D);
            Freeze_From := Last_Entity (Current_Scope);
         end if;

         D := Next (D);
      end loop;

   end Analyze_Declarations;

   --------------------------------
   -- Analyze_Default_Expression --
   --------------------------------

   procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id) is
   begin
      In_Default_Expression := True;
      Analyze (N);
      Resolve (N, T);
      In_Default_Expression := False;
   end Analyze_Default_Expression;

   -----------------------------
   --  Analyze_Implicit_Types --
   -----------------------------

   --  Nothing to do, since the only descendent is the head of the list of
   --  itypes, and all itype entities were analyzed when the implicit types
   --  were constructed (this is the whole point of implicit types!)

   procedure Analyze_Implicit_Types (N : Node_Id) is
   begin
      null;
   end Analyze_Implicit_Types;

   --------------------------------
   -- Analyze_Object_Declaration --
   --------------------------------

   procedure Analyze_Object_Declaration (N : Node_Id) is
      Loc : constant Source_Ptr := Sloc (N);
      Id  : constant Entity_Id  := Defining_Identifier (N);
      T   : Entity_Id;

      E : Node_Id := Expression (N);
      --  E is set to Expression (N) throughout this routine. When
      --  Expression (N) is modified, E is changed accordingly.

   begin
      if Constant_Present (N)
         and then Present (Current_Entity_In_Scope (Id))
      then
         Constant_Redeclaration (Id, N);

      --  In the normal case, enter identifiers at the start to catch
      --  premature usage in the initialization expression.

      else
         Enter_Name (Id);
      end if;

      --  Entities declared in Pure unit should be set Is_Pure
      --  Since 'Partition_Id cannot be applied to such an entity

      Set_Is_Pure (Id, Is_Pure (Current_Scope));

      --  There are three kinds of implicit types generated by an
      --  object declaration:

      --   1. those for generated by the original Object Definition

      --   2. those generated by the Expression

      --   3. those used to constrained the Object Definition with the
      --       expression constraints when it is unconstrained

      --  They must be generated in this order to avoid order of elaboration
      --  issues

      T := Find_Type_Of_Object (Object_Definition (N), N);

      --  If deferred constant, make sure context is appropriate

      if Constant_Present (N) and then No (E) then
         if (Ekind (Current_Scope) /= E_Package
              and then Ekind (Current_Scope) /= E_Generic_Package)
           or else In_Private_Part (Current_Scope)
         then
            Error_Msg_N
              ("invalid context for deferred constant declaration", N);
            Set_Constant_Present (N, False);

         --  In Ada 83, deferred constant must be of private type

         elsif not Is_Private_Type (T) then
            Note_Feature (Deferred_Constants_Of_Any_Type, Sloc (N));

            if Ada_83 and then Comes_From_Source (N) then
               Error_Msg_N
                 ("(Ada 83) deferred constant must be private type", N);
            end if;
         end if;

      --  If not a deferred constant, then object declaration freezes its type

      else
         Check_Fully_Declared (T, N);
         Freeze_Before (N, T);
      end if;

      --  Process initialization expression if present

      if Present (E) then
         Analyze (E);
         Check_Initialization (T, E);
         Resolve (E, T);
         Apply_Range_Check (E, Etype (E), T);
         Apply_Static_Length_Check (E, Etype (E), T);

         --  ??? Next block can be removed as soon as the new mechanism
         --  to get rid of expression actions are in place.

         Get_Rid_Of_Expression_Actions : declare
            Expr : Node_Id := Expression (N);

         begin
            if Nkind (Expr) = N_Expression_Actions then
               Insert_List_Before (N, Actions (Expr));
            end if;

            if Nkind (Expr) in N_Has_Itypes
              and then Present (First_Itype (Expr))
            then
               declare
                  Inode : Node_Id := Make_Implicit_Types (Loc);

               begin
                  Transfer_Itypes (From => Expr, To => Inode);
                  Insert_Before (N, Inode);
               end;
            end if;

            if Nkind (Expr) = N_Expression_Actions then
               Set_Expression (N, Expression (Expr));
               E := Expression (N);
            end if;
         end Get_Rid_Of_Expression_Actions;

         --  Have to wait until after actions so the itype is there.

         if Is_Array_Type (T) and then Is_Constrained (T) then
            Apply_Length_Check (E, T);
         end if;

      end if;

      --  Abstract type is never permitted for a variable or constant

      if Is_Abstract (T) then
         Error_Msg_N ("type of object cannot be abstract",
           Object_Definition (N));

      --  Case of unconstrained type

      elsif Is_Indefinite_Subtype (T) then

         Set_Has_U_Nominal_Subtype (Id);

         --  Nothing to do in deferred constant case

         if Constant_Present (N) and then No (E) then
            null;

         --  Otherwise must have an initialization

         elsif No (E) then
            if not Constant_Present (N) then
               Note_Feature (Unconstrained_Variables,
                 Sloc (Object_Definition (N)));

               if Ada_83
                 and then Comes_From_Source (Object_Definition (N))
               then
                  Error_Msg_N
                    ("(Ada 83) unconstrained variable not allowed",
                    Object_Definition (N));
               end if;
            end if;

            if Is_Class_Wide_Type (T) then
               Error_Msg_N
                 ("initialization required in class-wide declaration ", N);
            else
               Error_Msg_N
                 ("unconstrained subtype not allowed (need initialization)",
                  Object_Definition (N));
            end if;

         elsif Has_Unknown_Discriminants (T) then
            Unimplemented (N, "Objects of type with unknown discriminants");

         --  All OK, constrain the type with the expression size

         else
            Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
            T := Find_Type_Of_Object (Object_Definition (N), N);
            Freeze_Before (N, T);
         end if;
      end if;

      --  Now establish the proper kind and type of the object.

      if Constant_Present (N) then
         Set_Ekind (Id, E_Constant);

      else
         Set_Ekind (Id, E_Variable);
      end if;

      Set_Etype      (Id, T);
      Set_Is_Aliased (Id, Aliased_Present (N));

      Validate_Object_Declaration (N, Id, E, Object_Definition (N), T);

   end Analyze_Object_Declaration;

   ----------------------
   -- Check_Real_Bound --
   ----------------------

   procedure Check_Real_Bound (Bound : Node_Id) is
   begin
      if not Is_Real_Type (Etype (Bound)) then
         Error_Msg_N
           ("bound in real type definition must be of real type", Bound);

      elsif not Is_OK_Static_Expression (Bound) then
         Error_Msg_N
           ("non-static expression used for real type bound", Bound);

      else
         return;
      end if;

      Rewrite_Substitute_Tree
        (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
      Analyze (Bound);
      Resolve (Bound, Standard_Float);
   end Check_Real_Bound;

   -----------------------
   -- Conditional_Delay --
   -----------------------

   procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
   begin
      if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
         Set_Has_Delayed_Freeze (New_Ent);
      end if;
   end Conditional_Delay;

   ----------------------------
   -- Constant_Redeclaration --
   ----------------------------

   procedure Constant_Redeclaration (Id : Entity_Id; N : Node_Id) is
      E    : constant Node_Id   := Expression (N);
      Prev : constant Entity_Id := Current_Entity_In_Scope (Id);
      T    : Entity_Id;

   begin
      T := Find_Type_Of_Object (Object_Definition (N), N);
      Freeze_Before (N, T);

      --  Case of a constant with a previous declaration that was either not
      --  a constant, or was a full constant declaration. In either case, it
      --  seems best to let Enter_Name treat it as an illegal duplicate decl.

      if Ekind (Prev) /= E_Constant
        or else Present (Expression (Parent (Prev)))
      then
         Enter_Name (Id);

      --  Case of full declaration of constant has wrong type

      elsif Base_Type (Etype (Prev)) /= Base_Type (T) then
         Error_Msg_Sloc := Sloc (Prev);
         Error_Msg_N ("type does not match declaration#", N);
         Set_Full_View (Prev, Id);
         Set_Etype (Id, Any_Type);

      --  Otherwise process the full constant declaration

      else
         Set_Full_View (Prev, Id);
         Set_Is_Public (Id, Is_Public (Prev));
         Set_Is_Internal (Id);
         Append_Entity (Id, Current_Scope);

         if Is_Frozen (Prev) then
            Error_Msg_N ("full constant declaration appears too late", N);
         end if;

         --  Check ALIASED present if present before (RM 7.4(7))

         if Is_Aliased (Prev)
           and then not Aliased_Present (N)
         then
            Error_Msg_Sloc := Sloc (Prev);
            Error_Msg_N ("ALIASED required (see declaration#)", N);
         end if;

         if Present (E) and then No (Etype (E)) then
            --  How can E be not present here ???

            Analyze (E);
            Check_Initialization (T, E);
            Resolve (E, T);

            if Is_Indefinite_Subtype (T) then
               Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
               T := Find_Type_Of_Object (Object_Definition (N), N);
               Set_Etype (Id, T);
               Freeze_Before (N, T);
            end if;
         end if;
      end if;
   end Constant_Redeclaration;

   --------------------------------
   -- Analyze_Number_Declaration --
   --------------------------------

   procedure Analyze_Number_Declaration (N : Node_Id) is
      Id    : constant Entity_Id := Defining_Identifier (N);
      E     : constant Node_Id   := Expression (N);
      T     : Entity_Id;
      Index : Interp_Index;
      It    : Interp;

   begin
      --  Entities declared in Pure unit should be set Is_Pure
      --  Since 'Partition_Id cannot be applied to such an entity

      Set_Is_Pure (Id, Is_Pure (Current_Scope));

      Analyze (E);

      --  Verify that the expression is static and numeric. If
      --  the expression is overloaded, we apply the preference
      --  rule that favors root numeric types.

      if not Is_Overloaded (E) then
         T := Etype (E);

      else
         T := Any_Type;
         Get_First_Interp (E, Index, It);

         while Present (It.Typ) loop
            if (Is_Integer_Type (It.Typ)
                 or else Is_Real_Type (It.Typ))
              and then (Scope (Base_Type (It.Typ))) = Standard_Standard
            then
               if T = Any_Type then
                  T := It.Typ;

               elsif It.Typ = Universal_Real
                 or else It.Typ = Universal_Integer
               then
                  --  Choose universal interpretation over any other.

                  T := It.Typ;
                  exit;
               end if;
            end if;

            Get_Next_Interp (Index, It);
         end loop;
      end if;

      Enter_Name (Id);

      if Is_Integer_Type (T)  then
         Resolve (E, T);
         Set_Etype (Id, Universal_Integer);
         Set_Ekind (Id, E_Named_Integer);

      elsif Is_Real_Type (T) then
         Resolve (E, T);
         Set_Etype (Id, Universal_Real);
         Set_Ekind (Id, E_Named_Real);

      else
         Wrong_Type (E, Any_Numeric);
         Set_Etype (Id, Any_Type);
         Set_Ekind (Id, E_Constant);
      end if;

      if Nkind (E) = N_Integer_Literal
        or else Nkind (E) = N_Real_Literal
      then
         Set_Etype (E, Etype (Id));
      end if;

      if not Is_OK_Static_Expression (E) then
         Error_Msg_N ("non-static expression used in number declaration", E);
         Replace_Substitute_Tree (N, Make_Integer_Literal (Sloc (N), Uint_0));
         Set_Etype (N, Any_Type);
      end if;

   end Analyze_Number_Declaration;

   -------------------------
   -- Find_Type_Of_Object --
   -------------------------

   function Find_Type_Of_Object
     (Obj_Def     : Node_Id;
      Related_Nod : Node_Id)
      return        Entity_Id
   is
      Def_Kind : constant Node_Kind := Nkind (Obj_Def);
      P        : constant Node_Id   := Parent (Obj_Def);
      Obj      : constant Entity_Id := Defining_Identifier (P);
      T        : Entity_Id;

   begin
      --  Case of an anonymous array subtype

      if Def_Kind = N_Constrained_Array_Definition
        or else Def_Kind = N_Unconstrained_Array_Definition
      then

         T := Empty;
         Array_Type_Declaration (T, Obj_Def);

      --  create an explicit subtype whenever possible

      elsif Nkind (P) /=  N_Component_Declaration
        and then Def_Kind = N_Subtype_Indication
      then
         T := Make_Defining_Identifier (Sloc (P),
                New_External_Name (Chars (Obj), 'S'));

         Insert_Action (Obj_Def,
           Make_Subtype_Declaration (Sloc (P),
             Defining_Identifier => T,
             Subtype_Indication  => Relocate_Node (Obj_Def)));

      else
         T := Process_Subtype (Obj_Def, Related_Nod, Obj, 'S');
      end if;

      return T;
   end Find_Type_Of_Object;

   --------------------------------
   -- Analyze_Subtype_Indication --
   --------------------------------

   procedure Analyze_Subtype_Indication (N : Node_Id) is
      T : constant Node_Id := Subtype_Mark (N);
      R : constant Node_Id := Range_Expression (Constraint (N));

   begin
      Analyze (T);
      Analyze (R);
      Set_Etype (N, Etype (R));
   end Analyze_Subtype_Indication;

   ----------------------------
   -- Check_Delta_Expression --
   ----------------------------

   procedure Check_Delta_Expression (E : Node_Id) is
   begin
      if not (Is_Real_Type (Etype (E))) then
         Wrong_Type (E, Any_Real);

      elsif not Is_OK_Static_Expression (E) then
         Error_Msg_N ("non-static expression used for delta value", E);

      elsif not UR_Is_Positive (Expr_Value_R (E)) then
         Error_Msg_N ("delta expression must be positive", E);

      else
         return;
      end if;

      --  If any of above errors occurred, then replace the incorrect
      --  expression by the real 0.1, which should prevent further errors.

      Replace_Substitute_Tree (E,
        Make_Real_Literal (Sloc (E), Ureal_Tenth));
      Analyze (E);
      Resolve (E, Standard_Float);

   end Check_Delta_Expression;

   -----------------------------
   -- Check_Digits_Expression --
   -----------------------------

   procedure Check_Digits_Expression (E : Node_Id) is
   begin
      if not (Is_Integer_Type (Etype (E))) then
         Wrong_Type (E, Any_Integer);

      elsif not Is_OK_Static_Expression (E) then
         Error_Msg_N ("non-static expression used for digits value", E);

      elsif Expr_Value (E) <= 0 then
         Error_Msg_N ("digits value must be greater than zero", E);

      else
         return;
      end if;

      --  If any of above errors occurred, then replace the incorrect
      --  expression by the integer 1, which should prevent further errors.

      Replace_Substitute_Tree (E, Make_Integer_Literal (Sloc (E), Uint_1));
      Analyze (E);
      Resolve (E, Standard_Integer);

   end Check_Digits_Expression;

   --------------------------
   -- Check_Initialization --
   --------------------------

   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
   begin
      if Is_Limited_Type (T) then
         Error_Msg_N
           ("cannot initialize entities of limited type", Exp);
      end if;
   end Check_Initialization;

   ------------------------------
   -- Analyze_Type_Declaration --
   ------------------------------

   procedure Analyze_Type_Declaration (N : Node_Id) is
      Def    : constant Node_Id   := Type_Definition (N);
      Def_Id : constant Entity_Id := Defining_Identifier (N);
      T      : Entity_Id;

   begin

      --  If the unit is RCI or remote types then this is a remote
      --  access to subprogram type declaration. We need some special
      --  processing for such a declaration, including declaring
      --  Def_Id as a record (fat pointer) type with a link to the
      --  original declaration.

      case Nkind (Def) is

         when N_Access_To_Subprogram_Definition =>
            if Inside_Remote_Call_Interface_Unit
              or else Inside_Remote_Types_Unit
            then
               Process_Remote_AST_Declaration (N);
            end if;

         when others =>
            null;

      end case;

      T := Find_Type_Name (N);

      --  Entities declared in Pure unit should be set Is_Pure
      --  Since 'Partition_Id cannot be applied to such an entity

      Set_Is_Pure (T, Is_Pure (Current_Scope));

      --  Only composite types other than array types are allowed to have
      --  discriminants.

      case Nkind (Def) is

         --  For derived types, the rule will be checked once we've figured
         --  out the parent type.

         when N_Derived_Type_Definition =>
            null;

         --  For record types, discriminants are allowed.

         when N_Record_Definition =>
            null;

         when others =>
            if Present (Discriminant_Specifications (N)) then
               Error_Msg_N
                 ("elementary or array type cannot have discriminants",
                  Defining_Identifier
                  (First (Discriminant_Specifications (N))));
            end if;

      end case;

      --  Elaborate the type definition according to kind, and generate
      --  susbsidiary (implicit) subtypes where needed.

      case Nkind (Def) is

         when N_Access_To_Subprogram_Definition =>
            Access_Subprogram_Declaration (T, Def);

            --  Validate categorization rule against access type declaration
            --  usually a violation in Pure unit, Shared_Passive unit.

            Validate_Access_Type_Declaration (T, N);

         when N_Access_To_Object_Definition =>
            Access_Type_Declaration (T, Def);

            --  Validate categorization rule against access type declaration
            --  usually a violation in Pure unit, Shared_Passive unit.

            Validate_Access_Type_Declaration (T, N);

            --  If we are compiling calling stubs, we add read/write
            --  representation clause for each access to class wide limited
            --  private type (abstract this out to Sem_Attr???)

            if (Stub_Mode = Compile_Caller_Stub_Spec or
                Stub_Mode = Compile_Receiver_Stub_Spec)
              and then Is_ACWLP_Type (Def_Id)
            then
               Add_Racw_RW (N);
            end if;

         when N_Array_Type_Definition =>
            Array_Type_Declaration (T, Def);

         when N_Derived_Type_Definition =>
            Derived_Type_Declaration (T, N);

         when N_Enumeration_Type_Definition =>
            Enumeration_Type_Declaration (T, Def);

         when N_Floating_Point_Definition =>
            Floating_Point_Type_Declaration (T, Def);

         when N_Decimal_Fixed_Point_Definition =>
            Decimal_Fixed_Point_Type_Declaration (T, Def);

         when N_Ordinary_Fixed_Point_Definition =>
            Ordinary_Fixed_Point_Type_Declaration (T, Def);

         when N_Signed_Integer_Type_Definition =>
            Signed_Integer_Type_Declaration (T, Def);

         when N_Modular_Type_Definition =>
            Modular_Type_Declaration (T, Def);

         when N_Record_Definition =>
            if Tagged_Present (Def) then
               Tagged_Record_Type_Declaration (T, N);
            else
               Record_Type_Declaration (T, N);
            end if;

         when others =>
            pragma Assert (False); null;

      end case;

      --  Some common processing for all types

      Set_Depends_On_Private (T, Has_Private_Component (T));
      Set_Is_First_Subtype   (T, True);

      --  Both the declared entity, and its anonymous base type if one
      --  was created, need freeze nodes allocating.

      declare
         B : constant Entity_Id := Base_Type (T);

      begin
         --  In the case where the base type is different from the first
         --  subtype, we pre-allocate a freeze node, and set the proper
         --  link to the first subtype. Freeze_Entity will use this
         --  preallocated freeze node when it freezes the entity.

         if B /= T then

            --  Don't allocate freeze node if already allocated

            if No (Freeze_Node (B)) then
               Set_Has_Delayed_Freeze (B);
               Set_Freeze_Node (B, Make_Freeze_Entity (No_Location));
               Set_TSS_Elist (Freeze_Node (B), No_Elist);
            end if;

            Set_First_Subtype_Link (Freeze_Node (B), T);
         end if;

         Set_Has_Delayed_Freeze (T);
      end;

      --  Case of T is the full declaration of some private type which has
      --  been swapped in Defining_Identifier (N).

      if T /= Def_Id and then Is_Private_Type (Def_Id) then
         Process_Full_View (N, T, Def_Id);
      end if;
   end Analyze_Type_Declaration;

   -----------------------
   -- Process_Full_View --
   -----------------------

   procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is

   begin

      --  First some sanity checks that must be done after semantic
      --  decoration of the full view and thus cannot be placed with other
      --  similar checks in Find_Type_Name

      if not Is_Limited_Type (Priv_T) and then Is_Limited_Type (Full_T) then
         Error_Msg_N ("Completion of a non limited type cannot be limited",
           Full_T);

      elsif Is_Tagged_Type (Priv_T)
        and then Is_Limited_Type (Priv_T)
        and then not Is_Limited_Type (Full_T)
      then
         --  GNAT allow its own definition of Limited_Controlled to disobey
         --  this rule in order in ease the implementation. The next test is
         --  safe because Root_Controlled is defined in a private system child

         if Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
            null;
         else
            Error_Msg_N (
              "Completion of a limited tagged type must be limited", Full_T);
         end if;
      end if;

      --  Create a full declaration for all its subtypes recorded in
      --  Private_Dependents and swap them similarly to the base type.
      --  These are subtypes that have been define before the full
      --  declaration of the private type. We also swap the entry in
      --  Private_Dependents list so we can properly restore the
      --  private view on exit from the scope.

      declare
         Priv_Elmt : Elmt_Id;
         Priv      : Entity_Id;
         Full      : Entity_Id;

      begin
         Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
         while Present (Priv_Elmt) loop
            Priv := Node (Priv_Elmt);

            if Ekind (Priv) = E_Private_Subtype
              or else Ekind (Priv) = E_Limited_Private_Subtype
            then
               Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
               Attach_Itype_To (N, Full);
               Copy_And_Swap (Priv, Full);
               Complete_Private_Subtype (Full, Priv, Full_T, N);
               Replace_Elmt (Priv_Elmt, Full);
            end if;

            Priv_Elmt := Next_Elmt (Priv_Elmt);
         end loop;
      end;

      --  If the private view was tagged, copy the new Primitive
      --  operations from the private view to the full view.

      if Is_Tagged_Type (Full_T) then
         declare
            Priv_List : Elist_Id;
            Full_List : constant Elist_Id := Primitive_Operations (Full_T);
            P1, P2    : Elmt_Id;
            Prim      : Entity_Id;

         begin
            if Is_Tagged_Type (Priv_T) then
               Priv_List := Primitive_Operations (Priv_T);

               P1 := First_Elmt (Priv_List);
               while Present (P1) loop
                  Prim := Node (P1);

                  if No (Alias (Prim)) then
                     P2 := First_Elmt (Full_List);
                     while Present (P2) and then Node (P2) /= Prim loop
                        P2 := Next_Elmt (P2);
                     end loop;

                     --  If not found, that is a new one

                     if No (P2) then
                        Append_Elmt (Prim, Full_List);
                     end if;
                  end if;

                  P1 := Next_Elmt (P1);
               end loop;

            else
               --  In this case the partial view is non tagged, just check
               --  if "=" is not already defined in order to avoid to generate
               --  a default one

               Prim := Next_Entity (Full_T);
               while Present (Prim) loop
                  if Chars (Prim) = Name_Op_Eq
                    and then Etype (Prim) = Standard_Boolean
                    and then Etype (First_Formal (Prim)) = Full_T
                    and then Etype (Next_Formal (First_Formal (Prim))) = Full_T
                  then
                     Append_Elmt (Prim, Full_List);
                     exit;
                  end if;

                  Prim := Next_Entity (Prim);
               end loop;
            end if;

            --  Now the 2 views can share the same Primitive Operation list

            if Is_Tagged_Type (Priv_T) then
               Set_Primitive_Operations (Priv_T, Full_List);
            end if;

            --  Both views must share the same Class Wide type

            Set_Class_Wide_Type (Full_T, Class_Wide_Type (Priv_T));
         end;
      end if;
   end Process_Full_View;

   -------------------
   -- Copy_And_Swap --
   -------------------

   procedure Copy_And_Swap (Privat, Full : Entity_Id) is
      Loc : constant Source_Ptr := Sloc (Full);

   begin
      --  Initialize new full declaration entity by copying the pertinent
      --  fields of the corresponding private declaration entity.

      Copy_Private_To_Full (Privat, Full);
      Set_Sloc (Full, Loc);

      --  Swap the two entities. Now Privat is the full type entity and
      --  Full is the private one. They will be swapped back at the end
      --  of the private part. This swapping ensures that the entity that
      --  is visible in the private part is the full declaration.

      Exchange_Entities (Privat, Full);
      Set_Full_View (Full, Privat);
      Append_Entity (Full, Current_Scope);
   end Copy_And_Swap;

   ---------------------------
   --  Copy_Private_To_Full --
   ---------------------------

   procedure Copy_Private_To_Full (Priv, Full : Entity_Id) is
   begin
      Set_Ekind           (Full, Ekind (Priv)); --  for now, need a type!???
      Set_Etype           (Full, Any_Type);
      Set_Has_Discriminants
                          (Full, Has_Discriminants (Priv));

      if Has_Discriminants (Full) then
         Set_Discriminant_Constraint
                          (Full, Discriminant_Constraint (Priv));
      end if;

      Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
      Set_Homonym         (Full, Homonym (Priv));
      Set_Is_Abstract     (Full, Is_Abstract (Priv));
      Set_Is_Controlled   (Full, Is_Controlled (Priv));
      Set_Is_Immediately_Visible
                          (Full, Is_Immediately_Visible (Priv));
      Set_Is_Public       (Full, Is_Public (Priv));
      Set_Is_Pure         (Full, Is_Pure (Priv));
      Set_Is_Tagged_Type  (Full, Is_Tagged_Type (Priv));

      Conditional_Delay   (Full, Priv);

      if Is_Tagged_Type (Full) then
         Set_Primitive_Operations
                          (Full, Primitive_Operations (Priv));
      end if;

      Set_Is_Volatile     (Full, Is_Volatile (Priv));
      Set_Scope           (Full, Scope (Priv));
      Set_Next_Entity     (Full, Next_Entity (Priv));
      Set_First_Entity    (Full, First_Entity (Priv));
      Set_Last_Entity     (Full, Last_Entity (Priv));
   end Copy_Private_To_Full;

   --------------------
   -- Find_Type_Name --
   --------------------

   function Find_Type_Name (N : Node_Id) return Entity_Id is
      Id       : constant Entity_Id := Defining_Identifier (N);
      Prev     : Entity_Id;
      New_Id   : Entity_Id;
      Prev_Par : Node_Id;

   begin
      --  Find incomplete declaration, if some was given.

      Prev := Current_Entity_In_Scope (Id);

      if Present (Prev) then

         --  Previous declaration exists. Error if not incomplete/private case

         Prev_Par := Parent (Prev);

         if not Is_Incomplete_Or_Private_Type (Prev) then
            Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
            New_Id := Id;

         elsif Nkind (N) /= N_Full_Type_Declaration
           and then Nkind (N) /= N_Task_Type_Declaration
           and then Nkind (N) /= N_Protected_Type_Declaration
         then
            --  Completion must be a full type declarations (RM 7.3(4))

            Error_Msg_Sloc := Sloc (Prev);
            Error_Msg_NE ("invalid completion of }", Id, Prev);
            New_Id := Id;

         --  Case of full declaration of incomplete type

         elsif Ekind (Prev) = E_Incomplete_Type then

            --  Indicate that the incomplete declaration has a matching
            --  full declaration. The defining occurrence of the incomplete
            --  declaration remains the visible one, and the procedure
            --  Get_Full_View dereferences it whenever the type is used.

            Set_Full_View (Prev,  Id);
            Append_Entity (Id, Current_Scope);
            Set_Is_Public (Id, Is_Public (Prev));
            Set_Is_Internal (Id);
            New_Id := Id;

            if Nkind (N) = N_Full_Type_Declaration
              and then Nkind (Type_Definition (N)) =
                           N_Unconstrained_Array_Definition
            then
               Unimplemented
                 (N, "incomplete types completed with unconstrained arrays");
            end if;


         --  Case of full declaration of private type

         else
            if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
               if Etype (Prev) /= Prev then

                  --  Prev is a private subtype or a derived type, and needs
                  --  no completion.

                  Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
                  New_Id := Id;
               end if;

            elsif Nkind (N) /= N_Full_Type_Declaration
              or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
            then
               Error_Msg_N ("full view of private extension must be"
                 & " an extension", N);

            elsif not (Abstract_Present (Parent (Prev)))
              and then Abstract_Present (Type_Definition (N))
            then
               Error_Msg_N ("full view of non-abstract extension cannot"
                 & " be abstract", N);
            end if;

            if not In_Private_Part (Current_Scope) then
               Error_Msg_N
                 ("declaration of full view must appear in private part",  N);
            end if;

            Copy_And_Swap (Prev, Id);
            New_Id := Prev;
         end if;

         --  Verify that full declaration conforms to incomplete one

         if Present (Discriminant_Specifications (N))
           and then Is_Incomplete_Or_Private_Type (Prev)
         then
            Discriminant_Redeclaration (Prev, Discriminant_Specifications (N));

         elsif Is_Incomplete_Or_Private_Type (Prev)
           and then Present (Discriminant_Specifications (Prev_Par))
         then
            Error_Msg_N ("missing discriminants in full type declaration", N);
         end if;

         if Is_Tagged_Type (Prev) then
            Note_Feature (Tagged_Types, Sloc (N));

            --  The full declaration is either a tagged record or an
            --  extension otherwise this is an error

            if Nkind (Type_Definition (N)) = N_Record_Definition then
               if not Tagged_Present (Type_Definition (N)) then
                  Error_Msg_NE
                    ("full declaration of } must be tagged", Prev, Id);
                  Set_Primitive_Operations (Id, New_Elmt_List);
               end if;

            elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
               if No (Record_Extension_Part (Type_Definition (N))) then
                  Error_Msg_NE (
                    "full declaration of } must be a record extension",
                    Prev, Id);
                  Set_Primitive_Operations (Id, New_Elmt_List);
               end if;
            end if;
         end if;

         return New_Id;

      else
         --  New type declaration

         Enter_Name (Id);
         return Id;
      end if;
   end Find_Type_Name;

   ------------------------------
   -- Is_Valid_Constraint_Kind --
   ------------------------------

   function Is_Valid_Constraint_Kind
     (T_Kind          : Type_Kind;
      Constraint_Kind : Node_Kind)
      return Boolean is

   begin
      case T_Kind is

         when Enumeration_Kind |
              Integer_Kind =>
            return Constraint_Kind = N_Range_Constraint;

         when Decimal_Fixed_Point_Kind =>
            return Constraint_Kind = N_Digits_Constraint;

         when Ordinary_Fixed_Point_Kind =>
            return Constraint_Kind = N_Delta_Constraint or else
              Constraint_Kind = N_Range_Constraint;

         when Float_Kind =>
            return Constraint_Kind = N_Digits_Constraint or else
              Constraint_Kind = N_Range_Constraint;

         when Access_Kind       |
              Array_Kind        |
              E_Record_Type     |
              E_Record_Subtype  |
              Class_Wide_Kind   |
              E_Incomplete_Type |
              Private_Kind      |
              Concurrent_Kind  =>
            return Constraint_Kind = N_Index_Or_Discriminant_Constraint;

         when others =>
            return True; -- Error will be detected later.
      end case;

   end Is_Valid_Constraint_Kind;

   ---------------------
   -- Process_Subtype --
   ---------------------

   function Process_Subtype
     (S           : Node_Id;
      Related_Nod : Node_Id;
      Related_Id  : Entity_Id := Empty;
      Suffix      : Character := ' ')
      return        Entity_Id
   is
      P               : Node_Id;
      Def_Id          : Entity_Id;
      Subtype_Mark_Id : Entity_Id;
      N_Dynamic_Ityp  : Node_Id := Empty;

   begin
      --  Case of constraint present, so that we have an N_Subtype_Indication
      --  node (this node is created only if constraints are present).

      if Nkind (S) = N_Subtype_Indication then
         Find_Type (Subtype_Mark (S));
         P := Parent (S);
         Subtype_Mark_Id := Entity (Subtype_Mark (S));

         --  Explicit subtype declaration case

         if Nkind (P) = N_Subtype_Declaration then
            Def_Id := Defining_Identifier (P);

         --  Explicit derived type definition case

         elsif Nkind (P) = N_Derived_Type_Definition then
            Def_Id := Defining_Identifier (Parent (P));

         --  Implicit case, the Def_Id must be created as an implicit type.
         --  The one exception arises in the case of concurrent types,
         --  array and access types, where other subsidiary implicit types
         --  may be created and must appear before the main implicit type.
         --  In these cases we leave Def_Id set to Empty as a signal that the
         --  call to New_Itype has not yet been made to create Def_Id.

         else
            if Is_Array_Type (Subtype_Mark_Id)
              or else Is_Concurrent_Type (Subtype_Mark_Id)
              or else Is_Access_Type (Subtype_Mark_Id)
            then
               Def_Id := Empty;
            else
               Def_Id := New_Itype (E_Void, Related_Nod, Related_Id, Suffix);
            end if;

            --  Only set Has_Dynamic_Itypes if the type is Implicit

            N_Dynamic_Ityp := Related_Nod;
         end if;

         --  If the kind of constraint is invalid for this kind of type,
         --  then give an error, and then pretend no constraint was given.

         if not Is_Valid_Constraint_Kind
                   (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
         then
            Error_Msg_N
              ("incorrect constraint for this kind of type",
               Constraint (S));
            Rewrite_Substitute_Tree (S,
              New_Copy_Tree (Subtype_Mark (S)));

            --  Make recursive call, having got rid of the bogus constraint

            return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
         end if;

         --  Remaining processing depends on type

         case Ekind (Subtype_Mark_Id) is

            --  If the type is a access type, the constraint applies to the
            --  type being accessed. Create the corresponding subtype of it,
            --  promote it to an implicit type, and return an access to it.

            when Access_Kind =>
               Constrain_Access (Def_Id, S, Related_Nod);

            when Array_Kind =>
               Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);

            when Decimal_Fixed_Point_Kind =>
               Constrain_Decimal (Def_Id, S, N_Dynamic_Ityp);

            when Enumeration_Kind =>
               Constrain_Enumeration (Def_Id, S, N_Dynamic_Ityp);

            when Ordinary_Fixed_Point_Kind =>
               Constrain_Ordinary_Fixed (Def_Id, S, N_Dynamic_Ityp);

            when Float_Kind =>
               Constrain_Float (Def_Id, S, N_Dynamic_Ityp);

            when Integer_Kind =>
               Constrain_Integer (Def_Id, S, N_Dynamic_Ityp);

            when E_Record_Type     |
                 E_Record_Subtype  |
                 Class_Wide_Kind   |
                 E_Incomplete_Type =>
               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);

            when Private_Kind =>
               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
               Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);

            when Concurrent_Kind  =>
               Constrain_Concurrent (Def_Id, S,
                 Related_Nod, Related_Id, Suffix);

            when others =>
               Error_Msg_N ("invalid subtype mark in subtype indication", S);
         end case;

         --  Size is always inherited from base type, so is Is_Packed

         Set_Esize     (Def_Id, Esize     (Subtype_Mark_Id));
         Set_Is_Packed (Def_Id, Is_Packed (Subtype_Mark_Id));
         return Def_Id;

      --  Case of no constraints present

      else
         Find_Type (S);
         Check_Incomplete (S);
         return Entity (S);
      end if;
   end Process_Subtype;

   ----------------------
   -- Check_Incomplete --
   ----------------------

   procedure Check_Incomplete (T : Entity_Id) is
   begin
      if Ekind (Entity (T)) = E_Incomplete_Type then
         Error_Msg_N ("invalid use of type before its full declaration", T);
      end if;
   end Check_Incomplete;

   -----------------------
   --  Check_Completion --
   -----------------------

   procedure Check_Completion (Body_Id : Node_Id := Empty) is
      E : Entity_Id;

      procedure Post_Error;
      --  Post errors for ???

      procedure Post_Error is
      begin
         if not Comes_From_Source (E) then

            if (Ekind (E) = E_Task_Type
              or else Ekind (E) = E_Protected_Type)
            then
               --  It may be an anonymous protected type created for a
               --  single variable. Post error on variable, if present.

               declare
                  Var : Entity_Id;

               begin
                  Var := First_Entity (Current_Scope);

                  while Present (Var) loop
                     exit when Etype (Var) = E
                       and then Comes_From_Source (Var);

                     Var := Next_Entity (Var);
                  end loop;

                  if Present (Var) then
                     E := Var;
                  end if;
               end;
            end if;
         end if;

         if not Comes_From_Source (E) then

            --  If a generated entity has no completion, then either previous
            --  semantic errors have disabled the expansion phase, or else
            --  something is very wrong.

            if Errors_Detected > 0 then
               return;
            else
               pragma Assert (False); null;
            end if;
         end if;

         if No (Body_Id) then

            --  Check on a declarative part: post error on the declaration
            --  that has no completion.
            --  This is not the right place to post this message ???

            if Is_Type (E) then
               Error_Msg_NE ("missing full declaration for }", Parent (E), E);
            else
               Error_Msg_NE ("missing body for &", Parent (E), E);
            end if;

         else
            --  Package body has no completion for a declaration that appears
            --  in the corresponding spec. Post error on the body, with a
            --  reference to the non-completed declaration. However, do not
            --  post the message if the item is internal, and we have any
            --  errors so far (otherwise it could easily be an artifact of
            --  expansion, which is turned off if any errors occur, e.g. in
            --  the case of a missing task body procedure, where expansion of
            --  the task body was suppressed because of other errors).

            if Comes_From_Source (E)
              or else Errors_Detected = 0
            then
               Error_Msg_Sloc := Sloc (E);

               if Is_Type (E) then
                  Error_Msg_NE
                    ("missing full declaration for }!", Body_Id, E);
               else
                  Error_Msg_NE ("missing body for & declared#!",
                     Body_Id, E);
               end if;
            end if;
         end if;
      end Post_Error;

   --  Start processing for Check_Completion

   begin
      E := First_Entity (Current_Scope);
      while Present (E) loop
         if Is_Internal (E) then
            null;

         --  The following situation requires special handling: a child
         --  unit that appears in the context clause of the body of its
         --  parent:

         --    procedure Parent.Child (...);
         --
         --    with Parent.Child;
         --    package body Parent is

         --  Here Parent.Child appears as a local entity, but should not
         --  be flagged as requiring completion, because it is a
         --  compilation unit.

         elsif Ekind (E) = E_Function
           or else Ekind (E) = E_Procedure
           or else Ekind (E) = E_Generic_Function
           or else Ekind (E) = E_Generic_Procedure
         then
            if not Has_Completion (E)
              and then not Is_Abstract (E)
              and then Nkind (Parent (Get_Declaration_Node (E))) /=
                                                       N_Compilation_Unit
              and then Chars (E) /= Name_uSize
            then
               Post_Error;
            end if;

         elsif Ekind (E) = E_Package
           or else Ekind (E) = E_Generic_Package
         then
            if Unit_Requires_Body (E) then
               if not Has_Completion (E)
                 and then Nkind (Parent (Get_Declaration_Node (E))) /=
                                                       N_Compilation_Unit
               then
                  Post_Error;
               end if;
            else
               May_Need_Implicit_Body (E);
            end if;

         elsif Ekind (E) = E_Incomplete_Type
           and then No (Underlying_Type (E))
         then
            Post_Error;

         elsif (Ekind (E) = E_Task_Type or else
                Ekind (E) = E_Protected_Type)
           and then not Has_Completion (E)
         then
            Post_Error;

         elsif Ekind (E) = E_Constant
           and then Ekind (Etype (E)) = E_Task_Type
           and then not Has_Completion (Etype (E))
         then
            Post_Error;

         elsif Ekind (E) = E_Protected_Object
           and then not Has_Completion (Etype (E))
         then
            Post_Error;

         end if;

         E := Next_Entity (E);
      end loop;
   end Check_Completion;

   ----------------------------------------
   -- Prepare_Private_Subtype_Completion --
   ----------------------------------------

   procedure Prepare_Private_Subtype_Completion
     (Id          : Entity_Id;
      Related_Nod : Node_Id)
   is
      Id_B   : constant Entity_Id := Base_Type (Id);
      Full_B : constant Entity_Id := Full_View (Id_B);
      Full   : Entity_Id;
      Itypnod : Node_Id;

   begin
      if Present (Full_B) then

         --  The Base_Type is already completed, we can complete the
         --  subtype now. We have to create a new entity with the same name,
         --  Thus we can't use New_Itype.

         Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));

         --  Attach the full declaration to the list of implicit types
         --  after the private view. If the related node is not the
         --  parent of the private view (the private view is itself
         --  an itype), we can just attach it to the itype list.
         --  Otherwise (the private view is an explicit subtype
         --  declaration), we create an N_Implicit_Types node and
         --  place it after the declaration to ensure that the private
         --  view is seen first.

         if Related_Nod /= Parent (Id) then
            Attach_Itype_To (Related_Nod, Full);

         else
            Itypnod := Make_Implicit_Types (Sloc (Id));
            Set_First_Itype (Itypnod, Full);
            Insert_After (Related_Nod, Itypnod);
         end if;

         Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);

      end if;

      --  Place all subtypes on the Private_Dependents list. The ones
      --  that have not yet received a full view will receive one
      --  after the full view of the base type is seen (Process_Full_View).

      Append_Elmt (Id, Private_Dependents (Id_B));

   end Prepare_Private_Subtype_Completion;

   ------------------------------
   -- Complete_Private_Subtype --
   ------------------------------

   procedure Complete_Private_Subtype
     (Priv        : Entity_Id;
      Full        : Entity_Id;
      Full_Base   : Entity_Id;
      Related_Nod : Node_Id)
   is
      Save_Next_Entity : Entity_Id;
      Save_Next_Itype  : Entity_Id;

   begin
      --  Set semantic attributes for (implicit) private subtype completion.
      --  If the full type has no discriminants, then it is a copy of the full
      --  view of the base. Otherwise, it is a subtype of the base with a
      --  possible discriminant constraint. Save and restore the original
      --  Next_Entity and Next_Itype fields of full to ensure that the
      --  calls to Copy_Node do not corrupt the respective chains.
      --  Note that the type of the full view is the same entity as the
      --  type of the partial view. In this fashion, the subtype has
      --  access to the correct view of the parent.

      Save_Next_Entity := Next_Entity (Full);
      Save_Next_Itype  := Next_Itype (Full);

      case Ekind (Full_Base) is

         when Private_Kind     |
              E_Record_Type    |
              E_Record_Subtype |
              Class_Wide_Kind  =>
            Copy_Node (Priv, Full);

            Set_Has_Discriminants  (Full, Has_Discriminants (Full_Base));
            Set_First_Entity       (Full, First_Entity (Full_Base));
            Set_Last_Entity        (Full, Last_Entity (Full_Base));
            Set_Next_Itype         (Full, Save_Next_Itype);

            if Ekind (Full_Base) = E_Record_Type
              and then Has_Discriminants (Full_Base)
              and then Has_Discriminants (Priv) -- might not, if errors
              and then Present (Discriminant_Constraint (Priv))
              and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
            then
               Create_Constrained_Components (Full, Related_Nod,
                 Full_Base, Full_Base, Discriminant_Constraint (Priv));
            end if;

         when others =>
            Copy_Node (Full_Base, Full);
            Set_Chars          (Full, Chars (Priv));
            Set_Next_Itype     (Full, Save_Next_Itype);
            Conditional_Delay  (Full, Priv);
            Set_Sloc           (Full, Sloc (Priv));

      end case;

      Set_Next_Entity (Full, Save_Next_Entity);

      --  Set common attributes for all subtypes.

      Set_Ekind            (Full, Subtype_Kind (Ekind (Full_Base)));
      Set_Scope            (Full, Scope (Priv));
      Set_Esize            (Full, Esize (Full_Base));
      Set_Is_Controlled    (Full, Is_Controlled (Full_Base));
      Set_Has_Controlled   (Full, Has_Controlled (Full_Base));
      Set_Has_Tasks        (Full, Has_Tasks (Full_Base));

      if not Is_Concurrent_Type (Full_Base) then
         Set_Alignment_Clause (Full, Alignment_Clause (Full_Base));
      end if;

      Set_Depends_On_Private (Full, Has_Private_Component (Full));
      Set_Has_Delayed_Freeze (Full,
            Has_Delayed_Freeze (Full_Base) and not Is_Frozen (Full_Base));
      Set_Freeze_Node (Full, Empty);
      Set_Is_Frozen (Full, False);
      Set_Full_View (Priv, Full);
   end Complete_Private_Subtype;

   ---------------------------------
   -- Analyze_Subtype_Declaration --
   ---------------------------------

   procedure Analyze_Subtype_Declaration (N : Node_Id) is
      Id    : constant Entity_Id := Defining_Identifier (N);
      T     : Entity_Id;

   begin
      --  Entities declared in Pure unit should be set Is_Pure
      --  Since 'Partition_Id cannot be applied to such an entity

      Set_Is_Pure (Id, Is_Pure (Current_Scope));

      --  The following guard condition on Enter_Name is to handle cases
      --  where the defining identifier has already been entered into the
      --  scope but the the declaration as a whole needs to be analyzed.

      --  This case in particular happens for derived enumeration types.
      --  The derived enumeration type is processed as an inserted enumeration
      --  type declaration followed by a rewritten subtype declaration. The
      --  defining identifier, however, is entered into the name scope very
      --  early in the processing of the original type declaration and
      --  therefore needs to be avoided here, when the created subtype
      --  declaration is analyzed. (See Build_Derived_Types)

      --  This also happens when the full view of a private type is a
      --  derived type with constraints. In this case the entity has been
      --  introduced in the private declaration.

      if Present (Etype (Id))
        and then (Is_Private_Type (Etype (Id))
                   or else Is_Rewrite_Substitution (N))
      then
         null;

      else
         Enter_Name (Id);
      end if;

      T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
      pragma Assert (Is_Type (T));

      --  Inherit common attributes

      Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));

      --  In the case where there is no constraint given in the subtype
      --  indication, Process_Subtype just returns the Subtype_Mark,
      --  so its semantic attributes must be established here.

      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
         Set_Etype (Id, Base_Type (T));

         case Ekind (T) is
            when Array_Kind =>
               Set_Ekind                (Id, E_Array_Subtype);
               Set_First_Index          (Id, First_Index        (T));
               Set_Component_Type       (Id, Component_Type     (T));
               Set_Is_Aliased           (Id, Is_Aliased         (T));
               Set_Is_Constrained       (Id, Is_Constrained     (T));

            when Decimal_Fixed_Point_Kind =>
               Set_Ekind                (Id, E_Decimal_Fixed_Point_Subtype);
               Set_Digits_Value         (Id, Digits_Value       (T));
               Set_Delta_Value          (Id, Delta_Value        (T));
               Set_Scale_Value          (Id, Scale_Value        (T));
               Set_Small_Value          (Id, Small_Value        (T));
               Set_Scalar_Range         (Id, Scalar_Range       (T));
               Set_Machine_Radix_10     (Id, Machine_Radix_10   (T));

            when Enumeration_Kind =>
               Set_Ekind                (Id, E_Enumeration_Subtype);
               Set_First_Literal        (Id, First_Literal (Base_Type (T)));
               Set_Lit_Name_Table       (Id, Lit_Name_Table     (T));
               Set_Scalar_Range         (Id, Scalar_Range       (T));
               Set_Is_Character_Type    (Id, Is_Character_Type  (T));

            when Ordinary_Fixed_Point_Kind =>
               Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
               Set_Scalar_Range         (Id, Scalar_Range       (T));
               Set_Small_Value          (Id, Small_Value        (T));
               Set_Delta_Value          (Id, Delta_Value        (T));

            when Float_Kind =>
               Set_Ekind                (Id, E_Floating_Point_Subtype);
               Set_Scalar_Range         (Id, Scalar_Range       (T));
               Set_Digits_Value         (Id, Digits_Value       (T));

            when Signed_Integer_Kind =>
               Set_Ekind                (Id, E_Signed_Integer_Subtype);
               Set_Scalar_Range         (Id, Scalar_Range       (T));

            when Modular_Integer_Kind =>
               Set_Ekind                (Id, E_Modular_Integer_Subtype);
               Set_Scalar_Range         (Id, Scalar_Range       (T));
               Set_Modulus              (Id, Modulus            (T));
               Set_Non_Binary_Modulus   (Id, Non_Binary_Modulus (T));

            when Class_Wide_Kind =>
               Note_Feature (Class_Wide_Types, Sloc (Id));
               Set_First_Entity         (Id, First_Entity       (T));
               Set_Last_Entity          (Id, Last_Entity        (T));
               Set_Is_Tagged_Type       (Id, True);
               Set_Ekind                (Id, E_Class_Wide_Subtype);

               if Ekind (T) = E_Class_Wide_Subtype then
                  Set_Equivalent_Type   (Id, Equivalent_Type    (T));
               end if;

            when E_Record_Type | E_Record_Subtype =>
               Set_Ekind                (Id, E_Record_Subtype);
               Set_First_Entity         (Id, First_Entity       (T));
               Set_Last_Entity          (Id, Last_Entity        (T));
               Set_Is_Tagged_Type       (Id, Is_Tagged_Type     (T));
               Set_Has_Discriminants    (Id, Has_Discriminants  (T));
               Set_Is_Constrained       (Id, Is_Constrained     (T));

               if Has_Discriminants (T) then
                  Set_Discriminant_Constraint
                                        (Id, Discriminant_Constraint (T));
               end if;

               if Is_Tagged_Type (T) then
                  Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
                  Set_Primitive_Operations
                                        (Id, Primitive_Operations (T));
                  Set_Access_Disp_Table (Id, Access_Disp_Table  (T));
               end if;

            when Private_Kind =>
               Set_Ekind             (Id, Subtype_Kind (Ekind   (T)));
               Set_Has_Discriminants (Id, Has_Discriminants     (T));
               Set_Is_Constrained    (Id, Is_Constrained        (T));
               Set_Is_Tagged_Type    (Id, Is_Tagged_Type        (T));
               Set_First_Entity      (Id, First_Entity          (T));
               Set_Last_Entity       (Id, Last_Entity           (T));

               --  In general the attributes of the subtype of a private
               --  type are the attributes of the partial view of parent.
               --  However, the full view may be a discriminated type,
               --  and the subtype must share the discriminant constraint
               --  to generate correct calls to initialization procedures.

               if Has_Discriminants (T) then
                  Set_Discriminant_Constraint
                                     (Id, Discriminant_Constraint (T));

               elsif Present (Full_View (T))
                 and then Has_Discriminants (Full_View (T))
               then
                  Set_Discriminant_Constraint
                               (Id, Discriminant_Constraint (Full_View (T)));
               end if;

               Prepare_Private_Subtype_Completion (Id, N);

            when Access_Kind =>
               Set_Ekind             (Id, E_Access_Subtype);
               Set_Directly_Designated_Type
                                     (Id, Designated_Type       (T));

               --  A Pure library_item must not contain the declaration of a
               --  named access type, except within a subprogram, generic
               --  subprogram, task unit, or protected unit (RM 10.2.1(16)).

               if Comes_From_Source (Id)
                 and then Inside_Pure_Unit
                 and then not Inside_Subprogram_Task_Protected_Unit
               then
                  Error_Msg_N
                    ("named access types not allowed in pure unit", N);
               end if;

            when Concurrent_Kind =>

               Set_Ekind                (Id, Subtype_Kind (Ekind   (T)));
               Set_Corresponding_Record_Type (Id,
                                         Corresponding_Record_Type (T));
               Set_First_Entity         (Id, First_Entity          (T));
               Set_First_Private_Entity (Id,  First_Private_Entity (T));
               Set_Has_Discriminants    (Id, Has_Discriminants     (T));
               Set_Is_Constrained       (Id, Is_Constrained        (T));
               Set_Last_Entity          (Id, Last_Entity           (T));

               if Is_Constrained (T) then
                  Set_Discriminant_Constraint (Id,
                                           Discriminant_Constraint (T));
               end if;

            when others =>
               pragma Assert (False); null;
         end case;
      end if;

      if Etype (Id) = Any_Type then
         return;
      end if;

      --  Some common processing on all types

      Set_Is_Packed (Id, Is_Packed (T));
      Set_Esize     (Id, Esize     (T));

      if Ekind (T) not in Concurrent_Kind then
         Set_Alignment_Clause (Id, Alignment_Clause (T));
      end if;

      T := Etype (Id);

      Set_Is_Immediately_Visible (Id, True);
      Set_Depends_On_Private     (Id, Has_Private_Component (T));

      if Is_Array_Type (Id)
        and then Is_Packed (Id)
      then
         Set_Has_Delayed_Freeze (Id);

      elsif Is_Private_Type (T)
        and then Present (Full_View (T))
      then
         Conditional_Delay (Id, Full_View (T));

      else
         Conditional_Delay (Id, T);
      end if;

      Set_Has_Tasks      (Id, Has_Tasks (T));
      Set_Has_Controlled (Id, Has_Controlled (T));
      Set_Is_Controlled  (Id, Is_Controlled (T));

      if Has_Controlled (Id) then
         Note_Feature (Controlled_Types, Sloc (Id));
      end if;

      --  Now that the subtype is fully decorated we can create a
      --  completion if needed

   end Analyze_Subtype_Declaration;

   ----------------------
   -- Constrain_Float --
   ----------------------

   procedure Constrain_Float
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T    : constant Node_Id := Entity (Subtype_Mark (S));
      C    : Node_Id;
      D    : Node_Id;
      Rais : Node_Id;

   begin
      Set_Ekind            (Def_Id, E_Floating_Point_Subtype);
      Set_Etype            (Def_Id, Base_Type (T));
      Set_Esize            (Def_Id, Esize (T));
      Set_Alignment_Clause (Def_Id, Alignment_Clause (T));

      --  Process the constraint

      C := Constraint (S);

      --  Digits constraint present

      if Nkind (C) = N_Digits_Constraint then
         D := Digits_Expression (C);
         Analyze (D);
         Resolve (D, Any_Integer);
         Check_Digits_Expression (D);
         Set_Digits_Value (Def_Id, Expr_Value (D));

         --  Check that digits value is in range. Obviously we can do this
         --  at compile time, but it is strictly a runtime check, and of
         --  course there is an ACVC test that checks this!

         if Digits_Value (Def_Id) > Digits_Value (T) then
            Error_Msg_Uint_1 := Digits_Value (T);
            Error_Msg_N ("?digits value is too large, max here = ^", D);

            Rais :=
              Make_Raise_Statement (Sloc (D),
                Name =>
                  New_Reference_To (Standard_Constraint_Error, Sloc (D)));

            Insert_Before (Declaration_Node (Def_Id), Rais);
            Analyze (Rais);
         end if;

         C := Range_Constraint (C);

      --  No digits constraint present

      else
         Set_Digits_Value (Def_Id, Digits_Value (T));
      end if;

      --  Range constraint present

      if Nkind (C) = N_Range_Constraint then
         Set_Scalar_Range_For_Subtype
           (Def_Id, Range_Expression (C), T, Related_Nod);

      --  No range constraint present

      else
         pragma Assert (No (C));
         Set_Scalar_Range (Def_Id, Scalar_Range (T));

      end if;

   end Constrain_Float;

   -----------------------
   -- Constrain_Decimal --
   -----------------------

   procedure Constrain_Decimal
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T           : constant Entity_Id  := Entity (Subtype_Mark (S));
      C           : constant Node_Id    := Constraint (S);
      Loc         : constant Source_Ptr := Sloc (C);
      R           : Node_Id;
      Digits_Expr : Node_Id;
      Digits_Val  : Uint;
      Bound_Val   : Ureal;

   begin
      Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);

      Analyze (Digits_Expr);
      Resolve (Digits_Expr, Any_Integer);

      R := Range_Constraint (R);
      Digits_Expr := Digits_Expression (C);

      Check_Digits_Expression (Digits_Expr);
      Digits_Val := Expr_Value (Digits_Expr);

      if Digits_Val > Digits_Value (T) then
         Error_Msg_N ("digits expression is incompatible with subtype", C);
      end if;

      Set_Etype            (Def_Id, Base_Type        (T));
      Set_Esize            (Def_Id, Esize            (T));
      Set_Alignment_Clause (Def_Id, Alignment_Clause (T));
      Set_Delta_Value      (Def_Id, Delta_Value      (T));
      Set_Scale_Value      (Def_Id, Scale_Value      (T));
      Set_Small_Value      (Def_Id, Small_Value      (T));
      Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
      Set_Digits_Value     (Def_Id, Digits_Val);

      --  Manufacture range from given digits value if no range present

      if No (R) then
         Bound_Val := Ureal_10 ** (Digits_Val - 1);
         R :=
            Make_Range (Loc,
               Low_Bound =>
                 Make_Type_Conversion (Loc,
                    Subtype_Mark => New_Reference_To (T, Loc),
                    Expression =>
                      Make_Real_Literal (Loc, (-Bound_Val))),

               High_Bound =>
                 Make_Type_Conversion (Loc,
                    Subtype_Mark => New_Reference_To (T, Loc),
                    Expression => Make_Real_Literal (Loc, Bound_Val)));

      end if;

      Set_Scalar_Range_For_Subtype (Def_Id, R, T, Related_Nod);

   end Constrain_Decimal;

   ------------------------------
   -- Constrain_Ordinary_Fixed --
   ------------------------------

   procedure Constrain_Ordinary_Fixed
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T    : constant Node_Id := Entity (Subtype_Mark (S));
      C    : Node_Id;
      D    : Node_Id;
      Rais : Node_Id;

   begin
      Set_Ekind            (Def_Id, E_Ordinary_Fixed_Point_Subtype);
      Set_Etype            (Def_Id, Base_Type (T));
      Set_Esize            (Def_Id, Esize (T));
      Set_Alignment_Clause (Def_Id, Alignment_Clause (T));
      Set_Small_Value      (Def_Id, Small_Value      (T));

      --  Process the constraint

      C := Constraint (S);

      --  Delta constraint present

      if Nkind (C) = N_Delta_Constraint then
         D := Delta_Expression (C);
         Analyze (D);
         Resolve (D, Any_Real);
         Check_Delta_Expression (D);
         Set_Delta_Value (Def_Id, Expr_Value_R (D));

         --  Check that delta value is in range. Obviously we can do this
         --  at compile time, but it is strictly a runtime check, and of
         --  course there is an ACVC test that checks this!

         if Delta_Value (Def_Id) < Delta_Value (T) then
            Error_Msg_N ("?delta value is too small", D);

            Rais :=
              Make_Raise_Statement (Sloc (D),
                Name =>
                  New_Reference_To (Standard_Constraint_Error, Sloc (D)));

            Insert_Before (Declaration_Node (Def_Id), Rais);
            Analyze (Rais);
         end if;

         C := Range_Constraint (C);

      --  No delta constraint present

      else
         Set_Delta_Value (Def_Id, Delta_Value (T));
      end if;

      --  Range constraint present

      if Nkind (C) = N_Range_Constraint then
         Set_Scalar_Range_For_Subtype
           (Def_Id, Range_Expression (C), T, Related_Nod);

      --  No range constraint present

      else
         pragma Assert (No (C));
         Set_Scalar_Range (Def_Id, Scalar_Range (T));

      end if;

   end Constrain_Ordinary_Fixed;

   ---------------------------
   -- Constrain_Enumeration --
   ---------------------------

   procedure Constrain_Enumeration
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T : constant Entity_Id := Entity (Subtype_Mark (S));
      C : constant Node_Id   := Constraint (S);

   begin
      Set_Ekind (Def_Id, E_Enumeration_Subtype);

      Set_First_Literal     (Def_Id, First_Literal (Base_Type (T)));
      Set_Etype             (Def_Id, Base_Type (T));
      Set_Lit_Name_Table    (Def_Id, Lit_Name_Table (T));
      Set_Esize             (Def_Id, Esize (T));
      Set_Alignment_Clause  (Def_Id, Alignment_Clause (T));
      Set_Is_Character_Type (Def_Id, Is_Character_Type (T));

      Set_Scalar_Range_For_Subtype
        (Def_Id, Range_Expression (C), T, Related_Nod);

   end Constrain_Enumeration;

   -----------------------
   -- Constrain_Integer --
   -----------------------

   procedure Constrain_Integer
     (Def_Id      : Node_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T : constant Node_Id := Entity (Subtype_Mark (S));
      C : constant Node_Id := Constraint (S);

   begin
      if Is_Modular_Integer_Type (T) then
         Set_Ekind         (Def_Id, E_Modular_Integer_Subtype);
         Set_Modulus       (Def_Id, Modulus (T));
      else
         Set_Ekind         (Def_Id, E_Signed_Integer_Subtype);
      end if;

      Set_Etype            (Def_Id, Base_Type (T));
      Set_Esize            (Def_Id, Esize (T));
      Set_Alignment_Clause (Def_Id, Alignment_Clause (T));

      Set_Scalar_Range_For_Subtype
        (Def_Id, Range_Expression (C), T, Related_Nod);

   end Constrain_Integer;

   -------------------------------------
   -- Floating_Point_Type_Declaration --
   -------------------------------------

   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
      Digs          : constant Node_Id := Digits_Expression (Def);
      Digs_Val      : Uint;
      Base_Type     : Entity_Id;
      Implicit_Base : Entity_Id;

      function Can_Derive_From (E : Entity_Id) return Boolean;
      --  Find if given digits value allows derivation from specified type

      function Can_Derive_From (E : Entity_Id) return Boolean is
         Spec : constant Entity_Id := Real_Range_Specification (Def);

      begin
         if Digs_Val > Digits_Value (E) then
            return False;
         end if;

         if Present (Spec) then
            if Expr_Value_R (Type_Low_Bound (E)) >
               Expr_Value_R (Low_Bound (Spec))
            then
               return False;
            end if;

            if Expr_Value_R (Type_High_Bound (E)) <
               Expr_Value_R (High_Bound (Spec))
            then
               return False;
            end if;
         end if;

         return True;
      end Can_Derive_From;

   --  Start of processing for Floating_Point_Type_Declaration

   begin
      --  Create an implicit base type

      Implicit_Base :=
        New_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');

      --  Analyze and verify digits value

      Analyze (Digs);
      Resolve (Digs, Any_Integer);
      Check_Digits_Expression (Digs);
      Digs_Val := Expr_Value (Digs);

      --  Process possible range spec and find correct type to derive from

      Process_Real_Range_Specification (Def);

      if Can_Derive_From (Standard_Short_Float) then
         Base_Type := Standard_Short_Float;
      elsif Can_Derive_From (Standard_Float) then
         Base_Type := Standard_Float;
      elsif Can_Derive_From (Standard_Long_Float) then
         Base_Type := Standard_Long_Float;
      elsif Can_Derive_From (Standard_Long_Long_Float) then
         Base_Type := Standard_Long_Long_Float;

      --  If we can't derive from any existing type, use long long float
      --  and give appropriate message explaining the problem.

      else
         Base_Type := Standard_Long_Long_Float;

         if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
            Error_Msg_N ("digits value out of range", Digs);
         else
            Error_Msg_N
              ("range too large for any predefined type",
               Real_Range_Specification (Def));
         end if;
      end if;

      --  If there are bounds given in the declaration use them as the bounds
      --  of the type, otherwise use the bounds of the predefined base type
      --  that was chosen based on the Digits value.

      if Present (Real_Range_Specification (Def)) then
         Set_Scalar_Range (T, Real_Range_Specification (Def));
      else
         Set_Scalar_Range (T, Scalar_Range (Base_Type));
      end if;

      --  Complete definition of implicit base and declared first subtype

      Set_Scalar_Range     (Implicit_Base, Scalar_Range (Base_Type));
      Set_Etype            (Implicit_Base, Base_Type);
      Set_Esize            (Implicit_Base, Esize (Base_Type));
      Set_Alignment_Clause (Implicit_Base, Alignment_Clause (Base_Type));
      Set_Digits_Value     (Implicit_Base, Digs_Val);

      Set_Ekind            (T, E_Floating_Point_Subtype);
      Set_Etype            (T, Implicit_Base);
      Set_Esize            (T, Esize (Implicit_Base));
      Set_Alignment_Clause (T, Alignment_Clause (Implicit_Base));
      Set_Digits_Value     (T, Digs_Val);

   end Floating_Point_Type_Declaration;

   -------------------------------------------
   -- Ordinary_Fixed_Point_Type_Declaration --
   -------------------------------------------

   procedure Ordinary_Fixed_Point_Type_Declaration
     (T   : Entity_Id;
      Def : Node_Id)
   is
      Loc           : constant Source_Ptr := Sloc (Def);
      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
      RRS           : constant Node_Id    := Real_Range_Specification (Def);
      Implicit_Base : Entity_Id;
      Delta_Val     : Ureal;
      Small_Val     : Ureal;

   begin
      --  Create implicit base type

      Implicit_Base :=
        New_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
      Set_Etype (Implicit_Base, Implicit_Base);

      --  Analyze and process delta expression

      Analyze (Delta_Expr);
      Resolve (Delta_Expr, Any_Real);

      Check_Delta_Expression (Delta_Expr);
      Delta_Val := Expr_Value_R (Delta_Expr);

      if Delta_Val < Ureal_Fine_Delta then
         Error_Msg_N ("delta value must be greater than Fine_Delta", Def);
         Delta_Val := Ureal_Fine_Delta;
      end if;

      Set_Delta_Value (Implicit_Base, Delta_Val);

      --  Compute default small from given delta, which is the largest
      --  power of 2 that does not exceed the given delta value.

      declare
         Tmp   : Ureal := Ureal_1;
         Scale : Int   := 0;

      begin
         if Delta_Val < Ureal_1 then
            while Delta_Val < Tmp loop
               Tmp := Tmp / Ureal_2;
               Scale := Scale + 1;
            end loop;

         else
            loop
               Tmp := Tmp * Ureal_2;
               exit when Tmp > Delta_Val;
               Scale := Scale - 1;
            end loop;
         end if;

         Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
      end;

      Set_Small_Value (Implicit_Base, Small_Val);

      --  Analyze and process given range

      declare
         Low      : constant Node_Id := Low_Bound  (RRS);
         High     : constant Node_Id := High_Bound (RRS);
         Low_Val  : Ureal;
         High_Val : Ureal;
         Maxr     : Ureal;

      begin
         Analyze (Low);
         Analyze (High);
         Resolve (Low, Any_Real);
         Resolve (High, Any_Real);
         Check_Real_Bound (Low);
         Check_Real_Bound (High);

         --  Obtain the range, fudging the deltas as allowed to make sure we
         --  do not use too many bits (when the type is frozen, we will try
         --  to unfudge these values if it does not increase the size).

         Low_Val  := Expr_Value_R (Low)  + Small_Value (Implicit_Base);
         High_Val := Expr_Value_R (High) - Small_Value (Implicit_Base);
         Maxr     := UR_Max (abs Low_Val, abs High_Val);

         --  The base range is expressed using universal real literals. When
         --  the type is frozen, the Corresponding_Integer_Value will be set.

         Set_Scalar_Range (Implicit_Base,
           Make_Range (Loc,
             Low_Bound  => Make_Real_Literal (Loc, (-Maxr)),
             High_Bound => Make_Real_Literal (Loc, Maxr)));

         --  Also set scalar range of the first subtype

         Set_Scalar_Range (T,
           Make_Range (Loc,
             Low_Bound  => Make_Real_Literal (Loc, Low_Val),
             High_Bound => Make_Real_Literal (Loc, High_Val)));
      end;

      --  Find default size

      declare
         Min_Size : constant Nat := Minimum_Size (Implicit_Base);

      begin
         if Min_Size <= 8 then
            Set_Esize (Implicit_Base, Uint_8);

         elsif Min_Size <= 16 then
            Set_Esize (Implicit_Base, Uint_16);

         elsif Min_Size <= 32 then
            Set_Esize (Implicit_Base, Uint_32);

         elsif Min_Size <= 64 then
            Set_Esize (Implicit_Base, Uint_64);

            --  Output warning if more than 53 bits, and we only have 64-bit
            --  floating-point available, because that means that Fixed_IO
            --  will not be fully accurate.

            if Esize (Standard_Long_Long_Float) = 64
              and then Min_Size > 53
            then
               Error_Msg_N ("Fixed_IO may lose precision on this type?", Def);
            end if;

         --  Here we are out of range, so settle for 64 bits with error message

         else
            Set_Esize (Implicit_Base, Uint_64);
            Error_Msg_N ("fixed-point definition requires too many bits", Def);
         end if;
      end;

      --  Complete definition of first subtype

      Set_Ekind            (T, E_Ordinary_Fixed_Point_Subtype);
      Set_Etype            (T, Implicit_Base);
      Set_Esize            (T, Esize (Implicit_Base));
      Set_Alignment_Clause (T, Alignment_Clause (Implicit_Base));
      Set_Small_Value      (T, Small_Val);
      Set_Delta_Value      (T, Delta_Val);

   end Ordinary_Fixed_Point_Type_Declaration;

   ------------------------------------------
   -- Decimal_Fixed_Point_Type_Declaration --
   ------------------------------------------

   procedure Decimal_Fixed_Point_Type_Declaration
     (T : Entity_Id;
      Def : Node_Id)
   is
      Loc           : constant Source_Ptr := Sloc (Def);
      Digs_Expr     : constant Node_Id    := Digits_Expression (Def);
      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
      Implicit_Base : Entity_Id;
      Digs_Val      : Uint;
      Delta_Val     : Ureal;
      Scale_Val     : Uint;
      Bound_Val     : Ureal;

   --  Start of processing for Decimal_Fixed_Point_Type_Declaration

   begin
      --  Create implicit base type

      Implicit_Base :=
        New_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
      Set_Etype (Implicit_Base, Implicit_Base);

      --  Analyze and process delta expression

      Analyze (Delta_Expr);
      Resolve (Delta_Expr, Universal_Real);

      Check_Delta_Expression (Delta_Expr);
      Delta_Val := Expr_Value_R (Delta_Expr);

      --  Determine scale value from delta value and check delta is power of 10

      declare
         Val : Ureal := Delta_Val;

      begin
         Scale_Val := Uint_0;

         if Val < Ureal_1 then
            while Val < Ureal_1 loop
               Val := Val * Ureal_10;
               Scale_Val := Scale_Val + 1;
            end loop;

            if Scale_Val > 18 then
               Error_Msg_N ("scale exceeds maximum value of 18", Def);
               Scale_Val := UI_From_Int (+18);
            end if;

         else
            while Val > Ureal_1 loop
               Val := Val / Ureal_10;
               Scale_Val := Scale_Val - 1;
            end loop;

            if Scale_Val > 18 then
               Error_Msg_N ("scale is less than minimum value of -18", Def);
               Scale_Val := UI_From_Int (-18);
            end if;
         end if;

         if Val /= Ureal_1 then
            Error_Msg_N ("delta expression must be a power of 10", Def);
            Delta_Val := Ureal_10 ** (-Scale_Val);
         end if;
      end;

      --  Set delta, scale and small (small = delta for decimal type)

      Set_Delta_Value  (Implicit_Base, Delta_Val);
      Set_Scale_Value  (Implicit_Base, Scale_Val);
      Set_Small_Value  (Implicit_Base, Delta_Val);

      --  Analyze and process digits expression

      Analyze (Digs_Expr);
      Resolve (Digs_Expr, Any_Integer);
      Check_Digits_Expression (Digs_Expr);
      Digs_Val := Expr_Value (Digs_Expr);

      if Digs_Val > 18 then
         Digs_Val := UI_From_Int (+18);
         Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
      end if;

      Set_Digits_Value (Implicit_Base, Digs_Val);

      --  The base range is expressed using universal real literals. When
      --  the type is frozen, the Corresponding_Integer_Value will be set.

      Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;

      Set_Scalar_Range (Implicit_Base,
        Make_Range (Loc,
          Low_Bound  => Make_Real_Literal (Loc, -Bound_Val),
          High_Bound => Make_Real_Literal (Loc, Bound_Val)));

      --  Find and set appropriate size

      declare
         Min_Size : constant Nat := Minimum_Size (Implicit_Base);

      begin
         if Min_Size <= 8 then
            Set_Esize (Implicit_Base, Uint_8);

         elsif Min_Size <= 16 then
            Set_Esize (Implicit_Base, Uint_16);

         elsif Min_Size <= 32 then
            Set_Esize (Implicit_Base, Uint_32);

         else
            pragma Assert (Min_Size <= 64);
            Set_Esize (Implicit_Base, Uint_64);
         end if;
      end;

      --  Complete entity for first subtype

      Set_Ekind            (T, E_Decimal_Fixed_Point_Subtype);
      Set_Etype            (T, Implicit_Base);
      Set_Esize            (T, Esize (Implicit_Base));
      Set_Alignment_Clause (T, Alignment_Clause (Implicit_Base));
      Set_Digits_Value     (T, Digs_Val);
      Set_Delta_Value      (T, Delta_Val);
      Set_Small_Value      (T, Delta_Val);
      Set_Scale_Value      (T, Scale_Val);

      --  If there are bounds given in the declaration use them as the
      --  bounds of the first named subtype.

      if Present (Real_Range_Specification (Def)) then
         declare
            RRS      : constant Node_Id := Real_Range_Specification (Def);
            Low      : constant Node_Id := Low_Bound (RRS);
            High     : constant Node_Id := High_Bound (RRS);
            Low_Val  : Ureal;
            High_Val : Ureal;

         begin
            Analyze (Low);
            Analyze (High);
            Resolve (Low, Universal_Real);
            Resolve (High, Universal_Real);
            Check_Real_Bound (Low);
            Check_Real_Bound (High);

            Low_Val  := UR_Max (Expr_Value_R (Low), -Bound_Val);
            High_Val := UR_Min (Expr_Value_R (High), Bound_Val);

            --  The bounds are constructed with universal reals, to be set
            --  to the proper values with Corresponding_Integer_Value set
            --  when the subtype is frozen.

            Set_Scalar_Range (T,
              Make_Range (Loc,
                Low_Bound  => Make_Real_Literal (Loc, Low_Val),
                High_Bound => Make_Real_Literal (Loc, High_Val)));
         end;

      --  If no explicit range, use base range

      else
         Set_Scalar_Range (T, Scalar_Range (Implicit_Base));
      end if;

   end Decimal_Fixed_Point_Type_Declaration;

   -------------------------------------
   -- Signed_Integer_Type_Declaration --
   -------------------------------------

   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
      Implicit_Base : Entity_Id;
      Base_Type     : Entity_Id;
      Lo_Val        : Uint;
      Hi_Val        : Uint;
      Errs          : Boolean := False;
      Lo            : Node_Id;
      Hi            : Node_Id;

      function Can_Derive_From (E : Entity_Id) return Boolean;
      --  Determine whether given bounds allow derivation from specified type

      procedure Check_Bound (Expr : Node_Id);
      --  Check bound to make sure it is integral and static. If not, post
      --  appropriate error message and set Errs flag

      function Can_Derive_From (E : Entity_Id) return Boolean is
      begin
         return Lo_Val >= Expr_Value (Type_Low_Bound (E))
           and then Hi_Val <= Expr_Value (Type_High_Bound (E));
      end Can_Derive_From;

      procedure Check_Bound (Expr : Node_Id) is
      begin
         --  If a range constraint is used as an integer type definition, each
         --  bound of the range must be defined by a static expression of some
         --  integer type, but the two bounds need not have the same integer
         --  type (Negative bounds are allowed.) (RM 3.5.4)

         if not Is_Integer_Type (Etype (Expr)) then
            Error_Msg_N
              ("integer type definition bounds must be of integer type", Expr);
            Errs := True;

         elsif not Is_OK_Static_Expression (Expr) then
            Error_Msg_N
              ("non-static expression used for integer type bound", Expr);
            Errs := True;
         end if;
      end Check_Bound;

   --  Start of processing for Signed_Integer_Type_Declaration

   begin
      --  Create an anonymous base type

      Implicit_Base :=
        New_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');

      --  Analyze and check the bounds, they can be of any integer type

      Lo := Low_Bound (Def);
      Hi := High_Bound (Def);
      Analyze (Lo);
      Analyze (Hi);
      Resolve (Lo, Any_Integer);
      Resolve (Hi, Any_Integer);

      Check_Bound (Lo);
      Check_Bound (Hi);

      if Errs then
         Hi := Type_High_Bound (Standard_Long_Long_Integer);
         Lo := Type_Low_Bound (Standard_Long_Long_Integer);
      end if;

      --  Find type to derive from

      Lo_Val := Expr_Value (Lo);
      Hi_Val := Expr_Value (Hi);

      if Can_Derive_From (Standard_Short_Short_Integer) then
         Base_Type := Standard_Short_Short_Integer;
      elsif Can_Derive_From (Standard_Short_Integer) then
         Base_Type := Standard_Short_Integer;
      elsif Can_Derive_From (Standard_Integer) then
         Base_Type := Standard_Integer;
      elsif Can_Derive_From (Standard_Long_Integer) then
         Base_Type := Standard_Long_Integer;
      elsif Can_Derive_From (Standard_Long_Long_Integer) then
         Base_Type := Standard_Long_Long_Integer;
      else
         Base_Type := Standard_Long_Long_Integer;
         Error_Msg_N ("integer type definition bounds out of range", Def);
         Hi := Type_High_Bound (Standard_Long_Long_Integer);
         Lo := Type_Low_Bound (Standard_Long_Long_Integer);
      end if;

      --  Complete both implicit base and declared first subtype entities

      Set_Scalar_Range     (Implicit_Base, Scalar_Range (Base_Type));
      Set_Etype            (Implicit_Base, Base_Type);
      Set_Esize            (Implicit_Base, Esize (Base_Type));
      Set_Alignment_Clause (Implicit_Base, Alignment_Clause (Base_Type));

      Set_Ekind            (T, E_Signed_Integer_Subtype);
      Set_Etype            (T, Implicit_Base);
      Set_Esize            (T, Esize (Implicit_Base));
      Set_Alignment_Clause (T, Alignment_Clause (Implicit_Base));
      Set_Scalar_Range     (T, Def);
   end Signed_Integer_Type_Declaration;

   ------------------------------
   -- Modular_Type_Declaration --
   ------------------------------

   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
      Mod_Expr : constant Node_Id := Expression (Def);
      M_Val    : Uint;

   begin
      Set_Etype (T, T);
      Set_Ekind (T, E_Modular_Integer_Type);
      Analyze (Mod_Expr);
      Resolve (Mod_Expr, Any_Integer);

      if not Is_OK_Static_Expression (Mod_Expr) then
         Error_Msg_N
           ("non-static expression used for modular type bound", Mod_Expr);
         M_Val := 2 ** System_Max_Binary_Modulus_Power;
      else
         M_Val := Expr_Value (Mod_Expr);
      end if;

      if M_Val <= 1 then
         Error_Msg_N ("modulus value must be greater than 1", Mod_Expr);
         M_Val := 2 ** System_Max_Binary_Modulus_Power;
      end if;

      Set_Modulus (T, M_Val);

      --   Create bounds for the modular type based on the modulus given in
      --   the type declaration and then analyze and resolve those bounds.

      Set_Scalar_Range (T,
        Make_Range (Sloc (Mod_Expr),
          Low_Bound  =>
            Make_Integer_Literal (Sloc (Mod_Expr),
              Intval => Uint_0),
          High_Bound =>
            Make_Integer_Literal (Sloc (Mod_Expr),
              Intval => M_Val - 1)));

      Analyze (Low_Bound  (Scalar_Range (T)));
      Analyze (High_Bound (Scalar_Range (T)));
      Resolve (Low_Bound  (Scalar_Range (T)), T);
      Resolve (High_Bound (Scalar_Range (T)), T);

      --  Loop through powers of 2 to find number of bits required

      for Bits in Int range 1 .. System_Max_Binary_Modulus_Power loop

         --  Binary case

         if M_Val = 2 ** Bits then
            Set_Esize (T, UI_From_Int (Bits));
            return;

         --  Non-binary case

         elsif M_Val < 2 ** Bits then
            Set_Non_Binary_Modulus (T);

            if Bits > System_Max_Nonbinary_Modulus_Power then
               Error_Msg_Uint_1 :=
                 UI_From_Int (System_Max_Nonbinary_Modulus_Power);
               Error_Msg_N
                 ("nonbinary modulus exceeds limit (2'*'*^ - 1)", Mod_Expr);
               Set_Esize (T, UI_From_Int (System_Max_Binary_Modulus_Power));
               return;

            else
               --  In the non-binary case, we must have the actual size
               --  of the object be at least enough to hold the square
               --  of the modulus.
               --  This makes zero sense to me (RBKD) ???

               Set_Esize (T, UI_From_Int (Bits * 2));
               return;
            end if;
         end if;

      end loop;

      --  If we fall through, then the size exceed System.Max_Binary_Modulus
      --  so we just signal an error and set the maximum size.

      Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
      Error_Msg_N ("modulus exceeds limit (2'*'*^)", Mod_Expr);
      Set_Esize (T, UI_From_Int (System_Max_Binary_Modulus_Power));

   end Modular_Type_Declaration;

   ----------------------------------
   -- Enumeration_Type_Declaration --
   ----------------------------------

   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
      Ev             : Uint;
      L              : Node_Id;
      Int_Lit        : Node_Id;
      R_Node, B_Node : Node_Id;
      Table_Obj      : Entity_Id;
      Table_Type     : Entity_Id;

   begin
      --  Create identifier node representing lower bound

      B_Node := New_Node (N_Identifier, Sloc (Def));
      L := First (Literals (Def));
      Set_Chars (B_Node, Chars (L));
      Set_Entity (B_Node,  L);
      Set_Etype (B_Node, T);
      Set_Is_Static_Expression (B_Node, True);

      R_Node := New_Node (N_Range, Sloc (Def));
      Set_Low_Bound  (R_Node, B_Node);

      Set_Ekind (T, E_Enumeration_Type);
      Set_First_Literal (T, L);
      Set_Etype (T, T);

      Ev := Uint_0;

      --  Loop through literals of enumeration type setting pos and rep values

      while Present (L) loop
         Set_Ekind (L, E_Enumeration_Literal);
         Set_Etype (L, T);
         Set_Enumeration_Pos (L, Ev);
         Set_Enumeration_Rep (L, Ev);
         New_Overloaded_Entity (L);

         if Nkind (L) = N_Defining_Character_Literal then
            Set_Is_Character_Type (T, True);
         end if;

         Ev := Ev + 1;
         L := Next (L);
      end loop;

      --  Now create a node representing upper bound

      B_Node := New_Node (N_Identifier, Sloc (Def));
      Set_Chars (B_Node, Chars (Last (Literals (Def))));
      Set_Entity (B_Node,  Last (Literals (Def)));
      Set_Etype (B_Node, T);
      Set_Is_Static_Expression (B_Node, True);

      Set_High_Bound (R_Node, B_Node);
      Set_Scalar_Range (T, R_Node);
      Determine_Enum_Representation (T);

      --  Create two defining occurrences corresponding to a enumeration
      --  table containing the literal names and its type. This table is
      --  used in conjunction with calls to 'Image on enumeration values.
      --  This table is filled in by the back-end.

      Table_Obj :=
        Make_Defining_Identifier (Sloc (Def),
          Chars => New_External_Name (Chars (T), 'T'));

      Set_Is_Internal (Table_Obj);
      Append_Entity (Table_Obj, Current_Scope);
      Set_Current_Entity (Table_Obj);

      Table_Type := New_Itype (E_Enum_Table_Type, Parent (Def), T, 'T');
      Set_Has_Delayed_Freeze (Table_Type);

      Set_Etype         (Table_Obj, Table_Type);
      Set_Ekind         (Table_Obj, E_Variable);
      Set_Public_Status (Table_Obj);

      Set_Etype          (Table_Type, Table_Type);
      Set_Public_Status  (Table_Type);
      Set_Component_Type (Table_Type, Standard_A_String);
      Set_First_Index    (Table_Type,
        First (New_List (
          New_Occurrence_Of (Standard_Natural, Sloc (Def)))));

      Int_Lit := New_Node (N_Integer_Literal, Sloc (Def));
      Set_Intval (Int_Lit, Enumeration_Pos (Entity (Type_High_Bound (T))));
      Set_Etype  (Int_Lit, Standard_Integer);
      Set_Is_Static_Expression (Int_Lit, True);

      Set_Table_High_Bound (Table_Type, Int_Lit);
      Set_Lit_Name_Table (T, Table_Obj);
   end Enumeration_Type_Declaration;

   -----------------------------------
   -- Determine_Enum_Representation --
   -----------------------------------

   procedure Determine_Enum_Representation  (T : Entity_Id) is
      Lo : Uint;
      Hi : Uint;
      Sz : Nat;

   begin
      Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
      Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));

      if Lo < 0 then
         if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
            Sz := 8;

         elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
            Sz := 16;

         elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
            Sz := 32;

         elsif Lo >= -Uint_2**63 and then Hi < Uint_2**63 then
            Sz := 64;

         else
            pragma Assert (False); null;
         end if;

      else
         if Hi <= Uint_2**08 then
            Sz := 8;

         elsif Hi <= Uint_2**16 then
            Sz := 16;

         elsif Hi <= Uint_2**32 then
            Sz := 32;

         elsif Hi < Uint_2**63 then
            Sz := 64;

         else
            pragma Assert (False); null;
         end if;
      end if;

      Set_Esize (T, UI_From_Int (Sz));
   end Determine_Enum_Representation;

   ----------------------------
   -- Array_Type_Declaration --
   ----------------------------

   procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
      Component_Def : constant Node_Id := Subtype_Indication (Def);
      Element_Type  : Entity_Id;
      Implicit_Base : Entity_Id;
      Index         : Node_Id;
      Related_Id    : Entity_Id := Empty;
      Nb_Index      : Nat;
      P             : constant Node_Id := Parent (Def);
      Priv          : Entity_Id;

   begin
      if Nkind (Def) = N_Constrained_Array_Definition then

         Index := First (Discrete_Subtype_Definitions (Def));

         --  Find proper names for the implicit types which may be public.
         --  in case of anonymous arrays we use the name of the first object
         --  of that type as prefix.

         if No (T) then
            Related_Id :=  Defining_Identifier (P);
         else
            Related_Id := T;
         end if;

      else
         Index := First (Subtype_Marks (Def));
      end if;

      Nb_Index := 1;

      while Present (Index) loop
         Analyze (Index);
         Make_Index (Index, P, Related_Id, Nb_Index);
         Index := Next_Index (Index);
         Nb_Index := Nb_Index + 1;
      end loop;

      Element_Type := Process_Subtype (Component_Def, P, Related_Id, 'C');

      --  Constrained array case

      if No (T) then
         T := New_Itype (E_Void, P, Related_Id, 'T');
      end if;

      if Nkind (Def) = N_Constrained_Array_Definition then

         --  Establish Implicit_Base as unconstrained base type

         Implicit_Base := New_Itype (E_Array_Type, P, Related_Id, 'B');

         Set_Esize (Implicit_Base, Uint_0);
         Set_Etype (Implicit_Base, Implicit_Base);
         Set_Scope (Implicit_Base, Current_Scope);
         Set_Has_Delayed_Freeze (Implicit_Base);

         --  The constrained array type is a subtype of the unconstrained one

         Set_Ekind (T, E_Array_Subtype);
         Set_Esize (T, Uint_0);
         Set_Etype (T, Implicit_Base);
         Set_Scope (T, Current_Scope);
         Set_Is_Constrained (T, True);
         Set_First_Index    (T, First (Discrete_Subtype_Definitions (Def)));
         Set_Has_Delayed_Freeze (T);

         --  Complete setup of implicit base type

         Set_First_Index    (Implicit_Base, First_Index (T));
         Set_Component_Type (Implicit_Base, Element_Type);
         Set_Has_Tasks      (Implicit_Base, Has_Tasks (Element_Type));
         Set_Has_Controlled (Implicit_Base,
           Has_Controlled (Element_Type) or else Is_Controlled (Element_Type));

      --  Unconstrained array case

      else
         Set_Ekind (T, E_Array_Type);
         Set_Esize (T, Uint_0);
         Set_Etype (T, T);
         Set_Scope (T, Current_Scope);

         Set_Is_Constrained     (T, False);
         Set_First_Index        (T, First (Subtype_Marks (Def)));
         Set_Has_Delayed_Freeze (T, True);
      end if;

      Set_Component_Type (T, Element_Type);
      Set_Has_Tasks      (T, Has_Tasks (Element_Type));
      Set_Has_Controlled (T,
        Has_Controlled (Element_Type) or else Is_Controlled (Element_Type));

      if Aliased_Present (Def) then
         Set_Is_Aliased (T);
         Set_Is_Aliased (Etype (T));
      end if;

      Priv := Private_Ancestor (Element_Type);

      if Present (Priv) then
         Append_Elmt (T, Private_Dependents (Priv));
      end if;

      if Number_Dimensions (T) = 1 then
         New_Binary_Operator (Name_Op_Concat, T);
      end if;

      --  In the case of an unconstrained array the parser has already
      --  verified that all the indices are unconstrained but we still
      --  need to make sure that the element type is constrained.

      if Is_Indefinite_Subtype (Element_Type) then
         Error_Msg_N
           ("unconstrained element type in array declaration ",
            Component_Def);

      elsif Is_Abstract (Element_Type) then
         Error_Msg_N ("The type of a component cannot be abstract ",
              Component_Def);
      end if;

   end Array_Type_Declaration;

   ----------------
   -- Make_Index --
   ----------------

   procedure Make_Index
     (I            : Node_Id;
      Related_Nod  : Node_Id;
      Related_Id   : Entity_Id := Empty;
      Suffix_Index : Nat := 1)
   is
      R      : Node_Id;
      T      : Entity_Id;
      Def_Id : Entity_Id;

   begin
      --  For a discrete range used in a constrained array definition and
      --  defined by a range, an implicit conversion to the predefined type
      --  INTEGER is assumed if each bound is either a numeric literal, a named
      --  number, or an attribute, and the type of both bounds (prior to the
      --  implicit conversion) is the type universal_integer. Otherwise, both
      --  bounds must be of the same discrete type, other than universal
      --  integer; this type must be determinable independently of the
      --  context, but using the fact that the type must be discrete and that
      --  both bounds must have the same type.

      --  Character literals also have a universal type in the absence of
      --  of additional context,  and are resolved to Standard_Character.

      if Nkind (I) = N_Range then

         --  The index is given by a range constraint. The bounds are known
         --  to be of a consistent type.

         if not Is_Overloaded (I) then
            T := Etype (I);

            --  If the bounds are universal, choose the specific predefined
            --  type.

            if T = Universal_Integer then
               T := Standard_Integer;
            elsif T = Any_Character then
               T := Standard_Character;
            end if;

         else
            T := Any_Type;

            declare
               Ind : Interp_Index;
               It  : Interp;

            begin
               Get_First_Interp (I, Ind, It);

               while Present (It.Typ) loop
                  if Is_Discrete_Type (It.Typ) then
                     T := It.Typ;
                     exit;
                  end if;

                  Get_Next_Interp (Ind, It);
               end loop;

               if T = Any_Type then
                  Error_Msg_N ("discrete type required for range", I);
                  Set_Etype (I, Any_Type);
                  return;
               end if;
            end;
         end if;

         R := I;
         Process_Range_Expr_In_Decl (R, T, Related_Nod);

      elsif Nkind (I) = N_Subtype_Indication then

         --  The index is given by a subtype with a range constraint.

         T :=  Base_Type (Entity (Subtype_Mark (I)));
         R := Range_Expression (Constraint (I));
         Resolve (R, T);
         Process_Range_Expr_In_Decl (R,
           Entity (Subtype_Mark (I)), Related_Nod);

      elsif Nkind (I) = N_Attribute_Reference then

         --  The parser guarantees that the attribute is a RANGE attribute

         Analyze (I);
         T := Etype (I);
         Resolve (I, T);
         R := I;

      --  If none of the above, must be a subtype. We convert this to a
      --  range attribute reference because in the case of declared first
      --  named subtypes, the types in the range reference can be different
      --  from the type of the entity. A range attribute normalizes the
      --  reference and obtains the correct types for the bounds.
      --  This transformation is in the nature of an expansion, is only
      --  done if expansion is active. In particular, it is not done on
      --  formal generic types,  because we need to retain the name of the
      --  original index for instantiation purposes.

      else
         if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
            Error_Msg_N ("invalid subtype mark in discrete range ", I);
            Set_Etype (I, Any_Integer);
            return;

         elsif Expander_Active then
            Rewrite_Substitute_Tree (I,
              Make_Attribute_Reference (Sloc (I),
                Attribute_Name => Name_Range,
                Prefix         => Relocate_Node (I)));

            Analyze (I);
            T := Etype (I);
            Resolve (I, T);
            R := I;

         else
            --  Check that type is legal, nothing else to construct.

            if not Is_Discrete_Type (Etype (I)) then
               Error_Msg_N ("discrete type required for index", I);
            end if;

            return;
         end if;
      end if;

      if not Is_Discrete_Type (T) then
         Error_Msg_N ("discrete type required for range", I);
         Set_Etype (I, Any_Type);
         return;

      elsif T = Any_Type then
         Set_Etype (I, Any_Type);
         return;
      end if;

      Def_Id := New_Itype (E_Void, Related_Nod, Related_Id, 'X', Suffix_Index);
      Set_Etype (Def_Id, Base_Type (T));

      --  ??? what about modular types in the following situation

      if Is_Integer_Type (T) then
         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
      else
         Set_Ekind (Def_Id, E_Enumeration_Subtype);
         Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
      end if;

      Set_Esize            (Def_Id, Esize (T));
      Set_Alignment_Clause (Def_Id, Alignment_Clause (T));
      Set_Scalar_Range     (Def_Id, R);

      Set_Etype (I, Def_Id);
   end Make_Index;

   ---------------------
   -- Constrain_Array --
   ---------------------

   procedure Constrain_Array
     (Def_Id      : in out Entity_Id;
      SI          : Node_Id;
      Related_Nod : Node_Id;
      Related_Id  : Entity_Id;
      Suffix      : Character)
   is
      C                     : constant Node_Id := Constraint (SI);
      Number_Of_Constraints : Nat := 0;
      Index                 : Node_Id;
      S, T                  : Entity_Id;
      Constraint_OK         : Boolean := True;

   begin
      T := Entity (Subtype_Mark (SI));

      if Ekind (T) in Access_Kind then
         T := Designated_Type (T);
      end if;

      --  If an index constraint follows a subtype mark in a subtype indication
      --  then the type or subtype denoted by the subtype mark must not already
      --  impose an index constraint. The subtype mark must denote either an
      --  unconstrained array type or an access type whose designated type
      --  is such an array type... (RM 3.6.1)

      if Is_Constrained (T) then
         Error_Msg_N
           ("array type is already constrained", Subtype_Mark (SI));
         Constraint_OK := False;

      else
         S := First (Constraints (C));

         while Present (S) loop
            Number_Of_Constraints := Number_Of_Constraints + 1;
            S := Next (S);
         end loop;

         --  In either case, the index constraint must provide a discrete
         --  range for each index of the array type and the type of each
         --  discrete range must be the same as that of the corresponding
         --  index. (RM 3.6.1)

         if Number_Of_Constraints /= Number_Dimensions (T) then
            Error_Msg_NE ("incorrect number of index constraints for }", C, T);
            Constraint_OK := False;

         else
            S := First (Constraints (C));
            Index := First_Index (T);
            Analyze (Index);

            --  Apply constraints to each index type

            for J in 1 .. Number_Of_Constraints loop
               Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
               Index := Next (Index);
               S := Next (S);
            end loop;

         end if;
      end if;

      if No (Def_Id) then
         Def_Id :=
           New_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
      else
         Set_Ekind (Def_Id, E_Array_Subtype);
      end if;

      Set_Esize              (Def_Id, Esize (T));
      Set_Alignment_Clause   (Def_Id, Alignment_Clause (T));
      Set_Etype              (Def_Id, Base_Type (T));

      if Constraint_OK then
         Set_First_Index     (Def_Id, First (Constraints (C)));
      end if;

      Set_Component_Type     (Def_Id, Component_Type (T));
      Set_Has_Tasks          (Def_Id, Has_Tasks (T));
      Set_Has_Controlled     (Def_Id, Has_Controlled (T));
      Set_Is_Constrained     (Def_Id, True);
      Set_Is_Aliased         (Def_Id, Is_Aliased (T));
      Set_Is_Packed          (Def_Id, Is_Packed (T));
      Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));

      --  We always need a freeze node for a packed array subtype, so that
      --  we can build the Packed_Array_Type corresponding to the subtype.

      if Is_Packed (Def_Id) then
         Set_Has_Delayed_Freeze (Def_Id, True);
      end if;

      --  If the subtype is not that of a record component, build a freeze
      --  node if parent still needs one.

      if not Is_Type (Scope (Def_Id)) then
         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
         Conditional_Delay (Def_Id, T);
      end if;

   end Constrain_Array;

   --------------------------
   -- Constrain_Concurrent --
   --------------------------

   --  For concurrent types, the associated record value type carries the same
   --  discriminants, so when we constrain a concurrent type, we must constrain
   --  the value type as well.

   procedure Constrain_Concurrent
     (Def_Id      : in out Entity_Id;
      SI          : Node_Id;
      Related_Nod : Node_Id;
      Related_Id  : Entity_Id;
      Suffix      : Character)
   is
      T_Ent : constant Entity_Id := Entity (Subtype_Mark (SI));
      T_Val : constant Entity_Id := Corresponding_Record_Type (T_Ent);
      T_Sub : Entity_Id;

   begin
      if Present (T_Val) then

         if No (Def_Id) then
            Def_Id := New_Itype (E_Void, Related_Nod, Related_Id, Suffix);
         end if;

         Constrain_Discriminated_Type  (Def_Id, SI, Related_Nod);
         T_Sub := New_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');

         Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
         Set_Corresponding_Record_Type (Def_Id, T_Sub);

         Set_Etype                   (T_Sub, T_Val);
         Set_Esize                   (T_Sub, Uint_0);
         Set_Has_Discriminants       (T_Sub, True);
         Set_Is_Constrained          (T_Sub, True);
         Set_First_Entity            (T_Sub, First_Entity (T_Val));
         Set_Last_Entity             (T_Sub, Last_Entity (T_Val));

         if Has_Discriminants (Def_Id) then -- False only if errors.
            Set_Discriminant_Constraint (T_Sub,
                                         Discriminant_Constraint (Def_Id));
         end if;

         Set_Depends_On_Private      (T_Sub, Has_Private_Component (T_Sub));

      else
         --  If there is no associated record, expansion is disabled and this
         --  is a generic context. Create a subtype in any case, so that
         --  semantic analysis can proceed.

         if No (Def_Id) then
            Def_Id := New_Itype (E_Void, Related_Nod, Related_Id, Suffix);
         end if;

         Constrain_Discriminated_Type  (Def_Id, SI, Related_Nod);
      end if;
   end Constrain_Concurrent;

   ---------------------
   -- Constrain_Index --
   ---------------------

   procedure Constrain_Index
     (Index        : Node_Id;
      S            : Node_Id;
      Related_Nod  : Node_Id;
      Related_Id   : Entity_Id;
      Suffix       : Character;
      Suffix_Index : Nat)
   is
      Def_Id : Entity_Id;
      R      : Node_Id;
      T      : constant Entity_Id := Etype (Index);

   begin
      if Nkind (S) = N_Range
        or else Nkind (S) = N_Attribute_Reference
      then
         --  A Range attribute will transformed into N_Range by Resolve.

         Analyze (S);
         Set_Etype (S, T);
         R := S;
         Process_Range_Expr_In_Decl (R, T, Related_Nod);

         if Nkind (S) /= N_Range
           or else Base_Type (T) /= Base_Type (Etype (Low_Bound (S)))
           or else Base_Type (T) /= Base_Type (Etype (High_Bound (S)))
         then
            Error_Msg_N ("range expected", S);
         end if;

      elsif Nkind (S) = N_Subtype_Indication then
         Resolve_Discrete_Subtype_Indication (S, T);

         --  Make sure constraint is of the right kind.

         if Nkind (Constraint (S)) = N_Range_Constraint then
            R := Range_Expression (Constraint (S));
         end if;

      --  Subtype_Mark case, no anonymous subtypes to construct

      else
         Analyze (S);
         if Is_Entity_Name (S) then

            if not Is_Type (Entity (S))
              or else Base_Type (Entity (S)) /= Base_Type (T)
            then
               Error_Msg_N ("range expected", S);
            end if;

            return;

         else
            Error_Msg_N ("invalid index constraint", S);
            return;
         end if;
      end if;

      Def_Id :=
        New_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);

      Set_Etype (Def_Id, Base_Type (T));

      --  What about modular types in the following test ???

      if Is_Integer_Type (T) then
         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
      else
         Set_Ekind (Def_Id, E_Enumeration_Subtype);
         Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
      end if;

      Set_Esize            (Def_Id, Esize (T));
      Set_Alignment_Clause (Def_Id, Alignment_Clause (T));
      Set_Scalar_Range     (Def_Id, R);

      Set_Etype (S, Def_Id);
   end Constrain_Index;

   ------------------------------------
   -- Check_Or_Process_Discriminants --
   ------------------------------------

   --  If an incomplete or private type declaration was already given for
   --  the type, the discriminants may have already been processed if they
   --  were present on the incomplete declaration. In this case a full
   --  conformance check is performed otherwise just process them.

   procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id) is
   begin
      if Has_Discriminants (T) then

         --  ??? conformance checks not implemented

         null;

         --  Make the discriminants visible to component declarations.

         declare
            D    : Entity_Id := First_Discriminant (T);
            Prev : Entity_Id;

         begin
            while Present (D) loop
               Prev := Current_Entity (D);
               Set_Current_Entity (D);
               Set_Is_Immediately_Visible (D);
               Set_Homonym (D, Prev);
               D := Next_Discriminant (D);
            end loop;
         end;

      else
         if Present (Discriminant_Specifications (N)) then
            Process_Discriminants (N);
         end if;
      end if;
   end Check_Or_Process_Discriminants;

   -----------------------------
   -- Record_Type_Declaration --
   -----------------------------

   procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
      Def : constant Node_Id := Type_Definition (N);

   begin
      --  Records constitute a scope for the component declarations within.
      --  The scope is created prior to the processing of these declarations.
      --  Discriminants are processed first, so that they are visible when
      --  processing the other components. The Ekind of the record type itself
      --  is set to E_Record_Type (subtypes appear as E_Record_Subtype).
      --  If an incomplete or private type declaration was already given for
      --  the type, then this scope already exists, and the discriminants have
      --  been declared within. We must verify that the full declaration
      --  matches the incomplete one.

      New_Scope (T); -- Enter record scope
      Set_Is_Limited_Record (T, Limited_Present (Def));

      Check_Or_Process_Discriminants (N, T);

      Set_Ekind              (T, E_Record_Type);
      Set_Etype              (T, T);
      Set_Esize              (T, Uint_0);
      Set_Is_Constrained     (T, not Has_Discriminants (T));
      Set_Has_Delayed_Freeze (T, True);

      Record_Type_Definition (Def, T);

      --  Exit from record scope

      End_Scope;

   end Record_Type_Declaration;

   ------------------------------------
   -- Tagged_Record_Type_Declaration --
   ------------------------------------

   procedure Tagged_Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
      Def      : constant Node_Id := Type_Definition (N);
      Tag_Comp : Entity_Id;

   begin

      New_Scope (T); -- Enter record scope

      Set_Is_Tagged_Type (T);
      Set_Is_Limited_Record (T, Limited_Present (Def));

      --  Type is abstract if full declaration carries keyword, or if
      --  previous partial view did.

      Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def));
      Check_Or_Process_Discriminants (N, T);
      Set_Ekind              (T, E_Record_Type);
      Set_Etype              (T, T);
      Set_Esize              (T, Uint_0);
      Set_Is_Constrained     (T, not Has_Discriminants (T));
      Set_Has_Delayed_Freeze (T, True);

      --  Add a manually analyzed component corresponding to the component
      --  _tag, the corresponding piece of tree will be expanded as part of
      --  the freezing actions if it is not a CPP_Class

      Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
      Enter_Name (Tag_Comp);
      Set_Is_Tag (Tag_Comp);
      Set_Ekind (Tag_Comp, E_Component);
      Set_DT_Entry_Count (Tag_Comp, No_Uint);
      Set_Etype (Tag_Comp, RTE (RE_Tag));
      Set_Original_Record_Component (Tag_Comp, Tag_Comp);

      Record_Type_Definition (Def, T);

      Make_Class_Wide_Type (T);
      Set_Primitive_Operations (T, New_Elmt_List);

      if Has_Discriminants (T)
        and then Present (Discriminant_Default_Value (First_Discriminant (T)))
      then
         Error_Msg_N ("discriminants of tagged type cannot have defaults", N);
      end if;

      End_Scope; -- Exit record scope
   end Tagged_Record_Type_Declaration;

   ---------------------------
   -- Process_Discriminants --
   ---------------------------

   procedure Process_Discriminants (N : Node_Id) is
      Id                  : Node_Id;
      Discr               : Node_Id;
      Discr_Type          : Entity_Id;
      Default_Present     : Boolean := False;
      Default_Not_Present : Boolean := False;
      D_Minal             : Entity_Id;
      Elist               : Elist_Id;

   begin
      --  A composite type other than an array type can have discriminants.
      --  Discriminants of non-limited types must have a discrete type.
      --  On entry, the current scope is the composite type.

      --  The discriminants are initially entered into the scope of the type
      --  via Enter_Name with the default Ekind of E_Void to prevent premature
      --  use, as explained at the end of this procedure.

      Elist := New_Elmt_List;

      Discr := First (Discriminant_Specifications (N));
      while Present (Discr) loop
         Enter_Name (Defining_Identifier (Discr));

         if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
            Discr_Type := Access_Definition (N, Discriminant_Type (Discr));

         else
            Analyze (Discriminant_Type (Discr));
            Discr_Type := Etype (Discriminant_Type (Discr));
         end if;

         if Is_Access_Type (Discr_Type) then
            Note_Feature (Access_Discriminants, Sloc (Discr));

            --  A discriminant_specification for an access discriminant
            --  shall appear only in the declaration for a task or protected
            --  type, or for a type with the reserved word 'limited' in
            --  its definition or in one of its ancestors. (RM 3.7(10))

            if Nkind (Discriminant_Type (Discr)) = N_Access_Definition
              and then not Is_Concurrent_Type (Current_Scope)
              and then not Is_Concurrent_Record_Type (Current_Scope)
              and then not Is_Limited_Record (Current_Scope)
              and then Ekind (Current_Scope) /= E_Limited_Private_Type
            then
               Error_Msg_N
                 ("access discriminants allowed only for limited types",
                  Discriminant_Type (Discr));
            end if;

            if Ada_83 and then Comes_From_Source (Discr) then
               Error_Msg_N
                 ("(Ada 83) access discriminant not allowed", Discr);
            end if;

         elsif not Is_Discrete_Type (Discr_Type) then
            Error_Msg_N ("discriminants must have a discrete or access type",
              Discriminant_Type (Discr));
         end if;

         Set_Etype (Defining_Identifier (Discr), Discr_Type);

         --  If a discriminant specification includes the assignment compound
         --  delimiter followed by an expression, the expression is the default
         --  expression of the discriminant; the default expression must be of
         --  the type of the discriminant. (RM 3.7.1) Since this expression is
         --  a default expression, we do the special preanalysis, since this
         --  expression does not freeze (see "Handling of Default Expressions"
         --  in spec of package Sem).

         if Present (Expression (Discr)) then

            --  For now don't do this because we don't yet properly analyze
            --  the default expression later ???

            --   In_Default_Expression := True;

            Analyze (Expression (Discr));
            In_Default_Expression := False;
            Resolve (Expression (Discr), Discr_Type);
            Default_Present := True;
            Append_Elmt (Expression (Discr), Elist);

            --  Tag the defining identifiers for the discriminants with their
            --  corresponding default expressions from the tree.

            Set_Discriminant_Default_Value
              (Defining_Identifier (Discr), Expression (Discr));

         else
            Default_Not_Present := True;
         end if;

         Discr := Next (Discr);
      end loop;

      --  An element list consisting of the default expressions of the
      --  discriminants is constructed in the above loop and used to set
      --  the Discriminant_Constraint attribute for the type. If an object
      --  is declared of this (record or task) type without any explicit
      --  discriminant constraint given, this element list will form the
      --  actual parameters for the corresponding initialization procedure
      --  for the type.

      Set_Discriminant_Constraint (Current_Scope, Elist);

      --  Default expressions must be provided either for all or for none
      --  of the discriminants of a discriminant part. (RM 3.7.1)

      if Default_Present then
         if Nkind (N) = N_Formal_Type_Declaration then
            Error_Msg_N
              ("discriminant defaults not allowed for formal type", N);

         elsif Default_Not_Present then
            Error_Msg_N
              ("incomplete specification of defaults for discriminants", N);
         end if;
      end if;

      --  The use of the name of a discriminant is not allowed in default
      --  expressions of a discriminant part if the specification of the
      --  discriminant is itself given in the discriminant part. (RM 3.7.1)

      --  To detect this, the discriminant names are entered initially with an
      --  Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
      --  attempt to use a void entity (for example in an expression that is
      --  type-checked) produces the error message: premature usage.  Now after
      --  completing the semantic analysis of the discriminant part, we can set
      --  the Ekind of all the discriminants appropriately.

      Discr := First (Discriminant_Specifications (N));

      while Present (Discr) loop
         Id := Defining_Identifier (Discr);
         Set_Ekind (Id, E_Discriminant);

         --  Initialize the Original_Record_Component to the entity itself
         --  the New_Copy call in Build_Derived_Type will automatically
         --  propagate the right value to descendants

         Set_Original_Record_Component (Id, Id);

         --  Create discriminal, that is to say the associated entity
         --  to be used in initialization procedures for the type,
         --  in which a discriminal is a formal parameter whose actual
         --  is the value of the corresponding discriminant constraint.
         --  Discriminals are not used during semantic analysis, and are
         --  not fully defined entities until expansion. Thus they are not
         --  given a scope until intialization procedures are built.

         --  The discriminals have the same names as the discriminants

         D_Minal := Make_Defining_Identifier (Sloc (N), Chars (Id));
         Set_Ekind (D_Minal, E_In_Parameter);
         Set_Etype (D_Minal, Etype (Id));
         Set_Discriminal (Id, D_Minal);

         Discr := Next (Discr);
      end loop;

      Set_Has_Discriminants (Current_Scope);
   end Process_Discriminants;

   --------------------------------
   -- Discriminant_Redeclaration --
   --------------------------------

   procedure Discriminant_Redeclaration (T : Entity_Id; D_List : List_Id) is
   begin
      null; -- For now ???
   end Discriminant_Redeclaration;

   ----------------------------
   -- Record_Type_Definition --
   ----------------------------

   procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is
      Component : Entity_Id;

   begin
      --  If the component list of a record type is defined by the reserved
      --  word null and there is no discriminant part, then the record type has
      --  no components and all records of the type are null records (RM 3.7)
      --  This procedure is also called to process the extension part of a
      --  record extension, in which case the current scope may have inherited
      --  components.

      if No (Component_List (Def))
        or else Null_Present (Component_List (Def))
      then
         null;

      else
         Analyze_Declarations (Component_Items (Component_List (Def)));

         if Present (Variant_Part (Component_List (Def))) then
            Analyze (Variant_Part (Component_List (Def)));
         end if;
      end if;

      --  After completing the semantic analysis of the record definition,
      --  record components, both new and inherited, are accessible. Set
      --  their kind accordingly.

      Component := First_Entity (Current_Scope);
      while Present (Component) loop
         if Ekind (Component) = E_Void then
            Set_Ekind (Component, E_Component);
         end if;

         if Has_Tasks (Etype (Component)) then
            Set_Has_Tasks (T, True);
         end if;

         if Has_Controlled (Etype (Component))
           or else (Chars (Component) /= Name_uParent
                    and then Is_Controlled (Etype (Component)))
         then
            Note_Feature (Controlled_Types, Sloc (T));
            Set_Has_Controlled (T, True);
         end if;

         Component := Next_Entity (Component);
      end loop;
   end Record_Type_Definition;

   -----------------------------------
   -- Analyze_Component_Declaration --
   -----------------------------------

   procedure Analyze_Component_Declaration (N : Node_Id) is
      Id : constant Entity_Id := Defining_Identifier (N);
      T  : Entity_Id;
      P  : Entity_Id;

   begin
      Enter_Name (Defining_Identifier (N));
      T := Find_Type_Of_Object (Subtype_Indication (N), N);

      --  If the component declaration includes a default expression, then we
      --  check that the component is not of a limited type (RM 3.7(5)),
      --  and do the special preanalysis of the expression (see section on
      --  "Handling of Default Expressions" in the spec of package Sem).

      if Present (Expression (N)) then
         Analyze_Default_Expression (Expression (N), T);
         Check_Initialization (T, Expression (N));
      end if;

      if Is_Indefinite_Subtype (T) then
         Error_Msg_N
           ("unconstrained subtype in component declaration",
            Subtype_Indication (N));

      --  Components cannot be abstract, except for the special case of
      --  the _Parent field (case of extending an abstract tagged type)

      elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
         Error_Msg_N ("type of a component cannot be abstract", N);
      end if;

      Set_Etype (Id, T);
      Set_Is_Aliased (Id, Aliased_Present (N));

      --  If the this component is private (or depends on a private type),
      --  add the record type to private dependents of its ancestor type.

      P := Private_Ancestor (T);

      if Present (P) then
         Append_Elmt (Current_Scope, Private_Dependents (P));
      end if;

      if Is_Limited_Type (T)
        and then Chars (Id) /= Name_uParent
        and then Is_Tagged_Type (Current_Scope)
        and then Is_Derived_Type (Current_Scope)
        and then not Is_Limited_Record (Root_Type (Current_Scope))
      then
         Error_Msg_N
           ("extension of non limited type cannot have limited components", N);
      end if;

      --  Initialize the Original_Record_Component to the entity itself
      --  the New_Copy call in Build_Derived_Type will automatically
      --  propagate the right value to descendants

      Set_Original_Record_Component (Id, Id);
   end Analyze_Component_Declaration;

   ---------------------------
   -- Analyze_Others_Choice --
   ---------------------------

   --  Nothing to do for the others choice node itself, the semantic analysis
   --  of the others choice will occur as part of the processing of the parent

   procedure Analyze_Others_Choice (N : Node_Id) is
   begin
      null;
   end Analyze_Others_Choice;

   --------------------------
   -- Analyze_Variant_Part --
   --------------------------

   procedure Analyze_Variant_Part (N : Node_Id) is
      Case_Table     : Case_Table_Type (1 .. Number_Of_Case_Choices (N));
      Choice         : Node_Id;
      Choice_Count   : Nat := 0;
      Discr_Name     : Node_Id;
      Discr_Type     : Entity_Id;
      Discr_Btype    : Entity_Id;
      E              : Entity_Id;
      Lo             : Node_Id;
      Hi             : Node_Id;
      Exp_Lo         : Uint;
      Exp_Hi         : Uint;
      Invalid_Case   : Boolean := False;
      Kind           : Node_Kind;
      Others_Present : Boolean := False;
      Variant        : Node_Id;

      procedure Check_Choice (Lo, Hi : Node_Id; Choice : Node_Id);
      --  Check_Choice checks whether the given bounds of a choice are
      --  static and valid for the range of the discrete subtype. If not,
      --  a message is issued, otherwise the bounds are entered into
      --  the case table.

      procedure Check_Choice (Lo, Hi : Node_Id; Choice : Node_Id) is
      begin
         --  The simple expressions and discrete ranges given as choices
         --  in a variant part must be static (RM 3.7.3).

         if not Is_Static_Expression (Lo)
           or else not Is_Static_Expression (Hi)
         then
            Error_Msg_N
              ("choice given in variant part is not static", Choice);
            Invalid_Case := True;
            return;
         end if;

         if Choice_In_Range (Lo, Hi, Exp_Lo, Exp_Hi, Discr_Btype) then
            Choice_Count := Choice_Count + 1;
            Case_Table (Choice_Count).Choice_Lo := Lo;
            Case_Table (Choice_Count).Choice_Hi := Hi;
            Case_Table (Choice_Count).Choice_Node := Choice;
         end if;
      end Check_Choice;

   --  Start of processing for Analyze_Variant_Part

   begin
      Discr_Name := Name (N);
      Analyze (Discr_Name);

      if Ekind (Entity (Discr_Name)) /= E_Discriminant then
         Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
      end if;

      Discr_Type := Etype (Entity (Discr_Name));
      Discr_Btype := Base_Type (Discr_Type);

      --  The type of the discriminant of a variant part must not be a
      --  generic formal type (RM 3.7.3).

      if Is_Generic_Type (Discr_Type) then
         Error_Msg_N
           ("discriminant of variant part cannot be generic", Discr_Name);
         return;
      end if;

      if Is_OK_Static_Subtype (Discr_Type) then
         Exp_Lo := Expr_Value (Type_Low_Bound (Discr_Type));
         Exp_Hi := Expr_Value (Type_High_Bound (Discr_Type));

      else
         Exp_Lo := Expr_Value (Type_Low_Bound (Discr_Btype));
         Exp_Hi := Expr_Value (Type_High_Bound (Discr_Btype));
      end if;

      --  Now check each of the case choices against Exp_Base_Type.

      Variant := First (Variants (N));

      while Present (Variant) loop
         Choice := First (Discrete_Choices (Variant));

         while Present (Choice) loop
            Analyze (Choice);
            Kind := Nkind (Choice);

            if Kind = N_Range then
               Resolve (Choice, Discr_Type);
               Check_Choice (Low_Bound (Choice), High_Bound (Choice), Choice);

            elsif Is_Entity_Name (Choice)
              and then Is_Type (Entity (Choice))
            then
               E  := Entity (Choice);
               Lo := Type_Low_Bound (E);
               Hi := Type_High_Bound (E);
               Check_Choice (Lo, Hi, Choice);

            elsif Kind = N_Subtype_Indication then
               pragma Assert (False); null;        -- for now ???

            --  The choice others is only allowed for the last variant and as
            --  its only choice; it stands for all values (possibly none) not
            --  given in the choices of previous variants (RM 3.7.3).

            elsif Kind = N_Others_Choice then
               if not (Choice = First (Discrete_Choices (Variant))
                 and then Choice = Last (Discrete_Choices (Variant))
                 and then Variant = Last (Variants (N)))
               then
                  Error_Msg_N
                    ("the choice OTHERS must appear alone and last", Choice);
                  return;
               end if;

               Others_Present := True;

            else
               --  Must be an expression

               Resolve (Choice, Discr_Type);
               Check_Choice (Choice, Choice, Choice);
            end if;

            Choice := Next (Choice);
         end loop;

         if not Null_Present (Component_List (Variant)) then
            Analyze_Declarations (Component_Items (Component_List (Variant)));

            if Present (Variant_Part (Component_List (Variant))) then
               Analyze (Variant_Part (Component_List (Variant)));
            end if;
         end if;

         Variant := Next (Variant);
      end loop;

      if not Invalid_Case
        and then Case_Table'Length > 0
      then
         Check_Case_Choices
           (Case_Table (1 .. Choice_Count), N, Discr_Type, Others_Present);
      end if;

      if not Invalid_Case
        and then Others_Present
      then

         --  Fill in Others_Discrete_Choices field of the OTHERS choice

         Choice := Last (Discrete_Choices (Last (Variants (N))));
         Expand_Others_Choice
           (Case_Table (1 .. Choice_Count), Choice, Discr_Type);
      end if;

   end Analyze_Variant_Part;

   --------------------------
   -- Expand_Others_Choice --
   --------------------------

   procedure Expand_Others_Choice
     (Case_Table    : Case_Table_Type;
      Others_Choice : Node_Id;
      Choice_Type   : Entity_Id)
   is
      Choice      : Node_Id;
      Choice_List : List_Id := New_List;
      Exp_Lo      : Node_Id;
      Exp_Hi      : Node_Id;
      Hi          : Uint;
      Lo          : Uint;
      Loc         : Source_Ptr := Sloc (Others_Choice);
      Previous_Hi : Uint;

      function Lit_Of (Value : Uint) return Node_Id;
      --  Returns the Node_Id for the enumeration literal corresponding to the
      --  position given by Value within the enumeration type Choice_Type.

      function Build_Choice (Value1, Value2 : Uint) return Node_Id;
      --  Builds a node representing the missing choices given by the
      --  Value1 and Value2. A N_Range node is built if there is more than
      --  one literal value missing. Otherwise a single N_Integer_Literal,
      --  N_Identifier or N_Character_Literal is built depending on what
      --  Choice_Type is.

      ------------
      -- Lit_Of --
      ------------

      function Lit_Of (Value : Uint) return Node_Id is
         Lit : Entity_Id;

      begin
         --  In the case where the literal is of type Character, there needs
         --  to be some special handling since there is no explicit chain
         --  of literals to search. Instead, a N_Character_Literal node
         --  is created with the appropriate Char_Code and Chars fields.

         if Root_Type (Choice_Type) = Standard_Character then
            Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
            Lit := New_Node (N_Character_Literal, Loc);
            Set_Chars (Lit, Name_Find);
            Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
            Set_Etype (Lit, Choice_Type);
            Set_Is_Static_Expression (Lit, True);
            return Lit;

         --  Otherwise, iterate through the literals list of Choice_Type
         --  "Value" number of times until the desired literal is reached
         --  and then return an occurrence of it.

         else
            Lit := First_Literal (Choice_Type);
            for J in 1 .. UI_To_Int (Value) loop
               Lit := Next_Literal (Lit);
            end loop;

            return New_Occurrence_Of (Lit, Loc);
         end if;
      end Lit_Of;

      ------------------
      -- Build_Choice --
      ------------------

      function Build_Choice (Value1, Value2 : Uint) return Node_Id is
         Lit_Node : Node_Id;
         Lo, Hi   : Node_Id;

      begin
         --  If there is only one choice value missing between Value1 and
         --  Value2, build an integer or enumeration literal to represent it.

         if (Value2 - Value1) = 0 then
            if Is_Integer_Type (Choice_Type) then
               Lit_Node := Make_Integer_Literal (Loc, Value1);
               Set_Etype (Lit_Node, Choice_Type);
            else
               Lit_Node := Lit_Of (Value1);
            end if;

         --  Otherwise is more that one choice value that is missing between
         --  Value1 and Value2, therefore build a N_Range node of either
         --  integer or enumeration literals.

         else
            if Is_Integer_Type (Choice_Type) then
               Lo := Make_Integer_Literal (Loc, Value1);
               Set_Etype (Lo, Choice_Type);
               Hi := Make_Integer_Literal (Loc, Value2);
               Set_Etype (Hi, Choice_Type);
               Lit_Node :=
                 Make_Range (Loc,
                   Low_Bound  => Lo,
                   High_Bound => Hi);

            else
               Lit_Node :=
                 Make_Range (Loc,
                   Low_Bound  => Lit_Of (Value1),
                   High_Bound => Lit_Of (Value2));
            end if;
         end if;

         return Lit_Node;
      end Build_Choice;

   --  Start of processing for Expand_Others_Choice

   begin
      if Case_Table'Length = 0 then

         --  Pathological case: only an others case is present.
         --  The others case covers the full range of the type.

         if Is_Static_Subtype (Choice_Type) then
            Choice := New_Occurrence_Of (Choice_Type, Loc);
         else
            Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
         end if;

         Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
         return;
      end if;

      --  Establish the bound values for the variant depending upon whether
      --  the type of the discriminant name is static or not.

      if Is_OK_Static_Subtype (Choice_Type) then
         Exp_Lo := Type_Low_Bound (Choice_Type);
         Exp_Hi := Type_High_Bound (Choice_Type);
      else
         Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
         Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
      end if;

      Lo := Expr_Value (Case_Table (Case_Table'First).Choice_Lo);
      Hi := Expr_Value (Case_Table (Case_Table'First).Choice_Hi);
      Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Choice_Hi);

      --  Build the node for any missing choices that are smaller than any
      --  explicit choices given in the variant.

      if Expr_Value (Exp_Lo) < Lo then
         Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
      end if;

      --  Build the nodes representing any missing choices that lie between
      --  the explicit ones given in the variant.

      for J in Case_Table'First + 1 .. Case_Table'Last loop
         Lo := Expr_Value (Case_Table (J).Choice_Lo);
         Hi := Expr_Value (Case_Table (J).Choice_Hi);

         if Lo /= (Previous_Hi + 1) then
            Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
         end if;

         Previous_Hi := Hi;
      end loop;

      --  Build the node for any missing choices that are greater than any
      --  explicit choices given in the variant.

      if Expr_Value (Exp_Hi) > Hi then
         Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
      end if;

      Set_Others_Discrete_Choices (Others_Choice, Choice_List);
   end Expand_Others_Choice;

   ------------------------------------
   -- Build_Discriminant_Constraints --
   ------------------------------------

   function Build_Discriminant_Constraints
     (T           : Entity_Id;
      Def         : Node_Id;
      Related_Nod : Node_Id)
      return        Elist_Id
   is
      C          : Node_Id := Constraint (Def);
      Discr_Expr : array (1 .. Number_Discriminants (T)) of Node_Id;
      Discr      : Entity_Id;
      E          : Entity_Id;
      Elist      : Elist_Id := New_Elmt_List;
      Position   : Nat := 1;
      Id         : Entity_Id;
      Id2        : Entity_Id;
      N          : Node_Id;
      Not_Found  : Boolean;

      function Pos_Of_Discr (T : Entity_Id; Discr : Entity_Id) return Nat;
      --  Return the Position number (starting at 1) of a discriminant
      --  (Discr) within the discriminant list of the record type (T).

      function Pos_Of_Discr (T : Entity_Id; Discr : Entity_Id) return Nat is
         J : Nat := 1;
         D : Entity_Id;

      begin
         D := First_Discriminant (T);

         while Present (D) loop
            if D = Discr then
               return J;
            end if;

            D := Next_Discriminant (D);
            J := J + 1;
         end loop;

         --  Note: Since this function is called on discriminants that are
         --  known to belong to the record type, falling through the loop
         --  with no match signals an internal compiler error.

         pragma Assert (False);
      end Pos_Of_Discr;

   --  Start of processing for Build_Discriminant_Constraints

   begin
      for J in Discr_Expr'Range loop
         Discr_Expr (J) := Empty;
      end loop;

      Discr := First_Discriminant (T);
      N := First (Constraints (C));

      --  The following loop will process the positional associations only
      --  and will exit when a named association is seen. The named
      --  associations will then be processed by the subsequent loop.

      while Present (N) loop
         exit when Nkind (N) = N_Discriminant_Association; -- Named Assoc

         --  For a positional association, the (single) discriminant is
         --  implicitly specified by position, in textual order (RM 3.7.2).

         if No (Discr) then
            Error_Msg_N ("too many discriminants given in constraint", C);
            return New_Elmt_List;

         elsif Nkind (N) = N_Range then
            Error_Msg_N
              ("a range is not a valid discriminant constraint", N);
            Discr_Expr (Position) := Error;
            Position := Position + 1;
            Discr := Next_Discriminant (Discr);

         else
            Analyze (N);
            Discr_Expr (Position) := N;
            Resolve (N, Base_Type (Etype (Discr)));
            Remove_Side_Effects (N);
            Position := Position + 1;
            Discr := Next_Discriminant (Discr);

            if Present (Related_Nod)
              and then not Is_Static_Expression (N)
            then
               Set_Has_Dynamic_Itype (Related_Nod);
            end if;
         end if;

         N := Next (N);
      end loop;

      --  There should only be named associations left on the discriminant
      --  constraint. Any positional assoication are in error.

      while Present (N) loop

         if Nkind (N) = N_Discriminant_Association then
            E := Empty;
            Analyze (Expression (N));

            --  Search the entity list of the record looking at only the
            --  discriminants (which always appear first) to see if the
            --  simple name given in the constraint matches any of them.

            Id := First (Selector_Names (N));

            while Present (Id) loop
               Not_Found := True;
               Id2 := First_Entity (T);

               while Present (Id2)
                 and then Ekind (Id2) = E_Discriminant
               loop
                  if Chars (Id2) = Chars (Id) then
                     Not_Found := False;
                     exit;
                  end if;

                  Id2 := Next_Entity (Id2);
               end loop;

               if Not_Found then
                  Error_Msg_N ("& does not match any discriminant", Id);
                  return New_Elmt_List;
               end if;

               Position := Pos_Of_Discr (T, Id2);

               if No (Discr_Expr (Position)) then
                  Discr_Expr (Position) := Expression (N);
                  Resolve (Expression (N), Base_Type (Etype (Id2)));
                  Remove_Side_Effects (Expression (N));
               else
                  Error_Msg_N
                    ("duplicate constraint for discriminant&", Id);
               end if;

               --  A discriminant association with more than one
               --  discriminant name is only allowed if the named
               --  discriminants are all of the same type (RM 3.7.2).

               if E = Empty then
                  E := Etype (Id2);

               elsif Etype (Id2) /= E then
                  Error_Msg_N ("all discriminants in an association " &
                               "must have the same type", N);
               end if;

               Id := Next (Id);
            end loop;

         else
            --  Positional Association

            --  Named associations can be given in any order, but if both
            --  positional and named associations are used in the same
            --  discriminant constraint, then positional associations must
            --  occur first, at their normal position. Hence once a named
            --  association is used, the rest of the discriminant constraint
            --  must use only named associations.

            Error_Msg_N ("positional association follows named one", N);
            return New_Elmt_List;
         end if;

         N := Next (N);
      end loop;

      --  Furthermore, for each discriminant association (whether named or
      --  positional), the expression and the associated discriminants must
      --  have the same type. A discriminant constraint must provide exactly
      --  one value for each discriminant of the type (RM 3.7.2).

      --  missing code here???

      for J in Discr_Expr'Range loop
         if No (Discr_Expr (J)) then
            Error_Msg_N ("too few discriminants given in constraint", C);
            return New_Elmt_List;
         end if;
      end loop;

      --  Build an element list consisting of the expressions given in the
      --  discriminant constraint. The list is constructed after resolving
      --  any named discriminant associations and therefore the expressions
      --  appear in the textual order of the discriminants.

      Discr := First_Discriminant (T);

      for J in Discr_Expr'Range loop
         Append_Elmt (Discr_Expr (J), Elist);

         --  If any of the discriminant constraints is given by a discriminant
         --  the context may be a derived type derivation that renames them.
         --  Establish link between new and old discriminant.

         if Is_Entity_Name (Discr_Expr (J))
            and then Ekind (Entity (Discr_Expr (J))) = E_Discriminant
         then
            Set_Corresponding_Discriminant (Entity (Discr_Expr (J)), Discr);
         end if;

         Discr := Next_Discriminant (Discr);
      end loop;

      return Elist;
   end Build_Discriminant_Constraints;

   ----------------------------------
   -- Constrain_Discriminated_Type --
   ----------------------------------

   procedure Constrain_Discriminated_Type
     (Def_Id      : Entity_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T     : Entity_Id;
      C     : Node_Id;
      Elist : Elist_Id;
      Constraint_OK : Boolean := False;

   begin
      C := Constraint (S);

      --  A discriminant constraint is only allowed in a subtype indication,
      --  after a subtype mark. This subtype mark must denote either a type
      --  with discriminants, or an access type whose designated type is a
      --  type with discriminants. A discriminant constraint specifies the
      --  values of these discriminants (RM 3.7.2(5)).

      T := Base_Type (Entity (Subtype_Mark (S)));

      if Ekind (T) in Access_Kind then
         T := Designated_Type (T);
      end if;

      if not Has_Discriminants (T) then
         Error_Msg_N
           ("invalid constraint: type has no discriminant", C);
         Set_Etype (Def_Id, Any_Type);

      elsif Is_Constrained (Entity (Subtype_Mark (S))) then
         Error_Msg_N
           ("type is already constrained", Subtype_Mark (S));
         Set_Etype (Def_Id, Any_Type);

      else
         --  Explain Itype test here???

         if Is_Itype (Def_Id) then
            Elist := Build_Discriminant_Constraints (T, S, Related_Nod);
         else
            Elist := Build_Discriminant_Constraints (T, S, Empty);
         end if;

         Constraint_OK := not Is_Empty_Elmt_List (Elist);

      end if;

      if Ekind (T) = E_Record_Type then
         Set_Ekind (Def_Id, E_Record_Subtype);

      elsif Ekind (T) = E_Task_Type then
         Set_Ekind (Def_Id, E_Task_Subtype);

      elsif Ekind (T) = E_Protected_Type then
         Set_Ekind (Def_Id, E_Protected_Subtype);

      elsif Is_Private_Type (T) then
         Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));

      else
         --  Incomplete type.

         Set_Ekind (Def_Id, Ekind (T));
      end if;

      Set_Etype              (Def_Id, T);
      Set_Esize              (Def_Id, Uint_0);
      Set_Has_Controlled     (Def_Id, Has_Controlled (T));
      Set_Has_Discriminants  (Def_Id, Constraint_OK);
      Set_Has_Tasks          (Def_Id, Has_Tasks (T));
      Set_Is_Constrained     (Def_Id, Constraint_OK);
      Set_Is_Controlled      (Def_Id, Is_Controlled (T));
      Set_Is_Tagged_Type     (Def_Id, Is_Tagged_Type (T));
      Set_First_Entity       (Def_Id, First_Entity (T));
      Set_Last_Entity        (Def_Id, Last_Entity (T));
      Set_Is_Packed          (Def_Id, Is_Packed (T));

      if not Is_Concurrent_Type (T) then
         Set_Alignment_Clause (Def_Id, Alignment_Clause (T));
      end if;

      if Constraint_OK then
         Set_Discriminant_Constraint (Def_Id, Elist);
      end if;

      if Is_Tagged_Type (T) then
         Set_Class_Wide_Type      (Def_Id, Class_Wide_Type (T));
         Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
         Set_Access_Disp_Table    (Def_Id, Access_Disp_Table (T));
      end if;

      if Is_Record_Type (T) and then Constraint_OK then
         Create_Constrained_Components (Def_Id, Related_Nod, T, T, Elist);
      end if;

      --  Subtypes introduced by component declarations do not need to be
      --  marked as delayed, and do not get freeze nodes, because the semantics
      --  verifies that the parents of the subtypes are frozen before the
      --  enclosing record is frozen.

      if not Is_Type (Scope (Def_Id)) then
         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));

         if Is_Private_Type (T)
           and then Present (Full_View (T))
         then
            Conditional_Delay (Def_Id, Full_View (T));
         else
            Conditional_Delay (Def_Id, T);
         end if;
      end if;

   end Constrain_Discriminated_Type;

   -----------------------------------
   -- Create_Constrained_Components --
   -----------------------------------

   procedure Create_Constrained_Components
     (Subt        : Entity_Id;
      Decl_Node   : Node_Id;
      Typ         : Entity_Id;
      Parent_Rec  : Entity_Id;
      Constraints : Elist_Id)
   is
      Old_E : Entity_Id;
      New_E : Entity_Id;


      Index_Type     : Entity_Id;
      Old_Index      : Node_Id;
      New_Index      : Node_Id;
      New_Index_List : List_Id;

      New_Constraint : Elist_Id;
      Old_Constraint : Elmt_Id;
      Old_Expr       : Node_Id;
      New_Expr       : Node_Id;
      Low_Expr       : Node_Id;
      High_Expr      : Node_Id;
      Old_Type       : Entity_Id;

      Itype  : Entity_Id;
      Need_To_Create_Itype : Boolean;

      function Get_Value (D : Entity_Id) return Node_Id;
      --  Find the value of discriminant D in the discriminant constraint for
      --  the subtype.

      function Get_Value (D : Entity_Id) return Node_Id is
         Assoc : Elmt_Id;
         Disc  : Entity_Id;
      begin
         Assoc := First_Elmt (Constraints);
         Disc  := First_Discriminant (Parent_Rec);

         while Original_Record_Component (Disc) /= D loop
            Assoc := Next_Elmt (Assoc);
            Disc := Next_Discriminant (Disc);
         end loop;

         return Node (Assoc);
      end Get_Value;

   begin
      --  Tagged types and their descendants work without component
      --  expansion. To be investigated. ???

      if Is_Tagged_Type (Typ) then
         return;
      end if;

      Old_E := First_Entity (Typ);

      while Present (Old_E) loop
         Need_To_Create_Itype := False;

         if Old_E = First_Entity (Typ) then
            New_E := New_Copy (Old_E);
            Set_First_Entity (Subt, New_E);
         else
            Set_Next_Entity (New_E, New_Copy (Old_E));
            New_E := Next_Entity (New_E);
         end if;

         Old_Type := Etype (Old_E);

         if Is_Type (Old_E) then

            --  No need to consider anonymous types in the record
            --  declaration, they are the types of components that are
            --  about to be rebuilt.
            null;

         elsif Is_Array_Type (Old_Type) then
            New_Index_List := New_List;

            Old_Index := First_Index (Etype (Old_E));
            while Present (Old_Index) loop
               New_Index := New_Copy_Tree (Old_Index);

               if Nkind (New_Index) = N_Range then
                  Set_Etype (New_Index, Base_Type (Etype (Old_Index)));

                  Get_Index_Bounds (New_Index, Low_Expr, High_Expr);

                  Old_Expr := Low_Expr;
                  for J in 1 .. 2 loop
                     if Nkind (Old_Expr)         = N_Identifier   and then
                       Ekind (Entity (Old_Expr)) = E_Discriminant
                     then
                        Need_To_Create_Itype := True;

                        New_Expr := Get_Value (Entity (Old_Expr));

                        if J = 1 then
                           Set_Low_Bound
                             (New_Index, New_Copy_Tree (New_Expr));
                        else
                           Set_High_Bound
                             (New_Index, New_Copy_Tree (New_Expr));
                        end if;
                     end if;

                     Old_Expr := High_Expr;
                  end loop;

                  --  Create anonymous index type for range

                  Index_Type := New_Itype
                      (Subtype_Kind (Ekind (Etype (New_Index))), Decl_Node);
                  Set_Etype        (Index_Type, Etype (New_Index));
                  Set_Esize        (Index_Type, Esize (Etype (New_Index)));
                  Set_Scalar_Range (Index_Type, New_Index);

                  Set_Etype (New_Index, Index_Type);
               end if;

               Append (New_Index, To => New_Index_List);
               Old_Index := Next_Index (Old_Index);
            end loop;

            if Need_To_Create_Itype then
               Itype := New_Itype (E_Array_Subtype, Decl_Node);

               Set_Is_Constrained     (Itype);
               Set_Esize              (Itype, Esize              (Old_Type));
               Set_Alignment_Clause   (Itype, Alignment_Clause   (Old_Type));
               Set_Etype              (Itype, Base_Type          (Old_Type));
               Set_Component_Type     (Itype, Component_Type     (Old_Type));
               Set_Has_Tasks          (Itype, Has_Tasks          (Old_Type));
               Set_Has_Controlled     (Itype, Has_Controlled     (Old_Type));
               Set_Depends_On_Private (Itype, Depends_On_Private (Old_Type));

               Set_First_Index (Itype, First (New_Index_List));
               Set_Etype (New_E, Itype);

            else
               Set_Etype (New_E, Old_Type);
            end if;

         elsif Ekind (Old_Type) = E_Record_Subtype
           and then Has_Discriminants (Old_Type)

         then
            New_Constraint := New_Elmt_List;

            Old_Constraint :=
              First_Elmt (Discriminant_Constraint (Old_Type));

            while Present (Old_Constraint) loop
               Old_Expr := Node (Old_Constraint);

               if Nkind (Old_Expr)          = N_Identifier   and then
                  Ekind (Entity (Old_Expr)) = E_Discriminant
               then
                  Need_To_Create_Itype := True;
                  New_Expr := Get_Value (Entity (Old_Expr));

                  Append_Elmt (New_Expr, New_Constraint);

               else
                  Append_Elmt (Old_Expr, New_Constraint);
               end if;

               Old_Constraint := Next_Elmt (Old_Constraint);
            end loop;

            if Need_To_Create_Itype then

               Itype := New_Itype (E_Record_Subtype, Decl_Node);

               Set_Etype                   (Itype, Base_Type (Old_Type));
               Set_Discriminant_Constraint (Itype, New_Constraint);
               Set_Is_Tagged_Type          (Itype, Is_Tagged_Type (Old_Type));
               Set_Has_Discriminants       (Itype);
               Set_First_Entity            (Itype, First_Entity (Old_Type));
               Set_Last_Entity             (Itype, Last_Entity  (Old_Type));
               Set_Is_Constrained          (Itype);
               Set_Has_Tasks               (Itype, Has_Tasks (Old_Type));
               Set_Depends_On_Private (Itype, Depends_On_Private (Old_Type));

               if Is_Tagged_Type (Old_Type) then
                  Set_Access_Disp_Table (Itype, Access_Disp_Table (Old_Type));
               end if;

               --  If the component is a constrained record subtype, create
               --  its constrained components as well. The values of the
               --  discriminants to be used are those of the enclosing record
               --  type,  because those are the discriminants used to constrain
               --  the current component, and thus its subcomponents.

               Create_Constrained_Components (Itype, Decl_Node,
                                    Old_Type, Parent_Rec, Constraints);
               Set_Etype (New_E, Itype);

            else
               Set_Etype (New_E, Old_Type);
            end if;

         else
            Set_Etype (New_E, Old_Type);
         end if;

         Old_E := Next_Entity (Old_E);

      end loop;

      Set_Last_Entity (Subt, New_E);
   end Create_Constrained_Components;

   ------------------------------
   -- Derived_Type_Declaration --
   ------------------------------

   procedure Derived_Type_Declaration (T : in out Entity_Id; N : Node_Id) is
      Def             : constant Node_Id    := Type_Definition (N);
      Indic           : constant Node_Id    := Subtype_Indication (Def);
      Extension       : constant Node_Id    := Record_Extension_Part (Def);
      Derived_Type    : Entity_Id;
      Parent_Type     : Entity_Id;
      Taggd           : Boolean;

   begin
      if Nkind (Indic) = N_Subtype_Indication then
         Find_Type (Subtype_Mark (Indic));
         Parent_Type := Entity (Subtype_Mark (Indic));

         if not Is_Valid_Constraint_Kind
                    (Ekind (Parent_Type), Nkind (Constraint (Indic)))
         then
            Error_Msg_N
              ("incorrect constraint for this kind of type",
               Constraint (Indic));
            Rewrite_Substitute_Tree (Indic,
              New_Copy_Tree (Subtype_Mark (Indic)));
         end if;

         --  Otherwise we have a subtype mark without a constraint

      else
         Find_Type (Indic);
         Parent_Type := Entity (Indic);
      end if;

      if Parent_Type = Any_Type then
         Set_Etype (T, Any_Type);

         if Is_Tagged_Type (T) then
            Set_Primitive_Operations (T, New_Elmt_List);
         end if;

         return;
      end if;

      --  Only composite types other than array types are allowed to have
      --  discriminants.

      if Present (Discriminant_Specifications (N)) then
         if Is_Elementary_Type (Parent_Type)
           or else Is_Array_Type (Parent_Type) then
            Error_Msg_N
             ("elementary or array type cannot have discriminants",
              Defining_Identifier (First (Discriminant_Specifications (N))));
         end if;
      end if;

      --  In Ada 83, a derived type defined in a package specification cannot
      --  be used for further derivation until the end of its visible part.
      --  Note that derivation in the private part of the package is allowed.

      if (Ada_83 or Features_On)
        and then Is_Derived_Type (Parent_Type)
        and then In_Visible_Part (Scope (Parent_Type))
      then
         Note_Feature (Inheritance_At_Local_Derivation, Sloc (Indic));

         if Ada_83 and then Comes_From_Source (Indic) then
            Error_Msg_N
              ("(Ada 83): premature use of type for derivation", Indic);
         end if;
      end if;

      --  Check for early use of incomplete or private type

      if Ekind (Parent_Type) = E_Void
        or else Ekind (Parent_Type) = E_Incomplete_Type
      then
         Error_Msg_N ("premature derivation of incomplete type", Indic);
         return;

      elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
        and then not Is_Generic_Type (Parent_Type)
        and then not Is_Generic_Actual_Type (Parent_Type)
        and then No (Underlying_Type (Parent_Type)))
        or else Has_Private_Component (Parent_Type)
      then
         Error_Msg_N ("premature derivation of derived or private type",
          Indic);
      end if;

      --  Check that form of derivation is appropriate

      Taggd := Is_Tagged_Type (Parent_Type);

      if Present (Extension) and then not Taggd then
         Error_Msg_N
           ("type derived from non tagged type cannot have extension", Indic);

      elsif No (Extension) and then Taggd then
         Error_Msg_N
           ("type derived from tagged type must have extension", Indic);
      end if;

      Derived_Type := T;

      Build_Derived_Type (N, Parent_Type, T);
      Derive_Subprograms (Parent_Type, T);
      Set_Has_Delayed_Freeze (T);
   end Derived_Type_Declaration;

   ------------------------
   -- Build_Derived_Type --
   ------------------------

   procedure Build_Derived_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : in out Entity_Id)
   is
   begin
      --  Copy common attributes

      Set_Ekind (Derived_Type, Ekind (Base_Type     (Parent_Type)));
      Set_Esize (Derived_Type, Esize                (Parent_Type));
      Set_Etype (Derived_Type, Base_Type            (Parent_Type));
      Set_Has_Non_Standard_Rep
                (Derived_Type, Has_Non_Standard_Rep (Parent_Type));

      Set_Scope (Derived_Type, Current_Scope);

      if Ekind (Derived_Type) not in Concurrent_Kind then
         Set_Alignment_Clause (Derived_Type, Alignment_Clause (Parent_Type));
         --  should add alignment clause to concurrent types ???
      end if;

      case Ekind (Parent_Type) is
         when Numeric_Kind =>
            Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);

         when Array_Kind =>
            Build_Derived_Array_Type (N, Parent_Type,  Derived_Type);

         when E_Record_Type | E_Record_Subtype =>
            if Is_Tagged_Type (Parent_Type) then
               Build_Derived_Tagged_Type (N,
                 Type_Definition (N), Parent_Type, Derived_Type);
            else
               Build_Derived_Record_Type (N, Parent_Type, Derived_Type);
            end if;

            Set_Has_Specified_Layout
              (Derived_Type, Has_Specified_Layout (Parent_Type));

         when Class_Wide_Kind =>
            Build_Derived_Record_Type (N, Parent_Type, Derived_Type);

         when Enumeration_Kind =>
            Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);

         when Access_Kind =>
            Set_Directly_Designated_Type
              (Derived_Type, Designated_Type (Parent_Type));
            Set_Is_Access_Constant (Derived_Type,
              Is_Access_Constant (Parent_Type));
            Set_Storage_Size_Variable (Derived_Type,
              Storage_Size_Variable (Parent_Type));

         when Incomplete_Or_Private_Kind =>
            if Is_Tagged_Type (Parent_Type) then
               Build_Derived_Tagged_Type (N,
                 Type_Definition (N), Parent_Type, Derived_Type);
            else
               if Has_Discriminants (Parent_Type) then
                  Build_Derived_Record_Type (N, Parent_Type, Derived_Type);

               elsif Present (Full_View (Parent_Type))
                 and then Has_Discriminants (Full_View (Parent_Type))
               then
                  --  Inherit the discriminants of the full view, but
                  --  keep the proper parent type.

                  Build_Derived_Record_Type
                    (N, Full_View (Parent_Type), Derived_Type);
                  Set_Etype (Base_Type (Derived_Type),
                             Base_Type (Parent_Type));
               else
                  Set_Is_Constrained  (Derived_Type,
                    Is_Constrained (Parent_Type));
               end if;
            end if;

            if Is_Private_Type (Derived_Type) then
               Set_Private_Dependents (Derived_Type, New_Elmt_List);
            end if;

            if Is_Private_Type (Parent_Type)
              and then Base_Type (Parent_Type) = Parent_Type
            then
               Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
            end if;

         when Concurrent_Kind =>

            --  All attributes are inherited from parent. In particular,
            --  entries and the corresponding record type are the same.

            Set_First_Entity (Derived_Type,  First_Entity (Parent_Type));
            Set_Last_Entity  (Derived_Type,  Last_Entity  (Parent_Type));
            Set_Has_Tasks    (Derived_Type,  Is_Task_Type (Parent_Type));
            Set_Has_Discriminants (Derived_Type,
                Has_Discriminants (Parent_Type));
            Set_Corresponding_Record_Type (Derived_Type,
                Corresponding_Record_Type (Parent_Type));

            if Is_Task_Type (Parent_Type) then
               Set_Storage_Size_Variable (Derived_Type,
                 Storage_Size_Variable (Parent_Type));
            end if;

            Set_Has_Completion (Derived_Type);

         when others =>
            pragma Assert (False); null;
      end case;
   end Build_Derived_Type;

   ------------------------------
   -- Build_Derived_Array_Type --
   ------------------------------

   procedure Build_Derived_Array_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : in out Entity_Id)
   is
      Loc           : constant Source_Ptr := Sloc (N);
      Tdef          : constant Node_Id    := Type_Definition (N);
      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
      Implicit_Base : Entity_Id;
      New_Indic     : Node_Id;

      procedure Copy_Array_Attributes (T1 : Entity_Id; T2 : Entity_Id);
      --  Utility to initialize attributes of derived type and its base.

      procedure Copy_Array_Attributes (T1 : Entity_Id; T2 : Entity_Id) is
      begin
         Set_First_Index        (T1, First_Index           (T2));
         Set_Component_Type     (T1, Component_Type        (T2));
         Set_Is_Aliased         (T1, Is_Aliased            (T2));
         Set_Is_Constrained     (T1, Is_Constrained        (T2));
         Set_Has_Tasks          (T1, Has_Tasks             (T2));
         Set_Has_Controlled     (T1, Has_Controlled        (T2));
         Set_Depends_On_Private (T1, Has_Private_Component (T2));
         Set_Esize              (T1, Esize                 (T2));
         Set_Alignment_Clause   (T1, Alignment_Clause      (T2));
      end Copy_Array_Attributes;

   begin
      if not Is_Constrained (Parent_Type) then
         if Nkind (Indic) /= N_Subtype_Indication then
            Set_Ekind              (Derived_Type, E_Array_Type);
            Copy_Array_Attributes  (Derived_Type, Parent_Type);
            Set_Has_Delayed_Freeze (Derived_Type, True);

         else
            --  If the parent type is constrained, the derived type is a
            --  subtype of an implicit base type derived from the parent base.

            Implicit_Base :=
              New_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
            Set_Ekind             (Implicit_Base, Ekind (Parent_Type));
            Copy_Array_Attributes (Implicit_Base, Parent_Type);
            Set_Has_Delayed_Freeze (Implicit_Base, True);

            New_Indic :=
                Make_Subtype_Indication (Loc,
                  Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
                  Constraint => Constraint (Indic));
            Constrain_Array (Derived_Type, New_Indic, N, Empty, ' ');
         end if;

      else
         if Nkind (Indic) /= N_Subtype_Indication then
            Implicit_Base :=
              New_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
            Set_Ekind              (Implicit_Base, Ekind (Parent_Base));
            Set_Etype              (Implicit_Base, Parent_Base);
            Copy_Array_Attributes  (Implicit_Base, Parent_Base);
            Set_Has_Delayed_Freeze (Implicit_Base, True);

            Set_Ekind              (Derived_Type, Ekind (Parent_Type));
            Set_Etype              (Derived_Type, Implicit_Base);
            Copy_Array_Attributes  (Derived_Type, Parent_Type);

         else
            Error_Msg_N ("illegal constraint on constrained type", Indic);
         end if;
      end if;
   end Build_Derived_Array_Type;

   --------------------------------
   -- Build_Derived_Numeric_Type --
   --------------------------------

   procedure Build_Derived_Numeric_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id)
   is
      Loc           : constant Source_Ptr := Sloc (N);
      Tdef          : constant Node_Id := Type_Definition (N);
      Indic         : constant Node_Id := Subtype_Indication (Tdef);
      Implicit_Base : Entity_Id;
      Lo            : Node_Id;
      Hi            : Node_Id;
      T             : Entity_Id;

   --  Start of processing for Build_Derived_Numeric_Type

   begin
      --  Process the subtype indication including a validation check on
      --  the constraint if any.

      T := Process_Subtype (Indic, N);

      --  Introduce an implicit base type for the derived type even if
      --  there is no constraint attached to it, since this seems closer
      --  to the Ada semantics.

      Implicit_Base :=
        New_Itype (Ekind (Base_Type (Parent_Type)), N, Derived_Type, 'B');

      Set_Etype (Implicit_Base, Parent_Type);
      Set_Esize (Implicit_Base, Esize (Base_Type (Parent_Type)));
      Set_Alignment_Clause
                (Implicit_Base, Alignment_Clause (Parent_Type));

      Lo := New_Copy_Tree (Type_Low_Bound  (Base_Type (Parent_Type)));
      Hi := New_Copy_Tree (Type_High_Bound (Base_Type (Parent_Type)));

      Set_Scalar_Range (Implicit_Base,
        Make_Range (Loc,
          Low_Bound  => Lo,
          High_Bound => Hi));

      --  The Derived_Type, which is the entity of the declaration, is
      --  a subtype of the implicit base. Its Ekind is a subtype, even
      --  in the absence of an explicit constraint.

      Set_Etype (Derived_Type, Implicit_Base);

      if Nkind (Indic) /= N_Subtype_Indication then
         Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
         Set_Scalar_Range (Derived_Type, Scalar_Range (Parent_Type));
      end if;

      if Is_Modular_Integer_Type (Parent_Type) then
         Set_Modulus (Implicit_Base, Modulus (Parent_Type));
         Set_Modulus (Derived_Type, Modulus (Parent_Type));

      elsif Is_Floating_Point_Type (Parent_Type) then
         Set_Digits_Value (Derived_Type,  Digits_Value (Parent_Type));
         Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Type));

      elsif Is_Fixed_Point_Type (Parent_Type) then
         Set_Delta_Value (Derived_Type,  Delta_Value (Parent_Type));
         Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Type));
         Set_Small_Value (Derived_Type,  Small_Value (Parent_Type));
         Set_Small_Value (Implicit_Base, Small_Value (Parent_Type));

         if Is_Decimal_Fixed_Point_Type (Parent_Type) then
            Set_Scale_Value (Derived_Type,  Scale_Value (Parent_Type));
            Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Type));

            Set_Machine_Radix_10
              (Derived_Type,  Machine_Radix_10 (Parent_Type));
            Set_Machine_Radix_10
              (Implicit_Base, Machine_Radix_10 (Parent_Type));
         end if;
      end if;
   end Build_Derived_Numeric_Type;

   ------------------------------------
   -- Build_Derived_Enumeration_Type --
   ------------------------------------

   procedure Build_Derived_Enumeration_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id)
   is
      Loc           : constant Source_Ptr := Sloc (N);
      Def           : constant Node_Id    := Type_Definition (N);
      Indic         : constant Node_Id    := Subtype_Indication (Def);
      Implicit_Base : Entity_Id;
      Literal       : Entity_Id;
      New_Lit       : Entity_Id;
      Literals_List : List_Id;
      Type_Decl     : Node_Id;
      I_Node        : Node_Id;

   begin
      --  Since types Standard.Character and Standard.Wide_Character do
      --  not have explicit literals lists we need to process types derived
      --  from them specially. This is handled by Derived_Standard_Character.
      --  If the parent type is a generic type, there are no literals either,
      --  and we construct the same skeletal representation as for the generic
      --  parent type.

      if Root_Type (Parent_Type) = Standard_Character
        or else Root_Type (Parent_Type) = Standard_Wide_Character
      then
         Derived_Standard_Character (N, Parent_Type, Derived_Type);

      elsif Is_Generic_Type (Root_Type (Parent_Type)) then
         declare
            Lo : Node_Id;
            Hi : Node_Id;

         begin
            Lo :=
               Make_Attribute_Reference (Loc,
                 Attribute_Name => Name_First,
                 Prefix => New_Reference_To (Derived_Type, Loc));
            Set_Etype (Lo, Derived_Type);

            Hi :=
               Make_Attribute_Reference (Loc,
                 Attribute_Name => Name_Last,
                 Prefix => New_Reference_To (Derived_Type, Loc));
            Set_Etype (Hi, Derived_Type);

            Set_Scalar_Range (Derived_Type,
               Make_Range (Loc,
                 Low_Bound => Lo,
                 High_Bound => Hi));
         end;

      else
         --  Introduce an implicit base type for the derived type even
         --  if there is no constraint attached to it, since this seems
         --  closer to the Ada semantics. Build a full type declaration
         --  tree for the derived type using the implicit base type as
         --  the defining identifier. The build a subtype declaration
         --  tree which applies the constraint (if any) have it replace
         --  the derived type declaration.

         Literal := First_Literal (Parent_Type);
         Literals_List := New_List;

         while Present (Literal)
           and then Ekind (Literal) = E_Enumeration_Literal
         loop
            --  Literals of the derived type have the same representation as
            --  those of the parent type, but this representation can be
            --  overridden by an explicit representation clause. Indicate
            --  that there is no explicit representation given yet.

            New_Lit := New_Copy (Literal);
            Set_Enumeration_Rep_Expr (New_Lit, Empty);

            Append (New_Lit, Literals_List);
            Literal := Next_Literal (Literal);
         end loop;

         Implicit_Base :=
           Make_Defining_Identifier (Loc,
             New_External_Name (Chars (Derived_Type), 'B'));

         Type_Decl :=
           Make_Full_Type_Declaration (Loc,
             Defining_Identifier => Implicit_Base,
             Discriminant_Specifications => No_List,
             Type_Definition =>
               Make_Enumeration_Type_Definition (Loc, Literals_List));

         Mark_Rewrite_Insertion (Type_Decl);
         Insert_Before (N, Type_Decl);
         Analyze (Type_Decl);

         --  After the implicit base is analyzed its Etype needs to be
         --  changed to reflect the fact that it is derived from the
         --  parent type which was ignored during analysis. We also set
         --  the size at this point.

         Set_Etype (Implicit_Base, Parent_Type);

         Set_Esize            (Implicit_Base, Esize             (Parent_Type));
         Set_Alignment_Clause (Implicit_Base,  Alignment_Clause (Parent_Type));

         --  Process the subtype indication including a validation check
         --  on the constraint if any. If a constraint is given, its bounds
         --  must be implicitly converted to the new type.

         if Nkind (Indic) = N_Subtype_Indication then
            declare
               Hi  : Node_Id;
               Lo  : Node_Id;
               R   : Node_Id := Range_Expression (Constraint (Indic));

            begin
               if Nkind (R) = N_Range then
                  Hi :=
                    Make_Unchecked_Type_Conversion (Loc,
                      Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
                      Expression => Relocate_Node (High_Bound (R)));

                  Lo :=
                    Make_Unchecked_Type_Conversion (Loc,
                      Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
                      Expression => Relocate_Node (Low_Bound (R)));

               else
                  --  Constraint is a Range attribute. Replace with the
                  --  explicit mention of the bounds of the prefix, which
                  --  must be a subtype.

                  Analyze (Prefix (R));
                  Hi :=
                    Make_Unchecked_Type_Conversion (Loc,
                      Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
                      Expression =>
                        Make_Attribute_Reference (Loc,
                          Attribute_Name => Name_Last,
                          Prefix =>
                            New_Occurrence_Of (Entity (Prefix (R)), Loc)));

                  Lo :=
                    Make_Unchecked_Type_Conversion (Loc,
                      Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
                      Expression =>
                        Make_Attribute_Reference (Loc,
                        Attribute_Name => Name_First,
                        Prefix =>
                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
               end if;

               I_Node :=
                 Make_Subtype_Indication (Loc,
                   Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
                   Constraint =>
                     Make_Range_Constraint (Loc,
                       Range_Expression => Make_Range (Loc, Lo, Hi)));
            end;

         else
            I_Node := New_Occurrence_Of (Implicit_Base, Loc);
         end if;

         Rewrite_Substitute_Tree (N,
           Make_Subtype_Declaration (Loc,
             Defining_Identifier => Derived_Type,
             Subtype_Indication => I_Node));
         Analyze (N);
      end if;
   end Build_Derived_Enumeration_Type;

   -------------------------------
   -- Build_Derived_Record_Type --
   -------------------------------

   procedure Build_Derived_Record_Type
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id)
   is
      Type_Def : constant Node_Id := Type_Definition (N);
      Indic    : constant Node_Id := Subtype_Indication (Type_Def);
      New_Decl : Node_Id;
      I_Node   : Node_Id;
      Discs    : Elist_Id;
      Loc      : constant Source_Ptr := Sloc (N);
      Derived_Base : Entity_Id;
      Parent_Base  : Entity_Id := Base_Type (Parent_Type);

   begin
      --  A derived record type has the same fields and types as the parent.
      --  If the subtype indication has a constraint,  the constraint must be
      --  applied to the derived type to create the derived subtype. However,
      --  if the declaration has a discriminant part, the constraint on the
      --  parent type does not make the derived type into a constrained type,
      --  but the constraint only serves to rename the discriminants.
      --  For non-tagged types this is the only legal use of new
      --  discriminants.

      if Present (Discriminant_Specifications (N)) then
         New_Scope (Derived_Type);
         Process_Discriminants (N);

         if  Nkind (Indic) = N_Subtype_Indication then
            Discs :=
              Build_Discriminant_Constraints (Parent_Type, Indic, Empty);
         end if;

         End_Scope;
         Derived_Base := Derived_Type;

      else
         --  Introduce an implicit base type (derived from parent) and
         --  make the new derived type a subtype of it.

         Derived_Base :=
              New_Itype_Not_Attached (Ekind (Base_Type (Parent_Base)),
                                      Loc, Derived_Type, 'B');
         Set_Etype (Derived_Base, Parent_Base);

      end if;

      Set_Is_Constrained    (Derived_Base, Is_Constrained    (Parent_Type));
      Set_Is_Limited_Record (Derived_Base, Is_Limited_Record (Parent_Type));
      Set_Has_Discriminants (Derived_Base, Has_Discriminants (Parent_Type));
      Set_Esize             (Derived_Base, Esize             (Parent_Type));
      Set_Alignment_Clause  (Derived_Base, Alignment_Clause  (Parent_Type));

      if Has_Discriminants (Derived_Base) then
         Set_Discriminant_Constraint
                    (Derived_Base, Discriminant_Constraint (Parent_Type));
      end if;

      if Is_Private_Type (Derived_Base) then
         Set_Private_Dependents (Derived_Base, New_Elmt_List);
      end if;

      New_Decl :=
        New_Copy_With_Replacement (Parent (Parent_Base),
          Inherit_Components (N, Parent_Base, Derived_Base));

      if Present (Discriminant_Specifications (N)) then
         Rewrite_Substitute_Tree (N, New_Decl);
      else
         --  Insert derived type before current declaration, and
         --  then rewrite current declaration as a subtype of the
         --  derived base.

         Mark_Rewrite_Insertion (New_Decl);
         Insert_Before (N, New_Decl);
         Set_Depends_On_Private (Derived_Base,
                                 Has_Private_Component (Derived_Base));
         Set_Has_Delayed_Freeze (Derived_Base, True);

         if Nkind (Indic) = N_Subtype_Indication then
            I_Node :=
              Make_Subtype_Indication (Loc,
                Subtype_Mark => New_Occurrence_Of (Derived_Base, Loc),
                Constraint => Constraint (Indic));
         else
            I_Node := New_Occurrence_Of (Derived_Base, Loc);
         end if;

         Rewrite_Substitute_Tree (N,
           Make_Subtype_Declaration (Loc,
             Defining_Identifier => Derived_Type,
             Subtype_Indication => I_Node));
         Analyze (N);
      end if;
   end Build_Derived_Record_Type;

   --------------------------------
   -- Derived_Standard_Character --
   --------------------------------

   procedure Derived_Standard_Character
     (N             : Node_Id;
      Parent_Type   : Entity_Id;
      Derived_Type  : Entity_Id)
   is
      Def           : constant Node_Id   := Type_Definition (N);
      Indic         : constant Node_Id   := Subtype_Indication (Def);
      Implicit_Base : constant Entity_Id :=
                        New_Itype
                          (E_Enumeration_Type, N, Parent_Type, 'B');

      Lo, Hi        : Node_Id;
      R_Node        : Node_Id;

   begin
      Set_Etype (Implicit_Base, Base_Type (Parent_Type));
      Set_Esize (Implicit_Base, Esize (Root_Type (Parent_Type)));
      Set_Is_Character_Type (Implicit_Base, True);

      R_Node := New_Node (N_Range, Sloc (N));
      Set_Low_Bound (R_Node, New_Copy (Type_Low_Bound (Parent_Type)));
      Set_High_Bound (R_Node, New_Copy (Type_High_Bound (Parent_Type)));
      Set_Scalar_Range (Implicit_Base, R_Node);

      R_Node := New_Node (N_Range, Sloc (N));

      Set_Ekind (Derived_Type, E_Enumeration_Subtype);
      Set_Etype (Derived_Type, Implicit_Base);
      Set_Esize (Derived_Type, Esize (Root_Type (Parent_Type)));
      Set_Is_Character_Type (Derived_Type, True);

      if Nkind (Indic) = N_Subtype_Indication then
         Lo := New_Copy (Low_Bound (Range_Expression (Constraint (Indic))));
         Hi := New_Copy (High_Bound (Range_Expression (Constraint (Indic))));
      else
         Lo := New_Copy (Type_Low_Bound (Parent_Type));
         Hi := New_Copy (Type_High_Bound (Parent_Type));
      end if;

      Set_Low_Bound (R_Node, Lo);
      Set_High_Bound (R_Node, Hi);
      Set_Scalar_Range (Derived_Type, R_Node);

      Analyze (Lo);
      Analyze (Hi);
      Resolve (Lo, Derived_Type);
      Resolve (Hi, Derived_Type);

   end Derived_Standard_Character;

   -------------------------------
   -- Build_Derived_Tagged_Type --
   -------------------------------

   procedure Build_Derived_Tagged_Type
     (N            : Node_Id;
      Type_Def     : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id)
   is
      Assoc_List : Elist_Id;
      E          : Entity_Id;

      Subtype_Indic_Case : constant Boolean :=
        Nkind (Subtype_Indication (Type_Def)) = N_Subtype_Indication;

   begin
      Set_Is_Tagged_Type (Derived_Type);
      Set_Primitive_Operations (Derived_Type, New_Elmt_List);
      Set_Is_Limited_Record (Derived_Type, (Is_Limited_Record (Parent_Type)));
      New_Scope (Derived_Type);

      if Type_Access_Level (Derived_Type)
        /= Type_Access_Level (Parent_Type)
      then
         if Is_Controlled (Parent_Type) then
            Error_Msg_N
              ("controlled type must be declared at the library level?",
              Subtype_Indication (Type_Def));
         else
            Error_Msg_N
              ("type extension not allowed at deeper level than parent?",
              Subtype_Indication (Type_Def));
         end if;
         Temporary_Msg_N
           ("this will be a fatal error in the next release?!",
           Subtype_Indication (Type_Def));
         Temporary_Msg_N ("!see gnatinfo.txt for details?!",
           Subtype_Indication (Type_Def));
      end if;

      if Present (Discriminant_Specifications (N)) then
         if Is_Constrained (Parent_Type) or else Subtype_Indic_Case then
            Check_Or_Process_Discriminants (N, Derived_Type);

         else
            --  If a known_discriminant_part is provided then the parent
            --  subtype must be constrained (RM 3.7(13)).

            Error_Msg_N ("unconstrained type not allowed in this context",
              Subtype_Indication (Type_Def));
         end if;

      else
         --  The derived type can only have inherited discriminants if the
         --  parent type is unconstrained

         if Is_Constrained (Parent_Type) or else Subtype_Indic_Case then
            Set_Has_Discriminants (Derived_Type, False);
         else
            Set_Has_Discriminants (Derived_Type, True);
            Set_Discriminant_Constraint (Derived_Type,
              Discriminant_Constraint (Parent_Type));
         end if;
      end if;

      Set_Is_Constrained (Derived_Type, not Has_Discriminants (Derived_Type));

      --  Analyze the extension

      if Nkind (N) = N_Private_Extension_Declaration then
         Set_Ekind (Derived_Type, E_Record_Type_With_Private);
         Assoc_List := Inherit_Components (N, Parent_Type, Derived_Type);

      else
         Set_Ekind (Derived_Type, E_Record_Type);
         Assoc_List := Inherit_Components (N, Parent_Type, Derived_Type);
         Expand_Derived_Record (Derived_Type, Type_Def);

         --  Make previous components visible, to catch duplicates and
         --  invalid dependencies between components, (except for inherited
         --  discriminants that could hide new discriminants).
         --  Non-inherited discriminants are already in scope and visible.

         E := First_Entity (Derived_Type);

         while Present (E) loop
            if Ekind (E) = E_Component
              and then Ekind (Original_Record_Component (E)) /= E_Discriminant
            then
               Set_Homonym (E, Current_Entity (E));
               Set_Current_Entity (E);
               Set_Scope (E, Derived_Type);
               Set_Is_Immediately_Visible (E, True);
               Set_Ekind (E, E_Void);
            end if;

            E := Next_Entity (E);
         end loop;

         Record_Type_Definition
           (Record_Extension_Part (Type_Def), Derived_Type);
      end if;

      End_Scope;

      --  All tagged types defined in Ada.Finalization are controlled

      if Chars (Scope (Derived_Type)) = Name_Finalization
        and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
        and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
      then
         Note_Feature (Controlled_Types, Sloc (Derived_Type));
         Set_Is_Controlled (Derived_Type);
      else
         Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
      end if;

      Make_Class_Wide_Type (Derived_Type);
      Set_Is_Abstract (Derived_Type, Abstract_Present (Type_Def));

      --  The parent type is frozen for non-private extensions (RM 13.13(7)).

      if not Is_Private_Type (Derived_Type) then
         Freeze_Before (N, Parent_Type);
      end if;

   end Build_Derived_Tagged_Type;

   ------------------------
   -- Inherit_Components --
   ------------------------

   function Inherit_Components
     (N            : Node_Id;
      Parent_Type  : Entity_Id;
      Derived_Type : Entity_Id)
      return         Elist_Id
   is
      Assoc_List : Elist_Id := New_Elmt_List;
      Comp       : Entity_Id;
      New_Comp   : Entity_Id;
      Old_Disc   : Entity_Id;

      function Assoc (C : Entity_Id) return Entity_Id;
      --  This function searches the association list, and returns the entity
      --  that is associated with C. A matching entry is assumed to be present.

      procedure Inherit_Discriminant (Old_Disc : Entity_Id);
      --  Procedure to do discriminant inheritance processing for one discr

      function Assoc (C : Entity_Id) return Entity_Id is
         Elmt : Elmt_Id;

      begin
         Elmt := First_Elmt (Assoc_List);

         while Present (Elmt) loop

            if Node (Elmt) = C then
               return Node (Next_Elmt (Elmt));
            end if;

            Elmt := Next_Elmt (Elmt);
         end loop;

         return Empty;
      end Assoc;

      procedure Inherit_Discriminant (Old_Disc : Entity_Id) is
         D_Minal : Node_Id;

      begin
         New_Comp := New_Copy (Old_Disc);
         Set_Scope (New_Comp, Derived_Type);

         Append_Elmt   (Old_Disc, Assoc_List);
         Append_Elmt   (New_Comp, Assoc_List);
         Append_Entity (New_Comp, Derived_Type);

         D_Minal :=
           Make_Defining_Identifier
                (Sloc (N), New_External_Name (Chars (Old_Disc), 'D'));
         Set_Ekind (D_Minal, E_In_Parameter);
         Set_Etype (D_Minal, Etype (Old_Disc));

         Set_Discriminal (New_Comp, D_Minal);
      end Inherit_Discriminant;

   --  Start of processing for Inherit_Components

   begin
      Append_Elmt (Parent_Type,  Assoc_List);
      Append_Elmt (Derived_Type, Assoc_List);

      --  If the declaration has a discriminant part, the discriminants
      --  are already analyzed. If the parent type has discriminants,
      --  then some or all of them may correspond to the new discriminants.
      --  In  the case of untagged types, all of them must correspond.
      --  The correspondence determines the list of components that is built
      --  for the derived type. The discriminant part itself is not used
      --  further. It there are inherited discriminants, the discriminant
      --  part is incomplete,  but this does not affect subsequent expansion
      --  or translation in Gigi.

      if not Is_Tagged_Type (Parent_Type) then

         if Present (Discriminant_Specifications (N)) then
            New_Comp := First_Discriminant (Derived_Type);

            while Present (New_Comp) loop
               Old_Disc := Corresponding_Discriminant (New_Comp);

               if Present (Old_Disc) then
                  Append_Elmt (Old_Disc, Assoc_List);
                  Append_Elmt (New_Comp, Assoc_List);

               else
                  Error_Msg_N ("new discriminants must constrain old ones", N);
               end if;

               New_Comp := Next_Discriminant (New_Comp);
            end loop;

         elsif Has_Discriminants (Parent_Type) then

            --  Inherit all discriminants of parent.

            Old_Disc := First_Discriminant (Parent_Type);

            while Present (Old_Disc) loop
               Inherit_Discriminant (Old_Disc);
               Old_Disc := Next_Discriminant (Old_Disc);
            end loop;
         end if;

      else
         --  Parent type is tagged. Some of the discriminants may be
         --  renamed, some constrained, and some inherited.
         --  First we mark the renamed discriminants.  These renamed
         --  discriminants are not visible components of the derived
         --  type (3.4 (11)).

         if Present (Discriminant_Specifications (N)) then
            New_Comp := First_Discriminant (Derived_Type);

            while Present (New_Comp) loop
               Old_Disc := Corresponding_Discriminant (New_Comp);

               if Present (Old_Disc) then
                  Append_Elmt (Old_Disc, Assoc_List);
                  Append_Elmt (New_Comp, Assoc_List);
               end if;

               New_Comp := Next_Discriminant (New_Comp);
            end loop;
         end if;

         --  Next we inherit the discriminants of the parent which have
         --  not been renamed. If there is a discriminant constraint on
         --  the parent, the inherited components are not discriminants
         --  any longer, and cannot participate in  subsequent constraints
         --  on the derived type.

         if Has_Discriminants (Parent_Type) then
            Old_Disc := First_Discriminant (Parent_Type);

            while Present (Old_Disc) loop

               if No (Assoc (Old_Disc)) then
                  Inherit_Discriminant (Old_Disc);

                  if Is_Constrained (Parent_Type)
                    or else (Nkind (N) = N_Private_Extension_Declaration
                              and then Nkind (Subtype_Indication (N)) =
                                                    N_Subtype_Indication)
                    or else (Nkind (N) = N_Full_Type_Declaration
                              and then Nkind
                                (Subtype_Indication (Type_Definition (N))) =
                                                    N_Subtype_Indication)
                  then
                     --  The old discriminant is now a regular component

                     Set_Ekind (New_Comp, E_Component);
                  end if;
               end if;

               Old_Disc := Next_Discriminant (Old_Disc);
            end loop;
         end if;

      end if;

      --  Finally, inherit non-discriminant components unless they are not
      --  visible because defined or inherited from the full view of the parent

      Comp := First_Entity (Parent_Type);

      while Present (Comp) loop

         if Ekind (Comp) /= E_Component
           or else Chars (Comp) = Name_uParent
         then
            null;

         elsif not Is_Visible_Component (Comp) then
            null;

         else
            New_Comp := New_Copy (Comp);

            Append_Elmt   (Comp,     Assoc_List);
            Append_Elmt   (New_Comp, Assoc_List);
            Append_Entity (New_Comp, Derived_Type);
         end if;

         Comp := Next_Entity (Comp);
      end loop;

      return Assoc_List;

   end Inherit_Components;

   ---------------------
   --  Is_Null_Range --
   ---------------------

   function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
      Typ : Entity_Id := Etype (Lo);

   begin
      --  For discrete types, do the check against the bounds

      if Is_Discrete_Type (Typ) then
         return Expr_Value (Lo) > Expr_Value (Hi);

      --  For now, all other types are considered to be in range, TBSL ???

      else
         return False;
      end if;
   end Is_Null_Range;

   --------------------------
   -- Is_Visible_Component --
   --------------------------

   function Is_Visible_Component (C : Entity_Id) return Boolean is
      Original_Comp  : constant Entity_Id := Original_Record_Component (C);
      Original_Scope : constant Entity_Id := Scope (Original_Comp);

   begin
      --  This test only concern tagged types

      if not Is_Tagged_Type (Original_Scope) then
         return True;

      --  If it is _Parent or _Tag, there is no visiblity issue

      elsif not Comes_From_Source (Original_Comp) then
         return True;

      --  If the component has been declared in an ancestor which is
      --  currently a private type, then it is not visible

      elsif Is_Private_Type (Original_Scope) then
         return False;

      --  There is another wierd way in which a component may be invisible
      --  when the private and the full view are not derived from the same
      --  ancestor. Here is an example :

      --       type A1 is tagged      record F1 : integer; end record;
      --       type A2 is new A2 with record F2 : integer; end record;
      --       type T is new A2 with private;
      --     private
      --       type T is new A1 with private;

      --  In this case, the full view of T inherits F1 and F2 but the
      --  private view inherits only F2

      else
         declare
            Ancestor : Entity_Id := Scope (C);

         begin
            loop
               if Ancestor = Original_Scope then
                  return True;
               elsif Ancestor = Etype (Ancestor) then
                  return False;
               end if;

               Ancestor := Etype (Ancestor);
            end loop;

            return True;
         end;
      end if;
   end Is_Visible_Component;

   ---------------------
   -- In_Visible_Part --
   ---------------------

   function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
   begin
      return
        (Ekind (Scope_Id) = E_Package
            or else Ekind (Scope_Id) = E_Generic_Package)
          and then In_Open_Scopes (Scope_Id)
          and then not In_Package_Body (Scope_Id)
          and then not In_Private_Part (Scope_Id);
   end In_Visible_Part;

   ----------------------------------
   -- Collect_Primitive_Operations --
   ----------------------------------

   function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
      B_Type  : constant Entity_Id := Base_Type (T);
      B_Scope : constant Entity_Id := Scope (B_Type);
      Op_List : Elist_Id;
      Formal  : Entity_Id;
      Is_Prim : Boolean;
      Id      : Entity_Id;

   begin
      --  For tagged types, the primitive operations are collected as they
      --  are declared, and held in an explicit list which is simply returned.

      if Is_Tagged_Type (B_Type) then
         return Primitive_Operations (B_Type);

      else
         Op_List := New_Elmt_List;

         if B_Scope = Standard_Standard then
            if B_Type = Standard_String then
               Append_Elmt (Standard_Op_Concat, Op_List);

            elsif B_Type = Standard_Wide_String then
               Append_Elmt (Standard_Op_Concatw, Op_List);

            else
               null;
            end if;

         elsif Ekind (B_Scope) = E_Package
           or else Ekind (B_Scope) = E_Generic_Package
           or else Is_Derived_Type (B_Type)
         then
            Id := Next_Entity (B_Type);

            while Present (Id) loop
               if Is_Overloadable (Id) then
                  Is_Prim := False;

                  if Base_Type (Etype (Id)) = B_Type then
                     Is_Prim := True;
                  else
                     Formal := First_Formal (Id);
                     while Present (Formal) loop
                        if Base_Type (Etype (Formal)) = B_Type then
                           Is_Prim := True;
                           exit;
                        end if;

                        Formal := Next_Formal (Formal);
                     end loop;
                  end if;

                  if Is_Prim then
                     Append_Elmt (Id, Op_List);
                  end if;
               end if;

               Id := Next_Entity (Id);

            end loop;

         end if;

         return Op_List;
      end if;
   end Collect_Primitive_Operations;

   ------------------------
   -- Derive_Subprograms --
   ------------------------

   procedure Derive_Subprograms (Parent_Type, Derived_Type  : Entity_Id) is
      Op_List    : Elist_Id  := Collect_Primitive_Operations (Parent_Type);
      Elmt       : Elmt_Id;
      Subp       : Entity_Id;
      New_Subp   : Entity_Id;
      Formal     : Entity_Id;
      New_Formal : Entity_Id;

      procedure Replace_Type (Id, New_Id : Entity_Id);
      --  When the type is an anonymous access type, create a new access type
      --  designating the derived type. The implicit type mechanism doesn't
      --  need to be used because inherited subprograms are never used in Gigi.

      procedure Replace_Type (Id, New_Id : Entity_Id) is
         Acc_Type : Entity_Id;

      begin
         --  When the type is an anonymous access type, create a new access
         --  type designating the derived type. The implicit type mechanism
         --  doesn't need to be used because inherited subprograms are never
         --  used in Gigi.

         if Ekind (Etype (Id)) = E_Anonymous_Access_Type
           and then Base_Type (Designated_Type (Etype (Id)))
                  = Base_Type (Parent_Type)
         then
            Acc_Type := New_Copy (Etype (Id));
            Set_Etype (Acc_Type, Acc_Type);
            Set_Directly_Designated_Type (Acc_Type, Derived_Type);

            Set_Etype (New_Id, Acc_Type);

         elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type) then
            Set_Etype (New_Id, Derived_Type);
         else
            Set_Etype (New_Id, Etype (Id));
         end if;
      end Replace_Type;

   --  Start of processing for Derive_Subprograms

   begin
      Elmt := First_Elmt (Op_List);

      while Present (Elmt) loop
         Subp := Node (Elmt);
         New_Subp := New_Entity (N_Defining_Identifier, Sloc (Derived_Type));
         Set_Ekind (New_Subp, Ekind (Subp));
         Set_Chars (New_Subp, Chars (Subp));
         Replace_Type (Subp, New_Subp);
         Conditional_Delay (New_Subp, Subp);

         Formal := First_Formal (Subp);
         while Present (Formal) loop
            New_Formal := New_Copy (Formal);
            Append_Entity (New_Formal, New_Subp);
            Replace_Type (Formal, New_Formal);
            Formal := Next_Formal (Formal);
         end loop;

         Set_Alias (New_Subp, Subp);
         New_Overloaded_Entity (New_Subp);

         --  Indicate that a derived subprogram does not require a body.

         Set_Has_Completion (New_Subp);

         --  A derived function with a controlling result is abstract.
         --  If the Derived_Type is a formal generic derived type,
         --  then inherited operations are not abstract: check is
         --  done at instantiation time.

         if Is_Generic_Type (Derived_Type) then
            null;

         elsif Is_Abstract (Subp)
           or else (Is_Tagged_Type (Derived_Type)
             and then Etype (New_Subp) = Derived_Type)
         then
            Set_Is_Abstract (New_Subp);
         end if;

         Elmt := Next_Elmt (Elmt);
      end loop;
   end Derive_Subprograms;

   -------------------------------------------
   -- Analyze_Private_Extension_Declaration --
   -------------------------------------------

   procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
      T           : constant Entity_Id := Defining_Identifier (N);
      Indic       : constant Node_Id   := Subtype_Indication (N);
      Parent_Type : Entity_Id;

   begin
      Enter_Name (T);

      if Nkind (Indic) = N_Subtype_Indication then
         Find_Type (Subtype_Mark (Indic));
         Parent_Type := Entity (Subtype_Mark (Indic));
      else
         Find_Type (Indic);
         Parent_Type := Entity (Indic);
      end if;

      if not Is_Tagged_Type (Parent_Type) then
         Error_Msg_N
           ("parent of type extension must be a tagged type ", Indic);
         return;
      end if;

      if Ekind (Current_Scope) /= E_Package
        and then Ekind (Current_Scope) /= E_Generic_Package
        and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration
      then
         Error_Msg_N ("invalid context for private extension", N);
      end if;

      Set_Is_Tagged_Type     (T, True);
      Set_Ekind              (T, E_Record_Type_With_Private);
      Set_Esize              (T, Uint_0);
      Set_Alignment_Clause   (T, Alignment_Clause (Parent_Type));
      Set_Etype              (T, Base_Type (Parent_Type));
      Set_Scope              (T, Current_Scope);
      Set_Is_Limited_Record  (T, Is_Limited_Record (Parent_Type));
      Set_Private_Dependents (T, New_Elmt_List);
      Set_Depends_On_Private (T, True);
      Set_Has_Delayed_Freeze (T, True);

      --  Entities declared in Pure unit should be set Is_Pure
      --  Since 'Partition_Id cannot be applied to such an entity

      Set_Is_Pure (T, Is_Pure (Current_Scope));

      Build_Derived_Tagged_Type (N, N, Parent_Type, T);
      Derive_Subprograms (Parent_Type, T);
   end Analyze_Private_Extension_Declaration;

   --------------------------
   -- Make_Class_Wide_Type --
   --------------------------

   procedure Make_Class_Wide_Type  (T : Entity_Id) is
      CW_Type : Entity_Id;
      CW_Name : Name_Id;
      Next_E  : Entity_Id;

   begin

      --  The class wide type can have been defined by the partial view in
      --  which case evertything is already done

      if Present (Class_Wide_Type (T)) then
         return;
      end if;

      CW_Type :=
        New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');

      --  Inherit root type characteristics

      CW_Name := Chars (CW_Type);
      Next_E  := Next_Entity (CW_Type);
      Copy_Node (T, CW_Type);
      Set_Chars (CW_Type, CW_Name);
      Set_Next_Entity (CW_Type, Next_E);
      Set_Has_Delayed_Freeze (CW_Type);

      --  Customize the class-wide type: It has no prim. op., it cannot be
      --  abstract and its Etype points back to the root type

      Set_Ekind (CW_Type, E_Class_Wide_Type);
      Set_Primitive_Operations (CW_Type,  New_Elmt_List);
      Set_Is_Abstract (CW_Type, False);
      Set_Etype (CW_Type, T);
      Set_Is_Constrained (CW_Type, False);
      Set_Class_Wide_Type (T, CW_Type);

      --  The class-wide type of a class-wide type is itself (RM 3.9(14))

      Set_Class_Wide_Type (CW_Type, CW_Type);

   end Make_Class_Wide_Type;

   ----------------------------------
   -- Analyze_Incomplete_Type_Decl --
   ----------------------------------

   procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
      F : constant Boolean := Is_Pure (Current_Scope);
      T : Node_Id;

   begin
      --  Process an incomplete declaration. The identifier must not have been
      --  declared already in the scope. However, an incomplete declaration may
      --  appear in the private part of a package, for a private type that has
      --  already been declared.

      --  In this case, the discriminants (if any) must match.

      T := Find_Type_Name (N);

      Set_Ekind (T, E_Incomplete_Type);
      Set_Etype (T, T);
      New_Scope (T);

      if Present (Discriminant_Specifications (N)) then
         Process_Discriminants (N);
      end if;

      End_Scope;

      --  Entities declared in Pure unit should be set Is_Pure
      --  Since 'Partition_Id cannot be applied to such an entity

      Set_Is_Pure (T, F);
   end Analyze_Incomplete_Type_Decl;

   ----------------------------
   -- Access_Type_Declaration --
   ----------------------------

   procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
      S : constant Node_Id := Subtype_Indication (Def);
      P : constant Node_Id := Parent (Def);

   begin
      --  Check for permissible use of incomplete type

      if Nkind (S) /= N_Subtype_Indication then
         Analyze (S);

         if Ekind (Entity (S)) = E_Incomplete_Type then
            Set_Directly_Designated_Type (T, Entity (S));
         else
            Set_Directly_Designated_Type (T,
              Process_Subtype (S, P, T, 'P'));
         end if;

      else
         Set_Directly_Designated_Type (T,
           Process_Subtype (S, P, T, 'P'));
      end if;

      if All_Present (Def) or Constant_Present (Def) then
         Set_Ekind (T, E_General_Access_Type);
      else
         Set_Ekind (T, E_Access_Type);
      end if;

      if Base_Type (Designated_Type (T)) = T then
         Error_Msg_N ("access type cannot designate itself", S);
      end if;

      Set_Etype     (T, T);
      Set_Esize     (T, UI_From_Int (System_Address_Size));
      Set_Is_Access_Constant (T, Constant_Present (Def));

      --  Note that Has_Tasks is always false, since the access type itself
      --  is not a task type. See Einfo for more description on this point.
      --  Exactly the same consideration applies to Has_Controlled.

      Set_Has_Tasks      (T, False);
      Set_Has_Controlled (T, False);
   end Access_Type_Declaration;

   -----------------------------------
   -- Access_Subprogram_Declaration --
   -----------------------------------

   procedure Access_Subprogram_Declaration
     (T_Name : Entity_Id;
      T_Def  : Node_Id)
   is
      Formals : constant List_Id   := Parameter_Specifications (T_Def);

      --  The attachment of the itype is delayed otherwise it would be at
      --  the beginning of the itype list which is incorrect in presence
      --  of access parameters.

      Desig_Type : constant Entity_Id :=
        New_Itype_Not_Attached (E_Subprogram_Type, Sloc (Parent (T_Def)));

   begin
      if Nkind (T_Def) = N_Access_Function_Definition then
         Analyze (Subtype_Mark (T_Def));
         Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
      else
         Set_Etype (Desig_Type, Standard_Void_Type);
      end if;

      if Present (Formals) then
         New_Scope (Desig_Type);
         Process_Formals (Desig_Type, Formals, Parent (T_Def));
         End_Scope;
      end if;

      Attach_Itype_To (Parent (T_Def), Desig_Type);
      Check_Delayed_Subprogram (Desig_Type);

      Set_Ekind     (T_Name, E_Access_Subprogram_Type);
      Set_Etype     (T_Name, T_Name);
      Set_Esize     (T_Name, UI_From_Int (System_Address_Size));
      Set_Directly_Designated_Type (T_Name, Desig_Type);
   end Access_Subprogram_Declaration;

   ----------------------
   -- Constrain_Access --
   ----------------------

   procedure Constrain_Access
     (Def_Id      : in out Entity_Id;
      S           : Node_Id;
      Related_Nod : Node_Id)
   is
      T             : constant Entity_Id := Entity (Subtype_Mark (S));
      Desig_Type    : constant Entity_Id := Designated_Type (T);
      Desig_Subtype : Entity_Id := Empty;
      Constraint_OK : Boolean := True;

   begin
      if Ekind (Desig_Type) = E_Array_Type
        or else Ekind (Desig_Type) = E_String_Type
      then
         Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');

      elsif Ekind (Desig_Type) = E_Record_Type
        or else Ekind (Desig_Type) = E_Task_Type
        or else Ekind (Desig_Type) = E_Protected_Type
        or else Is_Private_Type (Desig_Type)
      then

         --  ??? The following code is a temporary kludge to ignore
         --  discriminant constraint on access type if
         --  it is constraining the current record. Avoid creating the
         --  implicit subtype of the record we are currently compiling
         --  since right now, we cannot handle these.
         --  For now, just return the access type itself.

         if Desig_Type = Current_Scope
           and then No (Def_Id)
         then
            Def_Id := Entity (Subtype_Mark (S));
            return;
         end if;

         Desig_Subtype := New_Itype (E_Void, Related_Nod);
         Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod);

         if Is_Private_Type (Desig_Type) then
            Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
         end if;

      else
         Error_Msg_N ("invalid constraint on access type", S);
         Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
         Constraint_OK := False;
      end if;

      if No (Def_Id) then
         Def_Id := New_Itype (E_Access_Subtype, Related_Nod);
      else
         Set_Ekind (Def_Id, E_Access_Subtype);
      end if;

      if Constraint_OK then
         Set_Etype (Def_Id, T);
      else
         Set_Etype (Def_Id, Any_Type);
      end if;

      Set_Esize                    (Def_Id, Esize (T));
      Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
      Set_Depends_On_Private       (Def_Id, Has_Private_Component (Def_Id));
      Set_Is_Access_Constant       (Def_Id, Is_Access_Constant (T));
   end Constrain_Access;

   -----------------------
   -- Access_Definition --
   -----------------------

   function Access_Definition
     (Related_Nod : Node_Id;
      N           : Node_Id)
      return        Entity_Id
   is
      Anon_Type : constant Entity_Id :=
        New_Itype (E_Anonymous_Access_Type, Related_Nod,
          Scope_Id => Scope (Current_Scope));

   begin
      if (Ekind (Current_Scope) = E_Entry
           or else Ekind (Current_Scope) = E_Entry_Family)
        and then Is_Task_Type (Etype (Scope (Current_Scope)))
      then
         Error_Msg_N ("task entries cannot have access parameters", N);
      end if;

      Find_Type (Subtype_Mark (N));

      Set_Directly_Designated_Type
                             (Anon_Type, Entity (Subtype_Mark (N)));
      Set_Etype              (Anon_Type, Anon_Type);
      Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));

      --  The annonymous access type is as public as the discriminated type or
      --  subprogram that defines it

      Set_Is_Public          (Anon_Type, Is_Public (Scope (Anon_Type)));
      return Anon_Type;
   end Access_Definition;

   -------------------------
   -- New_Binary_Operator --
   -------------------------

   procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
      Loc : constant Source_Ptr := Sloc (Typ);
      Op  : Entity_Id;

      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
      --  Create abbreviated declaration for the formal of a predefined
      --  Operator 'Op' of type 'Typ'

      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
         Formal : Entity_Id;

      begin
         Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
         Set_Etype (Formal, Typ);
         return Formal;
      end Make_Op_Formal;

   --  Start of processing for Make_Op_Formal

   begin
      Op :=  New_Internal_Entity (E_Operator, Current_Scope, Loc, 'F');

      Set_Etype                   (Op, Typ);
      Set_Chars                   (Op, Op_Name);
      Set_Homonym                 (Op, Get_Name_Entity_Id (Op_Name));
      Set_Is_Immediately_Visible  (Op);
      Set_Is_Internal             (Op);
      Set_Is_Intrinsic_Subprogram (Op);
      Set_Has_Completion          (Op);
      Append_Entity               (Op, Current_Scope);

      Set_Name_Entity_Id (Op_Name, Op);

      Append_Entity (Make_Op_Formal (Typ, Op), Op);
      Append_Entity (Make_Op_Formal (Typ, Op), Op);

   end New_Binary_Operator;

   --------------------------------
   -- Process_Range_Expr_In_Decl --
   --------------------------------

   procedure Process_Range_Expr_In_Decl
     (R           : Node_Id;
      T           : Entity_Id;
      Related_Nod : Node_Id)
   is
      Lo : Node_Id;
      Hi : Node_Id;

   begin
      Analyze (R);
      Resolve (R, Base_Type (T));

      if Nkind (R) = N_Range then
         Lo := Low_Bound (R);
         Hi := High_Bound (R);

         --  Resolve (actually Sem_Eval) has checked that the bounds are in
         --  then range of the base type. Here we check whether the bounds
         --  are in the range of the subtype itself. This is complicated by
         --  the fact that the bounds may represent the null range in which
         --  case the Constraint_Error exception should not be raised.

         if Is_OK_Static_Expression (Lo)
           and then Is_OK_Static_Expression (Hi)
         then
            if not Is_Null_Range (Lo, Hi) then
               if Is_Out_Of_Range (Lo, T) then
                  Compile_Time_Constraint_Error
                    (Lo, "static value out of range?");
               end if;

               if Is_Out_Of_Range (Hi, T) then
                  Compile_Time_Constraint_Error
                    (Hi, "static value out of range?");
               end if;
            end if;

         --  Case of one of the two expressions is not static

         else
            if Present (Related_Nod) then
               Set_Has_Dynamic_Itype (Related_Nod);
            end if;
         end if;
      end if;

      Get_Index_Bounds (R, Lo, Hi);
      Remove_Side_Effects (Lo);
      Remove_Side_Effects (Hi);
   end Process_Range_Expr_In_Decl;

   --------------------------------------
   -- Process_Real_Range_Specification --
   --------------------------------------

   procedure Process_Real_Range_Specification (Def : Node_Id) is
      Spec : constant Node_Id := Real_Range_Specification (Def);
      Lo   : Node_Id;
      Hi   : Node_Id;
      Err  : Boolean := False;

      procedure Analyze_Bound (N : Node_Id);
      --  Analyze and check one bound

      procedure Analyze_Bound (N : Node_Id) is
      begin
         Analyze (N);
         Resolve (N, Any_Real);

         if not Is_OK_Static_Expression (N) then
            Error_Msg_N
              ("bound in real type definition is not static", N);
            Err := True;
         end if;
      end Analyze_Bound;

   begin
      if Present (Spec) then
         Lo := Low_Bound (Spec);
         Hi := High_Bound (Spec);
         Analyze_Bound (Lo);
         Analyze_Bound (Hi);

         --  If error, clear away junk range specification

         if Err then
            Set_Real_Range_Specification (Def, Empty);
         end if;
      end if;
   end Process_Real_Range_Specification;

   ----------------------------------
   -- Set_Scalar_Range_For_Subtype --
   ----------------------------------

   procedure Set_Scalar_Range_For_Subtype
     (Def_Id      : Entity_Id;
      R           : Node_Id;
      Subt        : Node_Id;
      Related_Nod : Node_Id)
   is
   begin
      Set_Scalar_Range (Def_Id, R);

      --  We need to link the range into the tree before resolving it so
      --  that types that are referenced, including importantly the subtype
      --  itself, are properly frozen (Freeze_Expression requires that the
      --  expression be properly linked into the tree). Of course if it is
      --  already linked in, then we do not disturb the current link.

      if No (Parent (R)) then
         Set_Parent (R, Def_Id);
      end if;

      Process_Range_Expr_In_Decl (R, Subt, Related_Nod);
   end Set_Scalar_Range_For_Subtype;

end Sem_Ch3;