gcc/ada/sem_ch3.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 3                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision$
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;    use Atree;
  30 with Checks;   use Checks;
  31 with Elists;   use Elists;
  32 with Einfo;    use Einfo;
  33 with Errout;   use Errout;
  34 with Eval_Fat; use Eval_Fat;
  35 with Exp_Ch3;  use Exp_Ch3;
  36 with Exp_Dist; use Exp_Dist;
  37 with Exp_Util; use Exp_Util;
  38 with Freeze;   use Freeze;
  39 with Itypes;   use Itypes;
  40 with Layout;   use Layout;
  41 with Lib;      use Lib;
  42 with Lib.Xref; use Lib.Xref;
  43 with Namet;    use Namet;
  44 with Nmake;    use Nmake;
  45 with Opt;      use Opt;
  46 with Restrict; use Restrict;
  47 with Rtsfind;  use Rtsfind;
  48 with Sem;      use Sem;
  49 with Sem_Case; use Sem_Case;
  50 with Sem_Cat;  use Sem_Cat;
  51 with Sem_Ch6;  use Sem_Ch6;
  52 with Sem_Ch7;  use Sem_Ch7;
  53 with Sem_Ch8;  use Sem_Ch8;
  54 with Sem_Ch13; use Sem_Ch13;
  55 with Sem_Disp; use Sem_Disp;
  56 with Sem_Dist; use Sem_Dist;
  57 with Sem_Elim; use Sem_Elim;
  58 with Sem_Eval; use Sem_Eval;
  59 with Sem_Mech; use Sem_Mech;
  60 with Sem_Res;  use Sem_Res;
  61 with Sem_Smem; use Sem_Smem;
  62 with Sem_Type; use Sem_Type;
  63 with Sem_Util; use Sem_Util;
  64 with Stand;    use Stand;
  65 with Sinfo;    use Sinfo;
  66 with Snames;   use Snames;
  67 with Tbuild;   use Tbuild;
  68 with Ttypes;   use Ttypes;
  69 with Uintp;    use Uintp;
  70 with Urealp;   use Urealp;
  71
  72 package body Sem_Ch3 is
  73
  74    -----------------------
  75    -- Local Subprograms --
  76    -----------------------
  77
  78    procedure Build_Derived_Type
  79      (N             : Node_Id;
  80       Parent_Type   : Entity_Id;
  81       Derived_Type  : Entity_Id;
  82       Is_Completion : Boolean;
  83       Derive_Subps  : Boolean := True);
  84    --  Create and decorate a Derived_Type given the Parent_Type entity.
  85    --  N is the N_Full_Type_Declaration node containing the derived type
  86    --  definition. Parent_Type is the entity for the parent type in the derived
  87    --  type definition and Derived_Type the actual derived type. Is_Completion
  88    --  must be set to False if Derived_Type is the N_Defining_Identifier node
  89    --  in N (ie Derived_Type = Defining_Identifier (N)). In this case N is not
  90    --  the completion of a private type declaration. If Is_Completion is
  91    --  set to True, N is the completion of a private type declaration and
  92    --  Derived_Type is different from the defining identifier inside N (i.e.
  93    --  Derived_Type /= Defining_Identifier (N)). Derive_Subps indicates whether
  94    --  the parent subprograms should be derived. The only case where this
  95    --  parameter is False is when Build_Derived_Type is recursively called to
  96    --  process an implicit derived full type for a type derived from a private
  97    --  type (in that case the subprograms must only be derived for the private
  98    --  view of the type).
  99    --  ??? These flags need a bit of re-examination and re-documentation:
 100    --  ???  are they both necessary (both seem related to the recursion)?
 101
 102    procedure Build_Derived_Access_Type
 103      (N            : Node_Id;
 104       Parent_Type  : Entity_Id;
 105       Derived_Type : Entity_Id);
 106    --  Subsidiary procedure to Build_Derived_Type. For a derived access type,
 107    --  create an implicit base if the parent type is constrained or if the
 108    --  subtype indication has a constraint.
 109
 110    procedure Build_Derived_Array_Type
 111      (N            : Node_Id;
 112       Parent_Type  : Entity_Id;
 113       Derived_Type : Entity_Id);
 114    --  Subsidiary procedure to Build_Derived_Type. For a derived array type,
 115    --  create an implicit base if the parent type is constrained or if the
 116    --  subtype indication has a constraint.
 117
 118    procedure Build_Derived_Concurrent_Type
 119      (N            : Node_Id;
 120       Parent_Type  : Entity_Id;
 121       Derived_Type : Entity_Id);
 122    --  Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
 123    --  tected type, inherit entries and protected subprograms, check legality
 124    --  of discriminant constraints if any.
 125
 126    procedure Build_Derived_Enumeration_Type
 127      (N            : Node_Id;
 128       Parent_Type  : Entity_Id;
 129       Derived_Type : Entity_Id);
 130    --  Subsidiary procedure to Build_Derived_Type. For a derived enumeration
 131    --  type, we must create a new list of literals. Types derived from
 132    --  Character and Wide_Character are special-cased.
 133
 134    procedure Build_Derived_Numeric_Type
 135      (N            : Node_Id;
 136       Parent_Type  : Entity_Id;
 137       Derived_Type : Entity_Id);
 138    --  Subsidiary procedure to Build_Derived_Type. For numeric types, create
 139    --  an anonymous base type, and propagate constraint to subtype if needed.
 140
 141    procedure Build_Derived_Private_Type
 142      (N            : Node_Id;
 143       Parent_Type  : Entity_Id;
 144       Derived_Type : Entity_Id;
 145       Is_Completion : Boolean;
 146       Derive_Subps  : Boolean := True);
 147    --  Substidiary procedure to Build_Derived_Type. This procedure is complex
 148    --  because the parent may or may not have a completion, and the derivation
 149    --  may itself be a completion.
 150
 151    procedure Build_Derived_Record_Type
 152      (N            : Node_Id;
 153       Parent_Type  : Entity_Id;
 154       Derived_Type : Entity_Id;
 155       Derive_Subps : Boolean := True);
 156    --  Subsidiary procedure to Build_Derived_Type and
 157    --  Analyze_Private_Extension_Declaration used for tagged and untagged
 158    --  record types. All parameters are as in Build_Derived_Type except that
 159    --  N, in addition to being an N_Full_Type_Declaration node, can also be an
 160    --  N_Private_Extension_Declaration node. See the definition of this routine
 161    --  for much more info. Derive_Subps indicates whether subprograms should
 162    --  be derived from the parent type. The only case where Derive_Subps is
 163    --  False is for an implicit derived full type for a type derived from a
 164    --  private type (see Build_Derived_Type).
 165
 166    function Inherit_Components
 167      (N             : Node_Id;
 168       Parent_Base   : Entity_Id;
 169       Derived_Base  : Entity_Id;
 170       Is_Tagged     : Boolean;
 171       Inherit_Discr : Boolean;
 172       Discs         : Elist_Id)
 173       return          Elist_Id;
 174    --  Called from Build_Derived_Record_Type to inherit the components of
 175    --  Parent_Base (a base type) into the Derived_Base (the derived base type).
 176    --  For more information on derived types and component inheritance please
 177    --  consult the comment above the body of Build_Derived_Record_Type.
 178    --
 179    --  N is the original derived type declaration.
 180    --  Is_Tagged is set if we are dealing with tagged types.
 181    --  If Inherit_Discr is set, Derived_Base inherits its discriminants from
 182    --  Parent_Base, otherwise no discriminants are inherited.
 183    --  Discs gives the list of constraints that apply to Parent_Base in the
 184    --  derived type declaration. If Discs is set to No_Elist, then we have the
 185    --  following situation:
 186    --
 187    --     type Parent (D1..Dn : ..) is [tagged] record ...;
 188    --     type Derived is new Parent [with ...];
 189    --
 190    --  which gets treated as
 191    --
 192    --     type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
 193    --
 194    --  For untagged types the returned value is an association list:
 195    --  (Old_Component => New_Component), where Old_Component is the Entity_Id
 196    --  of a component in Parent_Base and New_Component is the Entity_Id of the
 197    --  corresponding component in Derived_Base. For untagged records, this
 198    --  association list is needed when copying the record declaration for the
 199    --  derived base. In the tagged case the value returned is irrelevant.
 200
 201    procedure Build_Discriminal (Discrim : Entity_Id);
 202    --  Create the discriminal corresponding to discriminant Discrim, that is
 203    --  the parameter corresponding to Discrim to be used in initialization
 204    --  procedures for the type where Discrim is a discriminant. Discriminals
 205    --  are not used during semantic analysis, and are not fully defined
 206    --  entities until expansion. Thus they are not given a scope until
 207    --  initialization procedures are built.
 208
 209    function Build_Discriminant_Constraints
 210      (T           : Entity_Id;
 211       Def         : Node_Id;
 212       Derived_Def : Boolean := False)
 213       return        Elist_Id;
 214    --  Validate discriminant constraints, and return the list of the
 215    --  constraints in order of discriminant declarations. T is the
 216    --  discriminated unconstrained type. Def is the N_Subtype_Indication
 217    --  node where the discriminants constraints for T are specified.
 218    --  Derived_Def is True if we are building the discriminant constraints
 219    --  in a derived type definition of the form "type D (...) is new T (xxx)".
 220    --  In this case T is the parent type and Def is the constraint "(xxx)" on
 221    --  T and this routine sets the Corresponding_Discriminant field of the
 222    --  discriminants in the derived type D to point to the corresponding
 223    --  discriminants in the parent type T.
 224
 225    procedure Build_Discriminated_Subtype
 226      (T           : Entity_Id;
 227       Def_Id      : Entity_Id;
 228       Elist       : Elist_Id;
 229       Related_Nod : Node_Id;
 230       For_Access  : Boolean := False);
 231    --  Subsidiary procedure to Constrain_Discriminated_Type and to
 232    --  Process_Incomplete_Dependents. Given
 233    --
 234    --     T (a possibly discriminated base type)
 235    --     Def_Id (a very partially built subtype for T),
 236    --
 237    --  the call completes Def_Id to be the appropriate E_*_Subtype.
 238    --
 239    --  The Elist is the list of discriminant constraints if any (it is set to
 240    --  No_Elist if T is not a discriminated type, and to an empty list if
 241    --  T has discriminants but there are no discriminant constraints). The
 242    --  Related_Nod is the same as Decl_Node in Create_Constrained_Components.
 243    --  The For_Access says whether or not this subtype is really constraining
 244    --  an access type. That is its sole purpose is the designated type of an
 245    --  access type -- in which case a Private_Subtype Is_For_Access_Subtype
 246    --  is built to avoid freezing T when the access subtype is frozen.
 247
 248    function Build_Scalar_Bound
 249      (Bound : Node_Id;
 250       Par_T : Entity_Id;
 251       Der_T : Entity_Id;
 252       Loc   : Source_Ptr)
 253       return  Node_Id;
 254    --  The bounds of a derived scalar type are conversions of the bounds of
 255    --  the parent type. Optimize the representation if the bounds are literals.
 256    --  Needs a more complete spec--what are the parameters exactly, and what
 257    --  exactly is the returned value, and how is Bound affected???
 258
 259    procedure Build_Underlying_Full_View
 260      (N   : Node_Id;
 261       Typ : Entity_Id;
 262       Par : Entity_Id);
 263    --  If the completion of a private type is itself derived from a private
 264    --  type, or if the full view of a private subtype is itself private, the
 265    --  back-end has no way to compute the actual size of this type. We build
 266    --  an internal subtype declaration of the proper parent type to convey
 267    --  this information. This extra mechanism is needed because a full
 268    --  view cannot itself have a full view (it would get clobbered during
 269    --  view exchanges).
 270
 271    procedure Check_Access_Discriminant_Requires_Limited
 272      (D   : Node_Id;
 273       Loc : Node_Id);
 274    --  Check the restriction that the type to which an access discriminant
 275    --  belongs must be a concurrent type or a descendant of a type with
 276    --  the reserved word 'limited' in its declaration.
 277
 278    procedure Check_Delta_Expression (E : Node_Id);
 279    --  Check that the expression represented by E is suitable for use as
 280    --  a delta expression, i.e. it is of real type and is static.
 281
 282    procedure Check_Digits_Expression (E : Node_Id);
 283    --  Check that the expression represented by E is suitable for use as
 284    --  a digits expression, i.e. it is of integer type, positive and static.
 285
 286    procedure Check_Incomplete (T : Entity_Id);
 287    --  Called to verify that an incomplete type is not used prematurely
 288
 289    procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
 290    --  Validate the initialization of an object declaration. T is the
 291    --  required type, and Exp is the initialization expression.
 292
 293    procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id);
 294    --  If T is the full declaration of an incomplete or private type, check
 295    --  the conformance of the discriminants, otherwise process them.
 296
 297    procedure Check_Real_Bound (Bound : Node_Id);
 298    --  Check given bound for being of real type and static. If not, post an
 299    --  appropriate message, and rewrite the bound with the real literal zero.
 300
 301    procedure Constant_Redeclaration
 302      (Id : Entity_Id;
 303       N  : Node_Id;
 304       T  : out Entity_Id);
 305    --  Various checks on legality of full declaration of deferred constant.
 306    --  Id is the entity for the redeclaration, N is the N_Object_Declaration,
 307    --  node. The caller has not yet set any attributes of this entity.
 308
 309    procedure Convert_Scalar_Bounds
 310      (N            : Node_Id;
 311       Parent_Type  : Entity_Id;
 312       Derived_Type : Entity_Id;
 313       Loc          : Source_Ptr);
 314    --  For derived scalar types, convert the bounds in the type definition
 315    --  to the derived type, and complete their analysis.
 316
 317    procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
 318    --  Copies attributes from array base type T2 to array base type T1.
 319    --  Copies only attributes that apply to base types, but not subtypes.
 320
 321    procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
 322    --  Copies attributes from array subtype T2 to array subtype T1. Copies
 323    --  attributes that apply to both subtypes and base types.
 324
 325    procedure Create_Constrained_Components
 326      (Subt        : Entity_Id;
 327       Decl_Node   : Node_Id;
 328       Typ         : Entity_Id;
 329       Constraints : Elist_Id);
 330    --  Build the list of entities for a constrained discriminated record
 331    --  subtype. If a component depends on a discriminant, replace its subtype
 332    --  using the discriminant values in the discriminant constraint.
 333    --  Subt is the defining identifier for the subtype whose list of
 334    --  constrained entities we will create. Decl_Node is the type declaration
 335    --  node where we will attach all the itypes created. Typ is the base
 336    --  discriminated type for the subtype Subt. Constraints is the list of
 337    --  discriminant constraints for Typ.
 338
 339    function Constrain_Component_Type
 340      (Compon_Type     : Entity_Id;
 341       Constrained_Typ : Entity_Id;
 342       Related_Node    : Node_Id;
 343       Typ             : Entity_Id;
 344       Constraints     : Elist_Id)
 345       return            Entity_Id;
 346    --  Given a discriminated base type Typ, a list of discriminant constraint
 347    --  Constraints for Typ and the type of a component of Typ, Compon_Type,
 348    --  create and return the type corresponding to Compon_type where all
 349    --  discriminant references are replaced with the corresponding
 350    --  constraint. If no discriminant references occurr in Compon_Typ then
 351    --  return it as is. Constrained_Typ is the final constrained subtype to
 352    --  which the constrained Compon_Type belongs. Related_Node is the node
 353    --  where we will attach all the itypes created.
 354
 355    procedure Constrain_Access
 356      (Def_Id      : in out Entity_Id;
 357       S           : Node_Id;
 358       Related_Nod : Node_Id);
 359    --  Apply a list of constraints to an access type. If Def_Id is empty,
 360    --  it is an anonymous type created for a subtype indication. In that
 361    --  case it is created in the procedure and attached to Related_Nod.
 362
 363    procedure Constrain_Array
 364      (Def_Id      : in out Entity_Id;
 365       SI          : Node_Id;
 366       Related_Nod : Node_Id;
 367       Related_Id  : Entity_Id;
 368       Suffix      : Character);
 369    --  Apply a list of index constraints to an unconstrained array type. The
 370    --  first parameter is the entity for the resulting subtype. A value of
 371    --  Empty for Def_Id indicates that an implicit type must be created, but
 372    --  creation is delayed (and must be done by this procedure) because other
 373    --  subsidiary implicit types must be created first (which is why Def_Id
 374    --  is an in/out parameter). Related_Nod gives the place where this type has
 375    --  to be inserted in the tree. The Related_Id and Suffix parameters are
 376    --  used to build the associated Implicit type name.
 377
 378    procedure Constrain_Concurrent
 379      (Def_Id      : in out Entity_Id;
 380       SI          : Node_Id;
 381       Related_Nod : Node_Id;
 382       Related_Id  : Entity_Id;
 383       Suffix      : Character);
 384    --  Apply list of discriminant constraints to an unconstrained concurrent
 385    --  type.
 386    --
 387    --    SI is the N_Subtype_Indication node containing the constraint and
 388    --    the unconstrained type to constrain.
 389    --
 390    --    Def_Id is the entity for the resulting constrained subtype. A
 391    --    value of Empty for Def_Id indicates that an implicit type must be
 392    --    created, but creation is delayed (and must be done by this procedure)
 393    --    because other subsidiary implicit types must be created first (which
 394    --    is why Def_Id is an in/out parameter).
 395    --
 396    --    Related_Nod gives the place where this type has to be inserted
 397    --    in the tree
 398    --
 399    --  The last two arguments are used to create its external name if needed.
 400
 401    function Constrain_Corresponding_Record
 402      (Prot_Subt   : Entity_Id;
 403       Corr_Rec    : Entity_Id;
 404       Related_Nod : Node_Id;
 405       Related_Id  : Entity_Id)
 406       return Entity_Id;
 407    --  When constraining a protected type or task type with discriminants,
 408    --  constrain the corresponding record with the same discriminant values.
 409
 410    procedure Constrain_Decimal
 411      (Def_Id      : Node_Id;
 412       S           : Node_Id;
 413       Related_Nod : Node_Id);
 414    --  Constrain a decimal fixed point type with a digits constraint and/or a
 415    --  range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
 416
 417    procedure Constrain_Discriminated_Type
 418      (Def_Id      : Entity_Id;
 419       S           : Node_Id;
 420       Related_Nod : Node_Id;
 421       For_Access  : Boolean := False);
 422    --  Process discriminant constraints of composite type. Verify that values
 423    --  have been provided for all discriminants, that the original type is
 424    --  unconstrained, and that the types of the supplied expressions match
 425    --  the discriminant types. The first three parameters are like in routine
 426    --  Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
 427    --  of For_Access.
 428
 429    procedure Constrain_Enumeration
 430      (Def_Id      : Node_Id;
 431       S           : Node_Id;
 432       Related_Nod : Node_Id);
 433    --  Constrain an enumeration type with a range constraint. This is
 434    --  identical to Constrain_Integer, but for the Ekind of the
 435    --  resulting subtype.
 436
 437    procedure Constrain_Float
 438      (Def_Id      : Node_Id;
 439       S           : Node_Id;
 440       Related_Nod : Node_Id);
 441    --  Constrain a floating point type with either a digits constraint
 442    --  and/or a range constraint, building a E_Floating_Point_Subtype.
 443
 444    procedure Constrain_Index
 445      (Index        : Node_Id;
 446       S            : Node_Id;
 447       Related_Nod  : Node_Id;
 448       Related_Id   : Entity_Id;
 449       Suffix       : Character;
 450       Suffix_Index : Nat);
 451    --  Process an index constraint in a constrained array declaration.
 452    --  The constraint can be a subtype name, or a range with or without
 453    --  an explicit subtype mark. The index is the corresponding index of the
 454    --  unconstrained array. The Related_Id and Suffix parameters are used to
 455    --  build the associated Implicit type name.
 456
 457    procedure Constrain_Integer
 458      (Def_Id      : Node_Id;
 459       S           : Node_Id;
 460       Related_Nod : Node_Id);
 461    --  Build subtype of a signed or modular integer type.
 462
 463    procedure Constrain_Ordinary_Fixed
 464      (Def_Id      : Node_Id;
 465       S           : Node_Id;
 466       Related_Nod : Node_Id);
 467    --  Constrain an ordinary fixed point type with a range constraint, and
 468    --  build an E_Ordinary_Fixed_Point_Subtype entity.
 469
 470    procedure Copy_And_Swap (Privat, Full : Entity_Id);
 471    --  Copy the Privat entity into the entity of its full declaration
 472    --  then swap the two entities in such a manner that the former private
 473    --  type is now seen as a full type.
 474
 475    procedure Copy_Private_To_Full (Priv, Full : Entity_Id);
 476    --  Initialize the full view declaration with the relevant fields
 477    --  from the private view.
 478
 479    procedure Decimal_Fixed_Point_Type_Declaration
 480      (T   : Entity_Id;
 481       Def : Node_Id);
 482    --  Create a new decimal fixed point type, and apply the constraint to
 483    --  obtain a subtype of this new type.
 484
 485    procedure Complete_Private_Subtype
 486      (Priv        : Entity_Id;
 487       Full        : Entity_Id;
 488       Full_Base   : Entity_Id;
 489       Related_Nod : Node_Id);
 490    --  Complete the implicit full view of a private subtype by setting
 491    --  the appropriate semantic fields. If the full view of the parent is
 492    --  a record type, build constrained components of subtype.
 493
 494    procedure Derived_Standard_Character
 495      (N             : Node_Id;
 496       Parent_Type   : Entity_Id;
 497       Derived_Type  : Entity_Id);
 498    --  Subsidiary procedure to Build_Derived_Enumeration_Type which handles
 499    --  derivations from types Standard.Character and Standard.Wide_Character.
 500
 501    procedure Derived_Type_Declaration
 502      (T             : Entity_Id;
 503       N             : Node_Id;
 504       Is_Completion : Boolean);
 505    --  Process a derived type declaration. This routine will invoke
 506    --  Build_Derived_Type to process the actual derived type definition.
 507    --  Parameters N and Is_Completion have the same meaning as in
 508    --  Build_Derived_Type. T is the N_Defining_Identifier for the entity
 509    --  defined in the N_Full_Type_Declaration node N, that is T is the
 510    --  derived type.
 511
 512    function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id;
 513    --  Given a subtype indication S (which is really an N_Subtype_Indication
 514    --  node or a plain N_Identifier), find the type of the subtype mark.
 515
 516    procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
 517    --  Insert each literal in symbol table, as an overloadable identifier
 518    --  Each enumeration type is mapped into a sequence of integers, and
 519    --  each literal is defined as a constant with integer value. If any
 520    --  of the literals are character literals, the type is a character
 521    --  type, which means that strings are legal aggregates for arrays of
 522    --  components of the type.
 523
 524    procedure Expand_Others_Choice
 525      (Case_Table     : Choice_Table_Type;
 526       Others_Choice  : Node_Id;
 527       Choice_Type    : Entity_Id);
 528    --  In the case of a variant part of a record type that has an OTHERS
 529    --  choice, this procedure expands the OTHERS into the actual choices
 530    --  that it represents. This new list of choice nodes is attached to
 531    --  the OTHERS node via the Others_Discrete_Choices field. The Case_Table
 532    --  contains all choices that have been given explicitly in the variant.
 533
 534    function Find_Type_Of_Object
 535      (Obj_Def     : Node_Id;
 536       Related_Nod : Node_Id)
 537       return        Entity_Id;
 538    --  Get type entity for object referenced by Obj_Def, attaching the
 539    --  implicit types generated to Related_Nod
 540
 541    procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
 542    --  Create a new float, and apply the constraint to obtain subtype of it
 543
 544    function Has_Range_Constraint (N : Node_Id) return Boolean;
 545    --  Given an N_Subtype_Indication node N, return True if a range constraint
 546    --  is present, either directly, or as part of a digits or delta constraint.
 547    --  In addition, a digits constraint in the decimal case returns True, since
 548    --  it establishes a default range if no explicit range is present.
 549
 550    function Is_Valid_Constraint_Kind
 551      (T_Kind          : Type_Kind;
 552       Constraint_Kind : Node_Kind)
 553       return Boolean;
 554    --  Returns True if it is legal to apply the given kind of constraint
 555    --  to the given kind of type (index constraint to an array type,
 556    --  for example).
 557
 558    procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
 559    --  Create new modular type. Verify that modulus is in  bounds and is
 560    --  a power of two (implementation restriction).
 561
 562    procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
 563    --  Create an abbreviated declaration for an operator in order to
 564    --  materialize minimally operators on derived types.
 565
 566    procedure Ordinary_Fixed_Point_Type_Declaration
 567      (T   : Entity_Id;
 568       Def : Node_Id);
 569    --  Create a new ordinary fixed point type, and apply the constraint
 570    --  to obtain subtype of it.
 571
 572    procedure Prepare_Private_Subtype_Completion
 573      (Id          : Entity_Id;
 574       Related_Nod : Node_Id);
 575    --  Id is a subtype of some private type. Creates the full declaration
 576    --  associated with Id whenever possible, i.e. when the full declaration
 577    --  of the base type is already known. Records each subtype into
 578    --  Private_Dependents of the base type.
 579
 580    procedure Process_Incomplete_Dependents
 581      (N      : Node_Id;
 582       Full_T : Entity_Id;
 583       Inc_T  : Entity_Id);
 584    --  Process all entities that depend on an incomplete type. There include
 585    --  subtypes, subprogram types that mention the incomplete type in their
 586    --  profiles, and subprogram with access parameters that designate the
 587    --  incomplete type.
 588
 589    --  Inc_T is the defining identifier of an incomplete type declaration, its
 590    --  Ekind is E_Incomplete_Type.
 591    --
 592    --    N is the corresponding N_Full_Type_Declaration for Inc_T.
 593    --
 594    --    Full_T is N's defining identifier.
 595    --
 596    --  Subtypes of incomplete types with discriminants are completed when the
 597    --  parent type is. This is simpler than private subtypes, because they can
 598    --  only appear in the same scope, and there is no need to exchange views.
 599    --  Similarly, access_to_subprogram types may have a parameter or a return
 600    --  type that is an incomplete type, and that must be replaced with the
 601    --  full type.
 602
 603    --  If the full type is tagged, subprogram with access parameters that
 604    --  designated the incomplete may be primitive operations of the full type,
 605    --  and have to be processed accordingly.
 606
 607    procedure Process_Real_Range_Specification (Def : Node_Id);
 608    --  Given the type definition for a real type, this procedure processes
 609    --  and checks the real range specification of this type definition if
 610    --  one is present. If errors are found, error messages are posted, and
 611    --  the Real_Range_Specification of Def is reset to Empty.
 612
 613    procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id);
 614    --  Process a record type declaration (for both untagged and tagged
 615    --  records). Parameters T and N are exactly like in procedure
 616    --  Derived_Type_Declaration, except that no flag Is_Completion is
 617    --  needed for this routine.
 618
 619    procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id);
 620    --  This routine is used to process the actual record type definition
 621    --  (both for untagged and tagged records). Def is a record type
 622    --  definition node. This procedure analyzes the components in this
 623    --  record type definition. T is the entity for the enclosing record
 624    --  type. It is provided so that its Has_Task flag can be set if any of
 625    --  the component have Has_Task set.
 626
 627    procedure Set_Fixed_Range
 628      (E   : Entity_Id;
 629       Loc : Source_Ptr;
 630       Lo  : Ureal;
 631       Hi  : Ureal);
 632    --  Build a range node with the given bounds and set it as the Scalar_Range
 633    --  of the given fixed-point type entity. Loc is the source location used
 634    --  for the constructed range. See body for further details.
 635
 636    procedure Set_Scalar_Range_For_Subtype
 637      (Def_Id      : Entity_Id;
 638       R           : Node_Id;
 639       Subt        : Entity_Id;
 640       Related_Nod : Node_Id);
 641    --  This routine is used to set the scalar range field for a subtype
 642    --  given Def_Id, the entity for the subtype, and R, the range expression
 643    --  for the scalar range. Subt provides the parent subtype to be used
 644    --  to analyze, resolve, and check the given range.
 645
 646    procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
 647    --  Create a new signed integer entity, and apply the constraint to obtain
 648    --  the required first named subtype of this type.
 649
 650    -----------------------
 651    -- Access_Definition --
 652    -----------------------
 653
 654    function Access_Definition
 655      (Related_Nod : Node_Id;
 656       N           : Node_Id)
 657       return        Entity_Id
 658    is
 659       Anon_Type : constant Entity_Id :=
 660                     Create_Itype (E_Anonymous_Access_Type, Related_Nod,
 661                                   Scope_Id => Scope (Current_Scope));
 662       Desig_Type : Entity_Id;
 663
 664    begin
 665       if Is_Entry (Current_Scope)
 666         and then Is_Task_Type (Etype (Scope (Current_Scope)))
 667       then
 668          Error_Msg_N ("task entries cannot have access parameters", N);
 669       end if;
 670
 671       Find_Type (Subtype_Mark (N));
 672       Desig_Type := Entity (Subtype_Mark (N));
 673
 674       Set_Directly_Designated_Type
 675                              (Anon_Type, Desig_Type);
 676       Set_Etype              (Anon_Type, Anon_Type);
 677       Init_Size_Align        (Anon_Type);
 678       Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
 679
 680       --  The anonymous access type is as public as the discriminated type or
 681       --  subprogram that defines it. It is imported (for back-end purposes)
 682       --  if the designated type is.
 683
 684       Set_Is_Public          (Anon_Type, Is_Public (Scope (Anon_Type)));
 685       Set_From_With_Type     (Anon_Type, From_With_Type (Desig_Type));
 686
 687       --  The context is either a subprogram declaration or an access
 688       --  discriminant, in a private or a full type declaration. In
 689       --  the case of a subprogram, If the designated type is incomplete,
 690       --  the operation will be a primitive operation of the full type, to
 691       --  be updated subsequently.
 692
 693       if Ekind (Desig_Type) = E_Incomplete_Type
 694         and then Is_Overloadable (Current_Scope)
 695       then
 696          Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
 697          Set_Has_Delayed_Freeze (Current_Scope);
 698       end if;
 699
 700       return Anon_Type;
 701    end Access_Definition;
 702
 703    -----------------------------------
 704    -- Access_Subprogram_Declaration --
 705    -----------------------------------
 706
 707    procedure Access_Subprogram_Declaration
 708      (T_Name : Entity_Id;
 709       T_Def  : Node_Id)
 710    is
 711       Formals : constant List_Id   := Parameter_Specifications (T_Def);
 712       Formal  : Entity_Id;
 713       Desig_Type : constant Entity_Id :=
 714                    Create_Itype (E_Subprogram_Type, Parent (T_Def));
 715
 716    begin
 717       if Nkind (T_Def) = N_Access_Function_Definition then
 718          Analyze (Subtype_Mark (T_Def));
 719          Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
 720       else
 721          Set_Etype (Desig_Type, Standard_Void_Type);
 722       end if;
 723
 724       if Present (Formals) then
 725          New_Scope (Desig_Type);
 726          Process_Formals (Desig_Type, Formals, Parent (T_Def));
 727
 728          --  A bit of a kludge here, End_Scope requires that the parent
 729          --  pointer be set to something reasonable, but Itypes don't
 730          --  have parent pointers. So we set it and then unset it ???
 731          --  If and when Itypes have proper parent pointers to their
 732          --  declarations, this kludge can be removed.
 733
 734          Set_Parent (Desig_Type, T_Name);
 735          End_Scope;
 736          Set_Parent (Desig_Type, Empty);
 737       end if;
 738
 739       --  The return type and/or any parameter type may be incomplete. Mark
 740       --  the subprogram_type as depending on the incomplete type, so that
 741       --  it can be updated when the full type declaration is seen.
 742
 743       if Present (Formals) then
 744          Formal := First_Formal (Desig_Type);
 745
 746          while Present (Formal) loop
 747
 748             if Ekind (Formal) /= E_In_Parameter
 749               and then Nkind (T_Def) = N_Access_Function_Definition
 750             then
 751                Error_Msg_N ("functions can only have IN parameters", Formal);
 752             end if;
 753
 754             if Ekind (Etype (Formal)) = E_Incomplete_Type then
 755                Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
 756                Set_Has_Delayed_Freeze (Desig_Type);
 757             end if;
 758
 759             Next_Formal (Formal);
 760          end loop;
 761       end if;
 762
 763       if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
 764         and then not Has_Delayed_Freeze (Desig_Type)
 765       then
 766          Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
 767          Set_Has_Delayed_Freeze (Desig_Type);
 768       end if;
 769
 770       Check_Delayed_Subprogram (Desig_Type);
 771
 772       if Protected_Present (T_Def) then
 773          Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
 774          Set_Convention (Desig_Type, Convention_Protected);
 775       else
 776          Set_Ekind (T_Name, E_Access_Subprogram_Type);
 777       end if;
 778
 779       Set_Etype                    (T_Name, T_Name);
 780       Init_Size_Align              (T_Name);
 781       Set_Directly_Designated_Type (T_Name, Desig_Type);
 782
 783       Check_Restriction (No_Access_Subprograms, T_Def);
 784    end Access_Subprogram_Declaration;
 785
 786    ----------------------------
 787    -- Access_Type_Declaration --
 788    ----------------------------
 789
 790    procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
 791       S : constant Node_Id := Subtype_Indication (Def);
 792       P : constant Node_Id := Parent (Def);
 793
 794    begin
 795       --  Check for permissible use of incomplete type
 796
 797       if Nkind (S) /= N_Subtype_Indication then
 798          Analyze (S);
 799
 800          if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
 801             Set_Directly_Designated_Type (T, Entity (S));
 802          else
 803             Set_Directly_Designated_Type (T,
 804               Process_Subtype (S, P, T, 'P'));
 805          end if;
 806
 807       else
 808          Set_Directly_Designated_Type (T,
 809            Process_Subtype (S, P, T, 'P'));
 810       end if;
 811
 812       if All_Present (Def) or Constant_Present (Def) then
 813          Set_Ekind (T, E_General_Access_Type);
 814       else
 815          Set_Ekind (T, E_Access_Type);
 816       end if;
 817
 818       if Base_Type (Designated_Type (T)) = T then
 819          Error_Msg_N ("access type cannot designate itself", S);
 820       end if;
 821
 822       Set_Etype              (T, T);
 823
 824       --  If the type has appeared already in a with_type clause, it is
 825       --  frozen and the pointer size is already set. Else, initialize.
 826
 827       if not From_With_Type (T) then
 828          Init_Size_Align (T);
 829       end if;
 830
 831       Set_Is_Access_Constant (T, Constant_Present (Def));
 832
 833       --  If designated type is an imported tagged type, indicate that the
 834       --  access type is also imported, and therefore restricted in its use.
 835       --  The access type may already be imported, so keep setting otherwise.
 836
 837       if From_With_Type (Designated_Type (T)) then
 838          Set_From_With_Type (T);
 839       end if;
 840
 841       --  Note that Has_Task is always false, since the access type itself
 842       --  is not a task type. See Einfo for more description on this point.
 843       --  Exactly the same consideration applies to Has_Controlled_Component.
 844
 845       Set_Has_Task (T, False);
 846       Set_Has_Controlled_Component (T, False);
 847    end Access_Type_Declaration;
 848
 849    -----------------------------------
 850    -- Analyze_Component_Declaration --
 851    -----------------------------------
 852
 853    procedure Analyze_Component_Declaration (N : Node_Id) is
 854       Id : constant Entity_Id := Defining_Identifier (N);
 855       T  : Entity_Id;
 856       P  : Entity_Id;
 857
 858    begin
 859       Generate_Definition (Id);
 860       Enter_Name (Id);
 861       T := Find_Type_Of_Object (Subtype_Indication (N), N);
 862
 863       --  If the component declaration includes a default expression, then we
 864       --  check that the component is not of a limited type (RM 3.7(5)),
 865       --  and do the special preanalysis of the expression (see section on
 866       --  "Handling of Default Expressions" in the spec of package Sem).
 867
 868       if Present (Expression (N)) then
 869          Analyze_Default_Expression (Expression (N), T);
 870          Check_Initialization (T, Expression (N));
 871       end if;
 872
 873       --  The parent type may be a private view with unknown discriminants,
 874       --  and thus unconstrained. Regular components must be constrained.
 875
 876       if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
 877          Error_Msg_N
 878            ("unconstrained subtype in component declaration",
 879             Subtype_Indication (N));
 880
 881       --  Components cannot be abstract, except for the special case of
 882       --  the _Parent field (case of extending an abstract tagged type)
 883
 884       elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
 885          Error_Msg_N ("type of a component cannot be abstract", N);
 886       end if;
 887
 888       Set_Etype (Id, T);
 889       Set_Is_Aliased (Id, Aliased_Present (N));
 890
 891       --  If the this component is private (or depends on a private type),
 892       --  flag the record type to indicate that some operations are not
 893       --  available.
 894
 895       P := Private_Component (T);
 896
 897       if Present (P) then
 898          --  Check for circular definitions.
 899
 900          if P = Any_Type then
 901             Set_Etype (Id, Any_Type);
 902
 903          --  There is a gap in the visibility of operations only if the
 904          --  component type is not defined in the scope of the record type.
 905
 906          elsif Scope (P) = Scope (Current_Scope) then
 907             null;
 908
 909          elsif Is_Limited_Type (P) then
 910             Set_Is_Limited_Composite (Current_Scope);
 911
 912          else
 913             Set_Is_Private_Composite (Current_Scope);
 914          end if;
 915       end if;
 916
 917       if P /= Any_Type
 918         and then Is_Limited_Type (T)
 919         and then Chars (Id) /= Name_uParent
 920         and then Is_Tagged_Type (Current_Scope)
 921       then
 922          if Is_Derived_Type (Current_Scope)
 923            and then not Is_Limited_Record (Root_Type (Current_Scope))
 924          then
 925             Error_Msg_N
 926               ("extension of nonlimited type cannot have limited components",
 927                N);
 928             Set_Etype (Id, Any_Type);
 929             Set_Is_Limited_Composite (Current_Scope, False);
 930
 931          elsif not Is_Derived_Type (Current_Scope)
 932            and then not Is_Limited_Record (Current_Scope)
 933          then
 934             Error_Msg_N ("nonlimited type cannot have limited components", N);
 935             Set_Etype (Id, Any_Type);
 936             Set_Is_Limited_Composite (Current_Scope, False);
 937          end if;
 938       end if;
 939
 940       Set_Original_Record_Component (Id, Id);
 941    end Analyze_Component_Declaration;
 942
 943    --------------------------
 944    -- Analyze_Declarations --
 945    --------------------------
 946
 947    procedure Analyze_Declarations (L : List_Id) is
 948       D           : Node_Id;
 949       Next_Node   : Node_Id;
 950       Freeze_From : Entity_Id := Empty;
 951
 952       procedure Adjust_D;
 953       --  Adjust D not to include implicit label declarations, since these
 954       --  have strange Sloc values that result in elaboration check problems.
 955
 956       procedure Adjust_D is
 957       begin
 958          while Present (Prev (D))
 959            and then Nkind (D) = N_Implicit_Label_Declaration
 960          loop
 961             Prev (D);
 962          end loop;
 963       end Adjust_D;
 964
 965    --  Start of processing for Analyze_Declarations
 966
 967    begin
 968       D := First (L);
 969       while Present (D) loop
 970
 971          --  Complete analysis of declaration
 972
 973          Analyze (D);
 974          Next_Node := Next (D);
 975
 976          if No (Freeze_From) then
 977             Freeze_From := First_Entity (Current_Scope);
 978          end if;
 979
 980          --  At the end of a declarative part, freeze remaining entities
 981          --  declared in it. The end of the visible declarations of a
 982          --  package specification is not the end of a declarative part
 983          --  if private declarations are present. The end of a package
 984          --  declaration is a freezing point only if it a library package.
 985          --  A task definition or protected type definition is not a freeze
 986          --  point either. Finally, we do not freeze entities in generic
 987          --  scopes, because there is no code generated for them and freeze
 988          --  nodes will be generated for the instance.
 989
 990          --  The end of a package instantiation is not a freeze point, but
 991          --  for now we make it one, because the generic body is inserted
 992          --  (currently) immediately after. Generic instantiations will not
 993          --  be a freeze point once delayed freezing of bodies is implemented.
 994          --  (This is needed in any case for early instantiations ???).
 995
 996          if No (Next_Node) then
 997             if Nkind (Parent (L)) = N_Component_List
 998               or else Nkind (Parent (L)) = N_Task_Definition
 999               or else Nkind (Parent (L)) = N_Protected_Definition
1000             then
1001                null;
1002
1003             elsif Nkind (Parent (L)) /= N_Package_Specification then
1004
1005                if Nkind (Parent (L)) = N_Package_Body then
1006                   Freeze_From := First_Entity (Current_Scope);
1007                end if;
1008
1009                Adjust_D;
1010                Freeze_All (Freeze_From, D);
1011                Freeze_From := Last_Entity (Current_Scope);
1012
1013             elsif Scope (Current_Scope) /= Standard_Standard
1014               and then not Is_Child_Unit (Current_Scope)
1015               and then No (Generic_Parent (Parent (L)))
1016             then
1017                null;
1018
1019             elsif L /= Visible_Declarations (Parent (L))
1020                or else No (Private_Declarations (Parent (L)))
1021                or else Is_Empty_List (Private_Declarations (Parent (L)))
1022             then
1023                Adjust_D;
1024                Freeze_All (Freeze_From, D);
1025                Freeze_From := Last_Entity (Current_Scope);
1026             end if;
1027
1028          --  If next node is a body then freeze all types before the body.
1029          --  An exception occurs for expander generated bodies, which can
1030          --  be recognized by their already being analyzed. The expander
1031          --  ensures that all types needed by these bodies have been frozen
1032          --  but it is not necessary to freeze all types (and would be wrong
1033          --  since it would not correspond to an RM defined freeze point).
1034
1035          elsif not Analyzed (Next_Node)
1036            and then (Nkind (Next_Node) = N_Subprogram_Body
1037              or else Nkind (Next_Node) = N_Entry_Body
1038              or else Nkind (Next_Node) = N_Package_Body
1039              or else Nkind (Next_Node) = N_Protected_Body
1040              or else Nkind (Next_Node) = N_Task_Body
1041              or else Nkind (Next_Node) in N_Body_Stub)
1042          then
1043             Adjust_D;
1044             Freeze_All (Freeze_From, D);
1045             Freeze_From := Last_Entity (Current_Scope);
1046          end if;
1047
1048          D := Next_Node;
1049       end loop;
1050
1051    end Analyze_Declarations;
1052
1053    --------------------------------
1054    -- Analyze_Default_Expression --
1055    --------------------------------
1056
1057    procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id) is
1058       Save_In_Default_Expression : constant Boolean := In_Default_Expression;
1059
1060    begin
1061       In_Default_Expression := True;
1062       Pre_Analyze_And_Resolve (N, T);
1063       In_Default_Expression := Save_In_Default_Expression;
1064    end Analyze_Default_Expression;
1065
1066    ----------------------------------
1067    -- Analyze_Incomplete_Type_Decl --
1068    ----------------------------------
1069
1070    procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
1071       F : constant Boolean := Is_Pure (Current_Scope);
1072       T : Entity_Id;
1073
1074    begin
1075       Generate_Definition (Defining_Identifier (N));
1076
1077       --  Process an incomplete declaration. The identifier must not have been
1078       --  declared already in the scope. However, an incomplete declaration may
1079       --  appear in the private part of a package, for a private type that has
1080       --  already been declared.
1081
1082       --  In this case, the discriminants (if any) must match.
1083
1084       T := Find_Type_Name (N);
1085
1086       Set_Ekind (T, E_Incomplete_Type);
1087       Init_Size_Align (T);
1088       Set_Is_First_Subtype (T, True);
1089       Set_Etype (T, T);
1090       New_Scope (T);
1091
1092       Set_Girder_Constraint (T, No_Elist);
1093
1094       if Present (Discriminant_Specifications (N)) then
1095          Process_Discriminants (N);
1096       end if;
1097
1098       End_Scope;
1099
1100       --  If the type has discriminants, non-trivial subtypes may be
1101       --  be declared before the full view of the type. The full views
1102       --  of those subtypes will be built after the full view of the type.
1103
1104       Set_Private_Dependents (T, New_Elmt_List);
1105       Set_Is_Pure (T, F);
1106    end Analyze_Incomplete_Type_Decl;
1107
1108    -----------------------------
1109    -- Analyze_Itype_Reference --
1110    -----------------------------
1111
1112    --  Nothing to do. This node is placed in the tree only for the benefit
1113    --  of Gigi processing, and has no effect on the semantic processing.
1114
1115    procedure Analyze_Itype_Reference (N : Node_Id) is
1116    begin
1117       pragma Assert (Is_Itype (Itype (N)));
1118       null;
1119    end Analyze_Itype_Reference;
1120
1121    --------------------------------
1122    -- Analyze_Number_Declaration --
1123    --------------------------------
1124
1125    procedure Analyze_Number_Declaration (N : Node_Id) is
1126       Id    : constant Entity_Id := Defining_Identifier (N);
1127       E     : constant Node_Id   := Expression (N);
1128       T     : Entity_Id;
1129       Index : Interp_Index;
1130       It    : Interp;
1131
1132    begin
1133       Generate_Definition (Id);
1134       Enter_Name (Id);
1135
1136       --  This is an optimization of a common case of an integer literal
1137
1138       if Nkind (E) = N_Integer_Literal then
1139          Set_Is_Static_Expression (E, True);
1140          Set_Etype                (E, Universal_Integer);
1141
1142          Set_Etype     (Id, Universal_Integer);
1143          Set_Ekind     (Id, E_Named_Integer);
1144          Set_Is_Frozen (Id, True);
1145          return;
1146       end if;
1147
1148       Set_Is_Pure (Id, Is_Pure (Current_Scope));
1149
1150       --  Process expression, replacing error by integer zero, to avoid
1151       --  cascaded errors or aborts further along in the processing
1152
1153       --  Replace Error by integer zero, which seems least likely to
1154       --  cause cascaded errors.
1155
1156       if E = Error then
1157          Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
1158          Set_Error_Posted (E);
1159       end if;
1160
1161       Analyze (E);
1162
1163       --  Verify that the expression is static and numeric. If
1164       --  the expression is overloaded, we apply the preference
1165       --  rule that favors root numeric types.
1166
1167       if not Is_Overloaded (E) then
1168          T := Etype (E);
1169
1170       else
1171          T := Any_Type;
1172          Get_First_Interp (E, Index, It);
1173
1174          while Present (It.Typ) loop
1175             if (Is_Integer_Type (It.Typ)
1176                  or else Is_Real_Type (It.Typ))
1177               and then (Scope (Base_Type (It.Typ))) = Standard_Standard
1178             then
1179                if T = Any_Type then
1180                   T := It.Typ;
1181
1182                elsif It.Typ = Universal_Real
1183                  or else It.Typ = Universal_Integer
1184                then
1185                   --  Choose universal interpretation over any other.
1186
1187                   T := It.Typ;
1188                   exit;
1189                end if;
1190             end if;
1191
1192             Get_Next_Interp (Index, It);
1193          end loop;
1194       end if;
1195
1196       if Is_Integer_Type (T)  then
1197          Resolve (E, T);
1198          Set_Etype (Id, Universal_Integer);
1199          Set_Ekind (Id, E_Named_Integer);
1200
1201       elsif Is_Real_Type (T) then
1202
1203          --  Because the real value is converted to universal_real, this
1204          --  is a legal context for a universal fixed expression.
1205
1206          if T = Universal_Fixed then
1207             declare
1208                Loc  : constant Source_Ptr := Sloc (N);
1209                Conv : constant Node_Id := Make_Type_Conversion (Loc,
1210                         Subtype_Mark =>
1211                           New_Occurrence_Of (Universal_Real, Loc),
1212                         Expression => Relocate_Node (E));
1213
1214             begin
1215                Rewrite (E, Conv);
1216                Analyze (E);
1217             end;
1218
1219          elsif T = Any_Fixed then
1220             Error_Msg_N ("illegal context for mixed mode operation", E);
1221
1222             --  Expression is of the form : universal_fixed * integer.
1223             --  Try to resolve as universal_real.
1224
1225             T := Universal_Real;
1226             Set_Etype (E, T);
1227          end if;
1228
1229          Resolve (E, T);
1230          Set_Etype (Id, Universal_Real);
1231          Set_Ekind (Id, E_Named_Real);
1232
1233       else
1234          Wrong_Type (E, Any_Numeric);
1235          Resolve (E, T);
1236          Set_Etype               (Id, T);
1237          Set_Ekind               (Id, E_Constant);
1238          Set_Not_Source_Assigned (Id, True);
1239          Set_Is_True_Constant    (Id, True);
1240          return;
1241       end if;
1242
1243       if Nkind (E) = N_Integer_Literal
1244         or else Nkind (E) = N_Real_Literal
1245       then
1246          Set_Etype (E, Etype (Id));
1247       end if;
1248
1249       if not Is_OK_Static_Expression (E) then
1250          Error_Msg_N ("non-static expression used in number declaration", E);
1251          Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
1252          Set_Etype (E, Any_Type);
1253       end if;
1254
1255    end Analyze_Number_Declaration;
1256
1257    --------------------------------
1258    -- Analyze_Object_Declaration --
1259    --------------------------------
1260
1261    procedure Analyze_Object_Declaration (N : Node_Id) is
1262       Loc   : constant Source_Ptr := Sloc (N);
1263       Id    : constant Entity_Id  := Defining_Identifier (N);
1264       T     : Entity_Id;
1265       Act_T : Entity_Id;
1266
1267       E : Node_Id := Expression (N);
1268       --  E is set to Expression (N) throughout this routine. When
1269       --  Expression (N) is modified, E is changed accordingly.
1270
1271       Prev_Entity : Entity_Id := Empty;
1272
1273       function Build_Default_Subtype return Entity_Id;
1274       --  If the object is limited or aliased, and if the type is unconstrained
1275       --  and there is no expression, the discriminants cannot be modified and
1276       --  the subtype of the object is constrained by the defaults, so it is
1277       --  worthile building the corresponding subtype.
1278
1279       ---------------------------
1280       -- Build_Default_Subtype --
1281       ---------------------------
1282
1283       function Build_Default_Subtype return Entity_Id is
1284          Act         : Entity_Id;
1285          Constraints : List_Id := New_List;
1286          Decl        : Node_Id;
1287          Disc        : Entity_Id;
1288
1289       begin
1290          Disc  := First_Discriminant (T);
1291
1292          if No (Discriminant_Default_Value (Disc)) then
1293             return T;   --   previous error.
1294          end if;
1295
1296          Act := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1297          while Present (Disc) loop
1298             Append (
1299               New_Copy_Tree (
1300                 Discriminant_Default_Value (Disc)), Constraints);
1301             Next_Discriminant (Disc);
1302          end loop;
1303
1304          Decl :=
1305            Make_Subtype_Declaration (Loc,
1306              Defining_Identifier => Act,
1307              Subtype_Indication =>
1308                Make_Subtype_Indication (Loc,
1309                  Subtype_Mark => New_Occurrence_Of (T, Loc),
1310                  Constraint =>
1311                    Make_Index_Or_Discriminant_Constraint
1312                      (Loc, Constraints)));
1313
1314          Insert_Before (N, Decl);
1315          Analyze (Decl);
1316          return Act;
1317       end Build_Default_Subtype;
1318
1319    --  Start of processing for Analyze_Object_Declaration
1320
1321    begin
1322       --  There are three kinds of implicit types generated by an
1323       --  object declaration:
1324
1325       --   1. Those for generated by the original Object Definition
1326
1327       --   2. Those generated by the Expression
1328
1329       --   3. Those used to constrained the Object Definition with the
1330       --       expression constraints when it is unconstrained
1331
1332       --  They must be generated in this order to avoid order of elaboration
1333       --  issues. Thus the first step (after entering the name) is to analyze
1334       --  the object definition.
1335
1336       if Constant_Present (N) then
1337          Prev_Entity := Current_Entity_In_Scope (Id);
1338
1339          --  If homograph is an implicit subprogram, it is overridden by the
1340          --  current declaration.
1341
1342          if Present (Prev_Entity)
1343            and then Is_Overloadable (Prev_Entity)
1344            and then Is_Inherited_Operation (Prev_Entity)
1345          then
1346             Prev_Entity := Empty;
1347          end if;
1348       end if;
1349
1350       if Present (Prev_Entity) then
1351          Constant_Redeclaration (Id, N, T);
1352
1353          Generate_Reference (Prev_Entity, Id, 'c');
1354
1355          --  If in main unit, set as referenced, so we do not complain about
1356          --  the full declaration being an unreferenced entity.
1357
1358          if In_Extended_Main_Source_Unit (Id) then
1359             Set_Referenced (Id);
1360          end if;
1361
1362          if Error_Posted (N) then
1363             --  Type mismatch or illegal redeclaration, Do not analyze
1364             --  expression to avoid cascaded errors.
1365
1366             T := Find_Type_Of_Object (Object_Definition (N), N);
1367             Set_Etype (Id, T);
1368             Set_Ekind (Id, E_Variable);
1369             return;
1370          end if;
1371
1372       --  In the normal case, enter identifier at the start to catch
1373       --  premature usage in the initialization expression.
1374
1375       else
1376          Generate_Definition (Id);
1377          Enter_Name (Id);
1378
1379          T := Find_Type_Of_Object (Object_Definition (N), N);
1380
1381          if Error_Posted (Id) then
1382             Set_Etype (Id, T);
1383             Set_Ekind (Id, E_Variable);
1384             return;
1385          end if;
1386       end if;
1387
1388       Set_Is_Pure (Id, Is_Pure (Current_Scope));
1389
1390       --  If deferred constant, make sure context is appropriate. We detect
1391       --  a deferred constant as a constant declaration with no expression.
1392
1393       if Constant_Present (N)
1394         and then No (E)
1395       then
1396          if not Is_Package (Current_Scope)
1397            or else In_Private_Part (Current_Scope)
1398          then
1399             Error_Msg_N
1400               ("invalid context for deferred constant declaration", N);
1401             Set_Constant_Present (N, False);
1402
1403          --  In Ada 83, deferred constant must be of private type
1404
1405          elsif not Is_Private_Type (T) then
1406             if Ada_83 and then Comes_From_Source (N) then
1407                Error_Msg_N
1408                  ("(Ada 83) deferred constant must be private type", N);
1409             end if;
1410          end if;
1411
1412       --  If not a deferred constant, then object declaration freezes its type
1413
1414       else
1415          Check_Fully_Declared (T, N);
1416          Freeze_Before (N, T);
1417       end if;
1418
1419       --  If the object was created by a constrained array definition, then
1420       --  set the link in both the anonymous base type and anonymous subtype
1421       --  that are built to represent the array type to point to the object.
1422
1423       if Nkind (Object_Definition (Declaration_Node (Id))) =
1424                         N_Constrained_Array_Definition
1425       then
1426          Set_Related_Array_Object (T, Id);
1427          Set_Related_Array_Object (Base_Type (T), Id);
1428       end if;
1429
1430       --  Special checks for protected objects not at library level
1431
1432       if Is_Protected_Type (T)
1433         and then not Is_Library_Level_Entity (Id)
1434       then
1435          Check_Restriction (No_Local_Protected_Objects, Id);
1436
1437          --  Protected objects with interrupt handlers must be at library level
1438
1439          if Has_Interrupt_Handler (T) then
1440             Error_Msg_N
1441               ("interrupt object can only be declared at library level", Id);
1442          end if;
1443       end if;
1444
1445       --  The actual subtype of the object is the nominal subtype, unless
1446       --  the nominal one is unconstrained and obtained from the expression.
1447
1448       Act_T := T;
1449
1450       --  Process initialization expression if present and not in error
1451
1452       if Present (E) and then E /= Error then
1453          Analyze (E);
1454
1455          if not Assignment_OK (N) then
1456             Check_Initialization (T, E);
1457          end if;
1458
1459          Resolve (E, T);
1460
1461          --  Check for library level object that will require implicit
1462          --  heap allocation.
1463
1464          if Is_Array_Type (T)
1465            and then not Size_Known_At_Compile_Time (T)
1466            and then Is_Library_Level_Entity (Id)
1467          then
1468             --  String literals are always allowed
1469
1470             if T = Standard_String
1471               and then Nkind (E) = N_String_Literal
1472             then
1473                null;
1474
1475             --  Otherwise we do not allow this since it may cause an
1476             --  implicit heap allocation.
1477
1478             else
1479                Check_Restriction
1480                  (No_Implicit_Heap_Allocations, Object_Definition (N));
1481             end if;
1482          end if;
1483
1484          --  Check incorrect use of dynamically tagged expressions. Note
1485          --  the use of Is_Tagged_Type (T) which seems redundant but is in
1486          --  fact important to avoid spurious errors due to expanded code
1487          --  for dispatching functions over an anonymous access type
1488
1489          if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
1490            and then Is_Tagged_Type (T)
1491            and then not Is_Class_Wide_Type (T)
1492          then
1493             Error_Msg_N ("dynamically tagged expression not allowed!", E);
1494          end if;
1495
1496          Apply_Scalar_Range_Check (E, T);
1497          Apply_Static_Length_Check (E, T);
1498       end if;
1499
1500       --  Abstract type is never permitted for a variable or constant.
1501       --  Note: we inhibit this check for objects that do not come from
1502       --  source because there is at least one case (the expansion of
1503       --  x'class'input where x is abstract) where we legitimately
1504       --  generate an abstract object.
1505
1506       if Is_Abstract (T) and then Comes_From_Source (N) then
1507          Error_Msg_N ("type of object cannot be abstract",
1508            Object_Definition (N));
1509          if Is_CPP_Class (T) then
1510             Error_Msg_NE ("\} may need a cpp_constructor",
1511               Object_Definition (N), T);
1512          end if;
1513
1514       --  Case of unconstrained type
1515
1516       elsif Is_Indefinite_Subtype (T) then
1517
1518          --  Nothing to do in deferred constant case
1519
1520          if Constant_Present (N) and then No (E) then
1521             null;
1522
1523          --  Case of no initialization present
1524
1525          elsif No (E) then
1526             if No_Initialization (N) then
1527                null;
1528
1529             elsif Is_Class_Wide_Type (T) then
1530                Error_Msg_N
1531                  ("initialization required in class-wide declaration ", N);
1532
1533             else
1534                Error_Msg_N
1535                  ("unconstrained subtype not allowed (need initialization)",
1536                   Object_Definition (N));
1537             end if;
1538
1539          --  Case of initialization present but in error. Set initial
1540          --  expression as absent (but do not make above complaints)
1541
1542          elsif E = Error then
1543             Set_Expression (N, Empty);
1544             E := Empty;
1545
1546          --  Case of initialization present
1547
1548          else
1549             --  Not allowed in Ada 83
1550
1551             if not Constant_Present (N) then
1552                if Ada_83
1553                  and then Comes_From_Source (Object_Definition (N))
1554                then
1555                   Error_Msg_N
1556                     ("(Ada 83) unconstrained variable not allowed",
1557                      Object_Definition (N));
1558                end if;
1559             end if;
1560
1561             --  Now we constrain the variable from the initializing expression
1562
1563             --  If the expression is an aggregate, it has been expanded into
1564             --  individual assignments. Retrieve the actual type from the
1565             --  expanded construct.
1566
1567             if Is_Array_Type (T)
1568               and then No_Initialization (N)
1569               and then Nkind (Original_Node (E)) = N_Aggregate
1570             then
1571                Act_T := Etype (E);
1572
1573             else
1574                Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
1575                Act_T := Find_Type_Of_Object (Object_Definition (N), N);
1576             end if;
1577
1578             Set_Is_Constr_Subt_For_U_Nominal (Act_T);
1579
1580             if Aliased_Present (N) then
1581                Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
1582             end if;
1583
1584             Freeze_Before (N, Act_T);
1585             Freeze_Before (N, T);
1586          end if;
1587
1588       elsif Is_Array_Type (T)
1589         and then No_Initialization (N)
1590         and then Nkind (Original_Node (E)) = N_Aggregate
1591       then
1592          if not Is_Entity_Name (Object_Definition (N)) then
1593             Act_T := Etype (E);
1594
1595             if Aliased_Present (N) then
1596                Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
1597             end if;
1598          end if;
1599
1600          --  When the given object definition and the aggregate are specified
1601          --  independently, and their lengths might differ do a length check.
1602          --  This cannot happen if the aggregate is of the form (others =>...)
1603
1604          if not Is_Constrained (T) then
1605             null;
1606
1607          elsif Nkind (E) = N_Raise_Constraint_Error then
1608
1609             --  Aggregate is statically illegal. Place back in declaration
1610
1611             Set_Expression (N, E);
1612             Set_No_Initialization (N, False);
1613
1614          elsif T = Etype (E) then
1615             null;
1616
1617          elsif Nkind (E) = N_Aggregate
1618            and then Present (Component_Associations (E))
1619            and then Present (Choices (First (Component_Associations (E))))
1620            and then Nkind (First
1621             (Choices (First (Component_Associations (E))))) = N_Others_Choice
1622          then
1623             null;
1624
1625          else
1626             Apply_Length_Check (E, T);
1627          end if;
1628
1629       elsif (Is_Limited_Record (T)
1630                or else Is_Concurrent_Type (T))
1631         and then not Is_Constrained (T)
1632         and then Has_Discriminants (T)
1633       then
1634          Act_T := Build_Default_Subtype;
1635          Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
1636
1637       elsif not Is_Constrained (T)
1638         and then Has_Discriminants (T)
1639         and then Constant_Present (N)
1640         and then Nkind (E) = N_Function_Call
1641       then
1642          --  The back-end has problems with constants of a discriminated type
1643          --  with defaults, if the initial value is a function call. We
1644          --  generate an intermediate temporary for the result of the call.
1645          --  It is unclear why this should make it acceptable to gcc. ???
1646
1647          Remove_Side_Effects (E);
1648       end if;
1649
1650       if T = Standard_Wide_Character
1651         or else Root_Type (T) = Standard_Wide_String
1652       then
1653          Check_Restriction (No_Wide_Characters, Object_Definition (N));
1654       end if;
1655
1656       --  Now establish the proper kind and type of the object
1657
1658       if Constant_Present (N) then
1659          Set_Ekind               (Id, E_Constant);
1660          Set_Not_Source_Assigned (Id, True);
1661          Set_Is_True_Constant    (Id, True);
1662
1663       else
1664          Set_Ekind (Id, E_Variable);
1665
1666          --  A variable is set as shared passive if it appears in a shared
1667          --  passive package, and is at the outer level. This is not done
1668          --  for entities generated during expansion, because those are
1669          --  always manipulated locally.
1670
1671          if Is_Shared_Passive (Current_Scope)
1672            and then Is_Library_Level_Entity (Id)
1673            and then Comes_From_Source (Id)
1674          then
1675             Set_Is_Shared_Passive (Id);
1676             Check_Shared_Var (Id, T, N);
1677          end if;
1678
1679          --  If an initializing expression is present, then the variable
1680          --  is potentially a true constant if no further assignments are
1681          --  present. The code generator can use this for optimization.
1682          --  The flag will be reset if there are any assignments. We only
1683          --  set this flag for non library level entities, since for any
1684          --  library level entities, assignments could exist in other units.
1685
1686          if Present (E) then
1687             if not Is_Library_Level_Entity (Id) then
1688
1689                --  For now we omit this, because it seems to cause some
1690                --  problems. In particular, if you uncomment this out, then
1691                --  test case 4427-002 will fail for unclear reasons ???
1692
1693                if False then
1694                   Set_Is_True_Constant (Id);
1695                end if;
1696             end if;
1697
1698          --  Case of no initializing expression present. If the type is not
1699          --  fully initialized, then we set Not_Source_Assigned, since this
1700          --  is a case of a potentially uninitialized object. Note that we
1701          --  do not consider access variables to be fully initialized for
1702          --  this purpose, since it still seems dubious if someone declares
1703          --  an access variable and never assigns to it.
1704
1705          else
1706             if Is_Access_Type (T)
1707               or else not Is_Fully_Initialized_Type (T)
1708             then
1709                Set_Not_Source_Assigned (Id);
1710             end if;
1711          end if;
1712       end if;
1713
1714       Init_Alignment (Id);
1715       Init_Esize     (Id);
1716
1717       if Aliased_Present (N) then
1718          Set_Is_Aliased (Id);
1719
1720          if No (E)
1721            and then Is_Record_Type (T)
1722            and then not Is_Constrained (T)
1723            and then Has_Discriminants (T)
1724          then
1725             Set_Actual_Subtype (Id, Build_Default_Subtype);
1726          end if;
1727       end if;
1728
1729       Set_Etype (Id, Act_T);
1730
1731       if Has_Controlled_Component (Etype (Id))
1732         or else Is_Controlled (Etype (Id))
1733       then
1734          if not Is_Library_Level_Entity (Id) then
1735             Check_Restriction (No_Nested_Finalization, N);
1736
1737          else
1738             Validate_Controlled_Object (Id);
1739          end if;
1740
1741          --  Generate a warning when an initialization causes an obvious
1742          --  ABE violation. If the init expression is a simple aggregate
1743          --  there shouldn't be any initialize/adjust call generated. This
1744          --  will be true as soon as aggregates are built in place when
1745          --  possible. ??? at the moment we do not generate warnings for
1746          --  temporaries created for those aggregates although a
1747          --  Program_Error might be generated if compiled with -gnato
1748
1749          if Is_Controlled (Etype (Id))
1750             and then Comes_From_Source (Id)
1751          then
1752             declare
1753                BT            : constant Entity_Id := Base_Type (Etype (Id));
1754                Implicit_Call : Entity_Id;
1755
1756                function Is_Aggr (N : Node_Id) return Boolean;
1757                --  Check that N is an aggregate
1758
1759                function Is_Aggr (N : Node_Id) return Boolean is
1760                begin
1761                   case Nkind (Original_Node (N)) is
1762                      when N_Aggregate | N_Extension_Aggregate =>
1763                         return True;
1764
1765                      when N_Qualified_Expression |
1766                           N_Type_Conversion      |
1767                           N_Unchecked_Type_Conversion =>
1768                         return Is_Aggr (Expression (Original_Node (N)));
1769
1770                      when others =>
1771                         return False;
1772                   end case;
1773                end Is_Aggr;
1774
1775             begin
1776                --  If no underlying type, we already are in an error situation
1777                --  don't try to add a warning since we do not have access
1778                --  prim-op list.
1779
1780                if No (Underlying_Type (BT)) then
1781                   Implicit_Call := Empty;
1782
1783                --  A generic type does not have usable primitive operators.
1784                --  Initialization calls are built for instances.
1785
1786                elsif Is_Generic_Type (BT) then
1787                   Implicit_Call := Empty;
1788
1789                --  if the init expression is not an aggregate, an adjust
1790                --  call will be generated
1791
1792                elsif Present (E) and then not Is_Aggr (E) then
1793                   Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
1794
1795                --  if no init expression and we are not in the deferred
1796                --  constant case, an Initialize call will be generated
1797
1798                elsif No (E) and then not Constant_Present (N) then
1799                   Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
1800
1801                else
1802                   Implicit_Call := Empty;
1803                end if;
1804             end;
1805          end if;
1806       end if;
1807
1808       if Has_Task (Etype (Id)) then
1809          if not Is_Library_Level_Entity (Id) then
1810             Check_Restriction (No_Task_Hierarchy, N);
1811             Check_Potentially_Blocking_Operation (N);
1812          end if;
1813       end if;
1814
1815       --  Some simple constant-propagation: if the expression is a constant
1816       --  string initialized with a literal, share the literal. This avoids
1817       --  a run-time copy.
1818
1819       if Present (E)
1820         and then Is_Entity_Name (E)
1821         and then Ekind (Entity (E)) = E_Constant
1822         and then Base_Type (Etype (E)) = Standard_String
1823       then
1824          declare
1825             Val : constant Node_Id := Constant_Value (Entity (E));
1826
1827          begin
1828             if Present (Val)
1829               and then Nkind (Val) = N_String_Literal
1830             then
1831                Rewrite (E, New_Copy (Val));
1832             end if;
1833          end;
1834       end if;
1835
1836       --  Another optimization: if the nominal subtype is unconstrained and
1837       --  the expression is a function call that returns and unconstrained
1838       --  type, rewrite the declararation as a renaming of the result of the
1839       --  call. The exceptions below are cases where the copy is expected,
1840       --  either by the back end (Aliased case) or by the semantics, as for
1841       --  initializing controlled types or copying tags for classwide types.
1842
1843       if Present (E)
1844         and then Nkind (E) = N_Explicit_Dereference
1845         and then Nkind (Original_Node (E)) = N_Function_Call
1846         and then not Is_Library_Level_Entity (Id)
1847         and then not Is_Constrained (T)
1848         and then not Is_Aliased (Id)
1849         and then not Is_Class_Wide_Type (T)
1850         and then not Is_Controlled (T)
1851         and then not Has_Controlled_Component (Base_Type (T))
1852         and then Expander_Active
1853       then
1854          Rewrite (N,
1855            Make_Object_Renaming_Declaration (Loc,
1856              Defining_Identifier => Id,
1857              Subtype_Mark        => New_Occurrence_Of
1858                                       (Base_Type (Etype (Id)), Loc),
1859              Name                => E));
1860
1861          Set_Renamed_Object (Id, E);
1862       end if;
1863
1864       if Present (Prev_Entity)
1865         and then Is_Frozen (Prev_Entity)
1866         and then not Error_Posted (Id)
1867       then
1868          Error_Msg_N ("full constant declaration appears too late", N);
1869       end if;
1870
1871       Check_Eliminated (Id);
1872    end Analyze_Object_Declaration;
1873
1874    ---------------------------
1875    -- Analyze_Others_Choice --
1876    ---------------------------
1877
1878    --  Nothing to do for the others choice node itself, the semantic analysis
1879    --  of the others choice will occur as part of the processing of the parent
1880
1881    procedure Analyze_Others_Choice (N : Node_Id) is
1882    begin
1883       null;
1884    end Analyze_Others_Choice;
1885
1886    -------------------------------------------
1887    -- Analyze_Private_Extension_Declaration --
1888    -------------------------------------------
1889
1890    procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
1891       T           : Entity_Id        := Defining_Identifier (N);
1892       Indic       : constant Node_Id := Subtype_Indication (N);
1893       Parent_Type : Entity_Id;
1894       Parent_Base : Entity_Id;
1895
1896    begin
1897       Generate_Definition (T);
1898       Enter_Name (T);
1899
1900       Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
1901       Parent_Base := Base_Type (Parent_Type);
1902
1903       if Parent_Type = Any_Type
1904         or else Etype (Parent_Type) = Any_Type
1905       then
1906          Set_Ekind (T, Ekind (Parent_Type));
1907          Set_Etype (T, Any_Type);
1908          return;
1909
1910       elsif not Is_Tagged_Type (Parent_Type) then
1911          Error_Msg_N
1912            ("parent of type extension must be a tagged type ", Indic);
1913          return;
1914
1915       elsif Ekind (Parent_Type) = E_Void
1916         or else Ekind (Parent_Type) = E_Incomplete_Type
1917       then
1918          Error_Msg_N ("premature derivation of incomplete type", Indic);
1919          return;
1920       end if;
1921
1922       --  Perhaps the parent type should be changed to the class-wide type's
1923       --  specific type in this case to prevent cascading errors ???
1924
1925       if Is_Class_Wide_Type (Parent_Type) then
1926          Error_Msg_N
1927            ("parent of type extension must not be a class-wide type", Indic);
1928          return;
1929       end if;
1930
1931       if (not Is_Package (Current_Scope)
1932            and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
1933         or else In_Private_Part (Current_Scope)
1934
1935       then
1936          Error_Msg_N ("invalid context for private extension", N);
1937       end if;
1938
1939       --  Set common attributes
1940
1941       Set_Is_Pure          (T, Is_Pure (Current_Scope));
1942       Set_Scope            (T, Current_Scope);
1943       Set_Ekind            (T, E_Record_Type_With_Private);
1944       Init_Size_Align      (T);
1945
1946       Set_Etype            (T,            Parent_Base);
1947       Set_Has_Task         (T, Has_Task  (Parent_Base));
1948
1949       Set_Convention       (T, Convention     (Parent_Type));
1950       Set_First_Rep_Item   (T, First_Rep_Item (Parent_Type));
1951       Set_Is_First_Subtype (T);
1952       Make_Class_Wide_Type (T);
1953
1954       Build_Derived_Record_Type (N, Parent_Type, T);
1955    end Analyze_Private_Extension_Declaration;
1956
1957    ---------------------------------
1958    -- Analyze_Subtype_Declaration --
1959    ---------------------------------
1960
1961    procedure Analyze_Subtype_Declaration (N : Node_Id) is
1962       Id       : constant Entity_Id := Defining_Identifier (N);
1963       T        : Entity_Id;
1964       R_Checks : Check_Result;
1965
1966    begin
1967       Generate_Definition (Id);
1968       Set_Is_Pure (Id, Is_Pure (Current_Scope));
1969       Init_Size_Align (Id);
1970
1971       --  The following guard condition on Enter_Name is to handle cases
1972       --  where the defining identifier has already been entered into the
1973       --  scope but the declaration as a whole needs to be analyzed.
1974
1975       --  This case in particular happens for derived enumeration types.
1976       --  The derived enumeration type is processed as an inserted enumeration
1977       --  type declaration followed by a rewritten subtype declaration. The
1978       --  defining identifier, however, is entered into the name scope very
1979       --  early in the processing of the original type declaration and
1980       --  therefore needs to be avoided here, when the created subtype
1981       --  declaration is analyzed. (See Build_Derived_Types)
1982
1983       --  This also happens when the full view of a private type is a
1984       --  derived type with constraints. In this case the entity has been
1985       --  introduced in the private declaration.
1986
1987       if Present (Etype (Id))
1988         and then (Is_Private_Type (Etype (Id))
1989                    or else Is_Task_Type (Etype (Id))
1990                    or else Is_Rewrite_Substitution (N))
1991       then
1992          null;
1993
1994       else
1995          Enter_Name (Id);
1996       end if;
1997
1998       T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
1999
2000       --  Inherit common attributes
2001
2002       Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
2003       Set_Is_Volatile (Id, Is_Volatile (T));
2004       Set_Is_Atomic   (Id, Is_Atomic   (T));
2005
2006       --  In the case where there is no constraint given in the subtype
2007       --  indication, Process_Subtype just returns the Subtype_Mark,
2008       --  so its semantic attributes must be established here.
2009
2010       if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
2011          Set_Etype (Id, Base_Type (T));
2012
2013          case Ekind (T) is
2014             when Array_Kind =>
2015                Set_Ekind                (Id, E_Array_Subtype);
2016
2017                --  Shouldn't we call Copy_Array_Subtype_Attributes here???
2018
2019                Set_First_Index          (Id, First_Index        (T));
2020                Set_Is_Aliased           (Id, Is_Aliased         (T));
2021                Set_Is_Constrained       (Id, Is_Constrained     (T));
2022
2023             when Decimal_Fixed_Point_Kind =>
2024                Set_Ekind                (Id, E_Decimal_Fixed_Point_Subtype);
2025                Set_Digits_Value         (Id, Digits_Value       (T));
2026                Set_Delta_Value          (Id, Delta_Value        (T));
2027                Set_Scale_Value          (Id, Scale_Value        (T));
2028                Set_Small_Value          (Id, Small_Value        (T));
2029                Set_Scalar_Range         (Id, Scalar_Range       (T));
2030                Set_Machine_Radix_10     (Id, Machine_Radix_10   (T));
2031                Set_Is_Constrained       (Id, Is_Constrained     (T));
2032                Set_RM_Size              (Id, RM_Size            (T));
2033
2034             when Enumeration_Kind =>
2035                Set_Ekind                (Id, E_Enumeration_Subtype);
2036                Set_First_Literal        (Id, First_Literal (Base_Type (T)));
2037                Set_Scalar_Range         (Id, Scalar_Range       (T));
2038                Set_Is_Character_Type    (Id, Is_Character_Type  (T));
2039                Set_Is_Constrained       (Id, Is_Constrained     (T));
2040                Set_RM_Size              (Id, RM_Size            (T));
2041
2042             when Ordinary_Fixed_Point_Kind =>
2043                Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
2044                Set_Scalar_Range         (Id, Scalar_Range       (T));
2045                Set_Small_Value          (Id, Small_Value        (T));
2046                Set_Delta_Value          (Id, Delta_Value        (T));
2047                Set_Is_Constrained       (Id, Is_Constrained     (T));
2048                Set_RM_Size              (Id, RM_Size            (T));
2049
2050             when Float_Kind =>
2051                Set_Ekind                (Id, E_Floating_Point_Subtype);
2052                Set_Scalar_Range         (Id, Scalar_Range       (T));
2053                Set_Digits_Value         (Id, Digits_Value       (T));
2054                Set_Is_Constrained       (Id, Is_Constrained     (T));
2055
2056             when Signed_Integer_Kind =>
2057                Set_Ekind                (Id, E_Signed_Integer_Subtype);
2058                Set_Scalar_Range         (Id, Scalar_Range       (T));
2059                Set_Is_Constrained       (Id, Is_Constrained     (T));
2060                Set_RM_Size              (Id, RM_Size            (T));
2061
2062             when Modular_Integer_Kind =>
2063                Set_Ekind                (Id, E_Modular_Integer_Subtype);
2064                Set_Scalar_Range         (Id, Scalar_Range       (T));
2065                Set_Is_Constrained       (Id, Is_Constrained     (T));
2066                Set_RM_Size              (Id, RM_Size            (T));
2067
2068             when Class_Wide_Kind =>
2069                Set_Ekind                (Id, E_Class_Wide_Subtype);
2070                Set_First_Entity         (Id, First_Entity       (T));
2071                Set_Last_Entity          (Id, Last_Entity        (T));
2072                Set_Class_Wide_Type      (Id, Class_Wide_Type    (T));
2073                Set_Cloned_Subtype       (Id, T);
2074                Set_Is_Tagged_Type       (Id, True);
2075                Set_Has_Unknown_Discriminants
2076                                         (Id, True);
2077
2078                if Ekind (T) = E_Class_Wide_Subtype then
2079                   Set_Equivalent_Type   (Id, Equivalent_Type    (T));
2080                end if;
2081
2082             when E_Record_Type | E_Record_Subtype =>
2083                Set_Ekind                (Id, E_Record_Subtype);
2084
2085                if Ekind (T) = E_Record_Subtype
2086                  and then Present (Cloned_Subtype (T))
2087                then
2088                   Set_Cloned_Subtype    (Id, Cloned_Subtype (T));
2089                else
2090                   Set_Cloned_Subtype    (Id, T);
2091                end if;
2092
2093                Set_First_Entity         (Id, First_Entity       (T));
2094                Set_Last_Entity          (Id, Last_Entity        (T));
2095                Set_Has_Discriminants    (Id, Has_Discriminants  (T));
2096                Set_Is_Constrained       (Id, Is_Constrained     (T));
2097                Set_Is_Limited_Record    (Id, Is_Limited_Record  (T));
2098                Set_Has_Unknown_Discriminants
2099                                         (Id, Has_Unknown_Discriminants (T));
2100
2101                if Has_Discriminants (T) then
2102                   Set_Discriminant_Constraint
2103                                         (Id, Discriminant_Constraint (T));
2104                   Set_Girder_Constraint_From_Discriminant_Constraint (Id);
2105
2106                elsif Has_Unknown_Discriminants (Id) then
2107                   Set_Discriminant_Constraint (Id, No_Elist);
2108                end if;
2109
2110                if Is_Tagged_Type (T) then
2111                   Set_Is_Tagged_Type    (Id);
2112                   Set_Is_Abstract       (Id, Is_Abstract (T));
2113                   Set_Primitive_Operations
2114                                         (Id, Primitive_Operations (T));
2115                   Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
2116                end if;
2117
2118             when Private_Kind =>
2119                Set_Ekind              (Id, Subtype_Kind (Ekind   (T)));
2120                Set_Has_Discriminants  (Id, Has_Discriminants     (T));
2121                Set_Is_Constrained     (Id, Is_Constrained        (T));
2122                Set_First_Entity       (Id, First_Entity          (T));
2123                Set_Last_Entity        (Id, Last_Entity           (T));
2124                Set_Private_Dependents (Id, New_Elmt_List);
2125                Set_Is_Limited_Record  (Id, Is_Limited_Record     (T));
2126                Set_Has_Unknown_Discriminants
2127                                       (Id, Has_Unknown_Discriminants (T));
2128
2129                if Is_Tagged_Type (T) then
2130                   Set_Is_Tagged_Type  (Id);
2131                   Set_Is_Abstract     (Id, Is_Abstract (T));
2132                   Set_Class_Wide_Type (Id, Class_Wide_Type (T));
2133                end if;
2134
2135                --  In general the attributes of the subtype of a private
2136                --  type are the attributes of the partial view of parent.
2137                --  However, the full view may be a discriminated type,
2138                --  and the subtype must share the discriminant constraint
2139                --  to generate correct calls to initialization procedures.
2140
2141                if Has_Discriminants (T) then
2142                   Set_Discriminant_Constraint
2143                                      (Id, Discriminant_Constraint (T));
2144                   Set_Girder_Constraint_From_Discriminant_Constraint (Id);
2145
2146                elsif Present (Full_View (T))
2147                  and then Has_Discriminants (Full_View (T))
2148                then
2149                   Set_Discriminant_Constraint
2150                                (Id, Discriminant_Constraint (Full_View (T)));
2151                   Set_Girder_Constraint_From_Discriminant_Constraint (Id);
2152
2153                   --  This would seem semantically correct, but apparently
2154                   --  confuses the back-end (4412-009). To be explained ???
2155
2156                   --  Set_Has_Discriminants (Id);
2157                end if;
2158
2159                Prepare_Private_Subtype_Completion (Id, N);
2160
2161             when Access_Kind =>
2162                Set_Ekind             (Id, E_Access_Subtype);
2163                Set_Is_Constrained    (Id, Is_Constrained        (T));
2164                Set_Is_Access_Constant
2165                                      (Id, Is_Access_Constant    (T));
2166                Set_Directly_Designated_Type
2167                                      (Id, Designated_Type       (T));
2168
2169                --  A Pure library_item must not contain the declaration of a
2170                --  named access type, except within a subprogram, generic
2171                --  subprogram, task unit, or protected unit (RM 10.2.1(16)).
2172
2173                if Comes_From_Source (Id)
2174                  and then In_Pure_Unit
2175                  and then not In_Subprogram_Task_Protected_Unit
2176                then
2177                   Error_Msg_N
2178                     ("named access types not allowed in pure unit", N);
2179                end if;
2180
2181             when Concurrent_Kind =>
2182
2183                Set_Ekind                (Id, Subtype_Kind (Ekind   (T)));
2184                Set_Corresponding_Record_Type (Id,
2185                                          Corresponding_Record_Type (T));
2186                Set_First_Entity         (Id, First_Entity          (T));
2187                Set_First_Private_Entity (Id, First_Private_Entity  (T));
2188                Set_Has_Discriminants    (Id, Has_Discriminants     (T));
2189                Set_Is_Constrained       (Id, Is_Constrained        (T));
2190                Set_Last_Entity          (Id, Last_Entity           (T));
2191
2192                if Has_Discriminants (T) then
2193                   Set_Discriminant_Constraint (Id,
2194                                            Discriminant_Constraint (T));
2195                   Set_Girder_Constraint_From_Discriminant_Constraint (Id);
2196                end if;
2197
2198             --  If the subtype name denotes an incomplete type
2199             --  an error was already reported by Process_Subtype.
2200
2201             when E_Incomplete_Type =>
2202                Set_Etype (Id, Any_Type);
2203
2204             when others =>
2205                raise Program_Error;
2206          end case;
2207       end if;
2208
2209       if Etype (Id) = Any_Type then
2210          return;
2211       end if;
2212
2213       --  Some common processing on all types
2214
2215       Set_Size_Info      (Id,                 T);
2216       Set_First_Rep_Item (Id, First_Rep_Item (T));
2217
2218       T := Etype (Id);
2219
2220       Set_Is_Immediately_Visible (Id, True);
2221       Set_Depends_On_Private     (Id, Has_Private_Component (T));
2222
2223       if Present (Generic_Parent_Type (N))
2224         and then
2225           (Nkind
2226              (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
2227             or else Nkind
2228               (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
2229                 /=  N_Formal_Private_Type_Definition)
2230       then
2231          if Is_Tagged_Type (Id) then
2232             if Is_Class_Wide_Type (Id) then
2233                Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
2234             else
2235                Derive_Subprograms (Generic_Parent_Type (N), Id, T);
2236             end if;
2237
2238          elsif Scope (Etype (Id)) /= Standard_Standard then
2239             Derive_Subprograms (Generic_Parent_Type (N), Id);
2240          end if;
2241       end if;
2242
2243       if Is_Private_Type (T)
2244         and then Present (Full_View (T))
2245       then
2246          Conditional_Delay (Id, Full_View (T));
2247
2248       --  The subtypes of components or subcomponents of protected types
2249       --  do not need freeze nodes, which would otherwise appear in the
2250       --  wrong scope (before the freeze node for the protected type). The
2251       --  proper subtypes are those of the subcomponents of the corresponding
2252       --  record.
2253
2254       elsif Ekind (Scope (Id)) /= E_Protected_Type
2255         and then Present (Scope (Scope (Id))) -- error defense!
2256         and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
2257       then
2258          Conditional_Delay (Id, T);
2259       end if;
2260
2261       --  Check that constraint_error is raised for a scalar subtype
2262       --  indication when the lower or upper bound of a non-null range
2263       --  lies outside the range of the type mark.
2264
2265       if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
2266          if Is_Scalar_Type (Etype (Id))
2267             and then Scalar_Range (Id) /=
2268                      Scalar_Range (Etype (Subtype_Mark
2269                                            (Subtype_Indication (N))))
2270          then
2271             Apply_Range_Check
2272               (Scalar_Range (Id),
2273                Etype (Subtype_Mark (Subtype_Indication (N))));
2274
2275          elsif Is_Array_Type (Etype (Id))
2276            and then Present (First_Index (Id))
2277          then
2278             --  This really should be a subprogram that finds the indications
2279             --  to check???
2280
2281             if ((Nkind (First_Index (Id)) = N_Identifier
2282                    and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
2283                  or else Nkind (First_Index (Id)) = N_Subtype_Indication)
2284               and then
2285                 Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
2286             then
2287                declare
2288                   Target_Typ : Entity_Id :=
2289                     Etype
2290                       (First_Index
2291                         (Etype (Subtype_Mark (Subtype_Indication (N)))));
2292                begin
2293                   R_Checks :=
2294                     Range_Check
2295                       (Scalar_Range (Etype (First_Index (Id))),
2296                        Target_Typ,
2297                        Etype (First_Index (Id)),
2298                        Defining_Identifier (N));
2299
2300                   Insert_Range_Checks
2301                     (R_Checks,
2302                      N,
2303                      Target_Typ,
2304                      Sloc (Defining_Identifier (N)));
2305                end;
2306             end if;
2307          end if;
2308       end if;
2309
2310       Check_Eliminated (Id);
2311    end Analyze_Subtype_Declaration;
2312
2313    --------------------------------
2314    -- Analyze_Subtype_Indication --
2315    --------------------------------
2316
2317    procedure Analyze_Subtype_Indication (N : Node_Id) is
2318       T : constant Entity_Id := Subtype_Mark (N);
2319       R : constant Node_Id   := Range_Expression (Constraint (N));
2320
2321    begin
2322       Analyze (T);
2323
2324       if R /= Error then
2325          Analyze (R);
2326          Set_Etype (N, Etype (R));
2327       else
2328          Set_Error_Posted (R);
2329          Set_Error_Posted (T);
2330       end if;
2331    end Analyze_Subtype_Indication;
2332
2333    ------------------------------
2334    -- Analyze_Type_Declaration --
2335    ------------------------------
2336
2337    procedure Analyze_Type_Declaration (N : Node_Id) is
2338       Def    : constant Node_Id   := Type_Definition (N);
2339       Def_Id : constant Entity_Id := Defining_Identifier (N);
2340       T      : Entity_Id;
2341       Prev   : Entity_Id;
2342
2343    begin
2344       Prev := Find_Type_Name (N);
2345
2346       if Ekind (Prev) = E_Incomplete_Type then
2347          T := Full_View (Prev);
2348       else
2349          T := Prev;
2350       end if;
2351
2352       Set_Is_Pure (T, Is_Pure (Current_Scope));
2353
2354       --  We set the flag Is_First_Subtype here. It is needed to set the
2355       --  corresponding flag for the Implicit class-wide-type created
2356       --  during tagged types processing.
2357
2358       Set_Is_First_Subtype (T, True);
2359
2360       --  Only composite types other than array types are allowed to have
2361       --  discriminants.
2362
2363       case Nkind (Def) is
2364
2365          --  For derived types, the rule will be checked once we've figured
2366          --  out the parent type.
2367
2368          when N_Derived_Type_Definition =>
2369             null;
2370
2371          --  For record types, discriminants are allowed.
2372
2373          when N_Record_Definition =>
2374             null;
2375
2376          when others =>
2377             if Present (Discriminant_Specifications (N)) then
2378                Error_Msg_N
2379                  ("elementary or array type cannot have discriminants",
2380                   Defining_Identifier
2381                   (First (Discriminant_Specifications (N))));
2382             end if;
2383       end case;
2384
2385       --  Elaborate the type definition according to kind, and generate
2386       --  susbsidiary (implicit) subtypes where needed. We skip this if
2387       --  it was already done (this happens during the reanalysis that
2388       --  follows a call to the high level optimizer).
2389
2390       if not Analyzed (T) then
2391          Set_Analyzed (T);
2392
2393          case Nkind (Def) is
2394
2395             when N_Access_To_Subprogram_Definition =>
2396                Access_Subprogram_Declaration (T, Def);
2397
2398                --  If this is a remote access to subprogram, we must create
2399                --  the equivalent fat pointer type, and related subprograms.
2400
2401                if Is_Remote_Types (Current_Scope)
2402                  or else Is_Remote_Call_Interface (Current_Scope)
2403                then
2404                   Validate_Remote_Access_To_Subprogram_Type (N);
2405                   Process_Remote_AST_Declaration (N);
2406                end if;
2407
2408                --  Validate categorization rule against access type declaration
2409                --  usually a violation in Pure unit, Shared_Passive unit.
2410
2411                Validate_Access_Type_Declaration (T, N);
2412
2413             when N_Access_To_Object_Definition =>
2414                Access_Type_Declaration (T, Def);
2415
2416                --  Validate categorization rule against access type declaration
2417                --  usually a violation in Pure unit, Shared_Passive unit.
2418
2419                Validate_Access_Type_Declaration (T, N);
2420
2421                --  If we are in a Remote_Call_Interface package and define
2422                --  a RACW, Read and Write attribute must be added.
2423
2424                if (Is_Remote_Call_Interface (Current_Scope)
2425                      or else Is_Remote_Types (Current_Scope))
2426                  and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
2427                then
2428                   Add_RACW_Features (Def_Id);
2429                end if;
2430
2431             when N_Array_Type_Definition =>
2432                Array_Type_Declaration (T, Def);
2433
2434             when N_Derived_Type_Definition =>
2435                Derived_Type_Declaration (T, N, T /= Def_Id);
2436
2437             when N_Enumeration_Type_Definition =>
2438                Enumeration_Type_Declaration (T, Def);
2439
2440             when N_Floating_Point_Definition =>
2441                Floating_Point_Type_Declaration (T, Def);
2442
2443             when N_Decimal_Fixed_Point_Definition =>
2444                Decimal_Fixed_Point_Type_Declaration (T, Def);
2445
2446             when N_Ordinary_Fixed_Point_Definition =>
2447                Ordinary_Fixed_Point_Type_Declaration (T, Def);
2448
2449             when N_Signed_Integer_Type_Definition =>
2450                Signed_Integer_Type_Declaration (T, Def);
2451
2452             when N_Modular_Type_Definition =>
2453                Modular_Type_Declaration (T, Def);
2454
2455             when N_Record_Definition =>
2456                Record_Type_Declaration (T, N);
2457
2458             when others =>
2459                raise Program_Error;
2460
2461          end case;
2462       end if;
2463
2464       if Etype (T) = Any_Type then
2465          return;
2466       end if;
2467
2468       --  Some common processing for all types
2469
2470       Set_Depends_On_Private (T, Has_Private_Component (T));
2471
2472       --  Both the declared entity, and its anonymous base type if one
2473       --  was created, need freeze nodes allocated.
2474
2475       declare
2476          B : constant Entity_Id := Base_Type (T);
2477
2478       begin
2479          --  In the case where the base type is different from the first
2480          --  subtype, we pre-allocate a freeze node, and set the proper
2481          --  link to the first subtype. Freeze_Entity will use this
2482          --  preallocated freeze node when it freezes the entity.
2483
2484          if B /= T then
2485             Ensure_Freeze_Node (B);
2486             Set_First_Subtype_Link (Freeze_Node (B), T);
2487          end if;
2488
2489          if not From_With_Type (T) then
2490             Set_Has_Delayed_Freeze (T);
2491          end if;
2492       end;
2493
2494       --  Case of T is the full declaration of some private type which has
2495       --  been swapped in Defining_Identifier (N).
2496
2497       if T /= Def_Id and then Is_Private_Type (Def_Id) then
2498          Process_Full_View (N, T, Def_Id);
2499
2500          --  Record the reference. The form of this is a little strange,
2501          --  since the full declaration has been swapped in. So the first
2502          --  parameter here represents the entity to which a reference is
2503          --  made which is the "real" entity, i.e. the one swapped in,
2504          --  and the second parameter provides the reference location.
2505
2506          Generate_Reference (T, T, 'c');
2507
2508          --  If in main unit, set as referenced, so we do not complain about
2509          --  the full declaration being an unreferenced entity.
2510
2511          if In_Extended_Main_Source_Unit (Def_Id) then
2512             Set_Referenced (Def_Id);
2513          end if;
2514
2515       --  For completion of incomplete type, process incomplete dependents
2516       --  and always mark the full type as referenced (it is the incomplete
2517       --  type that we get for any real reference).
2518
2519       elsif Ekind (Prev) = E_Incomplete_Type then
2520          Process_Incomplete_Dependents (N, T, Prev);
2521          Generate_Reference (Prev, Def_Id, 'c');
2522
2523          --  If in main unit, set as referenced, so we do not complain about
2524          --  the full declaration being an unreferenced entity.
2525
2526          if In_Extended_Main_Source_Unit (Def_Id) then
2527             Set_Referenced (Def_Id);
2528          end if;
2529
2530       --  If not private type or incomplete type completion, this is a real
2531       --  definition of a new entity, so record it.
2532
2533       else
2534          Generate_Definition (Def_Id);
2535       end if;
2536
2537       Check_Eliminated (Def_Id);
2538    end Analyze_Type_Declaration;
2539
2540    --------------------------
2541    -- Analyze_Variant_Part --
2542    --------------------------
2543
2544    procedure Analyze_Variant_Part (N : Node_Id) is
2545
2546       procedure Non_Static_Choice_Error (Choice : Node_Id);
2547       --  Error routine invoked by the generic instantiation below when
2548       --  the variant part has a non static choice.
2549
2550       procedure Process_Declarations (Variant : Node_Id);
2551       --  Analyzes all the declarations associated with a Variant.
2552       --  Needed by the generic instantiation below.
2553
2554       package Variant_Choices_Processing is new
2555         Generic_Choices_Processing
2556           (Get_Alternatives          => Variants,
2557            Get_Choices               => Discrete_Choices,
2558            Process_Empty_Choice      => No_OP,
2559            Process_Non_Static_Choice => Non_Static_Choice_Error,
2560            Process_Associated_Node   => Process_Declarations);
2561       use Variant_Choices_Processing;
2562       --  Instantiation of the generic choice processing package.
2563
2564       -----------------------------
2565       -- Non_Static_Choice_Error --
2566       -----------------------------
2567
2568       procedure Non_Static_Choice_Error (Choice : Node_Id) is
2569       begin
2570          Error_Msg_N ("choice given in variant part is not static", Choice);
2571       end Non_Static_Choice_Error;
2572
2573       --------------------------
2574       -- Process_Declarations --
2575       --------------------------
2576
2577       procedure Process_Declarations (Variant : Node_Id) is
2578       begin
2579          if not Null_Present (Component_List (Variant)) then
2580             Analyze_Declarations (Component_Items (Component_List (Variant)));
2581
2582             if Present (Variant_Part (Component_List (Variant))) then
2583                Analyze (Variant_Part (Component_List (Variant)));
2584             end if;
2585          end if;
2586       end Process_Declarations;
2587
2588       --  Variables local to Analyze_Case_Statement.
2589
2590       Others_Choice : Node_Id;
2591
2592       Discr_Name : Node_Id;
2593       Discr_Type : Entity_Id;
2594
2595       Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
2596       Last_Choice    : Nat;
2597       Dont_Care      : Boolean;
2598       Others_Present : Boolean := False;
2599
2600    --  Start of processing for Analyze_Variant_Part
2601
2602    begin
2603       Discr_Name := Name (N);
2604       Analyze (Discr_Name);
2605
2606       if Ekind (Entity (Discr_Name)) /= E_Discriminant then
2607          Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
2608       end if;
2609
2610       Discr_Type := Etype (Entity (Discr_Name));
2611
2612       if not Is_Discrete_Type (Discr_Type) then
2613          Error_Msg_N
2614            ("discriminant in a variant part must be of a discrete type",
2615              Name (N));
2616          return;
2617       end if;
2618
2619       --  Call the instantiated Analyze_Choices which does the rest of the work
2620
2621       Analyze_Choices
2622         (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
2623
2624       if Others_Present then
2625          --  Fill in Others_Discrete_Choices field of the OTHERS choice
2626
2627          Others_Choice := First (Discrete_Choices (Last (Variants (N))));
2628          Expand_Others_Choice
2629            (Case_Table (1 .. Last_Choice), Others_Choice, Discr_Type);
2630       end if;
2631
2632    end Analyze_Variant_Part;
2633
2634    ----------------------------
2635    -- Array_Type_Declaration --
2636    ----------------------------
2637
2638    procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
2639       Component_Def : constant Node_Id := Subtype_Indication (Def);
2640       Element_Type  : Entity_Id;
2641       Implicit_Base : Entity_Id;
2642       Index         : Node_Id;
2643       Related_Id    : Entity_Id := Empty;
2644       Nb_Index      : Nat;
2645       P             : constant Node_Id := Parent (Def);
2646       Priv          : Entity_Id;
2647
2648    begin
2649       if Nkind (Def) = N_Constrained_Array_Definition then
2650
2651          Index := First (Discrete_Subtype_Definitions (Def));
2652
2653          --  Find proper names for the implicit types which may be public.
2654          --  in case of anonymous arrays we use the name of the first object
2655          --  of that type as prefix.
2656
2657          if No (T) then
2658             Related_Id :=  Defining_Identifier (P);
2659          else
2660             Related_Id := T;
2661          end if;
2662
2663       else
2664          Index := First (Subtype_Marks (Def));
2665       end if;
2666
2667       Nb_Index := 1;
2668
2669       while Present (Index) loop
2670          Analyze (Index);
2671          Make_Index (Index, P, Related_Id, Nb_Index);
2672          Next_Index (Index);
2673          Nb_Index := Nb_Index + 1;
2674       end loop;
2675
2676       Element_Type := Process_Subtype (Component_Def, P, Related_Id, 'C');
2677
2678       --  Constrained array case
2679
2680       if No (T) then
2681          T := Create_Itype (E_Void, P, Related_Id, 'T');
2682       end if;
2683
2684       if Nkind (Def) = N_Constrained_Array_Definition then
2685
2686          --  Establish Implicit_Base as unconstrained base type
2687
2688          Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
2689
2690          Init_Size_Align        (Implicit_Base);
2691          Set_Etype              (Implicit_Base, Implicit_Base);
2692          Set_Scope              (Implicit_Base, Current_Scope);
2693          Set_Has_Delayed_Freeze (Implicit_Base);
2694
2695          --  The constrained array type is a subtype of the unconstrained one
2696
2697          Set_Ekind          (T, E_Array_Subtype);
2698          Init_Size_Align    (T);
2699          Set_Etype          (T, Implicit_Base);
2700          Set_Scope          (T, Current_Scope);
2701          Set_Is_Constrained (T, True);
2702          Set_First_Index    (T, First (Discrete_Subtype_Definitions (Def)));
2703          Set_Has_Delayed_Freeze (T);
2704
2705          --  Complete setup of implicit base type
2706
2707          Set_First_Index    (Implicit_Base, First_Index (T));
2708          Set_Component_Type (Implicit_Base, Element_Type);
2709          Set_Has_Task       (Implicit_Base, Has_Task (Element_Type));
2710          Set_Component_Size (Implicit_Base, Uint_0);
2711          Set_Has_Controlled_Component (Implicit_Base,
2712            Has_Controlled_Component (Element_Type)
2713              or else Is_Controlled (Element_Type));
2714          Set_Finalize_Storage_Only (Implicit_Base,
2715            Finalize_Storage_Only (Element_Type));
2716
2717       --  Unconstrained array case
2718
2719       else
2720          Set_Ekind                    (T, E_Array_Type);
2721          Init_Size_Align              (T);
2722          Set_Etype                    (T, T);
2723          Set_Scope                    (T, Current_Scope);
2724          Set_Component_Size           (T, Uint_0);
2725          Set_Is_Constrained           (T, False);
2726          Set_First_Index              (T, First (Subtype_Marks (Def)));
2727          Set_Has_Delayed_Freeze       (T, True);
2728          Set_Has_Task                 (T, Has_Task (Element_Type));
2729          Set_Has_Controlled_Component (T,
2730            Has_Controlled_Component (Element_Type)
2731              or else Is_Controlled (Element_Type));
2732          Set_Finalize_Storage_Only (T,
2733            Finalize_Storage_Only (Element_Type));
2734       end if;
2735
2736       Set_Component_Type (T, Element_Type);
2737
2738       if Aliased_Present (Def) then
2739          Set_Has_Aliased_Components (Etype (T));
2740       end if;
2741
2742       Priv := Private_Component (Element_Type);
2743
2744       if Present (Priv) then
2745          --  Check for circular definitions.
2746
2747          if Priv = Any_Type then
2748             Set_Component_Type (T, Any_Type);
2749             Set_Component_Type (Etype (T), Any_Type);
2750
2751          --  There is a gap in the visiblity of operations on the composite
2752          --  type only if the component type is defined in a different scope.
2753
2754          elsif Scope (Priv) = Current_Scope then
2755             null;
2756
2757          elsif Is_Limited_Type (Priv) then
2758             Set_Is_Limited_Composite (Etype (T));
2759             Set_Is_Limited_Composite (T);
2760          else
2761             Set_Is_Private_Composite (Etype (T));
2762             Set_Is_Private_Composite (T);
2763          end if;
2764       end if;
2765
2766       --  Create a concatenation operator for the new type. Internal
2767       --  array types created for packed entities do not need such, they
2768       --  are compatible with the user-defined type.
2769
2770       if Number_Dimensions (T) = 1
2771          and then not Is_Packed_Array_Type (T)
2772       then
2773          New_Binary_Operator (Name_Op_Concat, T);
2774       end if;
2775
2776       --  In the case of an unconstrained array the parser has already
2777       --  verified that all the indices are unconstrained but we still
2778       --  need to make sure that the element type is constrained.
2779
2780       if Is_Indefinite_Subtype (Element_Type) then
2781          Error_Msg_N
2782            ("unconstrained element type in array declaration ",
2783             Component_Def);
2784
2785       elsif Is_Abstract (Element_Type) then
2786          Error_Msg_N ("The type of a component cannot be abstract ",
2787               Component_Def);
2788       end if;
2789
2790    end Array_Type_Declaration;
2791
2792    -------------------------------
2793    -- Build_Derived_Access_Type --
2794    -------------------------------
2795
2796    procedure Build_Derived_Access_Type
2797      (N            : Node_Id;
2798       Parent_Type  : Entity_Id;
2799       Derived_Type : Entity_Id)
2800    is
2801       S : constant Node_Id := Subtype_Indication (Type_Definition (N));
2802
2803       Desig_Type      : Entity_Id;
2804       Discr           : Entity_Id;
2805       Discr_Con_Elist : Elist_Id;
2806       Discr_Con_El    : Elmt_Id;
2807
2808       Subt            : Entity_Id;
2809
2810    begin
2811       --  Set the designated type so it is available in case this is
2812       --  an access to a self-referential type, e.g. a standard list
2813       --  type with a next pointer. Will be reset after subtype is built.
2814
2815       Set_Directly_Designated_Type (Derived_Type,
2816         Designated_Type (Parent_Type));
2817
2818       Subt := Process_Subtype (S, N);
2819
2820       if Nkind (S) /= N_Subtype_Indication
2821         and then Subt /= Base_Type (Subt)
2822       then
2823          Set_Ekind (Derived_Type, E_Access_Subtype);
2824       end if;
2825
2826       if Ekind (Derived_Type) = E_Access_Subtype then
2827          declare
2828             Pbase      : constant Entity_Id := Base_Type (Parent_Type);
2829             Ibase      : constant Entity_Id :=
2830                            Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
2831             Svg_Chars  : constant Name_Id   := Chars (Ibase);
2832             Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
2833
2834          begin
2835             Copy_Node (Pbase, Ibase);
2836
2837             Set_Chars       (Ibase, Svg_Chars);
2838             Set_Next_Entity (Ibase, Svg_Next_E);
2839             Set_Sloc        (Ibase, Sloc (Derived_Type));
2840             Set_Scope       (Ibase, Scope (Derived_Type));
2841             Set_Freeze_Node (Ibase, Empty);
2842             Set_Is_Frozen   (Ibase, False);
2843
2844             Set_Etype (Ibase, Pbase);
2845             Set_Etype (Derived_Type, Ibase);
2846          end;
2847       end if;
2848
2849       Set_Directly_Designated_Type
2850         (Derived_Type, Designated_Type (Subt));
2851
2852       Set_Is_Constrained     (Derived_Type, Is_Constrained (Subt));
2853       Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
2854       Set_Size_Info          (Derived_Type,                     Parent_Type);
2855       Set_RM_Size            (Derived_Type, RM_Size            (Parent_Type));
2856       Set_Depends_On_Private (Derived_Type,
2857                               Has_Private_Component (Derived_Type));
2858       Conditional_Delay      (Derived_Type, Subt);
2859
2860       --  Note: we do not copy the Storage_Size_Variable, since
2861       --  we always go to the root type for this information.
2862
2863       --  Apply range checks to discriminants for derived record case
2864       --  ??? THIS CODE SHOULD NOT BE HERE REALLY.
2865
2866       Desig_Type := Designated_Type (Derived_Type);
2867       if Is_Composite_Type (Desig_Type)
2868         and then (not Is_Array_Type (Desig_Type))
2869         and then Has_Discriminants (Desig_Type)
2870         and then Base_Type (Desig_Type) /= Desig_Type
2871       then
2872          Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
2873          Discr_Con_El := First_Elmt (Discr_Con_Elist);
2874
2875          Discr := First_Discriminant (Base_Type (Desig_Type));
2876          while Present (Discr_Con_El) loop
2877             Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
2878             Next_Elmt (Discr_Con_El);
2879             Next_Discriminant (Discr);
2880          end loop;
2881       end if;
2882    end Build_Derived_Access_Type;
2883
2884    ------------------------------
2885    -- Build_Derived_Array_Type --
2886    ------------------------------
2887
2888    procedure Build_Derived_Array_Type
2889      (N            : Node_Id;
2890       Parent_Type  : Entity_Id;
2891       Derived_Type : Entity_Id)
2892    is
2893       Loc           : constant Source_Ptr := Sloc (N);
2894       Tdef          : constant Node_Id    := Type_Definition (N);
2895       Indic         : constant Node_Id    := Subtype_Indication (Tdef);
2896       Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
2897       Implicit_Base : Entity_Id;
2898       New_Indic     : Node_Id;
2899
2900       procedure Make_Implicit_Base;
2901       --  If the parent subtype is constrained, the derived type is a
2902       --  subtype of an implicit base type derived from the parent base.
2903
2904       ------------------------
2905       -- Make_Implicit_Base --
2906       ------------------------
2907
2908       procedure Make_Implicit_Base is
2909       begin
2910          Implicit_Base :=
2911            Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
2912
2913          Set_Ekind (Implicit_Base, Ekind (Parent_Base));
2914          Set_Etype (Implicit_Base, Parent_Base);
2915
2916          Copy_Array_Subtype_Attributes   (Implicit_Base, Parent_Base);
2917          Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
2918
2919          Set_Has_Delayed_Freeze (Implicit_Base, True);
2920       end Make_Implicit_Base;
2921
2922    --  Start of processing for Build_Derived_Array_Type
2923
2924    begin
2925       if not Is_Constrained (Parent_Type) then
2926          if Nkind (Indic) /= N_Subtype_Indication then
2927             Set_Ekind (Derived_Type, E_Array_Type);
2928
2929             Copy_Array_Subtype_Attributes   (Derived_Type, Parent_Type);
2930             Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
2931
2932             Set_Has_Delayed_Freeze (Derived_Type, True);
2933
2934          else
2935             Make_Implicit_Base;
2936             Set_Etype (Derived_Type, Implicit_Base);
2937
2938             New_Indic :=
2939               Make_Subtype_Declaration (Loc,
2940                 Defining_Identifier => Derived_Type,
2941                 Subtype_Indication  =>
2942                   Make_Subtype_Indication (Loc,
2943                     Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
2944                     Constraint => Constraint (Indic)));
2945
2946             Rewrite (N, New_Indic);
2947             Analyze (N);
2948          end if;
2949
2950       else
2951          if Nkind (Indic) /= N_Subtype_Indication then
2952             Make_Implicit_Base;
2953
2954             Set_Ekind             (Derived_Type, Ekind (Parent_Type));
2955             Set_Etype             (Derived_Type, Implicit_Base);
2956             Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
2957
2958          else
2959             Error_Msg_N ("illegal constraint on constrained type", Indic);
2960          end if;
2961       end if;
2962
2963       --  If the parent type is not a derived type itself, and is
2964       --  declared in a closed scope (e.g., a subprogram), then we
2965       --  need to explicitly introduce the new type's concatenation
2966       --  operator since Derive_Subprograms will not inherit the
2967       --  parent's operator.
2968
2969       if Number_Dimensions (Parent_Type) = 1
2970         and then not Is_Limited_Type (Parent_Type)
2971         and then not Is_Derived_Type (Parent_Type)
2972         and then not Is_Package (Scope (Base_Type (Parent_Type)))
2973       then
2974          New_Binary_Operator (Name_Op_Concat, Derived_Type);
2975       end if;
2976    end Build_Derived_Array_Type;
2977
2978    -----------------------------------
2979    -- Build_Derived_Concurrent_Type --
2980    -----------------------------------
2981
2982    procedure Build_Derived_Concurrent_Type
2983      (N            : Node_Id;
2984       Parent_Type  : Entity_Id;
2985       Derived_Type : Entity_Id)
2986    is
2987       D_Constraint : Node_Id;
2988       Disc_Spec    : Node_Id;
2989       Old_Disc     : Entity_Id;
2990       New_Disc     : Entity_Id;
2991
2992       Constraint_Present : constant Boolean :=
2993                              Nkind (Subtype_Indication (Type_Definition (N)))
2994                                                      = N_Subtype_Indication;
2995
2996    begin
2997       Set_Girder_Constraint (Derived_Type, No_Elist);
2998
2999       if Is_Task_Type (Parent_Type) then
3000          Set_Storage_Size_Variable (Derived_Type,
3001            Storage_Size_Variable (Parent_Type));
3002       end if;
3003
3004       if Present (Discriminant_Specifications (N)) then
3005          New_Scope (Derived_Type);
3006          Check_Or_Process_Discriminants (N, Derived_Type);
3007          End_Scope;
3008
3009       elsif Constraint_Present then
3010
3011          --  Build constrained subtype and derive from it
3012
3013          declare
3014             Loc  : constant Source_Ptr := Sloc (N);
3015             Anon : Entity_Id :=
3016                      Make_Defining_Identifier (Loc,
3017                        New_External_Name (Chars (Derived_Type), 'T'));
3018             Decl : Node_Id;
3019
3020          begin
3021             Decl :=
3022               Make_Subtype_Declaration (Loc,
3023                 Defining_Identifier => Anon,
3024                 Subtype_Indication =>
3025                   New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
3026             Insert_Before (N, Decl);
3027             Rewrite (Subtype_Indication (Type_Definition (N)),
3028               New_Occurrence_Of (Anon, Loc));
3029             Analyze (Decl);
3030             Set_Analyzed (Derived_Type, False);
3031             Analyze (N);
3032             return;
3033          end;
3034       end if;
3035
3036       --  All attributes are inherited from parent. In particular,
3037       --  entries and the corresponding record type are the same.
3038       --  Discriminants may be renamed, and must be treated separately.
3039
3040       Set_Has_Discriminants
3041         (Derived_Type, Has_Discriminants         (Parent_Type));
3042       Set_Corresponding_Record_Type
3043         (Derived_Type, Corresponding_Record_Type (Parent_Type));
3044
3045       if Constraint_Present then
3046
3047          if not Has_Discriminants (Parent_Type) then
3048             Error_Msg_N ("untagged parent must have discriminants", N);
3049
3050          elsif Present (Discriminant_Specifications (N)) then
3051
3052             --  Verify that new discriminants are used to constrain
3053             --  the old ones.
3054
3055             Old_Disc   := First_Discriminant (Parent_Type);
3056             New_Disc   := First_Discriminant (Derived_Type);
3057             Disc_Spec  := First (Discriminant_Specifications (N));
3058             D_Constraint :=
3059               First
3060                 (Constraints
3061                   (Constraint (Subtype_Indication (Type_Definition (N)))));
3062
3063             while Present (Old_Disc) and then Present (Disc_Spec) loop
3064
3065                if Nkind (Discriminant_Type (Disc_Spec)) /=
3066                                               N_Access_Definition
3067                then
3068                   Analyze (Discriminant_Type (Disc_Spec));
3069
3070                   if not Subtypes_Statically_Compatible (
3071                              Etype (Discriminant_Type (Disc_Spec)),
3072                                Etype (Old_Disc))
3073                   then
3074                      Error_Msg_N
3075                        ("not statically compatible with parent discriminant",
3076                         Discriminant_Type (Disc_Spec));
3077                   end if;
3078                end if;
3079
3080                if Nkind (D_Constraint) = N_Identifier
3081                  and then Chars (D_Constraint) /=
3082                    Chars (Defining_Identifier (Disc_Spec))
3083                then
3084                   Error_Msg_N ("new discriminants must constrain old ones",
3085                     D_Constraint);
3086                else
3087                   Set_Corresponding_Discriminant (New_Disc, Old_Disc);
3088                end if;
3089
3090                Next_Discriminant (Old_Disc);
3091                Next_Discriminant (New_Disc);
3092                Next (Disc_Spec);
3093             end loop;
3094
3095             if Present (Old_Disc) or else Present (Disc_Spec) then
3096                Error_Msg_N ("discriminant mismatch in derivation", N);
3097             end if;
3098
3099          end if;
3100
3101       elsif Present (Discriminant_Specifications (N)) then
3102          Error_Msg_N
3103            ("missing discriminant constraint in untagged derivation",
3104             N);
3105       end if;
3106
3107       if Present (Discriminant_Specifications (N)) then
3108
3109          Old_Disc := First_Discriminant (Parent_Type);
3110
3111          while Present (Old_Disc) loop
3112
3113             if No (Next_Entity (Old_Disc))
3114               or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
3115             then
3116                Set_Next_Entity (Last_Entity (Derived_Type),
3117                                          Next_Entity (Old_Disc));
3118                exit;
3119             end if;
3120
3121             Next_Discriminant (Old_Disc);
3122          end loop;
3123
3124       else
3125          Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
3126          if Has_Discriminants (Parent_Type) then
3127             Set_Discriminant_Constraint (
3128               Derived_Type, Discriminant_Constraint (Parent_Type));
3129          end if;
3130       end if;
3131
3132       Set_Last_Entity  (Derived_Type, Last_Entity  (Parent_Type));
3133
3134       Set_Has_Completion (Derived_Type);
3135    end Build_Derived_Concurrent_Type;
3136
3137    ------------------------------------
3138    -- Build_Derived_Enumeration_Type --
3139    ------------------------------------
3140
3141    procedure Build_Derived_Enumeration_Type
3142      (N            : Node_Id;
3143       Parent_Type  : Entity_Id;
3144       Derived_Type : Entity_Id)
3145    is
3146       Loc           : constant Source_Ptr := Sloc (N);
3147       Def           : constant Node_Id    := Type_Definition (N);
3148       Indic         : constant Node_Id    := Subtype_Indication (Def);
3149       Implicit_Base : Entity_Id;
3150       Literal       : Entity_Id;
3151       New_Lit       : Entity_Id;
3152       Literals_List : List_Id;
3153       Type_Decl     : Node_Id;
3154       Hi, Lo        : Node_Id;
3155       Rang_Expr     : Node_Id;
3156
3157    begin
3158       --  Since types Standard.Character and Standard.Wide_Character do
3159       --  not have explicit literals lists we need to process types derived
3160       --  from them specially. This is handled by Derived_Standard_Character.
3161       --  If the parent type is a generic type, there are no literals either,
3162       --  and we construct the same skeletal representation as for the generic
3163       --  parent type.
3164
3165       if Root_Type (Parent_Type) = Standard_Character
3166         or else Root_Type (Parent_Type) = Standard_Wide_Character
3167       then
3168          Derived_Standard_Character (N, Parent_Type, Derived_Type);
3169
3170       elsif Is_Generic_Type (Root_Type (Parent_Type)) then
3171          declare
3172             Lo : Node_Id;
3173             Hi : Node_Id;
3174
3175          begin
3176             Lo :=
3177                Make_Attribute_Reference (Loc,
3178                  Attribute_Name => Name_First,
3179                  Prefix => New_Reference_To (Derived_Type, Loc));
3180             Set_Etype (Lo, Derived_Type);
3181
3182             Hi :=
3183                Make_Attribute_Reference (Loc,
3184                  Attribute_Name => Name_Last,
3185                  Prefix => New_Reference_To (Derived_Type, Loc));
3186             Set_Etype (Hi, Derived_Type);
3187
3188             Set_Scalar_Range (Derived_Type,
3189                Make_Range (Loc,
3190                  Low_Bound => Lo,
3191                  High_Bound => Hi));
3192          end;
3193
3194       else
3195          --  If a constraint is present, analyze the bounds to catch
3196          --  premature usage of the derived literals.
3197
3198          if Nkind (Indic) = N_Subtype_Indication
3199            and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
3200          then
3201             Analyze (Low_Bound  (Range_Expression (Constraint (Indic))));
3202             Analyze (High_Bound (Range_Expression (Constraint (Indic))));
3203          end if;
3204
3205          --  Introduce an implicit base type for the derived type even
3206          --  if there is no constraint attached to it, since this seems
3207          --  closer to the Ada semantics. Build a full type declaration
3208          --  tree for the derived type using the implicit base type as
3209          --  the defining identifier. The build a subtype declaration
3210          --  tree which applies the constraint (if any) have it replace
3211          --  the derived type declaration.
3212
3213          Literal := First_Literal (Parent_Type);
3214          Literals_List := New_List;
3215
3216          while Present (Literal)
3217            and then Ekind (Literal) = E_Enumeration_Literal
3218          loop
3219             --  Literals of the derived type have the same representation as
3220             --  those of the parent type, but this representation can be
3221             --  overridden by an explicit representation clause. Indicate
3222             --  that there is no explicit representation given yet. These
3223             --  derived literals are implicit operations of the new type,
3224             --  and can be overriden by explicit ones.
3225
3226             if Nkind (Literal) = N_Defining_Character_Literal then
3227                New_Lit :=
3228                  Make_Defining_Character_Literal (Loc, Chars (Literal));
3229             else
3230                New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
3231             end if;
3232
3233             Set_Ekind                (New_Lit, E_Enumeration_Literal);
3234             Set_Enumeration_Pos      (New_Lit, Enumeration_Pos (Literal));
3235             Set_Enumeration_Rep      (New_Lit, Enumeration_Rep (Literal));
3236             Set_Enumeration_Rep_Expr (New_Lit, Empty);
3237             Set_Alias                (New_Lit, Literal);
3238             Set_Is_Known_Valid       (New_Lit, True);
3239
3240             Append (New_Lit, Literals_List);
3241             Next_Literal (Literal);
3242          end loop;
3243
3244          Implicit_Base :=
3245            Make_Defining_Identifier (Sloc (Derived_Type),
3246              New_External_Name (Chars (Derived_Type), 'B'));
3247
3248          --  Indicate the proper nature of the derived type. This must
3249          --  be done before analysis of the literals, to recognize cases
3250          --  when a literal may be hidden by a previous explicit function
3251          --  definition (cf. c83031a).
3252
3253          Set_Ekind (Derived_Type, E_Enumeration_Subtype);
3254          Set_Etype (Derived_Type, Implicit_Base);
3255
3256          Type_Decl :=
3257            Make_Full_Type_Declaration (Loc,
3258              Defining_Identifier => Implicit_Base,
3259              Discriminant_Specifications => No_List,
3260              Type_Definition =>
3261                Make_Enumeration_Type_Definition (Loc, Literals_List));
3262
3263          Mark_Rewrite_Insertion (Type_Decl);
3264          Insert_Before (N, Type_Decl);
3265          Analyze (Type_Decl);
3266
3267          --  After the implicit base is analyzed its Etype needs to be
3268          --  changed to reflect the fact that it is derived from the
3269          --  parent type which was ignored during analysis. We also set
3270          --  the size at this point.
3271
3272          Set_Etype (Implicit_Base, Parent_Type);
3273
3274          Set_Size_Info      (Implicit_Base,                 Parent_Type);
3275          Set_RM_Size        (Implicit_Base, RM_Size        (Parent_Type));
3276          Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
3277
3278          Set_Has_Non_Standard_Rep
3279                             (Implicit_Base, Has_Non_Standard_Rep
3280                                                            (Parent_Type));
3281          Set_Has_Delayed_Freeze (Implicit_Base);
3282
3283          --  Process the subtype indication including a validation check
3284          --  on the constraint, if any. If a constraint is given, its bounds
3285          --  must be implicitly converted to the new type.
3286
3287          if Nkind (Indic) = N_Subtype_Indication then
3288
3289             declare
3290                R   : constant Node_Id :=
3291                        Range_Expression (Constraint (Indic));
3292
3293             begin
3294                if Nkind (R) = N_Range then
3295                   Hi := Build_Scalar_Bound
3296                           (High_Bound (R), Parent_Type, Implicit_Base, Loc);
3297                   Lo := Build_Scalar_Bound
3298                           (Low_Bound  (R), Parent_Type, Implicit_Base, Loc);
3299
3300                else
3301                   --  Constraint is a Range attribute. Replace with the
3302                   --  explicit mention of the bounds of the prefix, which
3303                   --  must be a subtype.
3304
3305                   Analyze (Prefix (R));
3306                   Hi :=
3307                     Convert_To (Implicit_Base,
3308                       Make_Attribute_Reference (Loc,
3309                         Attribute_Name => Name_Last,
3310                         Prefix =>
3311                           New_Occurrence_Of (Entity (Prefix (R)), Loc)));
3312
3313                   Lo :=
3314                     Convert_To (Implicit_Base,
3315                       Make_Attribute_Reference (Loc,
3316                         Attribute_Name => Name_First,
3317                         Prefix =>
3318                           New_Occurrence_Of (Entity (Prefix (R)), Loc)));
3319                end if;
3320
3321             end;
3322
3323          else
3324             Hi :=
3325               Build_Scalar_Bound
3326                 (Type_High_Bound (Parent_Type),
3327                  Parent_Type, Implicit_Base, Loc);
3328             Lo :=
3329                Build_Scalar_Bound
3330                  (Type_Low_Bound (Parent_Type),
3331                   Parent_Type, Implicit_Base, Loc);
3332          end if;
3333
3334          Rang_Expr :=
3335            Make_Range (Loc,
3336              Low_Bound  => Lo,
3337              High_Bound => Hi);
3338
3339          --  If we constructed a default range for the case where no range
3340          --  was given, then the expressions in the range must not freeze
3341          --  since they do not correspond to expressions in the source.
3342
3343          if Nkind (Indic) /= N_Subtype_Indication then
3344             Set_Must_Not_Freeze (Lo);
3345             Set_Must_Not_Freeze (Hi);
3346             Set_Must_Not_Freeze (Rang_Expr);
3347          end if;
3348
3349          Rewrite (N,
3350            Make_Subtype_Declaration (Loc,
3351              Defining_Identifier => Derived_Type,
3352              Subtype_Indication =>
3353                Make_Subtype_Indication (Loc,
3354                  Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
3355                  Constraint =>
3356                    Make_Range_Constraint (Loc,
3357                      Range_Expression => Rang_Expr))));
3358
3359          Analyze (N);
3360
3361          --  If pragma Discard_Names applies on the first subtype
3362          --  of the parent type, then it must be applied on this
3363          --  subtype as well.
3364
3365          if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
3366             Set_Discard_Names (Derived_Type);
3367          end if;
3368
3369          --  Apply a range check. Since this range expression doesn't
3370          --  have an Etype, we have to specifically pass the Source_Typ
3371          --  parameter. Is this right???
3372
3373          if Nkind (Indic) = N_Subtype_Indication then
3374             Apply_Range_Check (Range_Expression (Constraint (Indic)),
3375                                Parent_Type,
3376                                Source_Typ => Entity (Subtype_Mark (Indic)));
3377          end if;
3378       end if;
3379
3380    end Build_Derived_Enumeration_Type;
3381
3382    --------------------------------
3383    -- Build_Derived_Numeric_Type --
3384    --------------------------------
3385
3386    procedure Build_Derived_Numeric_Type
3387      (N            : Node_Id;
3388       Parent_Type  : Entity_Id;
3389       Derived_Type : Entity_Id)
3390    is
3391       Loc           : constant Source_Ptr := Sloc (N);
3392       Tdef          : constant Node_Id    := Type_Definition (N);
3393       Indic         : constant Node_Id    := Subtype_Indication (Tdef);
3394       Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
3395       No_Constraint : constant Boolean    := Nkind (Indic) /=
3396                                                   N_Subtype_Indication;
3397       Implicit_Base    : Entity_Id;
3398
3399       Lo : Node_Id;
3400       Hi : Node_Id;
3401       T  : Entity_Id;
3402
3403    begin
3404       --  Process the subtype indication including a validation check on
3405       --  the constraint if any.
3406
3407       T := Process_Subtype (Indic, N);
3408
3409       --  Introduce an implicit base type for the derived type even if
3410       --  there is no constraint attached to it, since this seems closer
3411       --  to the Ada semantics.
3412
3413       Implicit_Base :=
3414         Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
3415
3416       Set_Etype          (Implicit_Base, Parent_Base);
3417       Set_Ekind          (Implicit_Base, Ekind          (Parent_Base));
3418       Set_Size_Info      (Implicit_Base,                 Parent_Base);
3419       Set_RM_Size        (Implicit_Base, RM_Size        (Parent_Base));
3420       Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
3421       Set_Parent         (Implicit_Base, Parent (Derived_Type));
3422
3423       if Is_Discrete_Or_Fixed_Point_Type (Parent_Base) then
3424          Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
3425       end if;
3426
3427       Set_Has_Delayed_Freeze (Implicit_Base);
3428
3429       Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Base));
3430       Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
3431
3432       Set_Scalar_Range (Implicit_Base,
3433         Make_Range (Loc,
3434           Low_Bound  => Lo,
3435           High_Bound => Hi));
3436
3437       if Has_Infinities (Parent_Base) then
3438          Set_Includes_Infinities (Scalar_Range (Implicit_Base));
3439       end if;
3440
3441       --  The Derived_Type, which is the entity of the declaration, is
3442       --  a subtype of the implicit base. Its Ekind is a subtype, even
3443       --  in the absence of an explicit constraint.
3444
3445       Set_Etype (Derived_Type, Implicit_Base);
3446
3447       --  If we did not have a constraint, then the Ekind is set from the
3448       --  parent type (otherwise Process_Subtype has set the bounds)
3449
3450       if No_Constraint then
3451          Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
3452       end if;
3453
3454       --  If we did not have a range constraint, then set the range
3455       --  from the parent type. Otherwise, the call to Process_Subtype
3456       --  has set the bounds.
3457
3458       if No_Constraint
3459         or else not Has_Range_Constraint (Indic)
3460       then
3461          Set_Scalar_Range (Derived_Type,
3462            Make_Range (Loc,
3463              Low_Bound  => New_Copy_Tree (Type_Low_Bound  (Parent_Type)),
3464              High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
3465          Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
3466
3467          if Has_Infinities (Parent_Type) then
3468             Set_Includes_Infinities (Scalar_Range (Derived_Type));
3469          end if;
3470       end if;
3471
3472       --  Set remaining type-specific fields, depending on numeric type
3473
3474       if Is_Modular_Integer_Type (Parent_Type) then
3475          Set_Modulus (Implicit_Base, Modulus (Parent_Base));
3476
3477          Set_Non_Binary_Modulus
3478            (Implicit_Base, Non_Binary_Modulus (Parent_Base));
3479
3480       elsif Is_Floating_Point_Type (Parent_Type) then
3481
3482          --  Digits of base type is always copied from the digits value of
3483          --  the parent base type, but the digits of the derived type will
3484          --  already have been set if there was a constraint present.
3485
3486          Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
3487          Set_Vax_Float    (Implicit_Base, Vax_Float    (Parent_Base));
3488
3489          if No_Constraint then
3490             Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
3491          end if;
3492
3493       elsif Is_Fixed_Point_Type (Parent_Type) then
3494
3495          --  Small of base type and derived type are always copied from
3496          --  the parent base type, since smalls never change. The delta
3497          --  of the base type is also copied from the parent base type.
3498          --  However the delta of the derived type will have been set
3499          --  already if a constraint was present.
3500
3501          Set_Small_Value (Derived_Type,  Small_Value (Parent_Base));
3502          Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
3503          Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
3504
3505          if No_Constraint then
3506             Set_Delta_Value (Derived_Type,  Delta_Value (Parent_Type));
3507          end if;
3508
3509          --  The scale and machine radix in the decimal case are always
3510          --  copied from the parent base type.
3511
3512          if Is_Decimal_Fixed_Point_Type (Parent_Type) then
3513             Set_Scale_Value (Derived_Type,  Scale_Value (Parent_Base));
3514             Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
3515
3516             Set_Machine_Radix_10
3517               (Derived_Type,  Machine_Radix_10 (Parent_Base));
3518             Set_Machine_Radix_10
3519               (Implicit_Base, Machine_Radix_10 (Parent_Base));
3520
3521             Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
3522
3523             if No_Constraint then
3524                Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
3525
3526             else
3527                --  the analysis of the subtype_indication sets the
3528                --  digits value of the derived type.
3529
3530                null;
3531             end if;
3532          end if;
3533       end if;
3534
3535       --  The type of the bounds is that of the parent type, and they
3536       --  must be converted to the derived type.
3537
3538       Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
3539
3540       --  The implicit_base should be frozen when the derived type is frozen,
3541       --  but note that it is used in the conversions of the bounds. For
3542       --  fixed types we delay the determination of the bounds until the proper
3543       --  freezing point. For other numeric types this is rejected by GCC, for
3544       --  reasons that are currently unclear (???), so we choose to freeze the
3545       --  implicit base now. In the case of integers and floating point types
3546       --  this is harmless because subsequent representation clauses cannot
3547       --  affect anything, but it is still baffling that we cannot use the
3548       --  same mechanism for all derived numeric types.
3549
3550       if Is_Fixed_Point_Type (Parent_Type) then
3551          Conditional_Delay (Implicit_Base, Parent_Type);
3552       else
3553          Freeze_Before (N, Implicit_Base);
3554       end if;
3555
3556    end Build_Derived_Numeric_Type;
3557
3558    --------------------------------
3559    -- Build_Derived_Private_Type --
3560    --------------------------------
3561
3562    procedure Build_Derived_Private_Type
3563      (N            : Node_Id;
3564       Parent_Type  : Entity_Id;
3565       Derived_Type : Entity_Id;
3566       Is_Completion : Boolean;
3567       Derive_Subps  : Boolean := True)
3568    is
3569       Der_Base    : Entity_Id;
3570       Discr       : Entity_Id;
3571       Full_Decl   : Node_Id := Empty;
3572       Full_Der    : Entity_Id;
3573       Full_P      : Entity_Id;
3574       Last_Discr  : Entity_Id;
3575       Par_Scope   : constant Entity_Id := Scope (Base_Type (Parent_Type));
3576       Swapped     : Boolean := False;
3577
3578       procedure Copy_And_Build;
3579       --  Copy derived type declaration, replace parent with its full view,
3580       --  and analyze new declaration.
3581
3582       procedure Copy_And_Build is
3583          Full_N  : Node_Id;
3584
3585       begin
3586          if Ekind (Parent_Type) in Record_Kind
3587            or else (Ekind (Parent_Type) in Enumeration_Kind
3588              and then Root_Type (Parent_Type) /= Standard_Character
3589              and then Root_Type (Parent_Type) /= Standard_Wide_Character
3590              and then not Is_Generic_Type (Root_Type (Parent_Type)))
3591          then
3592             Full_N := New_Copy_Tree (N);
3593             Insert_After (N, Full_N);
3594             Build_Derived_Type (
3595               Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
3596
3597          else
3598             Build_Derived_Type (
3599               N, Parent_Type, Full_Der, True, Derive_Subps => False);
3600          end if;
3601       end Copy_And_Build;
3602
3603    --  Start of processing for Build_Derived_Private_Type
3604
3605    begin
3606       if Is_Tagged_Type (Parent_Type) then
3607          Build_Derived_Record_Type
3608            (N, Parent_Type, Derived_Type, Derive_Subps);
3609          return;
3610
3611       elsif Has_Discriminants (Parent_Type) then
3612
3613          if Present (Full_View (Parent_Type)) then
3614             if not Is_Completion then
3615
3616                --  Copy declaration for subsequent analysis.
3617
3618                Full_Decl := New_Copy_Tree (N);
3619                Full_Der  := New_Copy (Derived_Type);
3620                Insert_After (N, Full_Decl);
3621
3622             else
3623                --  If this is a completion, the full view being built is
3624                --  itself private. We build a subtype of the parent with
3625                --  the same constraints as this full view, to convey to the
3626                --  back end the constrained components and the size of this
3627                --  subtype. If the parent is constrained, its full view can
3628                --  serve as the underlying full view of the derived type.
3629
3630                if No (Discriminant_Specifications (N)) then
3631
3632                   if Nkind (Subtype_Indication (Type_Definition (N)))
3633                     = N_Subtype_Indication
3634                   then
3635                      Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
3636
3637                   elsif Is_Constrained (Full_View (Parent_Type)) then
3638                      Set_Underlying_Full_View (Derived_Type,
3639                        Full_View (Parent_Type));
3640                   end if;
3641
3642                else
3643                   --  If there are new discriminants, the parent subtype is
3644                   --  constrained by them, but it is not clear how to build
3645                   --  the underlying_full_view in this case ???
3646
3647                   null;
3648                end if;
3649             end if;
3650          end if;
3651
3652          Build_Derived_Record_Type
3653            (N, Parent_Type, Derived_Type, Derive_Subps);
3654
3655          if Present (Full_View (Parent_Type))
3656            and then not Is_Completion
3657          then
3658             if not In_Open_Scopes (Par_Scope)
3659               or else not In_Same_Source_Unit (N, Parent_Type)
3660             then
3661                --  Swap partial and full views temporarily
3662
3663                Install_Private_Declarations (Par_Scope);
3664                Install_Visible_Declarations (Par_Scope);
3665                Swapped := True;
3666             end if;
3667
3668             --  Subprograms have been derived on the private view,
3669             --  the completion does not derive them anew.
3670
3671             Build_Derived_Record_Type
3672               (Full_Decl, Parent_Type, Full_Der, False);
3673
3674             if Swapped then
3675                Uninstall_Declarations (Par_Scope);
3676
3677                if In_Open_Scopes (Par_Scope) then
3678                   Install_Visible_Declarations (Par_Scope);
3679                end if;
3680             end if;
3681
3682             Der_Base := Base_Type (Derived_Type);
3683             Set_Full_View (Derived_Type, Full_Der);
3684             Set_Full_View (Der_Base, Base_Type (Full_Der));
3685
3686             --  Copy the discriminant list from full view to
3687             --  the partial views (base type and its subtype).
3688             --  Gigi requires that the partial and full views
3689             --  have the same discriminants.
3690             --  ??? Note that since the partial view is pointing
3691             --  to discriminants in the full view, their scope
3692             --  will be that of the full view. This might
3693             --  cause some front end problems and need
3694             --  adustment?
3695
3696             Discr := First_Discriminant (Base_Type (Full_Der));
3697             Set_First_Entity (Der_Base, Discr);
3698
3699             loop
3700                Last_Discr := Discr;
3701                Next_Discriminant (Discr);
3702                exit when No (Discr);
3703             end loop;
3704
3705             Set_Last_Entity (Der_Base, Last_Discr);
3706
3707             Set_First_Entity (Derived_Type, First_Entity (Der_Base));
3708             Set_Last_Entity  (Derived_Type, Last_Entity  (Der_Base));
3709
3710          else
3711             --  If this is a completion, the derived type stays private
3712             --  and there is no need to create a further full view, except
3713             --  in the unusual case when the derivation is nested within a
3714             --  child unit, see below.
3715
3716             null;
3717          end if;
3718
3719       elsif Present (Full_View (Parent_Type))
3720         and then  Has_Discriminants (Full_View (Parent_Type))
3721       then
3722          if Has_Unknown_Discriminants (Parent_Type)
3723            and then Nkind (Subtype_Indication (Type_Definition (N)))
3724              = N_Subtype_Indication
3725          then
3726             Error_Msg_N
3727               ("cannot constrain type with unknown discriminants",
3728                Subtype_Indication (Type_Definition (N)));
3729             return;
3730          end if;
3731
3732          --  Inherit the discriminants of the full view, but
3733          --  keep the proper parent type.
3734
3735          --  ??? this looks wrong, we are replacing (and thus,
3736          --  erasing) the partial view!
3737
3738          --  In any case, the primitive operations are inherited from
3739          --  the parent type, not from the internal full view.
3740
3741          Build_Derived_Record_Type
3742            (N, Full_View (Parent_Type), Derived_Type,
3743              Derive_Subps => False);
3744          Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
3745
3746          if Derive_Subps then
3747             Derive_Subprograms (Parent_Type, Derived_Type);
3748          end if;
3749
3750       else
3751
3752          --  Untagged type, No discriminants on either view.
3753
3754          if Nkind (Subtype_Indication (Type_Definition (N)))
3755            = N_Subtype_Indication
3756          then
3757             Error_Msg_N
3758               ("illegal constraint on type without discriminants", N);
3759          end if;
3760
3761          if Present (Discriminant_Specifications (N))
3762            and then Present (Full_View (Parent_Type))
3763            and then not Is_Tagged_Type (Full_View (Parent_Type))
3764          then
3765             Error_Msg_N
3766               ("cannot add discriminants to untagged type", N);
3767          end if;
3768
3769          Set_Girder_Constraint (Derived_Type, No_Elist);
3770          Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
3771          Set_Is_Controlled  (Derived_Type, Is_Controlled  (Parent_Type));
3772          Set_Has_Controlled_Component (Derived_Type,
3773            Has_Controlled_Component (Parent_Type));
3774
3775          --  Direct controlled types do not inherit the Finalize_Storage_Only
3776          --  flag.
3777
3778          if not Is_Controlled  (Parent_Type) then
3779             Set_Finalize_Storage_Only (Derived_Type,
3780               Finalize_Storage_Only (Parent_Type));
3781          end if;
3782
3783          --  Construct the implicit full view by deriving from full
3784          --  view of the parent type. In order to get proper visiblity,
3785          --  we install the parent scope and its declarations.
3786
3787          --  ??? if the parent is untagged private and its
3788          --  completion is tagged, this mechanism will not
3789          --  work because we cannot derive from the tagged
3790          --  full view unless we have an extension
3791
3792          if Present (Full_View (Parent_Type))
3793            and then not Is_Tagged_Type (Full_View (Parent_Type))
3794            and then not Is_Completion
3795          then
3796             Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
3797                                               Chars (Derived_Type));
3798             Set_Is_Itype (Full_Der);
3799             Set_Has_Private_Declaration (Full_Der);
3800             Set_Has_Private_Declaration (Derived_Type);
3801             Set_Associated_Node_For_Itype (Full_Der, N);
3802             Set_Parent (Full_Der, Parent (Derived_Type));
3803             Set_Full_View (Derived_Type, Full_Der);
3804
3805             if not In_Open_Scopes (Par_Scope) then
3806                Install_Private_Declarations (Par_Scope);
3807                Install_Visible_Declarations (Par_Scope);
3808                Copy_And_Build;
3809                Uninstall_Declarations (Par_Scope);
3810
3811             --  If parent scope is open and in another unit, and
3812             --  parent has a completion, then the derivation is taking
3813             --  place in the visible part of a child unit. In that
3814             --  case retrieve the full view of the parent momentarily.
3815
3816             elsif not In_Same_Source_Unit (N, Parent_Type) then
3817                Full_P := Full_View (Parent_Type);
3818                Exchange_Declarations (Parent_Type);
3819                Copy_And_Build;
3820                Exchange_Declarations (Full_P);
3821
3822             --  Otherwise it is a local derivation.
3823
3824             else
3825                Copy_And_Build;
3826             end if;
3827
3828             Set_Scope                (Full_Der, Current_Scope);
3829             Set_Is_First_Subtype     (Full_Der,
3830                                        Is_First_Subtype (Derived_Type));
3831             Set_Has_Size_Clause      (Full_Der, False);
3832             Set_Has_Alignment_Clause (Full_Der, False);
3833             Set_Next_Entity          (Full_Der, Empty);
3834             Set_Has_Delayed_Freeze   (Full_Der);
3835             Set_Is_Frozen            (Full_Der, False);
3836             Set_Freeze_Node          (Full_Der, Empty);
3837             Set_Depends_On_Private   (Full_Der,
3838                                         Has_Private_Component    (Full_Der));
3839             Set_Public_Status        (Full_Der);
3840          end if;
3841       end if;
3842
3843       Set_Has_Unknown_Discriminants (Derived_Type,
3844         Has_Unknown_Discriminants (Parent_Type));
3845
3846       if Is_Private_Type (Derived_Type) then
3847          Set_Private_Dependents (Derived_Type, New_Elmt_List);
3848       end if;
3849
3850       if Is_Private_Type (Parent_Type)
3851         and then Base_Type (Parent_Type) = Parent_Type
3852         and then In_Open_Scopes (Scope (Parent_Type))
3853       then
3854          Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
3855
3856          if Is_Child_Unit (Scope (Current_Scope))
3857            and then Is_Completion
3858            and then In_Private_Part (Current_Scope)
3859          then
3860             --  This is the unusual case where a type completed by a private
3861             --  derivation occurs within a package nested in a child unit,
3862             --  and the parent is declared in an ancestor. In this case, the
3863             --  full view of the parent type will become visible in the body
3864             --  of the enclosing child, and only then will the current type
3865             --  be possibly non-private. We build a underlying full view that
3866             --  will be installed when the enclosing child body is compiled.
3867
3868             declare
3869                IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
3870
3871             begin
3872                Full_Der :=
3873                  Make_Defining_Identifier (Sloc (Derived_Type),
3874                    Chars (Derived_Type));
3875                Set_Is_Itype (Full_Der);
3876                Set_Itype (IR, Full_Der);
3877                Insert_After (N, IR);
3878
3879                --  The full view will be used to swap entities on entry/exit
3880                --  to the body, and must appear in the entity list for the
3881                --  package.
3882
3883                Append_Entity (Full_Der, Scope (Derived_Type));
3884                Set_Has_Private_Declaration (Full_Der);
3885                Set_Has_Private_Declaration (Derived_Type);
3886                Set_Associated_Node_For_Itype (Full_Der, N);
3887                Set_Parent (Full_Der, Parent (Derived_Type));
3888                Full_P := Full_View (Parent_Type);
3889                Exchange_Declarations (Parent_Type);
3890                Copy_And_Build;
3891                Exchange_Declarations (Full_P);
3892                Set_Underlying_Full_View (Derived_Type, Full_Der);
3893             end;
3894          end if;
3895       end if;
3896    end Build_Derived_Private_Type;
3897
3898    -------------------------------
3899    -- Build_Derived_Record_Type --
3900    -------------------------------
3901
3902    --  1. INTRODUCTION.
3903
3904    --  Ideally we would like to use the same model of type derivation for
3905    --  tagged and untagged record types. Unfortunately this is not quite
3906    --  possible because the semantics of representation clauses is different
3907    --  for tagged and untagged records under inheritance. Consider the
3908    --  following:
3909
3910    --     type R (...) is [tagged] record ... end record;
3911    --     type T (...) is new R (...) [with ...];
3912
3913    --  The representation clauses of T can specify a completely different
3914    --  record layout from R's. Hence a same component can be placed in two very
3915    --  different positions in objects of type T and R. If R and T are tagged
3916    --  types, representation clauses for T can only specify the layout of non
3917    --  inherited components, thus components that are common in R and T have
3918    --  the same position in objects of type R or T.
3919
3920    --  This has two implications. The first is that the entire tree for R's
3921    --  declaration needs to be copied for T in the untagged case, so that
3922    --  T can be viewd as a record type of its own with its own derivation
3923    --  clauses. The second implication is the way we handle discriminants.
3924    --  Specifically, in the untagged case we need a way to communicate to Gigi
3925    --  what are the real discriminants in the record, while for the semantics
3926    --  we need to consider those introduced by the user to rename the
3927    --  discriminants in the parent type. This is handled by introducing the
3928    --  notion of girder discriminants. See below for more.
3929
3930    --  Fortunately the way regular components are inherited can be handled in
3931    --  the same way in tagged and untagged types.
3932
3933    --  To complicate things a bit more the private view of a private extension
3934    --  cannot be handled in the same way as the full view (for one thing the
3935    --  semantic rules are somewhat different). We will explain what differs
3936    --  below.
3937
3938    --  2. DISCRIMINANTS UNDER INHERITANCE.
3939
3940    --  The semantic rules governing the discriminants of derived types are
3941    --  quite subtle.
3942
3943    --   type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
3944    --      [abstract]  Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
3945
3946    --  If parent type has discriminants, then the discriminants that are
3947    --  declared in the derived type are [3.4 (11)]:
3948
3949    --  o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
3950    --    there is one;
3951
3952    --  o Otherwise, each discriminant of the parent type (implicitly
3953    --    declared in the same order with the same specifications). In this
3954    --    case, the discriminants are said to be "inherited", or if unknown in
3955    --    the parent are also unknown in the derived type.
3956
3957    --  Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
3958
3959    --  o The parent subtype shall be constrained;
3960
3961    --  o If the parent type is not a tagged type, then each discriminant of
3962    --    the derived type shall be used in the constraint defining a parent
3963    --    subtype [Implementation note: this ensures that the new discriminant
3964    --    can share storage with an existing discriminant.].
3965
3966    --  For the derived type each discriminant of the parent type is either
3967    --  inherited, constrained to equal some new discriminant of the derived
3968    --  type, or constrained to the value of an expression.
3969
3970    --  When inherited or constrained to equal some new discriminant, the
3971    --  parent discriminant and the discriminant of the derived type are said
3972    --  to "correspond".
3973
3974    --  If a discriminant of the parent type is constrained to a specific value
3975    --  in the derived type definition, then the discriminant is said to be
3976    --  "specified" by that derived type definition.
3977
3978    --  3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
3979
3980    --  We have spoken about girder discriminants in the point 1 (introduction)
3981    --  above. There are two sort of girder discriminants: implicit and
3982    --  explicit. As long as the derived type inherits the same discriminants as
3983    --  the root record type, girder discriminants are the same as regular
3984    --  discriminants, and are said to be implicit. However, if any discriminant
3985    --  in the root type was renamed in the derived type, then the derived
3986    --  type will contain explicit girder discriminants. Explicit girder
3987    --  discriminants are discriminants in addition to the semantically visible
3988    --  discriminants defined for the derived type. Girder discriminants are
3989    --  used by Gigi to figure out what are the physical discriminants in
3990    --  objects of the derived type (see precise definition in einfo.ads).
3991    --  As an example, consider the following:
3992
3993    --           type R  (D1, D2, D3 : Int) is record ... end record;
3994    --           type T1 is new R;
3995    --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
3996    --           type T3 is new T2;
3997    --           type T4 (Y : Int) is new T3 (Y, 99);
3998
3999    --  The following table summarizes the discriminants and girder
4000    --  discriminants in R and T1 through T4.
4001
4002    --   Type      Discrim     Girder Discrim  Comment
4003    --    R      (D1, D2, D3)   (D1, D2, D3)   Gider discrims are implicit in R
4004    --    T1     (D1, D2, D3)   (D1, D2, D3)   Gider discrims are implicit in T1
4005    --    T2     (X1, X2)       (D1, D2, D3)   Gider discrims are EXPLICIT in T2
4006    --    T3     (X1, X2)       (D1, D2, D3)   Gider discrims are EXPLICIT in T3
4007    --    T4     (Y)            (D1, D2, D3)   Gider discrims are EXPLICIT in T4
4008
4009    --  Field Corresponding_Discriminant (abbreviated CD below) allows to find
4010    --  the corresponding discriminant in the parent type, while
4011    --  Original_Record_Component (abbreviated ORC below), the actual physical
4012    --  component that is renamed. Finally the field Is_Completely_Hidden
4013    --  (abbreaviated ICH below) is set for all explicit girder discriminants
4014    --  (see einfo.ads for more info). For the above example this gives:
4015
4016    --                 Discrim     CD        ORC     ICH
4017    --                 ^^^^^^^     ^^        ^^^     ^^^
4018    --                 D1 in R    empty     itself    no
4019    --                 D2 in R    empty     itself    no
4020    --                 D3 in R    empty     itself    no
4021
4022    --                 D1 in T1  D1 in R    itself    no
4023    --                 D2 in T1  D2 in R    itself    no
4024    --                 D3 in T1  D3 in R    itself    no
4025
4026    --                 X1 in T2  D3 in T1  D3 in T2   no
4027    --                 X2 in T2  D1 in T1  D1 in T2   no
4028    --                 D1 in T2   empty    itself    yes
4029    --                 D2 in T2   empty    itself    yes
4030    --                 D3 in T2   empty    itself    yes
4031
4032    --                 X1 in T3  X1 in T2  D3 in T3   no
4033    --                 X2 in T3  X2 in T2  D1 in T3   no
4034    --                 D1 in T3   empty    itself    yes
4035    --                 D2 in T3   empty    itself    yes
4036    --                 D3 in T3   empty    itself    yes
4037
4038    --                 Y  in T4  X1 in T3  D3 in T3   no
4039    --                 D1 in T3   empty    itself    yes
4040    --                 D2 in T3   empty    itself    yes
4041    --                 D3 in T3   empty    itself    yes
4042
4043    --  4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES.
4044
4045    --  Type derivation for tagged types is fairly straightforward. if no
4046    --  discriminants are specified by the derived type, these are inherited
4047    --  from the parent. No explicit girder discriminants are ever necessary.
4048    --  The only manipulation that is done to the tree is that of adding a
4049    --  _parent field with parent type and constrained to the same constraint
4050    --  specified for the parent in the derived type definition. For instance:
4051
4052    --           type R  (D1, D2, D3 : Int) is tagged record ... end record;
4053    --           type T1 is new R with null record;
4054    --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
4055
4056    --  are changed into :
4057
4058    --           type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
4059    --              _parent : R (D1, D2, D3);
4060    --           end record;
4061
4062    --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
4063    --              _parent : T1 (X2, 88, X1);
4064    --           end record;
4065
4066    --  The discriminants actually present in R, T1 and T2 as well as their CD,
4067    --  ORC and ICH fields are:
4068
4069    --                 Discrim     CD        ORC     ICH
4070    --                 ^^^^^^^     ^^        ^^^     ^^^
4071    --                 D1 in R    empty     itself    no
4072    --                 D2 in R    empty     itself    no
4073    --                 D3 in R    empty     itself    no
4074
4075    --                 D1 in T1  D1 in R    D1 in R   no
4076    --                 D2 in T1  D2 in R    D2 in R   no
4077    --                 D3 in T1  D3 in R    D3 in R   no
4078
4079    --                 X1 in T2  D3 in T1   D3 in R   no
4080    --                 X2 in T2  D1 in T1   D1 in R   no
4081
4082    --  5. FIRST TRANSFORMATION FOR DERIVED RECORDS.
4083    --
4084    --  Regardless of whether we dealing with a tagged or untagged type
4085    --  we will transform all derived type declarations of the form
4086    --
4087    --               type T is new R (...) [with ...];
4088    --  or
4089    --               subtype S is R (...);
4090    --               type T is new S [with ...];
4091    --  into
4092    --               type BT is new R [with ...];
4093    --               subtype T is BT (...);
4094    --
4095    --  That is, the base derived type is constrained only if it has no
4096    --  discriminants. The reason for doing this is that GNAT's semantic model
4097    --  assumes that a base type with discriminants is unconstrained.
4098    --
4099    --  Note that, strictly speaking, the above transformation is not always
4100    --  correct. Consider for instance the following exercpt from ACVC b34011a:
4101    --
4102    --       procedure B34011A is
4103    --          type REC (D : integer := 0) is record
4104    --             I : Integer;
4105    --          end record;
4106
4107    --          package P is
4108    --             type T6 is new Rec;
4109    --             function F return T6;
4110    --          end P;
4111
4112    --          use P;
4113    --          package Q6 is
4114    --             type U is new T6 (Q6.F.I);                   -- ERROR: Q6.F.
4115    --          end Q6;
4116    --
4117    --  The definition of Q6.U is illegal. However transforming Q6.U into
4118
4119    --             type BaseU is new T6;
4120    --             subtype U is BaseU (Q6.F.I)
4121
4122    --  turns U into a legal subtype, which is incorrect. To avoid this problem
4123    --  we always analyze the constraint (in this case (Q6.F.I)) before applying
4124    --  the transformation described above.
4125
4126    --  There is another instance where the above transformation is incorrect.
4127    --  Consider:
4128
4129    --          package Pack is
4130    --             type Base (D : Integer) is tagged null record;
4131    --             procedure P (X : Base);
4132
4133    --             type Der is new Base (2) with null record;
4134    --             procedure P (X : Der);
4135    --          end Pack;
4136
4137    --  Then the above transformation turns this into
4138
4139    --             type Der_Base is new Base with null record;
4140    --             --  procedure P (X : Base) is implicitly inherited here
4141    --             --  as procedure P (X : Der_Base).
4142
4143    --             subtype Der is Der_Base (2);
4144    --             procedure P (X : Der);
4145    --             --  The overriding of P (X : Der_Base) is illegal since we
4146    --             --  have a parameter conformance problem.
4147
4148    --  To get around this problem, after having semantically processed Der_Base
4149    --  and the rewritten subtype declaration for Der, we copy Der_Base field
4150    --  Discriminant_Constraint from Der so that when parameter conformance is
4151    --  checked when P is overridden, no sematic errors are flagged.
4152
4153    --  6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
4154
4155    --  Regardless of the fact that we dealing with a tagged or untagged type
4156    --  we will transform all derived type declarations of the form
4157
4158    --               type R (D1, .., Dn : ...) is [tagged] record ...;
4159    --               type T is new R [with ...];
4160    --  into
4161    --               type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
4162
4163    --  The reason for such transformation is that it allows us to implement a
4164    --  very clean form of component inheritance as explained below.
4165
4166    --  Note that this transformation is not achieved by direct tree rewriting
4167    --  and manipulation, but rather by redoing the semantic actions that the
4168    --  above transformation will entail. This is done directly in routine
4169    --  Inherit_Components.
4170
4171    --  7. TYPE DERIVATION AND COMPONENT INHERITANCE.
4172
4173    --  In both tagged and untagged derived types, regular non discriminant
4174    --  components are inherited in the derived type from the parent type. In
4175    --  the absence of discriminants component, inheritance is straightforward
4176    --  as components can simply be copied from the parent.
4177    --  If the parent has discriminants, inheriting components constrained with
4178    --  these discriminants requires caution. Consider the following example:
4179
4180    --      type R  (D1, D2 : Positive) is [tagged] record
4181    --         S : String (D1 .. D2);
4182    --      end record;
4183
4184    --      type T1                is new R        [with null record];
4185    --      type T2 (X : positive) is new R (1, X) [with null record];
4186
4187    --  As explained in 6. above, T1 is rewritten as
4188
4189    --      type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
4190
4191    --  which makes the treatment for T1 and T2 identical.
4192
4193    --  What we want when inheriting S, is that references to D1 and D2 in R are
4194    --  replaced with references to their correct constraints, ie D1 and D2 in
4195    --  T1 and 1 and X in T2. So all R's discriminant references are replaced
4196    --  with either discriminant references in the derived type or expressions.
4197    --  This replacement is acheived as follows: before inheriting R's
4198    --  components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
4199    --  created in the scope of T1 (resp. scope of T2) so that discriminants D1
4200    --  and D2 of T1 are visible (resp. discriminant X of T2 is visible).
4201    --  For T2, for instance, this has the effect of replacing String (D1 .. D2)
4202    --  by String (1 .. X).
4203
4204    --  8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS.
4205
4206    --  We explain here the rules governing private type extensions relevant to
4207    --  type derivation. These rules are explained on the following example:
4208
4209    --      type D [(...)] is new A [(...)] with private;      <-- partial view
4210    --      type D [(...)] is new P [(...)] with null record;  <-- full view
4211
4212    --  Type A is called the ancestor subtype of the private extension.
4213    --  Type P is the parent type of the full view of the private extension. It
4214    --  must be A or a type derived from A.
4215
4216    --  The rules concerning the discriminants of private type extensions are
4217    --  [7.3(10-13)]:
4218
4219    --  o If a private extension inherits known discriminants from the ancestor
4220    --    subtype, then the full view shall also inherit its discriminants from
4221    --    the ancestor subtype and the parent subtype of the full view shall be
4222    --    constrained if and only if the ancestor subtype is constrained.
4223
4224    --  o If a partial view has unknown discriminants, then the full view may
4225    --    define a definite or an indefinite subtype, with or without
4226    --    discriminants.
4227
4228    --  o If a partial view has neither known nor unknown discriminants, then
4229    --    the full view shall define a definite subtype.
4230
4231    --  o If the ancestor subtype of a private extension has constrained
4232    --    discrimiants, then the parent subtype of the full view shall impose a
4233    --    statically matching constraint on those discriminants.
4234
4235    --  This means that only the following forms of private extensions are
4236    --  allowed:
4237
4238    --      type D is new A with private;      <-- partial view
4239    --      type D is new P with null record;  <-- full view
4240
4241    --  If A has no discriminants than P has no discriminants, otherwise P must
4242    --  inherit A's discriminants.
4243
4244    --      type D is new A (...) with private;      <-- partial view
4245    --      type D is new P (:::) with null record;  <-- full view
4246
4247    --  P must inherit A's discriminants and (...) and (:::) must statically
4248    --  match.
4249
4250    --      subtype A is R (...);
4251    --      type D is new A with private;      <-- partial view
4252    --      type D is new P with null record;  <-- full view
4253
4254    --  P must have inherited R's discriminants and must be derived from A or
4255    --  any of its subtypes.
4256
4257    --      type D (..) is new A with private;              <-- partial view
4258    --      type D (..) is new P [(:::)] with null record;  <-- full view
4259
4260    --  No specific constraints on P's discriminants or constraint (:::).
4261    --  Note that A can be unconstrained, but the parent subtype P must either
4262    --  be constrained or (:::) must be present.
4263
4264    --      type D (..) is new A [(...)] with private;      <-- partial view
4265    --      type D (..) is new P [(:::)] with null record;  <-- full view
4266
4267    --  P's constraints on A's discriminants must statically match those
4268    --  imposed by (...).
4269
4270    --  9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS.
4271
4272    --  The full view of a private extension is handled exactly as described
4273    --  above. The model chose for the private view of a private extension
4274    --  is the same for what concerns discriminants (ie they receive the same
4275    --  treatment as in the tagged case). However, the private view of the
4276    --  private extension always inherits the components of the parent base,
4277    --  without replacing any discriminant reference. Strictly speacking this
4278    --  is incorrect. However, Gigi never uses this view to generate code so
4279    --  this is a purely semantic issue. In theory, a set of transformations
4280    --  similar to those given in 5. and 6. above could be applied to private
4281    --  views of private extensions to have the same model of component
4282    --  inheritance as for non private extensions. However, this is not done
4283    --  because it would further complicate private type processing.
4284    --  Semantically speaking, this leaves us in an uncomfortable
4285    --  situation. As an example consider:
4286
4287    --          package Pack is
4288    --             type R (D : integer) is tagged record
4289    --                S : String (1 .. D);
4290    --             end record;
4291    --             procedure P (X : R);
4292    --             type T is new R (1) with private;
4293    --          private
4294    --             type T is new R (1) with null record;
4295    --          end;
4296
4297    --  This is transformed into:
4298
4299    --          package Pack is
4300    --             type R (D : integer) is tagged record
4301    --                S : String (1 .. D);
4302    --             end record;
4303    --             procedure P (X : R);
4304    --             type T is new R (1) with private;
4305    --          private
4306    --             type BaseT is new R with null record;
4307    --             subtype  T is BaseT (1);
4308    --          end;
4309
4310    --  (strictly speaking the above is incorrect Ada).
4311
4312    --  From the semantic standpoint the private view of private extension T
4313    --  should be flagged as constrained since one can clearly have
4314    --
4315    --             Obj : T;
4316    --
4317    --  in a unit withing Pack. However, when deriving subprograms for the
4318    --  private view of private extension T, T must be seen as unconstrained
4319    --  since T has discriminants (this is a constraint of the current
4320    --  subprogram derivation model). Thus, when processing the private view of
4321    --  a private extension such as T, we first mark T as unconstrained, we
4322    --  process it, we perform program derivation and just before returning from
4323    --  Build_Derived_Record_Type we mark T as constrained.
4324    --  ??? Are there are other unconfortable cases that we will have to
4325    --      deal with.
4326
4327    --  10. RECORD_TYPE_WITH_PRIVATE complications.
4328
4329    --  Types that are derived from a visible record type and have a private
4330    --  extension present other peculiarities. They behave mostly like private
4331    --  types, but if they have primitive operations defined, these will not
4332    --  have the proper signatures for further inheritance, because other
4333    --  primitive operations will use the implicit base that we define for
4334    --  private derivations below. This affect subprogram inheritance (see
4335    --  Derive_Subprograms for details). We also derive the implicit base from
4336    --  the base type of the full view, so that the implicit base is a record
4337    --  type and not another private type, This avoids infinite loops.
4338
4339    procedure Build_Derived_Record_Type
4340      (N            : Node_Id;
4341       Parent_Type  : Entity_Id;
4342       Derived_Type : Entity_Id;
4343       Derive_Subps : Boolean := True)
4344    is
4345       Loc          : constant Source_Ptr := Sloc (N);
4346       Parent_Base  : Entity_Id;
4347
4348       Type_Def     : Node_Id;
4349       Indic        : Node_Id;
4350
4351       Discrim      : Entity_Id;
4352       Last_Discrim : Entity_Id;
4353       Constrs      : Elist_Id;
4354       Discs        : Elist_Id := New_Elmt_List;
4355       --  An empty Discs list means that there were no constraints in the
4356       --  subtype indication or that there was an error processing it.
4357
4358       Assoc_List   : Elist_Id;
4359       New_Discrs   : Elist_Id;
4360
4361       New_Base     : Entity_Id;
4362       New_Decl     : Node_Id;
4363       New_Indic    : Node_Id;
4364
4365       Is_Tagged          : constant Boolean := Is_Tagged_Type (Parent_Type);
4366       Discriminant_Specs : constant Boolean
4367         := Present (Discriminant_Specifications (N));
4368       Private_Extension  : constant Boolean
4369         := (Nkind (N) = N_Private_Extension_Declaration);
4370
4371       Constraint_Present : Boolean;
4372       Inherit_Discrims   : Boolean := False;
4373
4374       Save_Etype         : Entity_Id;
4375       Save_Discr_Constr  : Elist_Id;
4376       Save_Next_Entity   : Entity_Id;
4377
4378    begin
4379       if Ekind (Parent_Type) = E_Record_Type_With_Private
4380         and then Present (Full_View (Parent_Type))
4381         and then Has_Discriminants (Parent_Type)
4382       then
4383          Parent_Base := Base_Type (Full_View (Parent_Type));
4384       else
4385          Parent_Base := Base_Type (Parent_Type);
4386       end if;
4387
4388       --  Before we start the previously documented transformations, here is
4389       --  a little fix for size and alignment of tagged types. Normally when
4390       --  we derive type D from type P, we copy the size and alignment of P
4391       --  as the default for D, and in the absence of explicit representation
4392       --  clauses for D, the size and alignment are indeed the same as the
4393       --  parent.
4394
4395       --  But this is wrong for tagged types, since fields may be added,
4396       --  and the default size may need to be larger, and the default
4397       --  alignment may need to be larger.
4398
4399       --  We therefore reset the size and alignment fields in the tagged
4400       --  case. Note that the size and alignment will in any case be at
4401       --  least as large as the parent type (since the derived type has
4402       --  a copy of the parent type in the _parent field)
4403
4404       if Is_Tagged then
4405          Init_Size_Align (Derived_Type);
4406       end if;
4407
4408       --  STEP 0a: figure out what kind of derived type declaration we have.
4409
4410       if Private_Extension then
4411          Type_Def := N;
4412          Set_Ekind (Derived_Type, E_Record_Type_With_Private);
4413
4414       else
4415          Type_Def := Type_Definition (N);
4416
4417          --  Ekind (Parent_Base) in not necessarily E_Record_Type since
4418          --  Parent_Base can be a private type or private extension. However,
4419          --  for tagged types with an extension the newly added fields are
4420          --  visible and hence the Derived_Type is always an E_Record_Type.
4421          --  (except that the parent may have its own private fields).
4422          --  For untagged types we preserve the Ekind of the Parent_Base.
4423
4424          if Present (Record_Extension_Part (Type_Def)) then
4425             Set_Ekind (Derived_Type, E_Record_Type);
4426          else
4427             Set_Ekind (Derived_Type, Ekind (Parent_Base));
4428          end if;
4429       end if;
4430
4431       --  Indic can either be an N_Identifier if the subtype indication
4432       --  contains no constraint or an N_Subtype_Indication if the subtype
4433       --  indication has a constraint.
4434
4435       Indic := Subtype_Indication (Type_Def);
4436       Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
4437
4438       if Constraint_Present then
4439          if not Has_Discriminants (Parent_Base) then
4440             Error_Msg_N
4441               ("invalid constraint: type has no discriminant",
4442                  Constraint (Indic));
4443
4444             Constraint_Present := False;
4445             Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
4446
4447          elsif Is_Constrained (Parent_Type) then
4448             Error_Msg_N
4449                ("invalid constraint: parent type is already constrained",
4450                   Constraint (Indic));
4451
4452             Constraint_Present := False;
4453             Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
4454          end if;
4455       end if;
4456
4457       --  STEP 0b: If needed, apply transformation given in point 5. above.
4458
4459       if not Private_Extension
4460         and then Has_Discriminants (Parent_Type)
4461         and then not Discriminant_Specs
4462         and then (Is_Constrained (Parent_Type) or else Constraint_Present)
4463       then
4464          --  First, we must analyze the constraint (see comment in point 5.).
4465
4466          if Constraint_Present then
4467             New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
4468
4469             if Has_Discriminants (Derived_Type)
4470               and then Has_Private_Declaration (Derived_Type)
4471               and then Present (Discriminant_Constraint (Derived_Type))
4472             then
4473                --  Verify that constraints of the full view conform to those
4474                --  given in partial view.
4475
4476                declare
4477                   C1, C2 : Elmt_Id;
4478
4479                begin
4480                   C1 := First_Elmt (New_Discrs);
4481                   C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
4482
4483                   while Present (C1) and then Present (C2) loop
4484                      if not
4485                        Fully_Conformant_Expressions (Node (C1), Node (C2))
4486                      then
4487                         Error_Msg_N (
4488                           "constraint not conformant to previous declaration",
4489                              Node (C1));
4490                      end if;
4491                      Next_Elmt (C1);
4492                      Next_Elmt (C2);
4493                   end loop;
4494                end;
4495             end if;
4496          end if;
4497
4498          --  Insert and analyze the declaration for the unconstrained base type
4499
4500          New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
4501
4502          New_Decl :=
4503            Make_Full_Type_Declaration (Loc,
4504               Defining_Identifier => New_Base,
4505               Type_Definition     =>
4506                 Make_Derived_Type_Definition (Loc,
4507                   Abstract_Present      => Abstract_Present (Type_Def),
4508                   Subtype_Indication    =>
4509                     New_Occurrence_Of (Parent_Base, Loc),
4510                   Record_Extension_Part =>
4511                     Relocate_Node (Record_Extension_Part (Type_Def))));
4512
4513          Set_Parent (New_Decl, Parent (N));
4514          Mark_Rewrite_Insertion (New_Decl);
4515          Insert_Before (N, New_Decl);
4516
4517          --  Note that this call passes False for the Derive_Subps
4518          --  parameter because subprogram derivation is deferred until
4519          --  after creating the subtype (see below).
4520
4521          Build_Derived_Type
4522            (New_Decl, Parent_Base, New_Base,
4523             Is_Completion => True, Derive_Subps => False);
4524
4525          --  ??? This needs re-examination to determine whether the
4526          --  above call can simply be replaced by a call to Analyze.
4527
4528          Set_Analyzed (New_Decl);
4529
4530          --  Insert and analyze the declaration for the constrained subtype
4531
4532          if Constraint_Present then
4533             New_Indic :=
4534               Make_Subtype_Indication (Loc,
4535                 Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
4536                 Constraint   => Relocate_Node (Constraint (Indic)));
4537
4538          else
4539             declare
4540                Expr        : Node_Id;
4541                Constr_List : List_Id := New_List;
4542                C           : Elmt_Id;
4543
4544             begin
4545                C := First_Elmt (Discriminant_Constraint (Parent_Type));
4546                while Present (C) loop
4547                   Expr := Node (C);
4548
4549                   --  It is safe here to call New_Copy_Tree since
4550                   --  Force_Evaluation was called on each constraint in
4551                   --  Build_Discriminant_Constraints.
4552
4553                   Append (New_Copy_Tree (Expr), To => Constr_List);
4554
4555                   Next_Elmt (C);
4556                end loop;
4557
4558                New_Indic :=
4559                  Make_Subtype_Indication (Loc,
4560                    Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
4561                    Constraint   =>
4562                      Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
4563             end;
4564          end if;
4565
4566          Rewrite (N,
4567            Make_Subtype_Declaration (Loc,
4568              Defining_Identifier => Derived_Type,
4569              Subtype_Indication  => New_Indic));
4570
4571          Analyze (N);
4572
4573          --  Derivation of subprograms must be delayed until the
4574          --  full subtype has been established to ensure proper
4575          --  overriding of subprograms inherited by full types.
4576          --  If the derivations occurred as part of the call to
4577          --  Build_Derived_Type above, then the check for type
4578          --  conformance would fail because earlier primitive
4579          --  subprograms could still refer to the full type prior
4580          --  the change to the new subtype and hence wouldn't
4581          --  match the new base type created here.
4582
4583          Derive_Subprograms (Parent_Type, Derived_Type);
4584
4585          --  For tagged types the Discriminant_Constraint of the new base itype
4586          --  is inherited from the first subtype so that no subtype conformance
4587          --  problem arise when the first subtype overrides primitive
4588          --  operations inherited by the implicit base type.
4589
4590          if Is_Tagged then
4591             Set_Discriminant_Constraint
4592               (New_Base, Discriminant_Constraint (Derived_Type));
4593          end if;
4594
4595          return;
4596       end if;
4597
4598       --  If we get here Derived_Type will have no discriminants or it will be
4599       --  a discriminated unconstrained base type.
4600
4601       --  STEP 1a: perform preliminary actions/checks for derived tagged types
4602
4603       if Is_Tagged then
4604          --  The parent type is frozen for non-private extensions (RM 13.14(7))
4605
4606          if not Private_Extension then
4607             Freeze_Before (N, Parent_Type);
4608          end if;
4609
4610          if Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type)
4611            and then not Is_Generic_Type (Derived_Type)
4612          then
4613             if Is_Controlled (Parent_Type) then
4614                Error_Msg_N
4615                  ("controlled type must be declared at the library level",
4616                   Indic);
4617             else
4618                Error_Msg_N
4619                  ("type extension at deeper accessibility level than parent",
4620                   Indic);
4621             end if;
4622
4623          else
4624             declare
4625                GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
4626
4627             begin
4628                if Present (GB)
4629                  and then GB /= Enclosing_Generic_Body (Parent_Base)
4630                then
4631                   Error_Msg_N
4632                     ("parent type must not be outside generic body",
4633                      Indic);
4634                end if;
4635             end;
4636          end if;
4637       end if;
4638
4639       --  STEP 1b : preliminary cleanup of the full view of private types
4640
4641       --  If the type is already marked as having discriminants, then it's the
4642       --  completion of a private type or private extension and we need to
4643       --  retain the discriminants from the partial view if the current
4644       --  declaration has Discriminant_Specifications so that we can verify
4645       --  conformance. However, we must remove any existing components that
4646       --  were inherited from the parent (and attached in Copy_Private_To_Full)
4647       --  because the full type inherits all appropriate components anyway, and
4648       --  we don't want the partial view's components interfering.
4649
4650       if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
4651          Discrim := First_Discriminant (Derived_Type);
4652          loop
4653             Last_Discrim := Discrim;
4654             Next_Discriminant (Discrim);
4655             exit when No (Discrim);
4656          end loop;
4657
4658          Set_Last_Entity (Derived_Type, Last_Discrim);
4659
4660       --  In all other cases wipe out the list of inherited components (even
4661       --  inherited discriminants), it will be properly rebuilt here.
4662
4663       else
4664          Set_First_Entity (Derived_Type, Empty);
4665          Set_Last_Entity  (Derived_Type, Empty);
4666       end if;
4667
4668       --  STEP 1c: Initialize some flags for the Derived_Type
4669
4670       --  The following flags must be initialized here so that
4671       --  Process_Discriminants can check that discriminants of tagged types
4672       --  do not have a default initial value and that access discriminants
4673       --  are only specified for limited records. For completeness, these
4674       --  flags are also initialized along with all the other flags below.
4675
4676       Set_Is_Tagged_Type    (Derived_Type, Is_Tagged);
4677       Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
4678
4679       --  STEP 2a: process discriminants of derived type if any.
4680
4681       New_Scope (Derived_Type);
4682
4683       if Discriminant_Specs then
4684          Set_Has_Unknown_Discriminants (Derived_Type, False);
4685
4686          --  The following call initializes fields Has_Discriminants and
4687          --  Discriminant_Constraint, unless we are processing the completion
4688          --  of a private type declaration.
4689
4690          Check_Or_Process_Discriminants (N, Derived_Type);
4691
4692          --  For non-tagged types the constraint on the Parent_Type must be
4693          --  present and is used to rename the discriminants.
4694
4695          if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
4696             Error_Msg_N ("untagged parent must have discriminants", Indic);
4697
4698          elsif not Is_Tagged and then not Constraint_Present then
4699             Error_Msg_N
4700               ("discriminant constraint needed for derived untagged records",
4701                Indic);
4702
4703          --  Otherwise the parent subtype must be constrained unless we have a
4704          --  private extension.
4705
4706          elsif not Constraint_Present
4707            and then not Private_Extension
4708            and then not Is_Constrained (Parent_Type)
4709          then
4710             Error_Msg_N
4711               ("unconstrained type not allowed in this context", Indic);
4712
4713          elsif Constraint_Present then
4714             --  The following call sets the field Corresponding_Discriminant
4715             --  for the discriminants in the Derived_Type.
4716
4717             Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
4718
4719             --  For untagged types all new discriminants must rename
4720             --  discriminants in the parent. For private extensions new
4721             --  discriminants cannot rename old ones (implied by [7.3(13)]).
4722
4723             Discrim := First_Discriminant (Derived_Type);
4724
4725             while Present (Discrim) loop
4726                if not Is_Tagged
4727                  and then not Present (Corresponding_Discriminant (Discrim))
4728                then
4729                   Error_Msg_N
4730                     ("new discriminants must constrain old ones", Discrim);
4731
4732                elsif Private_Extension
4733                  and then Present (Corresponding_Discriminant (Discrim))
4734                then
4735                   Error_Msg_N
4736                     ("Only static constraints allowed for parent"
4737                      & " discriminants in the partial view", Indic);
4738
4739                   exit;
4740                end if;
4741
4742                --  If a new discriminant is used in the constraint,
4743                --  then its subtype must be statically compatible
4744                --  with the parent discriminant's subtype (3.7(15)).
4745
4746                if Present (Corresponding_Discriminant (Discrim))
4747                  and then
4748                    not Subtypes_Statically_Compatible
4749                          (Etype (Discrim),
4750                           Etype (Corresponding_Discriminant (Discrim)))
4751                then
4752                   Error_Msg_N
4753                     ("subtype must be compatible with parent discriminant",
4754                      Discrim);
4755                end if;
4756
4757                Next_Discriminant (Discrim);
4758             end loop;
4759          end if;
4760
4761       --  STEP 2b: No new discriminants, inherit discriminants if any
4762
4763       else
4764          if Private_Extension then
4765             Set_Has_Unknown_Discriminants
4766               (Derived_Type, Has_Unknown_Discriminants (Parent_Type)
4767                              or else Unknown_Discriminants_Present (N));
4768          else
4769             Set_Has_Unknown_Discriminants
4770               (Derived_Type, Has_Unknown_Discriminants (Parent_Type));
4771          end if;
4772
4773          if not Has_Unknown_Discriminants (Derived_Type)
4774            and then Has_Discriminants (Parent_Type)
4775          then
4776             Inherit_Discrims := True;
4777             Set_Has_Discriminants
4778               (Derived_Type, True);
4779             Set_Discriminant_Constraint
4780               (Derived_Type, Discriminant_Constraint (Parent_Base));
4781          end if;
4782
4783          --  The following test is true for private types (remember
4784          --  transformation 5. is not applied to those) and in an error
4785          --  situation.
4786
4787          if Constraint_Present then
4788             Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
4789          end if;
4790
4791          --  For now mark a new derived type as cosntrained only if it has no
4792          --  discriminants. At the end of Build_Derived_Record_Type we properly
4793          --  set this flag in the case of private extensions. See comments in
4794          --  point 9. just before body of Build_Derived_Record_Type.
4795
4796          Set_Is_Constrained
4797            (Derived_Type,
4798             not (Inherit_Discrims
4799                  or else Has_Unknown_Discriminants (Derived_Type)));
4800       end if;
4801
4802       --  STEP 3: initialize fields of derived type.
4803
4804       Set_Is_Tagged_Type    (Derived_Type, Is_Tagged);
4805       Set_Girder_Constraint (Derived_Type, No_Elist);
4806
4807       --  Fields inherited from the Parent_Type
4808
4809       Set_Discard_Names
4810         (Derived_Type, Einfo.Discard_Names      (Parent_Type));
4811       Set_Has_Specified_Layout
4812         (Derived_Type, Has_Specified_Layout     (Parent_Type));
4813       Set_Is_Limited_Composite
4814         (Derived_Type, Is_Limited_Composite     (Parent_Type));
4815       Set_Is_Limited_Record
4816         (Derived_Type, Is_Limited_Record        (Parent_Type));
4817       Set_Is_Private_Composite
4818         (Derived_Type, Is_Private_Composite     (Parent_Type));
4819
4820       --  Fields inherited from the Parent_Base
4821
4822       Set_Has_Controlled_Component
4823         (Derived_Type, Has_Controlled_Component (Parent_Base));
4824       Set_Has_Non_Standard_Rep
4825         (Derived_Type, Has_Non_Standard_Rep     (Parent_Base));
4826       Set_Has_Primitive_Operations
4827         (Derived_Type, Has_Primitive_Operations (Parent_Base));
4828
4829       --  Direct controlled types do not inherit the Finalize_Storage_Only
4830       --  flag.
4831
4832       if not Is_Controlled  (Parent_Type) then
4833          Set_Finalize_Storage_Only (Derived_Type,
4834            Finalize_Storage_Only (Parent_Type));
4835       end if;
4836
4837       --  Set fields for private derived types.
4838
4839       if Is_Private_Type (Derived_Type) then
4840          Set_Depends_On_Private (Derived_Type, True);
4841          Set_Private_Dependents (Derived_Type, New_Elmt_List);
4842
4843       --  Inherit fields from non private record types. If this is the
4844       --  completion of a derivation from a private type, the parent itself
4845       --  is private, and the attributes come from its full view, which must
4846       --  be present.
4847
4848       else
4849          if Is_Private_Type (Parent_Base)
4850            and then not Is_Record_Type (Parent_Base)
4851          then
4852             Set_Component_Alignment
4853               (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
4854             Set_C_Pass_By_Copy
4855               (Derived_Type, C_Pass_By_Copy      (Full_View (Parent_Base)));
4856          else
4857             Set_Component_Alignment
4858               (Derived_Type, Component_Alignment (Parent_Base));
4859
4860             Set_C_Pass_By_Copy
4861               (Derived_Type, C_Pass_By_Copy      (Parent_Base));
4862          end if;
4863       end if;
4864
4865       --  Set fields for tagged types.
4866
4867       if Is_Tagged then
4868          Set_Primitive_Operations (Derived_Type, New_Elmt_List);
4869
4870          --  All tagged types defined in Ada.Finalization are controlled
4871
4872          if Chars (Scope (Derived_Type)) = Name_Finalization
4873            and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
4874            and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
4875          then
4876             Set_Is_Controlled (Derived_Type);
4877          else
4878             Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
4879          end if;
4880
4881          Make_Class_Wide_Type (Derived_Type);
4882          Set_Is_Abstract      (Derived_Type, Abstract_Present (Type_Def));
4883
4884          if Has_Discriminants (Derived_Type)
4885            and then Constraint_Present
4886          then
4887             Set_Girder_Constraint
4888               (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
4889          end if;
4890
4891       else
4892          Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
4893          Set_Has_Non_Standard_Rep
4894                        (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
4895       end if;
4896
4897       --  STEP 4: Inherit components from the parent base and constrain them.
4898       --          Apply the second transformation described in point 6. above.
4899
4900       if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
4901         or else not Has_Discriminants (Parent_Type)
4902         or else not Is_Constrained (Parent_Type)
4903       then
4904          Constrs := Discs;
4905       else
4906          Constrs := Discriminant_Constraint (Parent_Type);
4907       end if;
4908
4909       Assoc_List := Inherit_Components (N,
4910         Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
4911
4912       --  STEP 5a: Copy the parent record declaration for untagged types
4913
4914       if not Is_Tagged then
4915
4916          --  Discriminant_Constraint (Derived_Type) has been properly
4917          --  constructed. Save it and temporarily set it to Empty because we do
4918          --  not want the call to New_Copy_Tree below to mess this list.
4919
4920          if Has_Discriminants (Derived_Type) then
4921             Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
4922             Set_Discriminant_Constraint (Derived_Type, No_Elist);
4923          else
4924             Save_Discr_Constr := No_Elist;
4925          end if;
4926
4927          --  Save the Etype field of Derived_Type. It is correctly set now, but
4928          --  the call to New_Copy tree may remap it to point to itself, which
4929          --  is not what we want. Ditto for the Next_Entity field.
4930
4931          Save_Etype       := Etype (Derived_Type);
4932          Save_Next_Entity := Next_Entity (Derived_Type);
4933
4934          --  Assoc_List maps all girder discriminants in the Parent_Base to
4935          --  girder discriminants in the Derived_Type. It is fundamental that
4936          --  no types or itypes with discriminants other than the girder
4937          --  discriminants appear in the entities declared inside
4938          --  Derived_Type. Gigi won't like it.
4939
4940          New_Decl :=
4941            New_Copy_Tree
4942              (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
4943
4944          --  Restore the fields saved prior to the New_Copy_Tree call
4945          --  and compute the girder constraint.
4946
4947          Set_Etype       (Derived_Type, Save_Etype);
4948          Set_Next_Entity (Derived_Type, Save_Next_Entity);
4949
4950          if Has_Discriminants (Derived_Type) then
4951             Set_Discriminant_Constraint
4952               (Derived_Type, Save_Discr_Constr);
4953             Set_Girder_Constraint
4954               (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
4955          end if;
4956
4957          --  Insert the new derived type declaration
4958
4959          Rewrite (N, New_Decl);
4960
4961       --  STEP 5b: Complete the processing for record extensions in generics
4962
4963       --  There is no completion for record extensions declared in the
4964       --  parameter part of a generic, so we need to complete processing for
4965       --  these generic record extensions here. The call to
4966       --  Record_Type_Definition will change the Ekind of the components
4967       --  from E_Void to E_Component.
4968
4969       elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
4970          Record_Type_Definition (Empty, Derived_Type);
4971
4972       --  STEP 5c: Process the record extension for non private tagged types.
4973
4974       elsif not Private_Extension then
4975          --  Add the _parent field in the derived type.
4976
4977          Expand_Derived_Record (Derived_Type, Type_Def);
4978
4979          --  Analyze the record extension
4980
4981          Record_Type_Definition
4982            (Record_Extension_Part (Type_Def), Derived_Type);
4983       end if;
4984
4985       End_Scope;
4986
4987       if Etype (Derived_Type) = Any_Type then
4988          return;
4989       end if;
4990
4991       --  Set delayed freeze and then derive subprograms, we need to do
4992       --  this in this order so that derived subprograms inherit the
4993       --  derived freeze if necessary.
4994
4995       Set_Has_Delayed_Freeze (Derived_Type);
4996       if Derive_Subps then
4997          Derive_Subprograms (Parent_Type, Derived_Type);
4998       end if;
4999
5000       --  If we have a private extension which defines a constrained derived
5001       --  type mark as constrained here after we have derived subprograms. See
5002       --  comment on point 9. just above the body of Build_Derived_Record_Type.
5003
5004       if Private_Extension and then Inherit_Discrims then
5005          if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
5006             Set_Is_Constrained          (Derived_Type, True);
5007             Set_Discriminant_Constraint (Derived_Type, Discs);
5008
5009          elsif Is_Constrained (Parent_Type) then
5010             Set_Is_Constrained
5011               (Derived_Type, True);
5012             Set_Discriminant_Constraint
5013               (Derived_Type, Discriminant_Constraint (Parent_Type));
5014          end if;
5015       end if;
5016
5017    end Build_Derived_Record_Type;
5018
5019    ------------------------
5020    -- Build_Derived_Type --
5021    ------------------------
5022
5023    procedure Build_Derived_Type
5024      (N             : Node_Id;
5025       Parent_Type   : Entity_Id;
5026       Derived_Type  : Entity_Id;
5027       Is_Completion : Boolean;
5028       Derive_Subps  : Boolean := True)
5029    is
5030       Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
5031
5032    begin
5033       --  Set common attributes
5034
5035       Set_Scope          (Derived_Type, Current_Scope);
5036
5037       Set_Ekind          (Derived_Type, Ekind     (Parent_Base));
5038       Set_Etype          (Derived_Type,            Parent_Base);
5039       Set_Has_Task       (Derived_Type, Has_Task  (Parent_Base));
5040
5041       Set_Size_Info      (Derived_Type,                 Parent_Type);
5042       Set_RM_Size        (Derived_Type, RM_Size        (Parent_Type));
5043       Set_Convention     (Derived_Type, Convention     (Parent_Type));
5044       Set_Is_Controlled  (Derived_Type, Is_Controlled  (Parent_Type));
5045       Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
5046
5047       case Ekind (Parent_Type) is
5048          when Numeric_Kind =>
5049             Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
5050
5051          when Array_Kind =>
5052             Build_Derived_Array_Type (N, Parent_Type,  Derived_Type);
5053
5054          when E_Record_Type
5055             | E_Record_Subtype
5056             | Class_Wide_Kind  =>
5057             Build_Derived_Record_Type
5058               (N, Parent_Type, Derived_Type, Derive_Subps);
5059             return;
5060
5061          when Enumeration_Kind =>
5062             Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
5063
5064          when Access_Kind =>
5065             Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
5066
5067          when Incomplete_Or_Private_Kind =>
5068             Build_Derived_Private_Type
5069               (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
5070
5071             --  For discriminated types, the derivation includes deriving
5072             --  primitive operations. For others it is done below.
5073
5074             if Is_Tagged_Type (Parent_Type)
5075               or else Has_Discriminants (Parent_Type)
5076               or else (Present (Full_View (Parent_Type))
5077                         and then Has_Discriminants (Full_View (Parent_Type)))
5078             then
5079                return;
5080             end if;
5081
5082          when Concurrent_Kind =>
5083             Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
5084
5085          when others =>
5086             raise Program_Error;
5087       end case;
5088
5089       if Etype (Derived_Type) = Any_Type then
5090          return;
5091       end if;
5092
5093       --  Set delayed freeze and then derive subprograms, we need to do
5094       --  this in this order so that derived subprograms inherit the
5095       --  derived freeze if necessary.
5096
5097       Set_Has_Delayed_Freeze (Derived_Type);
5098       if Derive_Subps then
5099          Derive_Subprograms (Parent_Type, Derived_Type);
5100       end if;
5101
5102       Set_Has_Primitive_Operations
5103         (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
5104    end Build_Derived_Type;
5105
5106    -----------------------
5107    -- Build_Discriminal --
5108    -----------------------
5109
5110    procedure Build_Discriminal (Discrim : Entity_Id) is
5111       D_Minal : Entity_Id;
5112       CR_Disc : Entity_Id;
5113
5114    begin
5115       --  A discriminal has the same names as the discriminant.
5116
5117       D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
5118
5119       Set_Ekind     (D_Minal, E_In_Parameter);
5120       Set_Mechanism (D_Minal, Default_Mechanism);
5121       Set_Etype     (D_Minal, Etype (Discrim));
5122
5123       Set_Discriminal (Discrim, D_Minal);
5124       Set_Discriminal_Link (D_Minal, Discrim);
5125
5126       --  For task types, build at once the discriminants of the corresponding
5127       --  record, which are needed if discriminants are used in entry defaults
5128       --  and in family bounds.
5129
5130       if Is_Concurrent_Type (Current_Scope)
5131         or else Is_Limited_Type (Current_Scope)
5132       then
5133          CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
5134
5135          Set_Ekind     (CR_Disc, E_In_Parameter);
5136          Set_Mechanism (CR_Disc, Default_Mechanism);
5137          Set_Etype     (CR_Disc, Etype (Discrim));
5138          Set_CR_Discriminant (Discrim, CR_Disc);
5139       end if;
5140    end Build_Discriminal;
5141
5142    ------------------------------------
5143    -- Build_Discriminant_Constraints --
5144    ------------------------------------
5145
5146    function Build_Discriminant_Constraints
5147      (T           : Entity_Id;
5148       Def         : Node_Id;
5149       Derived_Def : Boolean := False)
5150       return        Elist_Id
5151    is
5152       C          : constant Node_Id := Constraint (Def);
5153       Nb_Discr   : constant Nat     := Number_Discriminants (T);
5154       Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
5155       --  Saves the expression corresponding to a given discriminant in T.
5156
5157       function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
5158       --  Return the Position number within array Discr_Expr of a discriminant
5159       --  D within the discriminant list of the discriminated type T.
5160
5161       ------------------
5162       -- Pos_Of_Discr --
5163       ------------------
5164
5165       function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
5166          Disc : Entity_Id;
5167
5168       begin
5169          Disc := First_Discriminant (T);
5170          for J in Discr_Expr'Range loop
5171             if Disc = D then
5172                return J;
5173             end if;
5174
5175             Next_Discriminant (Disc);
5176          end loop;
5177
5178          --  Note: Since this function is called on discriminants that are
5179          --  known to belong to the discriminated type, falling through the
5180          --  loop with no match signals an internal compiler error.
5181
5182          raise Program_Error;
5183       end Pos_Of_Discr;
5184
5185       --  Variables local to Build_Discriminant_Constraints
5186
5187       Discr : Entity_Id;
5188       E     : Entity_Id;
5189       Elist : Elist_Id := New_Elmt_List;
5190
5191       Constr    : Node_Id;
5192       Expr      : Node_Id;
5193       Id        : Node_Id;
5194       Position  : Nat;
5195       Found     : Boolean;
5196
5197       Discrim_Present : Boolean := False;
5198
5199    --  Start of processing for Build_Discriminant_Constraints
5200
5201    begin
5202       --  The following loop will process positional associations only.
5203       --  For a positional association, the (single) discriminant is
5204       --  implicitly specified by position, in textual order (RM 3.7.2).
5205
5206       Discr  := First_Discriminant (T);
5207       Constr := First (Constraints (C));
5208
5209       for D in Discr_Expr'Range loop
5210          exit when Nkind (Constr) = N_Discriminant_Association;
5211
5212          if No (Constr) then
5213             Error_Msg_N ("too few discriminants given in constraint", C);
5214             return New_Elmt_List;
5215
5216          elsif Nkind (Constr) = N_Range
5217            or else (Nkind (Constr) = N_Attribute_Reference
5218                      and then
5219                     Attribute_Name (Constr) = Name_Range)
5220          then
5221             Error_Msg_N
5222               ("a range is not a valid discriminant constraint", Constr);
5223             Discr_Expr (D) := Error;
5224
5225          else
5226             Analyze_And_Resolve (Constr, Base_Type (Etype (Discr)));
5227             Discr_Expr (D) := Constr;
5228          end if;
5229
5230          Next_Discriminant (Discr);
5231          Next (Constr);
5232       end loop;
5233
5234       if No (Discr) and then Present (Constr) then
5235          Error_Msg_N ("too many discriminants given in constraint", Constr);
5236          return New_Elmt_List;
5237       end if;
5238
5239       --  Named associations can be given in any order, but if both positional
5240       --  and named associations are used in the same discriminant constraint,
5241       --  then positional associations must occur first, at their normal
5242       --  position. Hence once a named association is used, the rest of the
5243       --  discriminant constraint must use only named associations.
5244
5245       while Present (Constr) loop
5246
5247          --  Positional association forbidden after a named association.
5248
5249          if Nkind (Constr) /= N_Discriminant_Association then
5250             Error_Msg_N ("positional association follows named one", Constr);
5251             return New_Elmt_List;
5252
5253          --  Otherwise it is a named association
5254
5255          else
5256             --  E records the type of the discriminants in the named
5257             --  association. All the discriminants specified in the same name
5258             --  association must have the same type.
5259
5260             E := Empty;
5261
5262             --  Search the list of discriminants in T to see if the simple name
5263             --  given in the constraint matches any of them.
5264
5265             Id := First (Selector_Names (Constr));
5266             while Present (Id) loop
5267                Found := False;
5268
5269                --  If Original_Discriminant is present, we are processing a
5270                --  generic instantiation and this is an instance node. We need
5271                --  to find the name of the corresponding discriminant in the
5272                --  actual record type T and not the name of the discriminant in
5273                --  the generic formal. Example:
5274                --
5275                --    generic
5276                --       type G (D : int) is private;
5277                --    package P is
5278                --       subtype W is G (D => 1);
5279                --    end package;
5280                --    type Rec (X : int) is record ... end record;
5281                --    package Q is new P (G => Rec);
5282                --
5283                --  At the point of the instantiation, formal type G is Rec
5284                --  and therefore when reanalyzing "subtype W is G (D => 1);"
5285                --  which really looks like "subtype W is Rec (D => 1);" at
5286                --  the point of instantiation, we want to find the discriminant
5287                --  that corresponds to D in Rec, ie X.
5288
5289                if Present (Original_Discriminant (Id)) then
5290                   Discr := Find_Corresponding_Discriminant (Id, T);
5291                   Found := True;
5292
5293                else
5294                   Discr := First_Discriminant (T);
5295                   while Present (Discr) loop
5296                      if Chars (Discr) = Chars (Id) then
5297                         Found := True;
5298                         exit;
5299                      end if;
5300
5301                      Next_Discriminant (Discr);
5302                   end loop;
5303
5304                   if not Found then
5305                      Error_Msg_N ("& does not match any discriminant", Id);
5306                      return New_Elmt_List;
5307
5308                   --  The following is only useful for the benefit of generic
5309                   --  instances but it does not interfere with other
5310                   --  processing for the non-generic case so we do it in all
5311                   --  cases (for generics this statement is executed when
5312                   --  processing the generic definition, see comment at the
5313                   --  begining of this if statement).
5314
5315                   else
5316                      Set_Original_Discriminant (Id, Discr);
5317                   end if;
5318                end if;
5319
5320                Position := Pos_Of_Discr (T, Discr);
5321
5322                if Present (Discr_Expr (Position)) then
5323                   Error_Msg_N ("duplicate constraint for discriminant&", Id);
5324
5325                else
5326                   --  Each discriminant specified in the same named association
5327                   --  must be associated with a separate copy of the
5328                   --  corresponding expression.
5329
5330                   if Present (Next (Id)) then
5331                      Expr := New_Copy_Tree (Expression (Constr));
5332                      Set_Parent (Expr, Parent (Expression (Constr)));
5333                   else
5334                      Expr := Expression (Constr);
5335                   end if;
5336
5337                   Discr_Expr (Position) := Expr;
5338                   Analyze_And_Resolve (Expr, Base_Type (Etype (Discr)));
5339                end if;
5340
5341                --  A discriminant association with more than one discriminant
5342                --  name is only allowed if the named discriminants are all of
5343                --  the same type (RM 3.7.1(8)).
5344
5345                if E = Empty then
5346                   E := Base_Type (Etype (Discr));
5347
5348                elsif Base_Type (Etype (Discr)) /= E then
5349                   Error_Msg_N
5350                     ("all discriminants in an association " &
5351                      "must have the same type", Id);
5352                end if;
5353
5354                Next (Id);
5355             end loop;
5356          end if;
5357
5358          Next (Constr);
5359       end loop;
5360
5361       --  A discriminant constraint must provide exactly one value for each
5362       --  discriminant of the type (RM 3.7.1(8)).
5363
5364       for J in Discr_Expr'Range loop
5365          if No (Discr_Expr (J)) then
5366             Error_Msg_N ("too few discriminants given in constraint", C);
5367             return New_Elmt_List;
5368          end if;
5369       end loop;
5370
5371       --  Determine if there are discriminant expressions in the constraint.
5372
5373       for J in Discr_Expr'Range loop
5374          if Denotes_Discriminant (Discr_Expr (J)) then
5375             Discrim_Present := True;
5376          end if;
5377       end loop;
5378
5379       --  Build an element list consisting of the expressions given in the
5380       --  discriminant constraint and apply the appropriate range
5381       --  checks. The list is constructed after resolving any named
5382       --  discriminant associations and therefore the expressions appear in
5383       --  the textual order of the discriminants.
5384
5385       Discr := First_Discriminant (T);
5386       for J in Discr_Expr'Range loop
5387          if Discr_Expr (J) /= Error then
5388
5389             Append_Elmt (Discr_Expr (J), Elist);
5390
5391             --  If any of the discriminant constraints is given by a
5392             --  discriminant and we are in a derived type declaration we
5393             --  have a discriminant renaming. Establish link between new
5394             --  and old discriminant.
5395
5396             if Denotes_Discriminant (Discr_Expr (J)) then
5397                if Derived_Def then
5398                   Set_Corresponding_Discriminant
5399                     (Entity (Discr_Expr (J)), Discr);
5400                end if;
5401
5402             --  Force the evaluation of non-discriminant expressions.
5403             --  If we have found a discriminant in the constraint 3.4(26)
5404             --  and 3.8(18) demand that no range checks are performed are
5405             --  after evaluation. In all other cases perform a range check.
5406
5407             else
5408                if not Discrim_Present then
5409                   Apply_Range_Check (Discr_Expr (J), Etype (Discr));
5410                end if;
5411
5412                Force_Evaluation (Discr_Expr (J));
5413             end if;
5414
5415          --  Check that the designated type of an access discriminant's
5416          --  expression is not a class-wide type unless the discriminant's
5417          --  designated type is also class-wide.
5418
5419             if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
5420               and then not Is_Class_Wide_Type
5421                          (Designated_Type (Etype (Discr)))
5422               and then Etype (Discr_Expr (J)) /= Any_Type
5423               and then Is_Class_Wide_Type
5424                          (Designated_Type (Etype (Discr_Expr (J))))
5425             then
5426                Wrong_Type (Discr_Expr (J), Etype (Discr));
5427             end if;
5428          end if;
5429
5430          Next_Discriminant (Discr);
5431       end loop;
5432
5433       return Elist;
5434    end Build_Discriminant_Constraints;
5435
5436    ---------------------------------
5437    -- Build_Discriminated_Subtype --
5438    ---------------------------------
5439
5440    procedure Build_Discriminated_Subtype
5441      (T           : Entity_Id;
5442       Def_Id      : Entity_Id;
5443       Elist       : Elist_Id;
5444       Related_Nod : Node_Id;
5445       For_Access  : Boolean := False)
5446    is
5447       Has_Discrs  : constant Boolean := Has_Discriminants (T);
5448       Constrained : constant Boolean
5449                       := (Has_Discrs and then not Is_Empty_Elmt_List (Elist))
5450                            or else Is_Constrained (T);
5451
5452    begin
5453       if Ekind (T) = E_Record_Type then
5454          if For_Access then
5455             Set_Ekind (Def_Id, E_Private_Subtype);
5456             Set_Is_For_Access_Subtype (Def_Id, True);
5457          else
5458             Set_Ekind (Def_Id, E_Record_Subtype);
5459          end if;
5460
5461       elsif Ekind (T) = E_Task_Type then
5462          Set_Ekind (Def_Id, E_Task_Subtype);
5463
5464       elsif Ekind (T) = E_Protected_Type then
5465          Set_Ekind (Def_Id, E_Protected_Subtype);
5466
5467       elsif Is_Private_Type (T) then
5468          Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
5469
5470       elsif Is_Class_Wide_Type (T) then
5471          Set_Ekind (Def_Id, E_Class_Wide_Subtype);
5472
5473       else
5474          --  Incomplete type. Attach subtype to list of dependents, to be
5475          --  completed with full view of parent type.
5476
5477          Set_Ekind (Def_Id, Ekind (T));
5478          Append_Elmt (Def_Id, Private_Dependents (T));
5479       end if;
5480
5481       Set_Etype             (Def_Id, T);
5482       Init_Size_Align       (Def_Id);
5483       Set_Has_Discriminants (Def_Id, Has_Discrs);
5484       Set_Is_Constrained    (Def_Id, Constrained);
5485
5486       Set_First_Entity      (Def_Id, First_Entity   (T));
5487       Set_Last_Entity       (Def_Id, Last_Entity    (T));
5488       Set_First_Rep_Item    (Def_Id, First_Rep_Item (T));
5489
5490       if Is_Tagged_Type (T) then
5491          Set_Is_Tagged_Type  (Def_Id);
5492          Make_Class_Wide_Type (Def_Id);
5493       end if;
5494
5495       Set_Girder_Constraint (Def_Id, No_Elist);
5496
5497       if Has_Discrs then
5498          Set_Discriminant_Constraint (Def_Id, Elist);
5499          Set_Girder_Constraint_From_Discriminant_Constraint (Def_Id);
5500       end if;
5501
5502       if Is_Tagged_Type (T) then
5503          Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
5504          Set_Is_Abstract (Def_Id, Is_Abstract (T));
5505       end if;
5506
5507       --  Subtypes introduced by component declarations do not need to be
5508       --  marked as delayed, and do not get freeze nodes, because the semantics
5509       --  verifies that the parents of the subtypes are frozen before the
5510       --  enclosing record is frozen.
5511
5512       if not Is_Type (Scope (Def_Id)) then
5513          Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
5514
5515          if Is_Private_Type (T)
5516            and then Present (Full_View (T))
5517          then
5518             Conditional_Delay (Def_Id, Full_View (T));
5519          else
5520             Conditional_Delay (Def_Id, T);
5521          end if;
5522       end if;
5523
5524       if Is_Record_Type (T) then
5525          Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
5526
5527          if Has_Discrs
5528             and then not Is_Empty_Elmt_List (Elist)
5529             and then not For_Access
5530          then
5531             Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
5532          elsif not For_Access then
5533             Set_Cloned_Subtype (Def_Id, T);
5534          end if;
5535       end if;
5536
5537    end Build_Discriminated_Subtype;
5538
5539    ------------------------
5540    -- Build_Scalar_Bound --
5541    ------------------------
5542
5543    function Build_Scalar_Bound
5544      (Bound : Node_Id;
5545       Par_T : Entity_Id;
5546       Der_T : Entity_Id;
5547       Loc   : Source_Ptr)
5548       return Node_Id
5549    is
5550       New_Bound : Entity_Id;
5551
5552    begin
5553       --  Note: not clear why this is needed, how can the original bound
5554       --  be unanalyzed at this point? and if it is, what business do we
5555       --  have messing around with it? and why is the base type of the
5556       --  parent type the right type for the resolution. It probably is
5557       --  not! It is OK for the new bound we are creating, but not for
5558       --  the old one??? Still if it never happens, no problem!
5559
5560       Analyze_And_Resolve (Bound, Base_Type (Par_T));
5561
5562       if Nkind (Bound) = N_Integer_Literal
5563         or else Nkind (Bound) = N_Real_Literal
5564       then
5565          New_Bound := New_Copy (Bound);
5566          Set_Etype (New_Bound, Der_T);
5567          Set_Analyzed (New_Bound);
5568
5569       elsif Is_Entity_Name (Bound) then
5570          New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
5571
5572       --  The following is almost certainly wrong. What business do we have
5573       --  relocating a node (Bound) that is presumably still attached to
5574       --  the tree elsewhere???
5575
5576       else
5577          New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
5578       end if;
5579
5580       Set_Etype (New_Bound, Der_T);
5581       return New_Bound;
5582    end Build_Scalar_Bound;
5583
5584    --------------------------------
5585    -- Build_Underlying_Full_View --
5586    --------------------------------
5587
5588    procedure Build_Underlying_Full_View
5589      (N   : Node_Id;
5590       Typ : Entity_Id;
5591       Par : Entity_Id)
5592    is
5593       Loc  : constant Source_Ptr := Sloc (N);
5594       Subt : constant Entity_Id :=
5595                Make_Defining_Identifier
5596                  (Loc, New_External_Name (Chars (Typ), 'S'));
5597
5598       Constr : Node_Id;
5599       Indic  : Node_Id;
5600       C      : Node_Id;
5601       Id     : Node_Id;
5602
5603    begin
5604       if Nkind (N) = N_Full_Type_Declaration then
5605          Constr := Constraint (Subtype_Indication (Type_Definition (N)));
5606
5607       --  ??? ??? is this assert right, I assume so otherwise Constr
5608       --  would not be defined below (this used to be an elsif)
5609
5610       else pragma Assert (Nkind (N) = N_Subtype_Declaration);
5611          Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
5612       end if;
5613
5614       --  If the constraint has discriminant associations, the discriminant
5615       --  entity is already set, but it denotes a discriminant of the new
5616       --  type, not the original parent, so it must be found anew.
5617
5618       C := First (Constraints (Constr));
5619
5620       while Present (C) loop
5621
5622          if Nkind (C) = N_Discriminant_Association then
5623             Id := First (Selector_Names (C));
5624
5625             while Present (Id) loop
5626                Set_Original_Discriminant (Id, Empty);
5627                Next (Id);
5628             end loop;
5629          end if;
5630
5631          Next (C);
5632       end loop;
5633
5634       Indic := Make_Subtype_Declaration (Loc,
5635          Defining_Identifier => Subt,
5636          Subtype_Indication  =>
5637            Make_Subtype_Indication (Loc,
5638              Subtype_Mark => New_Reference_To (Par, Loc),
5639              Constraint   => New_Copy_Tree (Constr)));
5640
5641       Insert_Before (N, Indic);
5642       Analyze (Indic);
5643       Set_Underlying_Full_View (Typ, Full_View (Subt));
5644    end Build_Underlying_Full_View;
5645
5646    -------------------------------
5647    -- Check_Abstract_Overriding --
5648    -------------------------------
5649
5650    procedure Check_Abstract_Overriding (T : Entity_Id) is
5651       Op_List  : Elist_Id;
5652       Elmt     : Elmt_Id;
5653       Subp     : Entity_Id;
5654       Type_Def : Node_Id;
5655
5656    begin
5657       Op_List := Primitive_Operations (T);
5658
5659       --  Loop to check primitive operations
5660
5661       Elmt := First_Elmt (Op_List);
5662       while Present (Elmt) loop
5663          Subp := Node (Elmt);
5664
5665          --  Special exception, do not complain about failure to
5666          --  override _Input and _Output, since we always provide
5667          --  automatic overridings for these subprograms.
5668
5669          if Is_Abstract (Subp)
5670            and then Chars (Subp) /= Name_uInput
5671            and then Chars (Subp) /= Name_uOutput
5672            and then not Is_Abstract (T)
5673          then
5674             if Present (Alias (Subp)) then
5675                --  Only perform the check for a derived subprogram when
5676                --  the type has an explicit record extension. This avoids
5677                --  incorrectly flagging abstract subprograms for the case
5678                --  of a type without an extension derived from a formal type
5679                --  with a tagged actual (can occur within a private part).
5680
5681                Type_Def := Type_Definition (Parent (T));
5682                if Nkind (Type_Def) = N_Derived_Type_Definition
5683                  and then Present (Record_Extension_Part (Type_Def))
5684                then
5685                   Error_Msg_NE
5686                     ("type must be declared abstract or & overridden",
5687                      T, Subp);
5688                end if;
5689             else
5690                Error_Msg_NE
5691                  ("abstract subprogram not allowed for type&",
5692                   Subp, T);
5693                Error_Msg_NE
5694                  ("nonabstract type has abstract subprogram&",
5695                   T, Subp);
5696             end if;
5697          end if;
5698
5699          Next_Elmt (Elmt);
5700       end loop;
5701    end Check_Abstract_Overriding;
5702
5703    ------------------------------------------------
5704    -- Check_Access_Discriminant_Requires_Limited --
5705    ------------------------------------------------
5706
5707    procedure Check_Access_Discriminant_Requires_Limited
5708      (D   : Node_Id;
5709       Loc : Node_Id)
5710    is
5711    begin
5712       --  A discriminant_specification for an access discriminant
5713       --  shall appear only in the declaration for a task or protected
5714       --  type, or for a type with the reserved word 'limited' in
5715       --  its definition or in one of its ancestors. (RM 3.7(10))
5716
5717       if Nkind (Discriminant_Type (D)) = N_Access_Definition
5718         and then not Is_Concurrent_Type (Current_Scope)
5719         and then not Is_Concurrent_Record_Type (Current_Scope)
5720         and then not Is_Limited_Record (Current_Scope)
5721         and then Ekind (Current_Scope) /= E_Limited_Private_Type
5722       then
5723          Error_Msg_N
5724            ("access discriminants allowed only for limited types", Loc);
5725       end if;
5726    end Check_Access_Discriminant_Requires_Limited;
5727
5728    -----------------------------------
5729    -- Check_Aliased_Component_Types --
5730    -----------------------------------
5731
5732    procedure Check_Aliased_Component_Types (T : Entity_Id) is
5733       C : Entity_Id;
5734
5735    begin
5736       --  ??? Also need to check components of record extensions,
5737       --  but not components of protected types (which are always
5738       --  limited).
5739
5740       if not Is_Limited_Type (T) then
5741          if Ekind (T) = E_Record_Type then
5742             C := First_Component (T);
5743             while Present (C) loop
5744                if Is_Aliased (C)
5745                  and then Has_Discriminants (Etype (C))
5746                  and then not Is_Constrained (Etype (C))
5747                  and then not In_Instance
5748                then
5749                   Error_Msg_N
5750                     ("aliased component must be constrained ('R'M 3.6(11))",
5751                       C);
5752                end if;
5753
5754                Next_Component (C);
5755             end loop;
5756
5757          elsif Ekind (T) = E_Array_Type then
5758             if Has_Aliased_Components (T)
5759               and then Has_Discriminants (Component_Type (T))
5760               and then not Is_Constrained (Component_Type (T))
5761               and then not In_Instance
5762             then
5763                Error_Msg_N
5764                  ("aliased component type must be constrained ('R'M 3.6(11))",
5765                     T);
5766             end if;
5767          end if;
5768       end if;
5769    end Check_Aliased_Component_Types;
5770
5771    ----------------------
5772    -- Check_Completion --
5773    ----------------------
5774
5775    procedure Check_Completion (Body_Id : Node_Id := Empty) is
5776       E : Entity_Id;
5777
5778       procedure Post_Error;
5779       --  Post error message for lack of completion for entity E
5780
5781       procedure Post_Error is
5782       begin
5783          if not Comes_From_Source (E) then
5784
5785             if (Ekind (E) = E_Task_Type
5786               or else Ekind (E) = E_Protected_Type)
5787             then
5788                --  It may be an anonymous protected type created for a
5789                --  single variable. Post error on variable, if present.
5790
5791                declare
5792                   Var : Entity_Id;
5793
5794                begin
5795                   Var := First_Entity (Current_Scope);
5796
5797                   while Present (Var) loop
5798                      exit when Etype (Var) = E
5799                        and then Comes_From_Source (Var);
5800
5801                      Next_Entity (Var);
5802                   end loop;
5803
5804                   if Present (Var) then
5805                      E := Var;
5806                   end if;
5807                end;
5808             end if;
5809          end if;
5810
5811          --  If a generated entity has no completion, then either previous
5812          --  semantic errors have disabled the expansion phase, or else
5813          --  we had missing subunits, or else we are compiling without expan-
5814          --  sion, or else something is very wrong.
5815
5816          if not Comes_From_Source (E) then
5817             pragma Assert
5818               (Errors_Detected > 0
5819                 or else Subunits_Missing
5820                 or else not Expander_Active);
5821             return;
5822
5823          --  Here for source entity
5824
5825          else
5826             --  Here if no body to post the error message, so we post the error
5827             --  on the declaration that has no completion. This is not really
5828             --  the right place to post it, think about this later ???
5829
5830             if No (Body_Id) then
5831                if Is_Type (E) then
5832                   Error_Msg_NE
5833                     ("missing full declaration for }", Parent (E), E);
5834                else
5835                   Error_Msg_NE
5836                     ("missing body for &", Parent (E), E);
5837                end if;
5838
5839             --  Package body has no completion for a declaration that appears
5840             --  in the corresponding spec. Post error on the body, with a
5841             --  reference to the non-completed declaration.
5842
5843             else
5844                Error_Msg_Sloc := Sloc (E);
5845
5846                if Is_Type (E) then
5847                   Error_Msg_NE
5848                     ("missing full declaration for }!", Body_Id, E);
5849
5850                elsif Is_Overloadable (E)
5851                  and then Current_Entity_In_Scope (E) /= E
5852                then
5853                   --  It may be that the completion is mistyped and appears
5854                   --  as a  distinct overloading of the entity.
5855
5856                   declare
5857                      Candidate : Entity_Id := Current_Entity_In_Scope (E);
5858                      Decl      : Node_Id := Unit_Declaration_Node (Candidate);
5859
5860                   begin
5861                      if Is_Overloadable (Candidate)
5862                        and then Ekind (Candidate) = Ekind (E)
5863                        and then Nkind (Decl) = N_Subprogram_Body
5864                        and then Acts_As_Spec (Decl)
5865                      then
5866                         Check_Type_Conformant (Candidate, E);
5867
5868                      else
5869                         Error_Msg_NE ("missing body for & declared#!",
5870                            Body_Id, E);
5871                      end if;
5872                   end;
5873                else
5874                   Error_Msg_NE ("missing body for & declared#!",
5875                      Body_Id, E);
5876                end if;
5877             end if;
5878          end if;
5879       end Post_Error;
5880
5881    --  Start processing for Check_Completion
5882
5883    begin
5884       E := First_Entity (Current_Scope);
5885       while Present (E) loop
5886          if Is_Intrinsic_Subprogram (E) then
5887             null;
5888
5889          --  The following situation requires special handling: a child
5890          --  unit that appears in the context clause of the body of its
5891          --  parent:
5892
5893          --    procedure Parent.Child (...);
5894          --
5895          --    with Parent.Child;
5896          --    package body Parent is
5897
5898          --  Here Parent.Child appears as a local entity, but should not
5899          --  be flagged as requiring completion, because it is a
5900          --  compilation unit.
5901
5902          elsif     Ekind (E) = E_Function
5903            or else Ekind (E) = E_Procedure
5904            or else Ekind (E) = E_Generic_Function
5905            or else Ekind (E) = E_Generic_Procedure
5906          then
5907             if not Has_Completion (E)
5908               and then not Is_Abstract (E)
5909               and then Nkind (Parent (Unit_Declaration_Node (E))) /=
5910                                                        N_Compilation_Unit
5911               and then Chars (E) /= Name_uSize
5912             then
5913                Post_Error;
5914             end if;
5915
5916          elsif Is_Entry (E) then
5917             if not Has_Completion (E) and then
5918               (Ekind (Scope (E)) = E_Protected_Object
5919                 or else Ekind (Scope (E)) = E_Protected_Type)
5920             then
5921                Post_Error;
5922             end if;
5923
5924          elsif Is_Package (E) then
5925             if Unit_Requires_Body (E) then
5926                if not Has_Completion (E)
5927                  and then Nkind (Parent (Unit_Declaration_Node (E))) /=
5928                                                        N_Compilation_Unit
5929                then
5930                   Post_Error;
5931                end if;
5932
5933             elsif not Is_Child_Unit (E) then
5934                May_Need_Implicit_Body (E);
5935             end if;
5936
5937          elsif Ekind (E) = E_Incomplete_Type
5938            and then No (Underlying_Type (E))
5939          then
5940             Post_Error;
5941
5942          elsif (Ekind (E) = E_Task_Type or else
5943                 Ekind (E) = E_Protected_Type)
5944            and then not Has_Completion (E)
5945          then
5946             Post_Error;
5947
5948          elsif Ekind (E) = E_Constant
5949            and then Ekind (Etype (E)) = E_Task_Type
5950            and then not Has_Completion (Etype (E))
5951          then
5952             Post_Error;
5953
5954          elsif Ekind (E) = E_Protected_Object
5955            and then not Has_Completion (Etype (E))
5956          then
5957             Post_Error;
5958
5959          elsif Ekind (E) = E_Record_Type then
5960             if Is_Tagged_Type (E) then
5961                Check_Abstract_Overriding (E);
5962             end if;
5963
5964             Check_Aliased_Component_Types (E);
5965
5966          elsif Ekind (E) = E_Array_Type then
5967             Check_Aliased_Component_Types (E);
5968
5969          end if;
5970
5971          Next_Entity (E);
5972       end loop;
5973    end Check_Completion;
5974
5975    ----------------------------
5976    -- Check_Delta_Expression --
5977    ----------------------------
5978
5979    procedure Check_Delta_Expression (E : Node_Id) is
5980    begin
5981       if not (Is_Real_Type (Etype (E))) then
5982          Wrong_Type (E, Any_Real);
5983
5984       elsif not Is_OK_Static_Expression (E) then
5985          Error_Msg_N ("non-static expression used for delta value", E);
5986
5987       elsif not UR_Is_Positive (Expr_Value_R (E)) then
5988          Error_Msg_N ("delta expression must be positive", E);
5989
5990       else
5991          return;
5992       end if;
5993
5994       --  If any of above errors occurred, then replace the incorrect
5995       --  expression by the real 0.1, which should prevent further errors.
5996
5997       Rewrite (E,
5998         Make_Real_Literal (Sloc (E), Ureal_Tenth));
5999       Analyze_And_Resolve (E, Standard_Float);
6000
6001    end Check_Delta_Expression;
6002
6003    -----------------------------
6004    -- Check_Digits_Expression --
6005    -----------------------------
6006
6007    procedure Check_Digits_Expression (E : Node_Id) is
6008    begin
6009       if not (Is_Integer_Type (Etype (E))) then
6010          Wrong_Type (E, Any_Integer);
6011
6012       elsif not Is_OK_Static_Expression (E) then
6013          Error_Msg_N ("non-static expression used for digits value", E);
6014
6015       elsif Expr_Value (E) <= 0 then
6016          Error_Msg_N ("digits value must be greater than zero", E);
6017
6018       else
6019          return;
6020       end if;
6021
6022       --  If any of above errors occurred, then replace the incorrect
6023       --  expression by the integer 1, which should prevent further errors.
6024
6025       Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
6026       Analyze_And_Resolve (E, Standard_Integer);
6027
6028    end Check_Digits_Expression;
6029
6030    ----------------------
6031    -- Check_Incomplete --
6032    ----------------------
6033
6034    procedure Check_Incomplete (T : Entity_Id) is
6035    begin
6036       if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
6037          Error_Msg_N ("invalid use of type before its full declaration", T);
6038       end if;
6039    end Check_Incomplete;
6040
6041    --------------------------
6042    -- Check_Initialization --
6043    --------------------------
6044
6045    procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
6046    begin
6047       if (Is_Limited_Type (T)
6048            or else Is_Limited_Composite (T))
6049         and then not In_Instance
6050       then
6051          Error_Msg_N
6052            ("cannot initialize entities of limited type", Exp);
6053       end if;
6054    end Check_Initialization;
6055
6056    ------------------------------------
6057    -- Check_Or_Process_Discriminants --
6058    ------------------------------------
6059
6060    --  If an incomplete or private type declaration was already given for
6061    --  the type, the discriminants may have already been processed if they
6062    --  were present on the incomplete declaration. In this case a full
6063    --  conformance check is performed otherwise just process them.
6064
6065    procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id) is
6066    begin
6067       if Has_Discriminants (T) then
6068
6069          --  Make the discriminants visible to component declarations.
6070
6071          declare
6072             D    : Entity_Id := First_Discriminant (T);
6073             Prev : Entity_Id;
6074
6075          begin
6076             while Present (D) loop
6077                Prev := Current_Entity (D);
6078                Set_Current_Entity (D);
6079                Set_Is_Immediately_Visible (D);
6080                Set_Homonym (D, Prev);
6081
6082                --  This restriction gets applied to the full type here; it
6083                --  has already been applied earlier to the partial view
6084
6085                Check_Access_Discriminant_Requires_Limited (Parent (D), N);
6086
6087                Next_Discriminant (D);
6088             end loop;
6089          end;
6090
6091       elsif Present (Discriminant_Specifications (N)) then
6092          Process_Discriminants (N);
6093       end if;
6094    end Check_Or_Process_Discriminants;
6095
6096    ----------------------
6097    -- Check_Real_Bound --
6098    ----------------------
6099
6100    procedure Check_Real_Bound (Bound : Node_Id) is
6101    begin
6102       if not Is_Real_Type (Etype (Bound)) then
6103          Error_Msg_N
6104            ("bound in real type definition must be of real type", Bound);
6105
6106       elsif not Is_OK_Static_Expression (Bound) then
6107          Error_Msg_N
6108            ("non-static expression used for real type bound", Bound);
6109
6110       else
6111          return;
6112       end if;
6113
6114       Rewrite
6115         (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
6116       Analyze (Bound);
6117       Resolve (Bound, Standard_Float);
6118    end Check_Real_Bound;
6119
6120    ------------------------------
6121    -- Complete_Private_Subtype --
6122    ------------------------------
6123
6124    procedure Complete_Private_Subtype
6125      (Priv        : Entity_Id;
6126       Full        : Entity_Id;
6127       Full_Base   : Entity_Id;
6128       Related_Nod : Node_Id)
6129    is
6130       Save_Next_Entity : Entity_Id;
6131       Save_Homonym     : Entity_Id;
6132
6133    begin
6134       --  Set semantic attributes for (implicit) private subtype completion.
6135       --  If the full type has no discriminants, then it is a copy of the full
6136       --  view of the base. Otherwise, it is a subtype of the base with a
6137       --  possible discriminant constraint. Save and restore the original
6138       --  Next_Entity field of full to ensure that the calls to Copy_Node
6139       --  do not corrupt the entity chain.
6140
6141       --  Note that the type of the full view is the same entity as the
6142       --  type of the partial view. In this fashion, the subtype has
6143       --  access to the correct view of the parent.
6144
6145       Save_Next_Entity := Next_Entity (Full);
6146       Save_Homonym     := Homonym (Priv);
6147
6148       case Ekind (Full_Base) is
6149
6150          when E_Record_Type    |
6151               E_Record_Subtype |
6152               Class_Wide_Kind  |
6153               Private_Kind     |
6154               Task_Kind        |
6155               Protected_Kind   =>
6156             Copy_Node (Priv, Full);
6157
6158             Set_Has_Discriminants  (Full, Has_Discriminants (Full_Base));
6159             Set_First_Entity       (Full, First_Entity (Full_Base));
6160             Set_Last_Entity        (Full, Last_Entity (Full_Base));
6161
6162          when others =>
6163             Copy_Node (Full_Base, Full);
6164             Set_Chars          (Full, Chars (Priv));
6165             Conditional_Delay  (Full, Priv);
6166             Set_Sloc           (Full, Sloc (Priv));
6167
6168       end case;
6169
6170       Set_Next_Entity (Full, Save_Next_Entity);
6171       Set_Homonym     (Full, Save_Homonym);
6172       Set_Associated_Node_For_Itype (Full, Related_Nod);
6173
6174       --  Set common attributes for all subtypes.
6175
6176       Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
6177
6178       --  The Etype of the full view is inconsistent. Gigi needs to see the
6179       --  structural full view,  which is what the current scheme gives:
6180       --  the Etype of the full view is the etype of the full base. However,
6181       --  if the full base is a derived type, the full view then looks like
6182       --  a subtype of the parent, not a subtype of the full base. If instead
6183       --  we write:
6184
6185       --       Set_Etype (Full, Full_Base);
6186
6187       --  then we get inconsistencies in the front-end (confusion between
6188       --  views). Several outstanding bugs are related to this.
6189
6190       Set_Is_First_Subtype (Full, False);
6191       Set_Scope            (Full, Scope (Priv));
6192       Set_Size_Info        (Full, Full_Base);
6193       Set_RM_Size          (Full, RM_Size (Full_Base));
6194       Set_Is_Itype         (Full);
6195
6196       --  A subtype of a private-type-without-discriminants, whose full-view
6197       --  has discriminants with default expressions, is not constrained!
6198
6199       if not Has_Discriminants (Priv) then
6200          Set_Is_Constrained (Full, Is_Constrained (Full_Base));
6201       end if;
6202
6203       Set_First_Rep_Item     (Full, First_Rep_Item (Full_Base));
6204       Set_Depends_On_Private (Full, Has_Private_Component (Full));
6205
6206       --  Freeze the private subtype entity if its parent is delayed,
6207       --  and not already frozen. We skip this processing if the type
6208       --  is an anonymous subtype of a record component, or is the
6209       --  corresponding record of a protected type, since ???
6210
6211       if not Is_Type (Scope (Full)) then
6212          Set_Has_Delayed_Freeze (Full,
6213            Has_Delayed_Freeze (Full_Base)
6214                and then (not Is_Frozen (Full_Base)));
6215       end if;
6216
6217       Set_Freeze_Node (Full, Empty);
6218       Set_Is_Frozen (Full, False);
6219       Set_Full_View (Priv, Full);
6220
6221       if Has_Discriminants (Full) then
6222          Set_Girder_Constraint_From_Discriminant_Constraint (Full);
6223          Set_Girder_Constraint (Priv, Girder_Constraint (Full));
6224          if Has_Unknown_Discriminants (Full) then
6225             Set_Discriminant_Constraint (Full, No_Elist);
6226          end if;
6227       end if;
6228
6229       if Ekind (Full_Base) = E_Record_Type
6230         and then Has_Discriminants (Full_Base)
6231         and then Has_Discriminants (Priv) -- might not, if errors
6232         and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
6233       then
6234          Create_Constrained_Components
6235            (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
6236
6237       --  If the full base is itself derived from private, build a congruent
6238       --  subtype of its underlying type, for use by the back end.
6239
6240       elsif Ekind (Full_Base) in Private_Kind
6241         and then Is_Derived_Type (Full_Base)
6242         and then Has_Discriminants (Full_Base)
6243         and then
6244           Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
6245       then
6246          Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base));
6247
6248       elsif Is_Record_Type (Full_Base) then
6249
6250          --  Show Full is simply a renaming of Full_Base.
6251
6252          Set_Cloned_Subtype (Full, Full_Base);
6253       end if;
6254
6255       --  It is usafe to share to bounds of a scalar type, because the
6256       --  Itype is elaborated on demand, and if a bound is non-static
6257       --  then different orders of elaboration in different units will
6258       --  lead to different external symbols.
6259
6260       if Is_Scalar_Type (Full_Base) then
6261          Set_Scalar_Range (Full,
6262            Make_Range (Sloc (Related_Nod),
6263              Low_Bound  => Duplicate_Subexpr (Type_Low_Bound  (Full_Base)),
6264              High_Bound => Duplicate_Subexpr (Type_High_Bound (Full_Base))));
6265       end if;
6266
6267       --  ??? It seems that a lot of fields are missing that should be
6268       --  copied from  Full_Base to Full. Here are some that are introduced
6269       --  in a non-disruptive way but a cleanup is necessary.
6270
6271       if Is_Tagged_Type (Full_Base) then
6272          Set_Is_Tagged_Type (Full);
6273          Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
6274
6275       elsif Is_Concurrent_Type (Full_Base) then
6276
6277          if Has_Discriminants (Full)
6278            and then Present (Corresponding_Record_Type (Full_Base))
6279          then
6280             Set_Corresponding_Record_Type (Full,
6281               Constrain_Corresponding_Record
6282                 (Full, Corresponding_Record_Type (Full_Base),
6283                   Related_Nod, Full_Base));
6284
6285          else
6286             Set_Corresponding_Record_Type (Full,
6287               Corresponding_Record_Type (Full_Base));
6288          end if;
6289       end if;
6290
6291    end Complete_Private_Subtype;
6292
6293    ----------------------------
6294    -- Constant_Redeclaration --
6295    ----------------------------
6296
6297    procedure Constant_Redeclaration
6298      (Id : Entity_Id;
6299       N  : Node_Id;
6300       T  : out Entity_Id)
6301    is
6302       Prev    : constant Entity_Id := Current_Entity_In_Scope (Id);
6303       Obj_Def : constant Node_Id := Object_Definition (N);
6304       New_T   : Entity_Id;
6305
6306    begin
6307       if Nkind (Parent (Prev)) = N_Object_Declaration then
6308          if Nkind (Object_Definition
6309                      (Parent (Prev))) = N_Subtype_Indication
6310          then
6311             --  Find type of new declaration. The constraints of the two
6312             --  views must match statically, but there is no point in
6313             --  creating an itype for the full view.
6314
6315             if Nkind (Obj_Def) = N_Subtype_Indication then
6316                Find_Type (Subtype_Mark (Obj_Def));
6317                New_T := Entity (Subtype_Mark (Obj_Def));
6318
6319             else
6320                Find_Type (Obj_Def);
6321                New_T := Entity (Obj_Def);
6322             end if;
6323
6324             T := Etype (Prev);
6325
6326          else
6327             --  The full view may impose a constraint, even if the partial
6328             --  view does not, so construct the subtype.
6329
6330             New_T := Find_Type_Of_Object (Obj_Def, N);
6331             T     := New_T;
6332          end if;
6333
6334       else
6335          --  Current declaration is illegal, diagnosed below in Enter_Name.
6336
6337          T := Empty;
6338          New_T := Any_Type;
6339       end if;
6340
6341       --  If previous full declaration exists, or if a homograph is present,
6342       --  let Enter_Name handle it, either with an error, or with the removal
6343       --  of an overridden implicit subprogram.
6344
6345       if Ekind (Prev) /= E_Constant
6346         or else Present (Expression (Parent (Prev)))
6347       then
6348          Enter_Name (Id);
6349
6350       --  Verify that types of both declarations match.
6351
6352       elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then
6353          Error_Msg_Sloc := Sloc (Prev);
6354          Error_Msg_N ("type does not match declaration#", N);
6355          Set_Full_View (Prev, Id);
6356          Set_Etype (Id, Any_Type);
6357
6358       --  If so, process the full constant declaration
6359
6360       else
6361          Set_Full_View (Prev, Id);
6362          Set_Is_Public (Id, Is_Public (Prev));
6363          Set_Is_Internal (Id);
6364          Append_Entity (Id, Current_Scope);
6365
6366          --  Check ALIASED present if present before (RM 7.4(7))
6367
6368          if Is_Aliased (Prev)
6369            and then not Aliased_Present (N)
6370          then
6371             Error_Msg_Sloc := Sloc (Prev);
6372             Error_Msg_N ("ALIASED required (see declaration#)", N);
6373          end if;
6374
6375          --  Check that placement is in private part
6376
6377          if Ekind (Current_Scope) = E_Package
6378            and then not In_Private_Part (Current_Scope)
6379          then
6380             Error_Msg_Sloc := Sloc (Prev);
6381             Error_Msg_N ("full constant for declaration#"
6382                          & " must be in private part", N);
6383          end if;
6384       end if;
6385    end Constant_Redeclaration;
6386
6387    ----------------------
6388    -- Constrain_Access --
6389    ----------------------
6390
6391    procedure Constrain_Access
6392      (Def_Id      : in out Entity_Id;
6393       S           : Node_Id;
6394       Related_Nod : Node_Id)
6395    is
6396       T             : constant Entity_Id := Entity (Subtype_Mark (S));
6397       Desig_Type    : constant Entity_Id := Designated_Type (T);
6398       Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
6399       Constraint_OK : Boolean := True;
6400
6401    begin
6402       if Is_Array_Type (Desig_Type) then
6403          Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
6404
6405       elsif (Is_Record_Type (Desig_Type)
6406               or else Is_Incomplete_Or_Private_Type (Desig_Type))
6407         and then not Is_Constrained (Desig_Type)
6408       then
6409          --  ??? The following code is a temporary kludge to ignore
6410          --  discriminant constraint on access type if
6411          --  it is constraining the current record. Avoid creating the
6412          --  implicit subtype of the record we are currently compiling
6413          --  since right now, we cannot handle these.
6414          --  For now, just return the access type itself.
6415
6416          if Desig_Type = Current_Scope
6417            and then No (Def_Id)
6418          then
6419             Set_Ekind (Desig_Subtype, E_Record_Subtype);
6420             Def_Id := Entity (Subtype_Mark (S));
6421
6422             --  This call added to ensure that the constraint is
6423             --  analyzed (needed for a B test). Note that we
6424             --  still return early from this procedure to avoid
6425             --  recursive processing. ???
6426
6427             Constrain_Discriminated_Type
6428               (Desig_Subtype, S, Related_Nod, For_Access => True);
6429
6430             return;
6431          end if;
6432
6433          Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
6434            For_Access => True);
6435
6436       elsif (Is_Task_Type (Desig_Type)
6437               or else Is_Protected_Type (Desig_Type))
6438         and then not Is_Constrained (Desig_Type)
6439       then
6440          Constrain_Concurrent
6441            (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
6442
6443       else
6444          Error_Msg_N ("invalid constraint on access type", S);
6445          Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
6446          Constraint_OK := False;
6447       end if;
6448
6449       if No (Def_Id) then
6450          Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
6451       else
6452          Set_Ekind (Def_Id, E_Access_Subtype);
6453       end if;
6454
6455       if Constraint_OK then
6456          Set_Etype (Def_Id, Base_Type (T));
6457
6458          if Is_Private_Type (Desig_Type) then
6459             Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
6460          end if;
6461       else
6462          Set_Etype (Def_Id, Any_Type);
6463       end if;
6464
6465       Set_Size_Info                (Def_Id, T);
6466       Set_Is_Constrained           (Def_Id, Constraint_OK);
6467       Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
6468       Set_Depends_On_Private       (Def_Id, Has_Private_Component (Def_Id));
6469       Set_Is_Access_Constant       (Def_Id, Is_Access_Constant (T));
6470
6471       --  Itypes created for constrained record components do not receive
6472       --  a freeze node, they are elaborated when first seen.
6473
6474       if not Is_Record_Type (Current_Scope) then
6475          Conditional_Delay (Def_Id, T);
6476       end if;
6477    end Constrain_Access;
6478
6479    ---------------------
6480    -- Constrain_Array --
6481    ---------------------
6482
6483    procedure Constrain_Array
6484      (Def_Id      : in out Entity_Id;
6485       SI          : Node_Id;
6486       Related_Nod : Node_Id;
6487       Related_Id  : Entity_Id;
6488       Suffix      : Character)
6489    is
6490       C                     : constant Node_Id := Constraint (SI);
6491       Number_Of_Constraints : Nat := 0;
6492       Index                 : Node_Id;
6493       S, T                  : Entity_Id;
6494       Constraint_OK         : Boolean := True;
6495
6496    begin
6497       T := Entity (Subtype_Mark (SI));
6498
6499       if Ekind (T) in Access_Kind then
6500          T := Designated_Type (T);
6501       end if;
6502
6503       --  If an index constraint follows a subtype mark in a subtype indication
6504       --  then the type or subtype denoted by the subtype mark must not already
6505       --  impose an index constraint. The subtype mark must denote either an
6506       --  unconstrained array type or an access type whose designated type
6507       --  is such an array type... (RM 3.6.1)
6508
6509       if Is_Constrained (T) then
6510          Error_Msg_N
6511            ("array type is already constrained", Subtype_Mark (SI));
6512          Constraint_OK := False;
6513
6514       else
6515          S := First (Constraints (C));
6516
6517          while Present (S) loop
6518             Number_Of_Constraints := Number_Of_Constraints + 1;
6519             Next (S);
6520          end loop;
6521
6522          --  In either case, the index constraint must provide a discrete
6523          --  range for each index of the array type and the type of each
6524          --  discrete range must be the same as that of the corresponding
6525          --  index. (RM 3.6.1)
6526
6527          if Number_Of_Constraints /= Number_Dimensions (T) then
6528             Error_Msg_NE ("incorrect number of index constraints for }", C, T);
6529             Constraint_OK := False;
6530
6531          else
6532             S := First (Constraints (C));
6533             Index := First_Index (T);
6534             Analyze (Index);
6535
6536             --  Apply constraints to each index type
6537
6538             for J in 1 .. Number_Of_Constraints loop
6539                Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
6540                Next (Index);
6541                Next (S);
6542             end loop;
6543
6544          end if;
6545       end if;
6546
6547       if No (Def_Id) then
6548          Def_Id :=
6549            Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
6550       else
6551          Set_Ekind (Def_Id, E_Array_Subtype);
6552       end if;
6553
6554       Set_Size_Info      (Def_Id,                (T));
6555       Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
6556       Set_Etype          (Def_Id, Base_Type      (T));
6557
6558       if Constraint_OK then
6559          Set_First_Index (Def_Id, First (Constraints (C)));
6560       end if;
6561
6562       Set_Component_Type     (Def_Id, Component_Type (T));
6563       Set_Is_Constrained     (Def_Id, True);
6564       Set_Is_Aliased         (Def_Id, Is_Aliased (T));
6565       Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
6566
6567       Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
6568       Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
6569
6570       --  If the subtype is not that of a record component, build a freeze
6571       --  node if parent still needs one.
6572
6573       --  If the subtype is not that of a record component, make sure
6574       --  that the Depends_On_Private status is set (explanation ???)
6575       --  and also that a conditional delay is set.
6576
6577       if not Is_Type (Scope (Def_Id)) then
6578          Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
6579          Conditional_Delay (Def_Id, T);
6580       end if;
6581
6582    end Constrain_Array;
6583
6584    ------------------------------
6585    -- Constrain_Component_Type --
6586    ------------------------------
6587
6588    function Constrain_Component_Type
6589      (Compon_Type     : Entity_Id;
6590       Constrained_Typ : Entity_Id;
6591       Related_Node    : Node_Id;
6592       Typ             : Entity_Id;
6593       Constraints     : Elist_Id)
6594       return            Entity_Id
6595    is
6596       Loc : constant Source_Ptr := Sloc (Constrained_Typ);
6597
6598       function Build_Constrained_Array_Type
6599         (Old_Type : Entity_Id)
6600          return     Entity_Id;
6601       --  If Old_Type is an array type, one of whose indices is
6602       --  constrained by a discriminant, build an Itype whose constraint
6603       --  replaces the discriminant with its value in the constraint.
6604
6605       function Build_Constrained_Discriminated_Type
6606         (Old_Type : Entity_Id)
6607          return     Entity_Id;
6608       --  Ditto for record components.
6609
6610       function Build_Constrained_Access_Type
6611         (Old_Type : Entity_Id)
6612          return     Entity_Id;
6613       --  Ditto for access types. Makes use of previous two functions, to
6614       --  constrain designated type.
6615
6616       function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
6617       --  T is an array or discriminated type, C is a list of constraints
6618       --  that apply to T. This routine builds the constrained subtype.
6619
6620       function Is_Discriminant (Expr : Node_Id) return Boolean;
6621       --  Returns True if Expr is a discriminant.
6622
6623       function Get_Value (Discrim : Entity_Id) return Node_Id;
6624       --  Find the value of discriminant Discrim in Constraint.
6625
6626       -----------------------------------
6627       -- Build_Constrained_Access_Type --
6628       -----------------------------------
6629
6630       function Build_Constrained_Access_Type
6631         (Old_Type : Entity_Id)
6632         return      Entity_Id
6633       is
6634          Desig_Type    : constant Entity_Id := Designated_Type (Old_Type);
6635          Itype         : Entity_Id;
6636          Desig_Subtype : Entity_Id;
6637          Scop          : Entity_Id;
6638
6639       begin
6640          --  if the original access type was not embedded in the enclosing
6641          --  type definition, there is no need to produce a new access
6642          --  subtype. In fact every access type with an explicit constraint
6643          --  generates an itype whose scope is the enclosing record.
6644
6645          if not Is_Type (Scope (Old_Type)) then
6646             return Old_Type;
6647
6648          elsif Is_Array_Type (Desig_Type) then
6649             Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
6650
6651          elsif Has_Discriminants (Desig_Type) then
6652
6653             --  This may be an access type to an enclosing record type for
6654             --  which we are constructing the constrained components. Return
6655             --  the enclosing record subtype. This is not always correct,
6656             --  but avoids infinite recursion. ???
6657
6658             Desig_Subtype := Any_Type;
6659
6660             for J in reverse 0 .. Scope_Stack.Last loop
6661                Scop := Scope_Stack.Table (J).Entity;
6662
6663                if Is_Type (Scop)
6664                  and then Base_Type (Scop) = Base_Type (Desig_Type)
6665                then
6666                   Desig_Subtype := Scop;
6667                end if;
6668
6669                exit when not Is_Type (Scop);
6670             end loop;
6671
6672             if Desig_Subtype = Any_Type then
6673                Desig_Subtype :=
6674                  Build_Constrained_Discriminated_Type (Desig_Type);
6675             end if;
6676
6677          else
6678             return Old_Type;
6679          end if;
6680
6681          if Desig_Subtype /= Desig_Type then
6682             --  The Related_Node better be here or else we won't be able
6683             --  to attach new itypes to a node in the tree.
6684
6685             pragma Assert (Present (Related_Node));
6686
6687             Itype := Create_Itype (E_Access_Subtype, Related_Node);
6688
6689             Set_Etype                    (Itype, Base_Type      (Old_Type));
6690             Set_Size_Info                (Itype,                (Old_Type));
6691             Set_Directly_Designated_Type (Itype, Desig_Subtype);
6692             Set_Depends_On_Private       (Itype, Has_Private_Component
6693                                                                 (Old_Type));
6694             Set_Is_Access_Constant       (Itype, Is_Access_Constant
6695                                                                 (Old_Type));
6696
6697             --  The new itype needs freezing when it depends on a not frozen
6698             --  type and the enclosing subtype needs freezing.
6699
6700             if Has_Delayed_Freeze (Constrained_Typ)
6701               and then not Is_Frozen (Constrained_Typ)
6702             then
6703                Conditional_Delay (Itype, Base_Type (Old_Type));
6704             end if;
6705
6706             return Itype;
6707
6708          else
6709             return Old_Type;
6710          end if;
6711       end Build_Constrained_Access_Type;
6712
6713       ----------------------------------
6714       -- Build_Constrained_Array_Type --
6715       ----------------------------------
6716
6717       function Build_Constrained_Array_Type
6718         (Old_Type : Entity_Id)
6719          return     Entity_Id
6720       is
6721          Lo_Expr     : Node_Id;
6722          Hi_Expr     : Node_Id;
6723          Old_Index   : Node_Id;
6724          Range_Node  : Node_Id;
6725          Constr_List : List_Id;
6726
6727          Need_To_Create_Itype : Boolean := False;
6728
6729       begin
6730          Old_Index := First_Index (Old_Type);
6731          while Present (Old_Index) loop
6732             Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
6733
6734             if Is_Discriminant (Lo_Expr)
6735               or else Is_Discriminant (Hi_Expr)
6736             then
6737                Need_To_Create_Itype := True;
6738             end if;
6739
6740             Next_Index (Old_Index);
6741          end loop;
6742
6743          if Need_To_Create_Itype then
6744             Constr_List := New_List;
6745
6746             Old_Index := First_Index (Old_Type);
6747             while Present (Old_Index) loop
6748                Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
6749
6750                if Is_Discriminant (Lo_Expr) then
6751                   Lo_Expr := Get_Value (Lo_Expr);
6752                end if;
6753
6754                if Is_Discriminant (Hi_Expr) then
6755                   Hi_Expr := Get_Value (Hi_Expr);
6756                end if;
6757
6758                Range_Node :=
6759                  Make_Range
6760                    (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
6761
6762                Append (Range_Node, To => Constr_List);
6763
6764                Next_Index (Old_Index);
6765             end loop;
6766
6767             return Build_Subtype (Old_Type, Constr_List);
6768
6769          else
6770             return Old_Type;
6771          end if;
6772       end Build_Constrained_Array_Type;
6773
6774       ------------------------------------------
6775       -- Build_Constrained_Discriminated_Type --
6776       ------------------------------------------
6777
6778       function Build_Constrained_Discriminated_Type
6779         (Old_Type : Entity_Id)
6780          return     Entity_Id
6781       is
6782          Expr           : Node_Id;
6783          Constr_List    : List_Id;
6784          Old_Constraint : Elmt_Id;
6785
6786          Need_To_Create_Itype : Boolean := False;
6787
6788       begin
6789          Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
6790          while Present (Old_Constraint) loop
6791             Expr := Node (Old_Constraint);
6792
6793             if Is_Discriminant (Expr) then
6794                Need_To_Create_Itype := True;
6795             end if;
6796
6797             Next_Elmt (Old_Constraint);
6798          end loop;
6799
6800          if Need_To_Create_Itype then
6801             Constr_List := New_List;
6802
6803             Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
6804             while Present (Old_Constraint) loop
6805                Expr := Node (Old_Constraint);
6806
6807                if Is_Discriminant (Expr) then
6808                   Expr := Get_Value (Expr);
6809                end if;
6810
6811                Append (New_Copy_Tree (Expr), To => Constr_List);
6812
6813                Next_Elmt (Old_Constraint);
6814             end loop;
6815
6816             return Build_Subtype (Old_Type, Constr_List);
6817
6818          else
6819             return Old_Type;
6820          end if;
6821       end Build_Constrained_Discriminated_Type;
6822
6823       -------------------
6824       -- Build_Subtype --
6825       -------------------
6826
6827       function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
6828          Indic       : Node_Id;
6829          Subtyp_Decl : Node_Id;
6830          Def_Id      : Entity_Id;
6831          Btyp        : Entity_Id := Base_Type (T);
6832
6833       begin
6834          --  The Related_Node better be here or else we won't be able
6835          --  to attach new itypes to a node in the tree.
6836
6837          pragma Assert (Present (Related_Node));
6838
6839          --  If the view of the component's type is incomplete or private
6840          --  with unknown discriminants, then the constraint must be applied
6841          --  to the full type.
6842
6843          if Has_Unknown_Discriminants (Btyp)
6844            and then Present (Underlying_Type (Btyp))
6845          then
6846             Btyp := Underlying_Type (Btyp);
6847          end if;
6848
6849          Indic :=
6850            Make_Subtype_Indication (Loc,
6851              Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
6852              Constraint   => Make_Index_Or_Discriminant_Constraint (Loc, C));
6853
6854          Def_Id := Create_Itype (Ekind (T), Related_Node);
6855
6856          Subtyp_Decl :=
6857            Make_Subtype_Declaration (Loc,
6858              Defining_Identifier => Def_Id,
6859              Subtype_Indication  => Indic);
6860          Set_Parent (Subtyp_Decl, Parent (Related_Node));
6861
6862          --  Itypes must be analyzed with checks off (see itypes.ads).
6863
6864          Analyze (Subtyp_Decl, Suppress => All_Checks);
6865
6866          return Def_Id;
6867       end Build_Subtype;
6868
6869       ---------------
6870       -- Get_Value --
6871       ---------------
6872
6873       function Get_Value (Discrim : Entity_Id) return Node_Id is
6874          D : Entity_Id := First_Discriminant (Typ);
6875          E : Elmt_Id   := First_Elmt (Constraints);
6876
6877       begin
6878          while Present (D) loop
6879
6880             --  If we are constraining the subtype of a derived tagged type,
6881             --  recover the discriminant of the parent, which appears in
6882             --  the constraint of an inherited component.
6883
6884             if D = Entity (Discrim)
6885               or else Corresponding_Discriminant (D) = Entity (Discrim)
6886             then
6887                return Node (E);
6888             end if;
6889
6890             Next_Discriminant (D);
6891             Next_Elmt (E);
6892          end loop;
6893
6894          --  Something is wrong if we did not find the value
6895
6896          raise Program_Error;
6897       end Get_Value;
6898
6899       ---------------------
6900       -- Is_Discriminant --
6901       ---------------------
6902
6903       function Is_Discriminant (Expr : Node_Id) return Boolean is
6904          Discrim_Scope : Entity_Id;
6905
6906       begin
6907          if Denotes_Discriminant (Expr) then
6908             Discrim_Scope := Scope (Entity (Expr));
6909
6910             --  Either we have a reference to one of Typ's discriminants,
6911
6912             pragma Assert (Discrim_Scope = Typ
6913
6914                --  or to the discriminants of the parent type, in the case
6915                --  of a derivation of a tagged type with variants.
6916
6917                or else Discrim_Scope = Etype (Typ)
6918                or else Full_View (Discrim_Scope) = Etype (Typ)
6919
6920                --  or same as above for the case where the discriminants
6921                --  were declared in Typ's private view.
6922
6923                or else (Is_Private_Type (Discrim_Scope)
6924                         and then Chars (Discrim_Scope) = Chars (Typ))
6925
6926                --  or else we are deriving from the full view and the
6927                --  discriminant is declared in the private entity.
6928
6929                or else (Is_Private_Type (Typ)
6930                         and then Chars (Discrim_Scope) = Chars (Typ))
6931
6932                --  or we have a class-wide type, in which case make sure the
6933                --  discriminant found belongs to the root type.
6934
6935                or else (Is_Class_Wide_Type (Typ)
6936                         and then Etype (Typ) = Discrim_Scope));
6937
6938             return True;
6939          end if;
6940
6941          --  In all other cases we have something wrong.
6942
6943          return False;
6944       end Is_Discriminant;
6945
6946    --  Start of processing for Constrain_Component_Type
6947
6948    begin
6949       if Is_Array_Type (Compon_Type) then
6950          return Build_Constrained_Array_Type (Compon_Type);
6951
6952       elsif Has_Discriminants (Compon_Type) then
6953          return Build_Constrained_Discriminated_Type (Compon_Type);
6954
6955       elsif Is_Access_Type (Compon_Type) then
6956          return Build_Constrained_Access_Type (Compon_Type);
6957       end if;
6958
6959       return Compon_Type;
6960    end Constrain_Component_Type;
6961
6962    --------------------------
6963    -- Constrain_Concurrent --
6964    --------------------------
6965
6966    --  For concurrent types, the associated record value type carries the same
6967    --  discriminants, so when we constrain a concurrent type, we must constrain
6968    --  the value type as well.
6969
6970    procedure Constrain_Concurrent
6971      (Def_Id      : in out Entity_Id;
6972       SI          : Node_Id;
6973       Related_Nod : Node_Id;
6974       Related_Id  : Entity_Id;
6975       Suffix      : Character)
6976    is
6977       T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
6978       T_Val : Entity_Id;
6979
6980    begin
6981       if Ekind (T_Ent) in Access_Kind then
6982          T_Ent := Designated_Type (T_Ent);
6983       end if;
6984
6985       T_Val := Corresponding_Record_Type (T_Ent);
6986
6987       if Present (T_Val) then
6988
6989          if No (Def_Id) then
6990             Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
6991          end if;
6992
6993          Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
6994
6995          Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
6996          Set_Corresponding_Record_Type (Def_Id,
6997            Constrain_Corresponding_Record
6998              (Def_Id, T_Val, Related_Nod, Related_Id));
6999
7000       else
7001          --  If there is no associated record, expansion is disabled and this
7002          --  is a generic context. Create a subtype in any case, so that
7003          --  semantic analysis can proceed.
7004
7005          if No (Def_Id) then
7006             Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
7007          end if;
7008
7009          Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
7010       end if;
7011    end Constrain_Concurrent;
7012
7013    ------------------------------------
7014    -- Constrain_Corresponding_Record --
7015    ------------------------------------
7016
7017    function Constrain_Corresponding_Record
7018      (Prot_Subt   : Entity_Id;
7019       Corr_Rec    : Entity_Id;
7020       Related_Nod : Node_Id;
7021       Related_Id  : Entity_Id)
7022       return Entity_Id
7023    is
7024       T_Sub : constant Entity_Id
7025         := Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
7026
7027    begin
7028       Set_Etype                   (T_Sub, Corr_Rec);
7029       Init_Size_Align             (T_Sub);
7030       Set_Has_Discriminants       (T_Sub, Has_Discriminants (Prot_Subt));
7031       Set_Is_Constrained          (T_Sub, True);
7032       Set_First_Entity            (T_Sub, First_Entity (Corr_Rec));
7033       Set_Last_Entity             (T_Sub, Last_Entity  (Corr_Rec));
7034
7035       Conditional_Delay (T_Sub, Corr_Rec);
7036
7037       if Has_Discriminants (Prot_Subt) then -- False only if errors.
7038          Set_Discriminant_Constraint (T_Sub,
7039                                       Discriminant_Constraint (Prot_Subt));
7040          Set_Girder_Constraint_From_Discriminant_Constraint (T_Sub);
7041          Create_Constrained_Components (T_Sub, Related_Nod, Corr_Rec,
7042                                         Discriminant_Constraint (T_Sub));
7043       end if;
7044
7045       Set_Depends_On_Private      (T_Sub, Has_Private_Component (T_Sub));
7046
7047       return T_Sub;
7048    end Constrain_Corresponding_Record;
7049
7050    -----------------------
7051    -- Constrain_Decimal --
7052    -----------------------
7053
7054    procedure Constrain_Decimal
7055      (Def_Id      : Node_Id;
7056       S           : Node_Id;
7057       Related_Nod : Node_Id)
7058    is
7059       T           : constant Entity_Id  := Entity (Subtype_Mark (S));
7060       C           : constant Node_Id    := Constraint (S);
7061       Loc         : constant Source_Ptr := Sloc (C);
7062       Range_Expr  : Node_Id;
7063       Digits_Expr : Node_Id;
7064       Digits_Val  : Uint;
7065       Bound_Val   : Ureal;
7066
7067    begin
7068       Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
7069
7070       if Nkind (C) = N_Range_Constraint then
7071          Range_Expr := Range_Expression (C);
7072          Digits_Val := Digits_Value (T);
7073
7074       else
7075          pragma Assert (Nkind (C) = N_Digits_Constraint);
7076          Digits_Expr := Digits_Expression (C);
7077          Analyze_And_Resolve (Digits_Expr, Any_Integer);
7078
7079          Check_Digits_Expression (Digits_Expr);
7080          Digits_Val := Expr_Value (Digits_Expr);
7081
7082          if Digits_Val > Digits_Value (T) then
7083             Error_Msg_N
7084                ("digits expression is incompatible with subtype", C);
7085             Digits_Val := Digits_Value (T);
7086          end if;
7087
7088          if Present (Range_Constraint (C)) then
7089             Range_Expr := Range_Expression (Range_Constraint (C));
7090          else
7091             Range_Expr := Empty;
7092          end if;
7093       end if;
7094
7095       Set_Etype            (Def_Id, Base_Type        (T));
7096       Set_Size_Info        (Def_Id,                  (T));
7097       Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
7098       Set_Delta_Value      (Def_Id, Delta_Value      (T));
7099       Set_Scale_Value      (Def_Id, Scale_Value      (T));
7100       Set_Small_Value      (Def_Id, Small_Value      (T));
7101       Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
7102       Set_Digits_Value     (Def_Id, Digits_Val);
7103
7104       --  Manufacture range from given digits value if no range present
7105
7106       if No (Range_Expr) then
7107          Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
7108          Range_Expr :=
7109             Make_Range (Loc,
7110                Low_Bound =>
7111                  Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
7112                High_Bound =>
7113                  Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
7114
7115       end if;
7116
7117       Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T, Related_Nod);
7118       Set_Discrete_RM_Size (Def_Id);
7119
7120       --  Unconditionally delay the freeze, since we cannot set size
7121       --  information in all cases correctly until the freeze point.
7122
7123       Set_Has_Delayed_Freeze (Def_Id);
7124    end Constrain_Decimal;
7125
7126    ----------------------------------
7127    -- Constrain_Discriminated_Type --
7128    ----------------------------------
7129
7130    procedure Constrain_Discriminated_Type
7131      (Def_Id      : Entity_Id;
7132       S           : Node_Id;
7133       Related_Nod : Node_Id;
7134       For_Access  : Boolean := False)
7135    is
7136       T     : Entity_Id;
7137       C     : Node_Id;
7138       Elist : Elist_Id := New_Elmt_List;
7139
7140       procedure Fixup_Bad_Constraint;
7141       --  This is called after finding a bad constraint, and after having
7142       --  posted an appropriate error message. The mission is to leave the
7143       --  entity T in as reasonable state as possible!
7144
7145       procedure Fixup_Bad_Constraint is
7146       begin
7147          --  Set a reasonable Ekind for the entity. For an incomplete type,
7148          --  we can't do much, but for other types, we can set the proper
7149          --  corresponding subtype kind.
7150
7151          if Ekind (T) = E_Incomplete_Type then
7152             Set_Ekind (Def_Id, Ekind (T));
7153          else
7154             Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
7155          end if;
7156
7157          Set_Etype (Def_Id, Any_Type);
7158          Set_Error_Posted (Def_Id);
7159       end Fixup_Bad_Constraint;
7160
7161    --  Start of processing for Constrain_Discriminated_Type
7162
7163    begin
7164       C := Constraint (S);
7165
7166       --  A discriminant constraint is only allowed in a subtype indication,
7167       --  after a subtype mark. This subtype mark must denote either a type
7168       --  with discriminants, or an access type whose designated type is a
7169       --  type with discriminants. A discriminant constraint specifies the
7170       --  values of these discriminants (RM 3.7.2(5)).
7171
7172       T := Base_Type (Entity (Subtype_Mark (S)));
7173
7174       if Ekind (T) in Access_Kind then
7175          T := Designated_Type (T);
7176       end if;
7177
7178       if not Has_Discriminants (T) then
7179          Error_Msg_N ("invalid constraint: type has no discriminant", C);
7180          Fixup_Bad_Constraint;
7181          return;
7182
7183       elsif Is_Constrained (Entity (Subtype_Mark (S))) then
7184          Error_Msg_N ("type is already constrained", Subtype_Mark (S));
7185          Fixup_Bad_Constraint;
7186          return;
7187       end if;
7188
7189       --  T may be an unconstrained subtype (e.g. a generic actual).
7190       --  Constraint applies to the base type.
7191
7192       T := Base_Type (T);
7193
7194       Elist := Build_Discriminant_Constraints (T, S);
7195
7196       --  If the list returned was empty we had an error in building the
7197       --  discriminant constraint. We have also already signalled an error
7198       --  in the incomplete type case
7199
7200       if Is_Empty_Elmt_List (Elist) then
7201          Fixup_Bad_Constraint;
7202          return;
7203       end if;
7204
7205       Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
7206    end Constrain_Discriminated_Type;
7207
7208    ---------------------------
7209    -- Constrain_Enumeration --
7210    ---------------------------
7211
7212    procedure Constrain_Enumeration
7213      (Def_Id      : Node_Id;
7214       S           : Node_Id;
7215       Related_Nod : Node_Id)
7216    is
7217       T : constant Entity_Id := Entity (Subtype_Mark (S));
7218       C : constant Node_Id   := Constraint (S);
7219
7220    begin
7221       Set_Ekind (Def_Id, E_Enumeration_Subtype);
7222
7223       Set_First_Literal     (Def_Id, First_Literal (Base_Type (T)));
7224
7225       Set_Etype             (Def_Id, Base_Type         (T));
7226       Set_Size_Info         (Def_Id,                   (T));
7227       Set_First_Rep_Item    (Def_Id, First_Rep_Item    (T));
7228       Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
7229
7230       Set_Scalar_Range_For_Subtype
7231         (Def_Id, Range_Expression (C), T, Related_Nod);
7232
7233       Set_Discrete_RM_Size (Def_Id);
7234
7235    end Constrain_Enumeration;
7236
7237    ----------------------
7238    -- Constrain_Float --
7239    ----------------------
7240
7241    procedure Constrain_Float
7242      (Def_Id      : Node_Id;
7243       S           : Node_Id;
7244       Related_Nod : Node_Id)
7245    is
7246       T    : constant Entity_Id := Entity (Subtype_Mark (S));
7247       C    : Node_Id;
7248       D    : Node_Id;
7249       Rais : Node_Id;
7250
7251    begin
7252       Set_Ekind (Def_Id, E_Floating_Point_Subtype);
7253
7254       Set_Etype          (Def_Id, Base_Type      (T));
7255       Set_Size_Info      (Def_Id,                (T));
7256       Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
7257
7258       --  Process the constraint
7259
7260       C := Constraint (S);
7261
7262       --  Digits constraint present
7263
7264       if Nkind (C) = N_Digits_Constraint then
7265          D := Digits_Expression (C);
7266          Analyze_And_Resolve (D, Any_Integer);
7267          Check_Digits_Expression (D);
7268          Set_Digits_Value (Def_Id, Expr_Value (D));
7269
7270          --  Check that digits value is in range. Obviously we can do this
7271          --  at compile time, but it is strictly a runtime check, and of
7272          --  course there is an ACVC test that checks this!
7273
7274          if Digits_Value (Def_Id) > Digits_Value (T) then
7275             Error_Msg_Uint_1 := Digits_Value (T);
7276             Error_Msg_N ("?digits value is too large, maximum is ^", D);
7277             Rais := Make_Raise_Constraint_Error (Sloc (D));
7278             Insert_Action (Declaration_Node (Def_Id), Rais);
7279          end if;
7280
7281          C := Range_Constraint (C);
7282
7283       --  No digits constraint present
7284
7285       else
7286          Set_Digits_Value (Def_Id, Digits_Value (T));
7287       end if;
7288
7289       --  Range constraint present
7290
7291       if Nkind (C) = N_Range_Constraint then
7292          Set_Scalar_Range_For_Subtype
7293            (Def_Id, Range_Expression (C), T, Related_Nod);
7294
7295       --  No range constraint present
7296
7297       else
7298          pragma Assert (No (C));
7299          Set_Scalar_Range (Def_Id, Scalar_Range (T));
7300       end if;
7301
7302       Set_Is_Constrained (Def_Id);
7303    end Constrain_Float;
7304
7305    ---------------------
7306    -- Constrain_Index --
7307    ---------------------
7308
7309    procedure Constrain_Index
7310      (Index        : Node_Id;
7311       S            : Node_Id;
7312       Related_Nod  : Node_Id;
7313       Related_Id   : Entity_Id;
7314       Suffix       : Character;
7315       Suffix_Index : Nat)
7316    is
7317       Def_Id     : Entity_Id;
7318       R          : Node_Id := Empty;
7319       Checks_Off : Boolean := False;
7320       T          : constant Entity_Id := Etype (Index);
7321
7322    begin
7323       if Nkind (S) = N_Range
7324         or else Nkind (S) = N_Attribute_Reference
7325       then
7326          --  A Range attribute will transformed into N_Range by Resolve.
7327
7328          Analyze (S);
7329          Set_Etype (S, T);
7330          R := S;
7331
7332          --  ??? Why on earth do we turn checks of in this very specific case ?
7333
7334          --  From the revision history: (Constrain_Index): Call
7335          --  Process_Range_Expr_In_Decl with range checking off for range
7336          --  bounds that are attributes. This avoids some horrible
7337          --  constraint error checks.
7338
7339          if Nkind (R) = N_Range
7340            and then Nkind (Low_Bound (R)) = N_Attribute_Reference
7341            and then Nkind (High_Bound (R)) = N_Attribute_Reference
7342          then
7343             Checks_Off := True;
7344          end if;
7345
7346          Process_Range_Expr_In_Decl
7347            (R, T, Related_Nod, Empty_List, Checks_Off);
7348
7349          if not Error_Posted (S)
7350            and then
7351              (Nkind (S) /= N_Range
7352                or else Base_Type (T) /= Base_Type (Etype (Low_Bound (S)))
7353                or else Base_Type (T) /= Base_Type (Etype (High_Bound (S))))
7354          then
7355             if Base_Type (T) /= Any_Type
7356               and then Etype (Low_Bound (S)) /= Any_Type
7357               and then Etype (High_Bound (S)) /= Any_Type
7358             then
7359                Error_Msg_N ("range expected", S);
7360             end if;
7361          end if;
7362
7363       elsif Nkind (S) = N_Subtype_Indication then
7364          --  the parser has verified that this is a discrete indication.
7365
7366          Resolve_Discrete_Subtype_Indication (S, T);
7367          R := Range_Expression (Constraint (S));
7368
7369       elsif Nkind (S) = N_Discriminant_Association then
7370
7371          --  syntactically valid in subtype indication.
7372
7373          Error_Msg_N ("invalid index constraint", S);
7374          Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
7375          return;
7376
7377       --  Subtype_Mark case, no anonymous subtypes to construct
7378
7379       else
7380          Analyze (S);
7381
7382          if Is_Entity_Name (S) then
7383
7384             if not Is_Type (Entity (S)) then
7385                Error_Msg_N ("expect subtype mark for index constraint", S);
7386
7387             elsif Base_Type (Entity (S)) /= Base_Type (T) then
7388                Wrong_Type (S, Base_Type (T));
7389             end if;
7390
7391             return;
7392
7393          else
7394             Error_Msg_N ("invalid index constraint", S);
7395             Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
7396             return;
7397          end if;
7398       end if;
7399
7400       Def_Id :=
7401         Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
7402
7403       Set_Etype (Def_Id, Base_Type (T));
7404
7405       if Is_Modular_Integer_Type (T) then
7406          Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
7407
7408       elsif Is_Integer_Type (T) then
7409          Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
7410
7411       else
7412          Set_Ekind (Def_Id, E_Enumeration_Subtype);
7413          Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
7414       end if;
7415
7416       Set_Size_Info      (Def_Id,                (T));
7417       Set_RM_Size        (Def_Id, RM_Size        (T));
7418       Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
7419
7420       Set_Scalar_Range   (Def_Id, R);
7421
7422       Set_Etype (S, Def_Id);
7423       Set_Discrete_RM_Size (Def_Id);
7424    end Constrain_Index;
7425
7426    -----------------------
7427    -- Constrain_Integer --
7428    -----------------------
7429
7430    procedure Constrain_Integer
7431      (Def_Id      : Node_Id;
7432       S           : Node_Id;
7433       Related_Nod : Node_Id)
7434    is
7435       T : constant Entity_Id := Entity (Subtype_Mark (S));
7436       C : constant Node_Id   := Constraint (S);
7437
7438    begin
7439       Set_Scalar_Range_For_Subtype
7440         (Def_Id, Range_Expression (C), T, Related_Nod);
7441
7442       if Is_Modular_Integer_Type (T) then
7443          Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
7444       else
7445          Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
7446       end if;
7447
7448       Set_Etype            (Def_Id, Base_Type        (T));
7449       Set_Size_Info        (Def_Id,                  (T));
7450       Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
7451       Set_Discrete_RM_Size (Def_Id);
7452
7453    end Constrain_Integer;
7454
7455    ------------------------------
7456    -- Constrain_Ordinary_Fixed --
7457    ------------------------------
7458
7459    procedure Constrain_Ordinary_Fixed
7460      (Def_Id      : Node_Id;
7461       S           : Node_Id;
7462       Related_Nod : Node_Id)
7463    is
7464       T    : constant Entity_Id := Entity (Subtype_Mark (S));
7465       C    : Node_Id;
7466       D    : Node_Id;
7467       Rais : Node_Id;
7468
7469    begin
7470       Set_Ekind          (Def_Id, E_Ordinary_Fixed_Point_Subtype);
7471       Set_Etype          (Def_Id, Base_Type        (T));
7472       Set_Size_Info      (Def_Id,                  (T));
7473       Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
7474       Set_Small_Value    (Def_Id, Small_Value      (T));
7475
7476       --  Process the constraint
7477
7478       C := Constraint (S);
7479
7480       --  Delta constraint present
7481
7482       if Nkind (C) = N_Delta_Constraint then
7483          D := Delta_Expression (C);
7484          Analyze_And_Resolve (D, Any_Real);
7485          Check_Delta_Expression (D);
7486          Set_Delta_Value (Def_Id, Expr_Value_R (D));
7487
7488          --  Check that delta value is in range. Obviously we can do this
7489          --  at compile time, but it is strictly a runtime check, and of
7490          --  course there is an ACVC test that checks this!
7491
7492          if Delta_Value (Def_Id) < Delta_Value (T) then
7493             Error_Msg_N ("?delta value is too small", D);
7494             Rais := Make_Raise_Constraint_Error (Sloc (D));
7495             Insert_Action (Declaration_Node (Def_Id), Rais);
7496          end if;
7497
7498          C := Range_Constraint (C);
7499
7500       --  No delta constraint present
7501
7502       else
7503          Set_Delta_Value (Def_Id, Delta_Value (T));
7504       end if;
7505
7506       --  Range constraint present
7507
7508       if Nkind (C) = N_Range_Constraint then
7509          Set_Scalar_Range_For_Subtype
7510            (Def_Id, Range_Expression (C), T, Related_Nod);
7511
7512       --  No range constraint present
7513
7514       else
7515          pragma Assert (No (C));
7516          Set_Scalar_Range (Def_Id, Scalar_Range (T));
7517
7518       end if;
7519
7520       Set_Discrete_RM_Size (Def_Id);
7521
7522       --  Unconditionally delay the freeze, since we cannot set size
7523       --  information in all cases correctly until the freeze point.
7524
7525       Set_Has_Delayed_Freeze (Def_Id);
7526    end Constrain_Ordinary_Fixed;
7527
7528    ---------------------------
7529    -- Convert_Scalar_Bounds --
7530    ---------------------------
7531
7532    procedure Convert_Scalar_Bounds
7533      (N            : Node_Id;
7534       Parent_Type  : Entity_Id;
7535       Derived_Type : Entity_Id;
7536       Loc          : Source_Ptr)
7537    is
7538       Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
7539
7540       Lo  : Node_Id;
7541       Hi  : Node_Id;
7542       Rng : Node_Id;
7543
7544    begin
7545       Lo := Build_Scalar_Bound
7546               (Type_Low_Bound (Derived_Type),
7547                Parent_Type, Implicit_Base, Loc);
7548
7549       Hi := Build_Scalar_Bound
7550               (Type_High_Bound (Derived_Type),
7551                Parent_Type, Implicit_Base, Loc);
7552
7553       Rng :=
7554         Make_Range (Loc,
7555           Low_Bound  => Lo,
7556           High_Bound => Hi);
7557
7558       Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
7559
7560       Set_Parent (Rng, N);
7561       Set_Scalar_Range (Derived_Type, Rng);
7562
7563       --  Analyze the bounds
7564
7565       Analyze_And_Resolve (Lo, Implicit_Base);
7566       Analyze_And_Resolve (Hi, Implicit_Base);
7567
7568       --  Analyze the range itself, except that we do not analyze it if
7569       --  the bounds are real literals, and we have a fixed-point type.
7570       --  The reason for this is that we delay setting the bounds in this
7571       --  case till we know the final Small and Size values (see circuit
7572       --  in Freeze.Freeze_Fixed_Point_Type for further details).
7573
7574       if Is_Fixed_Point_Type (Parent_Type)
7575         and then Nkind (Lo) = N_Real_Literal
7576         and then Nkind (Hi) = N_Real_Literal
7577       then
7578          return;
7579
7580       --  Here we do the analysis of the range.
7581
7582       --  Note: we do this manually, since if we do a normal Analyze and
7583       --  Resolve call, there are problems with the conversions used for
7584       --  the derived type range.
7585
7586       else
7587          Set_Etype    (Rng, Implicit_Base);
7588          Set_Analyzed (Rng, True);
7589       end if;
7590    end Convert_Scalar_Bounds;
7591
7592    -------------------
7593    -- Copy_And_Swap --
7594    -------------------
7595
7596    procedure Copy_And_Swap (Privat, Full : Entity_Id) is
7597    begin
7598       --  Initialize new full declaration entity by copying the pertinent
7599       --  fields of the corresponding private declaration entity.
7600
7601       Copy_Private_To_Full (Privat, Full);
7602
7603       --  Swap the two entities. Now Privat is the full type entity and
7604       --  Full is the private one. They will be swapped back at the end
7605       --  of the private part. This swapping ensures that the entity that
7606       --  is visible in the private part is the full declaration.
7607
7608       Exchange_Entities (Privat, Full);
7609       Append_Entity (Full, Scope (Full));
7610    end Copy_And_Swap;
7611
7612    -------------------------------------
7613    -- Copy_Array_Base_Type_Attributes --
7614    -------------------------------------
7615
7616    procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
7617    begin
7618       Set_Component_Alignment      (T1, Component_Alignment      (T2));
7619       Set_Component_Type           (T1, Component_Type           (T2));
7620       Set_Component_Size           (T1, Component_Size           (T2));
7621       Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
7622       Set_Finalize_Storage_Only    (T1, Finalize_Storage_Only    (T2));
7623       Set_Has_Non_Standard_Rep     (T1, Has_Non_Standard_Rep     (T2));
7624       Set_Has_Task                 (T1, Has_Task                 (T2));
7625       Set_Is_Packed                (T1, Is_Packed                (T2));
7626       Set_Has_Aliased_Components   (T1, Has_Aliased_Components   (T2));
7627       Set_Has_Atomic_Components    (T1, Has_Atomic_Components    (T2));
7628       Set_Has_Volatile_Components  (T1, Has_Volatile_Components  (T2));
7629    end Copy_Array_Base_Type_Attributes;
7630
7631    -----------------------------------
7632    -- Copy_Array_Subtype_Attributes --
7633    -----------------------------------
7634
7635    procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
7636    begin
7637       Set_Size_Info (T1, T2);
7638
7639       Set_First_Index          (T1, First_Index           (T2));
7640       Set_Is_Aliased           (T1, Is_Aliased            (T2));
7641       Set_Is_Atomic            (T1, Is_Atomic             (T2));
7642       Set_Is_Volatile          (T1, Is_Volatile           (T2));
7643       Set_Is_Constrained       (T1, Is_Constrained        (T2));
7644       Set_Depends_On_Private   (T1, Has_Private_Component (T2));
7645       Set_First_Rep_Item       (T1, First_Rep_Item        (T2));
7646       Set_Convention           (T1, Convention            (T2));
7647       Set_Is_Limited_Composite (T1, Is_Limited_Composite  (T2));
7648       Set_Is_Private_Composite (T1, Is_Private_Composite  (T2));
7649    end Copy_Array_Subtype_Attributes;
7650
7651    --------------------------
7652    -- Copy_Private_To_Full --
7653    --------------------------
7654
7655    procedure Copy_Private_To_Full (Priv, Full : Entity_Id) is
7656    begin
7657       --  We temporarily set Ekind to a value appropriate for a type to
7658       --  avoid assert failures in Einfo from checking for setting type
7659       --  attributes on something that is not a type. Ekind (Priv) is an
7660       --  appropriate choice, since it allowed the attributes to be set
7661       --  in the first place. This Ekind value will be modified later.
7662
7663       Set_Ekind (Full, Ekind (Priv));
7664
7665       --  Also set Etype temporarily to Any_Type, again, in the absence
7666       --  of errors, it will be properly reset, and if there are errors,
7667       --  then we want a value of Any_Type to remain.
7668
7669       Set_Etype (Full, Any_Type);
7670
7671       --  Now start copying attributes
7672
7673       Set_Has_Discriminants          (Full, Has_Discriminants       (Priv));
7674
7675       if Has_Discriminants (Full) then
7676          Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
7677          Set_Girder_Constraint       (Full, Girder_Constraint       (Priv));
7678       end if;
7679
7680       Set_Homonym                    (Full, Homonym                 (Priv));
7681       Set_Is_Immediately_Visible     (Full, Is_Immediately_Visible  (Priv));
7682       Set_Is_Public                  (Full, Is_Public               (Priv));
7683       Set_Is_Pure                    (Full, Is_Pure                 (Priv));
7684       Set_Is_Tagged_Type             (Full, Is_Tagged_Type          (Priv));
7685
7686       Conditional_Delay              (Full,                          Priv);
7687
7688       if Is_Tagged_Type (Full) then
7689          Set_Primitive_Operations    (Full, Primitive_Operations    (Priv));
7690
7691          if Priv = Base_Type (Priv) then
7692             Set_Class_Wide_Type      (Full, Class_Wide_Type         (Priv));
7693          end if;
7694       end if;
7695
7696       Set_Is_Volatile                (Full, Is_Volatile             (Priv));
7697       Set_Scope                      (Full, Scope                   (Priv));
7698       Set_Next_Entity                (Full, Next_Entity             (Priv));
7699       Set_First_Entity               (Full, First_Entity            (Priv));
7700       Set_Last_Entity                (Full, Last_Entity             (Priv));
7701
7702       --  If access types have been recorded for later handling, keep them
7703       --  in the full view so that they get handled when the full view freeze
7704       --  node is expanded.
7705
7706       if Present (Freeze_Node (Priv))
7707         and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
7708       then
7709          Ensure_Freeze_Node (Full);
7710          Set_Access_Types_To_Process (Freeze_Node (Full),
7711            Access_Types_To_Process (Freeze_Node (Priv)));
7712       end if;
7713    end Copy_Private_To_Full;
7714
7715    -----------------------------------
7716    -- Create_Constrained_Components --
7717    -----------------------------------
7718
7719    procedure Create_Constrained_Components
7720      (Subt        : Entity_Id;
7721       Decl_Node   : Node_Id;
7722       Typ         : Entity_Id;
7723       Constraints : Elist_Id)
7724    is
7725       Loc         : constant Source_Ptr := Sloc (Subt);
7726       Assoc_List  : List_Id  := New_List;
7727       Comp_List   : Elist_Id := New_Elmt_List;
7728       Discr_Val   : Elmt_Id;
7729       Errors      : Boolean;
7730       New_C       : Entity_Id;
7731       Old_C       : Entity_Id;
7732       Is_Static   : Boolean := True;
7733       Parent_Type : constant Entity_Id := Etype (Typ);
7734
7735       procedure Collect_Fixed_Components (Typ : Entity_Id);
7736       --  Collect components of parent type that do not appear in a variant
7737       --  part.
7738
7739       procedure Create_All_Components;
7740       --  Iterate over Comp_List to create the components of the subtype.
7741
7742       function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
7743       --  Creates a new component from Old_Compon, coppying all the fields from
7744       --  it, including its Etype, inserts the new component in the Subt entity
7745       --  chain and returns the new component.
7746
7747       function Is_Variant_Record (T : Entity_Id) return Boolean;
7748       --  If true, and discriminants are static, collect only components from
7749       --  variants selected by discriminant values.
7750
7751       ------------------------------
7752       -- Collect_Fixed_Components --
7753       ------------------------------
7754
7755       procedure Collect_Fixed_Components (Typ : Entity_Id) is
7756       begin
7757       --   Build association list for discriminants, and find components of
7758       --  the variant part selected by the values of the discriminants.
7759
7760          Old_C := First_Discriminant (Typ);
7761          Discr_Val := First_Elmt (Constraints);
7762
7763          while Present (Old_C) loop
7764             Append_To (Assoc_List,
7765               Make_Component_Association (Loc,
7766                  Choices    => New_List (New_Occurrence_Of (Old_C, Loc)),
7767                  Expression => New_Copy (Node (Discr_Val))));
7768
7769             Next_Elmt (Discr_Val);
7770             Next_Discriminant (Old_C);
7771          end loop;
7772
7773          --  The tag, and the possible parent and controller components
7774          --  are unconditionally in the subtype.
7775
7776          if Is_Tagged_Type (Typ)
7777            or else Has_Controlled_Component (Typ)
7778          then
7779             Old_C := First_Component (Typ);
7780
7781             while Present (Old_C) loop
7782                if Chars ((Old_C)) = Name_uTag
7783                  or else Chars ((Old_C)) = Name_uParent
7784                  or else Chars ((Old_C)) = Name_uController
7785                then
7786                   Append_Elmt (Old_C, Comp_List);
7787                end if;
7788
7789                Next_Component (Old_C);
7790             end loop;
7791          end if;
7792       end Collect_Fixed_Components;
7793
7794       ---------------------------
7795       -- Create_All_Components --
7796       ---------------------------
7797
7798       procedure Create_All_Components is
7799          Comp : Elmt_Id;
7800
7801       begin
7802          Comp := First_Elmt (Comp_List);
7803
7804          while Present (Comp) loop
7805             Old_C := Node (Comp);
7806             New_C := Create_Component (Old_C);
7807
7808             Set_Etype
7809               (New_C,
7810                Constrain_Component_Type
7811                  (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
7812             Set_Is_Public (New_C, Is_Public (Subt));
7813
7814             Next_Elmt (Comp);
7815          end loop;
7816       end Create_All_Components;
7817
7818       ----------------------
7819       -- Create_Component --
7820       ----------------------
7821
7822       function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
7823          New_Compon : Entity_Id := New_Copy (Old_Compon);
7824
7825       begin
7826          --  Set the parent so we have a proper link for freezing etc. This
7827          --  is not a real parent pointer, since of course our parent does
7828          --  not own up to us and reference us, we are an illegitimate
7829          --  child of the original parent!
7830
7831          Set_Parent (New_Compon, Parent (Old_Compon));
7832
7833          --  We do not want this node marked as Comes_From_Source, since
7834          --  otherwise it would get first class status and a separate
7835          --  cross-reference line would be generated. Illegitimate
7836          --  children do not rate such recognition.
7837
7838          Set_Comes_From_Source (New_Compon, False);
7839
7840          --  But it is a real entity, and a birth certificate must be
7841          --  properly registered by entering it into the entity list.
7842
7843          Enter_Name (New_Compon);
7844          return New_Compon;
7845       end Create_Component;
7846
7847       -----------------------
7848       -- Is_Variant_Record --
7849       -----------------------
7850
7851       function Is_Variant_Record (T : Entity_Id) return Boolean is
7852       begin
7853          return Nkind (Parent (T)) = N_Full_Type_Declaration
7854            and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
7855            and then Present (Component_List (Type_Definition (Parent (T))))
7856            and then Present (
7857              Variant_Part (Component_List (Type_Definition (Parent (T)))));
7858       end Is_Variant_Record;
7859
7860    --  Start of processing for Create_Constrained_Components
7861
7862    begin
7863       pragma Assert (Subt /= Base_Type (Subt));
7864       pragma Assert (Typ = Base_Type (Typ));
7865
7866       Set_First_Entity (Subt, Empty);
7867       Set_Last_Entity  (Subt, Empty);
7868
7869       --  Check whether constraint is fully static, in which case we can
7870       --  optimize the list of components.
7871
7872       Discr_Val := First_Elmt (Constraints);
7873
7874       while Present (Discr_Val) loop
7875
7876          if not Is_OK_Static_Expression (Node (Discr_Val)) then
7877             Is_Static := False;
7878             exit;
7879          end if;
7880
7881          Next_Elmt (Discr_Val);
7882       end loop;
7883
7884       New_Scope (Subt);
7885
7886       --  Inherit the discriminants of the parent type.
7887
7888       Old_C := First_Discriminant (Typ);
7889
7890       while Present (Old_C) loop
7891          New_C := Create_Component (Old_C);
7892          Set_Is_Public (New_C, Is_Public (Subt));
7893          Next_Discriminant (Old_C);
7894       end loop;
7895
7896       if Is_Static
7897         and then Is_Variant_Record (Typ)
7898       then
7899          Collect_Fixed_Components (Typ);
7900
7901          Gather_Components (
7902            Typ,
7903            Component_List (Type_Definition (Parent (Typ))),
7904            Governed_By   => Assoc_List,
7905            Into          => Comp_List,
7906            Report_Errors => Errors);
7907          pragma Assert (not Errors);
7908
7909          Create_All_Components;
7910
7911       --  If the subtype declaration is created for a tagged type derivation
7912       --  with constraints, we retrieve the record definition of the parent
7913       --  type to select the components of the proper variant.
7914
7915       elsif Is_Static
7916         and then Is_Tagged_Type (Typ)
7917         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
7918         and then
7919           Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
7920         and then Is_Variant_Record (Parent_Type)
7921       then
7922          Collect_Fixed_Components (Typ);
7923
7924          Gather_Components (
7925            Typ,
7926            Component_List (Type_Definition (Parent (Parent_Type))),
7927            Governed_By   => Assoc_List,
7928            Into          => Comp_List,
7929            Report_Errors => Errors);
7930          pragma Assert (not Errors);
7931
7932          --  If the tagged derivation has a type extension, collect all the
7933          --  new components therein.
7934
7935          if Present (
7936            Record_Extension_Part (Type_Definition (Parent (Typ))))
7937          then
7938             Old_C := First_Component (Typ);
7939
7940             while Present (Old_C) loop
7941                if Original_Record_Component (Old_C) = Old_C
7942                 and then Chars (Old_C) /= Name_uTag
7943                 and then Chars (Old_C) /= Name_uParent
7944                 and then Chars (Old_C) /= Name_uController
7945                then
7946                   Append_Elmt (Old_C, Comp_List);
7947                end if;
7948
7949                Next_Component (Old_C);
7950             end loop;
7951          end if;
7952
7953          Create_All_Components;
7954
7955       else
7956          --  If the discriminants are not static, or if this is a multi-level
7957          --  type extension, we have to include all the components of the
7958          --  parent type.
7959
7960          Old_C := First_Component (Typ);
7961
7962          while Present (Old_C) loop
7963             New_C := Create_Component (Old_C);
7964
7965             Set_Etype
7966               (New_C,
7967                Constrain_Component_Type
7968                  (Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
7969             Set_Is_Public (New_C, Is_Public (Subt));
7970
7971             Next_Component (Old_C);
7972          end loop;
7973       end if;
7974
7975       End_Scope;
7976    end Create_Constrained_Components;
7977
7978    ------------------------------------------
7979    -- Decimal_Fixed_Point_Type_Declaration --
7980    ------------------------------------------
7981
7982    procedure Decimal_Fixed_Point_Type_Declaration
7983      (T   : Entity_Id;
7984       Def : Node_Id)
7985    is
7986       Loc           : constant Source_Ptr := Sloc (Def);
7987       Digs_Expr     : constant Node_Id    := Digits_Expression (Def);
7988       Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
7989       Implicit_Base : Entity_Id;
7990       Digs_Val      : Uint;
7991       Delta_Val     : Ureal;
7992       Scale_Val     : Uint;
7993       Bound_Val     : Ureal;
7994
7995    --  Start of processing for Decimal_Fixed_Point_Type_Declaration
7996
7997    begin
7998       Check_Restriction (No_Fixed_Point, Def);
7999
8000       --  Create implicit base type
8001
8002       Implicit_Base :=
8003         Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
8004       Set_Etype (Implicit_Base, Implicit_Base);
8005
8006       --  Analyze and process delta expression
8007
8008       Analyze_And_Resolve (Delta_Expr, Universal_Real);
8009
8010       Check_Delta_Expression (Delta_Expr);
8011       Delta_Val := Expr_Value_R (Delta_Expr);
8012
8013       --  Check delta is power of 10, and determine scale value from it
8014
8015       declare
8016          Val : Ureal := Delta_Val;
8017
8018       begin
8019          Scale_Val := Uint_0;
8020
8021          if Val < Ureal_1 then
8022             while Val < Ureal_1 loop
8023                Val := Val * Ureal_10;
8024                Scale_Val := Scale_Val + 1;
8025             end loop;
8026
8027             if Scale_Val > 18 then
8028                Error_Msg_N ("scale exceeds maximum value of 18", Def);
8029                Scale_Val := UI_From_Int (+18);
8030             end if;
8031
8032          else
8033             while Val > Ureal_1 loop
8034                Val := Val / Ureal_10;
8035                Scale_Val := Scale_Val - 1;
8036             end loop;
8037
8038             if Scale_Val < -18 then
8039                Error_Msg_N ("scale is less than minimum value of -18", Def);
8040                Scale_Val := UI_From_Int (-18);
8041             end if;
8042          end if;
8043
8044          if Val /= Ureal_1 then
8045             Error_Msg_N ("delta expression must be a power of 10", Def);
8046             Delta_Val := Ureal_10 ** (-Scale_Val);
8047          end if;
8048       end;
8049
8050       --  Set delta, scale and small (small = delta for decimal type)
8051
8052       Set_Delta_Value (Implicit_Base, Delta_Val);
8053       Set_Scale_Value (Implicit_Base, Scale_Val);
8054       Set_Small_Value (Implicit_Base, Delta_Val);
8055
8056       --  Analyze and process digits expression
8057
8058       Analyze_And_Resolve (Digs_Expr, Any_Integer);
8059       Check_Digits_Expression (Digs_Expr);
8060       Digs_Val := Expr_Value (Digs_Expr);
8061
8062       if Digs_Val > 18 then
8063          Digs_Val := UI_From_Int (+18);
8064          Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
8065       end if;
8066
8067       Set_Digits_Value (Implicit_Base, Digs_Val);
8068       Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
8069
8070       --  Set range of base type from digits value for now. This will be
8071       --  expanded to represent the true underlying base range by Freeze.
8072
8073       Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
8074
8075       --  Set size to zero for now, size will be set at freeze time. We have
8076       --  to do this for ordinary fixed-point, because the size depends on
8077       --  the specified small, and we might as well do the same for decimal
8078       --  fixed-point.
8079
8080       Init_Size_Align (Implicit_Base);
8081
8082       --  Complete entity for first subtype
8083
8084       Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
8085       Set_Etype          (T, Implicit_Base);
8086       Set_Size_Info      (T, Implicit_Base);
8087       Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
8088       Set_Digits_Value   (T, Digs_Val);
8089       Set_Delta_Value    (T, Delta_Val);
8090       Set_Small_Value    (T, Delta_Val);
8091       Set_Scale_Value    (T, Scale_Val);
8092       Set_Is_Constrained (T);
8093
8094       --  If there are bounds given in the declaration use them as the
8095       --  bounds of the first named subtype.
8096
8097       if Present (Real_Range_Specification (Def)) then
8098          declare
8099             RRS      : constant Node_Id := Real_Range_Specification (Def);
8100             Low      : constant Node_Id := Low_Bound (RRS);
8101             High     : constant Node_Id := High_Bound (RRS);
8102             Low_Val  : Ureal;
8103             High_Val : Ureal;
8104
8105          begin
8106             Analyze_And_Resolve (Low, Any_Real);
8107             Analyze_And_Resolve (High, Any_Real);
8108             Check_Real_Bound (Low);
8109             Check_Real_Bound (High);
8110             Low_Val := Expr_Value_R (Low);
8111             High_Val := Expr_Value_R (High);
8112
8113             if Low_Val < (-Bound_Val) then
8114                Error_Msg_N
8115                  ("range low bound too small for digits value", Low);
8116                Low_Val := -Bound_Val;
8117             end if;
8118
8119             if High_Val > Bound_Val then
8120                Error_Msg_N
8121                  ("range high bound too large for digits value", High);
8122                High_Val := Bound_Val;
8123             end if;
8124
8125             Set_Fixed_Range (T, Loc, Low_Val, High_Val);
8126          end;
8127
8128       --  If no explicit range, use range that corresponds to given
8129       --  digits value. This will end up as the final range for the
8130       --  first subtype.
8131
8132       else
8133          Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
8134       end if;
8135
8136    end Decimal_Fixed_Point_Type_Declaration;
8137
8138    -----------------------
8139    -- Derive_Subprogram --
8140    -----------------------
8141
8142    procedure Derive_Subprogram
8143      (New_Subp     : in out Entity_Id;
8144       Parent_Subp  : Entity_Id;
8145       Derived_Type : Entity_Id;
8146       Parent_Type  : Entity_Id;
8147       Actual_Subp  : Entity_Id := Empty)
8148    is
8149       Formal     : Entity_Id;
8150       New_Formal : Entity_Id;
8151       Same_Subt  : constant Boolean :=
8152         Is_Scalar_Type (Parent_Type)
8153           and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
8154
8155       function Is_Private_Overriding return Boolean;
8156       --  If Subp is a private overriding of a visible operation, the in-
8157       --  herited operation derives from the overridden op (even though
8158       --  its body is the overriding one) and the inherited operation is
8159       --  visible now. See sem_disp to see the details of the handling of
8160       --  the overridden subprogram, which is removed from the list of
8161       --  primitive operations of the type.
8162
8163       procedure Replace_Type (Id, New_Id : Entity_Id);
8164       --  When the type is an anonymous access type, create a new access type
8165       --  designating the derived type.
8166
8167       ---------------------------
8168       -- Is_Private_Overriding --
8169       ---------------------------
8170
8171       function Is_Private_Overriding return Boolean is
8172          Prev : Entity_Id;
8173
8174       begin
8175          Prev := Homonym (Parent_Subp);
8176
8177          --  The visible operation that is overriden is a homonym of
8178          --  the parent subprogram. We scan the homonym chain to find
8179          --  the one whose alias is the subprogram we are deriving.
8180
8181          while Present (Prev) loop
8182             if Is_Dispatching_Operation (Parent_Subp)
8183               and then Present (Prev)
8184               and then Ekind (Prev) = Ekind (Parent_Subp)
8185               and then Alias (Prev) = Parent_Subp
8186               and then Scope (Parent_Subp) = Scope (Prev)
8187               and then not Is_Hidden (Prev)
8188             then
8189                return True;
8190             end if;
8191
8192             Prev := Homonym (Prev);
8193          end loop;
8194
8195          return False;
8196       end Is_Private_Overriding;
8197
8198       ------------------
8199       -- Replace_Type --
8200       ------------------
8201
8202       procedure Replace_Type (Id, New_Id : Entity_Id) is
8203          Acc_Type : Entity_Id;
8204          IR       : Node_Id;
8205
8206       begin
8207          --  When the type is an anonymous access type, create a new access
8208          --  type designating the derived type. This itype must be elaborated
8209          --  at the point of the derivation, not on subsequent calls that may
8210          --  be out of the proper scope for Gigi, so we insert a reference to
8211          --  it after the derivation.
8212
8213          if Ekind (Etype (Id)) = E_Anonymous_Access_Type then
8214             declare
8215                Desig_Typ : Entity_Id := Designated_Type (Etype (Id));
8216
8217             begin
8218                if Ekind (Desig_Typ) = E_Record_Type_With_Private
8219                  and then Present (Full_View (Desig_Typ))
8220                  and then not Is_Private_Type (Parent_Type)
8221                then
8222                   Desig_Typ := Full_View (Desig_Typ);
8223                end if;
8224
8225                if Base_Type (Desig_Typ) = Base_Type (Parent_Type) then
8226                   Acc_Type := New_Copy (Etype (Id));
8227                   Set_Etype (Acc_Type, Acc_Type);
8228                   Set_Scope (Acc_Type, New_Subp);
8229
8230                   --  Compute size of anonymous access type.
8231
8232                   if Is_Array_Type (Desig_Typ)
8233                     and then not Is_Constrained (Desig_Typ)
8234                   then
8235                      Init_Size (Acc_Type, 2 * System_Address_Size);
8236                   else
8237                      Init_Size (Acc_Type, System_Address_Size);
8238                   end if;
8239
8240                   Init_Alignment (Acc_Type);
8241
8242                   Set_Directly_Designated_Type (Acc_Type, Derived_Type);
8243
8244                   Set_Etype (New_Id, Acc_Type);
8245                   Set_Scope (New_Id, New_Subp);
8246
8247                   --  Create a reference to it.
8248
8249                   IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
8250                   Set_Itype (IR, Acc_Type);
8251                   Insert_After (Parent (Derived_Type), IR);
8252
8253                else
8254                   Set_Etype (New_Id, Etype (Id));
8255                end if;
8256             end;
8257          elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
8258            or else
8259              (Ekind (Etype (Id)) = E_Record_Type_With_Private
8260                and then Present (Full_View (Etype (Id)))
8261                and then Base_Type (Full_View (Etype (Id))) =
8262                  Base_Type (Parent_Type))
8263          then
8264
8265             --  Constraint checks on formals are generated during expansion,
8266             --  based on the signature of the original subprogram. The bounds
8267             --  of the derived type are not relevant, and thus we can use
8268             --  the base type for the formals. However, the return type may be
8269             --  used in a context that requires that the proper static bounds
8270             --  be used (a case statement, for example)  and for those cases
8271             --  we must use the derived type (first subtype), not its base.
8272
8273             if Etype (Id) = Parent_Type
8274               and then Same_Subt
8275             then
8276                Set_Etype (New_Id, Derived_Type);
8277             else
8278                Set_Etype (New_Id, Base_Type (Derived_Type));
8279             end if;
8280
8281          else
8282             Set_Etype (New_Id, Etype (Id));
8283          end if;
8284       end Replace_Type;
8285
8286    --  Start of processing for Derive_Subprogram
8287
8288    begin
8289       New_Subp :=
8290          New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
8291       Set_Ekind (New_Subp, Ekind (Parent_Subp));
8292
8293       --  Check whether the inherited subprogram is a private operation that
8294       --  should be inherited but not yet made visible. Such subprograms can
8295       --  become visible at a later point (e.g., the private part of a public
8296       --  child unit) via Declare_Inherited_Private_Subprograms. If the
8297       --  following predicate is true, then this is not such a private
8298       --  operation and the subprogram simply inherits the name of the parent
8299       --  subprogram. Note the special check for the names of controlled
8300       --  operations, which are currently exempted from being inherited with
8301       --  a hidden name because they must be findable for generation of
8302       --  implicit run-time calls.
8303
8304       if not Is_Hidden (Parent_Subp)
8305         or else Is_Internal (Parent_Subp)
8306         or else Is_Private_Overriding
8307         or else Is_Internal_Name (Chars (Parent_Subp))
8308         or else Chars (Parent_Subp) = Name_Initialize
8309         or else Chars (Parent_Subp) = Name_Adjust
8310         or else Chars (Parent_Subp) = Name_Finalize
8311       then
8312          Set_Chars (New_Subp, Chars (Parent_Subp));
8313
8314       --  If parent is hidden, this can be a regular derivation if the
8315       --  parent is immediately visible in a non-instantiating context,
8316       --  or if we are in the private part of an instance. This test
8317       --  should still be refined ???
8318
8319       --  The test for In_Instance_Not_Visible avoids inheriting the
8320       --  derived operation as a non-visible operation in cases where
8321       --  the parent subprogram might not be visible now, but was
8322       --  visible within the original generic, so it would be wrong
8323       --  to make the inherited subprogram non-visible now. (Not
8324       --  clear if this test is fully correct; are there any cases
8325       --  where we should declare the inherited operation as not
8326       --  visible to avoid it being overridden, e.g., when the
8327       --  parent type is a generic actual with private primitives ???)
8328
8329       --  (they should be treated the same as other private inherited
8330       --  subprograms, but it's not clear how to do this cleanly). ???
8331
8332       elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
8333               and then Is_Immediately_Visible (Parent_Subp)
8334               and then not In_Instance)
8335         or else In_Instance_Not_Visible
8336       then
8337          Set_Chars (New_Subp, Chars (Parent_Subp));
8338
8339       --  The type is inheriting a private operation, so enter
8340       --  it with a special name so it can't be overridden.
8341
8342       else
8343          Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
8344       end if;
8345
8346       Set_Parent (New_Subp, Parent (Derived_Type));
8347       Replace_Type (Parent_Subp, New_Subp);
8348       Conditional_Delay (New_Subp, Parent_Subp);
8349
8350       Formal := First_Formal (Parent_Subp);
8351       while Present (Formal) loop
8352          New_Formal := New_Copy (Formal);
8353
8354          --  Normally we do not go copying parents, but in the case of
8355          --  formals, we need to link up to the declaration (which is
8356          --  the parameter specification), and it is fine to link up to
8357          --  the original formal's parameter specification in this case.
8358
8359          Set_Parent (New_Formal, Parent (Formal));
8360
8361          Append_Entity (New_Formal, New_Subp);
8362
8363          Replace_Type (Formal, New_Formal);
8364          Next_Formal (Formal);
8365       end loop;
8366
8367       --  If this derivation corresponds to a tagged generic actual, then
8368       --  primitive operations rename those of the actual. Otherwise the
8369       --  primitive operations rename those of the parent type.
8370
8371       if No (Actual_Subp) then
8372          Set_Alias (New_Subp, Parent_Subp);
8373          Set_Is_Intrinsic_Subprogram (New_Subp,
8374            Is_Intrinsic_Subprogram (Parent_Subp));
8375
8376       else
8377          Set_Alias (New_Subp, Actual_Subp);
8378       end if;
8379
8380       --  Derived subprograms of a tagged type must inherit the convention
8381       --  of the parent subprogram (a requirement of AI-117). Derived
8382       --  subprograms of untagged types simply get convention Ada by default.
8383
8384       if Is_Tagged_Type (Derived_Type) then
8385          Set_Convention  (New_Subp, Convention  (Parent_Subp));
8386       end if;
8387
8388       Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
8389       Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
8390
8391       if Ekind (Parent_Subp) = E_Procedure then
8392          Set_Is_Valued_Procedure
8393            (New_Subp, Is_Valued_Procedure (Parent_Subp));
8394       end if;
8395
8396       New_Overloaded_Entity (New_Subp, Derived_Type);
8397
8398       --  Check for case of a derived subprogram for the instantiation
8399       --  of a formal derived tagged type, so mark the subprogram as
8400       --  dispatching and inherit the dispatching attributes of the
8401       --  parent subprogram. The derived subprogram is effectively a
8402       --  renaming of the actual subprogram, so it needs to have the
8403       --  same attributes as the actual.
8404
8405       if Present (Actual_Subp)
8406         and then Is_Dispatching_Operation (Parent_Subp)
8407       then
8408          Set_Is_Dispatching_Operation (New_Subp);
8409          if Present (DTC_Entity (Parent_Subp)) then
8410             Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
8411             Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
8412          end if;
8413       end if;
8414
8415       --  Indicate that a derived subprogram does not require a body
8416       --  and that it does not require processing of default expressions.
8417
8418       Set_Has_Completion (New_Subp);
8419       Set_Default_Expressions_Processed (New_Subp);
8420
8421       --  A derived function with a controlling result is abstract.
8422       --  If the Derived_Type is a nonabstract formal generic derived
8423       --  type, then inherited operations are not abstract: check is
8424       --  done at instantiation time. If the derivation is for a generic
8425       --  actual, the function is not abstract unless the actual is.
8426
8427       if Is_Generic_Type (Derived_Type)
8428         and then not Is_Abstract (Derived_Type)
8429       then
8430          null;
8431
8432       elsif Is_Abstract (Alias (New_Subp))
8433         or else (Is_Tagged_Type (Derived_Type)
8434                    and then Etype (New_Subp) = Derived_Type
8435                    and then No (Actual_Subp))
8436       then
8437          Set_Is_Abstract (New_Subp);
8438       end if;
8439
8440       if Ekind (New_Subp) = E_Function then
8441          Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
8442       end if;
8443    end Derive_Subprogram;
8444
8445    ------------------------
8446    -- Derive_Subprograms --
8447    ------------------------
8448
8449    procedure Derive_Subprograms
8450      (Parent_Type    : Entity_Id;
8451       Derived_Type   : Entity_Id;
8452       Generic_Actual : Entity_Id := Empty)
8453    is
8454       Op_List     : Elist_Id := Collect_Primitive_Operations (Parent_Type);
8455       Act_List    : Elist_Id;
8456       Act_Elmt    : Elmt_Id;
8457       Elmt        : Elmt_Id;
8458       Subp        : Entity_Id;
8459       New_Subp    : Entity_Id := Empty;
8460       Parent_Base : Entity_Id;
8461
8462    begin
8463       if Ekind (Parent_Type) = E_Record_Type_With_Private
8464         and then Has_Discriminants (Parent_Type)
8465         and then Present (Full_View (Parent_Type))
8466       then
8467          Parent_Base := Full_View (Parent_Type);
8468       else
8469          Parent_Base := Parent_Type;
8470       end if;
8471
8472       Elmt := First_Elmt (Op_List);
8473
8474       if Present (Generic_Actual) then
8475          Act_List := Collect_Primitive_Operations (Generic_Actual);
8476          Act_Elmt := First_Elmt (Act_List);
8477       else
8478          Act_Elmt := No_Elmt;
8479       end if;
8480
8481       --  Literals are derived earlier in the process of building the
8482       --  derived type, and are skipped here.
8483
8484       while Present (Elmt) loop
8485          Subp := Node (Elmt);
8486
8487          if Ekind (Subp) /= E_Enumeration_Literal then
8488             if No (Generic_Actual) then
8489                Derive_Subprogram
8490                  (New_Subp, Subp, Derived_Type, Parent_Base);
8491
8492             else
8493                Derive_Subprogram (New_Subp, Subp,
8494                  Derived_Type, Parent_Base, Node (Act_Elmt));
8495                Next_Elmt (Act_Elmt);
8496             end if;
8497          end if;
8498
8499          Next_Elmt (Elmt);
8500       end loop;
8501    end Derive_Subprograms;
8502
8503    --------------------------------
8504    -- Derived_Standard_Character --
8505    --------------------------------
8506
8507    procedure Derived_Standard_Character
8508      (N             : Node_Id;
8509       Parent_Type   : Entity_Id;
8510       Derived_Type  : Entity_Id)
8511    is
8512       Loc           : constant Source_Ptr := Sloc (N);
8513       Def           : constant Node_Id    := Type_Definition (N);
8514       Indic         : constant Node_Id    := Subtype_Indication (Def);
8515       Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
8516       Implicit_Base : constant Entity_Id  :=
8517                         Create_Itype
8518                           (E_Enumeration_Type, N, Derived_Type, 'B');
8519
8520       Lo : Node_Id;
8521       Hi : Node_Id;
8522       T  : Entity_Id;
8523
8524    begin
8525       T := Process_Subtype (Indic, N);
8526
8527       Set_Etype     (Implicit_Base, Parent_Base);
8528       Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
8529       Set_RM_Size   (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
8530
8531       Set_Is_Character_Type  (Implicit_Base, True);
8532       Set_Has_Delayed_Freeze (Implicit_Base);
8533
8534       Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Type));
8535       Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
8536
8537       Set_Scalar_Range (Implicit_Base,
8538         Make_Range (Loc,
8539           Low_Bound  => Lo,
8540           High_Bound => Hi));
8541
8542       Conditional_Delay (Derived_Type, Parent_Type);
8543
8544       Set_Ekind (Derived_Type, E_Enumeration_Subtype);
8545       Set_Etype (Derived_Type, Implicit_Base);
8546       Set_Size_Info         (Derived_Type, Parent_Type);
8547
8548       if Unknown_RM_Size (Derived_Type) then
8549          Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
8550       end if;
8551
8552       Set_Is_Character_Type (Derived_Type, True);
8553
8554       if Nkind (Indic) /= N_Subtype_Indication then
8555          Set_Scalar_Range (Derived_Type, Scalar_Range (Implicit_Base));
8556       end if;
8557
8558       Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
8559
8560       --  Because the implicit base is used in the conversion of the bounds,
8561       --  we have to freeze it now. This is similar to what is done for
8562       --  numeric types, and it equally suspicious, but otherwise a non-
8563       --  static bound will have a reference to an unfrozen type, which is
8564       --  rejected by Gigi (???).
8565
8566       Freeze_Before (N, Implicit_Base);
8567
8568    end Derived_Standard_Character;
8569
8570    ------------------------------
8571    -- Derived_Type_Declaration --
8572    ------------------------------
8573
8574    procedure Derived_Type_Declaration
8575      (T             : Entity_Id;
8576       N             : Node_Id;
8577       Is_Completion : Boolean)
8578    is
8579       Def          : constant Node_Id := Type_Definition (N);
8580       Indic        : constant Node_Id := Subtype_Indication (Def);
8581       Extension    : constant Node_Id := Record_Extension_Part (Def);
8582       Parent_Type  : Entity_Id;
8583       Parent_Scope : Entity_Id;
8584       Taggd        : Boolean;
8585
8586    begin
8587       Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
8588
8589       if Parent_Type = Any_Type
8590         or else Etype (Parent_Type) = Any_Type
8591         or else (Is_Class_Wide_Type (Parent_Type)
8592                   and then Etype (Parent_Type) = T)
8593       then
8594          --  If Parent_Type is undefined or illegal, make new type into
8595          --  a subtype of Any_Type, and set a few attributes to prevent
8596          --  cascaded errors. If this is a self-definition, emit error now.
8597
8598          if T = Parent_Type
8599            or else T = Etype (Parent_Type)
8600          then
8601             Error_Msg_N ("type cannot be used in its own definition", Indic);
8602          end if;
8603
8604          Set_Ekind        (T, Ekind (Parent_Type));
8605          Set_Etype        (T, Any_Type);
8606          Set_Scalar_Range (T, Scalar_Range (Any_Type));
8607
8608          if Is_Tagged_Type (T) then
8609             Set_Primitive_Operations (T, New_Elmt_List);
8610          end if;
8611          return;
8612
8613       elsif Is_Unchecked_Union (Parent_Type) then
8614          Error_Msg_N ("cannot derive from Unchecked_Union type", N);
8615       end if;
8616
8617       --  Only composite types other than array types are allowed to have
8618       --  discriminants.
8619
8620       if Present (Discriminant_Specifications (N))
8621         and then (Is_Elementary_Type (Parent_Type)
8622                   or else Is_Array_Type (Parent_Type))
8623         and then not Error_Posted (N)
8624       then
8625          Error_Msg_N
8626            ("elementary or array type cannot have discriminants",
8627             Defining_Identifier (First (Discriminant_Specifications (N))));
8628          Set_Has_Discriminants (T, False);
8629       end if;
8630
8631       --  In Ada 83, a derived type defined in a package specification cannot
8632       --  be used for further derivation until the end of its visible part.
8633       --  Note that derivation in the private part of the package is allowed.
8634
8635       if Ada_83
8636         and then Is_Derived_Type (Parent_Type)
8637         and then In_Visible_Part (Scope (Parent_Type))
8638       then
8639          if Ada_83 and then Comes_From_Source (Indic) then
8640             Error_Msg_N
8641               ("(Ada 83): premature use of type for derivation", Indic);
8642          end if;
8643       end if;
8644
8645       --  Check for early use of incomplete or private type
8646
8647       if Ekind (Parent_Type) = E_Void
8648         or else Ekind (Parent_Type) = E_Incomplete_Type
8649       then
8650          Error_Msg_N ("premature derivation of incomplete type", Indic);
8651          return;
8652
8653       elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
8654               and then not Is_Generic_Type (Parent_Type)
8655               and then not Is_Generic_Type (Root_Type (Parent_Type))
8656               and then not Is_Generic_Actual_Type (Parent_Type))
8657         or else Has_Private_Component (Parent_Type)
8658       then
8659          --  The ancestor type of a formal type can be incomplete, in which
8660          --  case only the operations of the partial view are available in
8661          --  the generic. Subsequent checks may be required when the full
8662          --  view is analyzed, to verify that derivation from a tagged type
8663          --  has an extension.
8664
8665          if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
8666             null;
8667
8668          elsif No (Underlying_Type (Parent_Type))
8669            or else Has_Private_Component (Parent_Type)
8670          then
8671             Error_Msg_N
8672               ("premature derivation of derived or private type", Indic);
8673
8674             --  Flag the type itself as being in error, this prevents some
8675             --  nasty problems with people looking at the malformed type.
8676
8677             Set_Error_Posted (T);
8678
8679          --  Check that within the immediate scope of an untagged partial
8680          --  view it's illegal to derive from the partial view if the
8681          --  full view is tagged. (7.3(7))
8682
8683          --  We verify that the Parent_Type is a partial view by checking
8684          --  that it is not a Full_Type_Declaration (i.e. a private type or
8685          --  private extension declaration), to distinguish a partial view
8686          --  from  a derivation from a private type which also appears as
8687          --  E_Private_Type.
8688
8689          elsif Present (Full_View (Parent_Type))
8690            and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
8691            and then not Is_Tagged_Type (Parent_Type)
8692            and then Is_Tagged_Type (Full_View (Parent_Type))
8693          then
8694             Parent_Scope := Scope (T);
8695             while Present (Parent_Scope)
8696               and then Parent_Scope /= Standard_Standard
8697             loop
8698                if Parent_Scope = Scope (Parent_Type) then
8699                   Error_Msg_N
8700                     ("premature derivation from type with tagged full view",
8701                      Indic);
8702                end if;
8703
8704                Parent_Scope := Scope (Parent_Scope);
8705             end loop;
8706          end if;
8707       end if;
8708
8709       --  Check that form of derivation is appropriate
8710
8711       Taggd := Is_Tagged_Type (Parent_Type);
8712
8713       --  Perhaps the parent type should be changed to the class-wide type's
8714       --  specific type in this case to prevent cascading errors ???
8715
8716       if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
8717          Error_Msg_N ("parent type must not be a class-wide type", Indic);
8718          return;
8719       end if;
8720
8721       if Present (Extension) and then not Taggd then
8722          Error_Msg_N
8723            ("type derived from untagged type cannot have extension", Indic);
8724
8725       elsif No (Extension) and then Taggd then
8726          --  If this is within a private part (or body) of a generic
8727          --  instantiation then the derivation is allowed (the parent
8728          --  type can only appear tagged in this case if it's a generic
8729          --  actual type, since it would otherwise have been rejected
8730          --  in the analysis of the generic template).
8731
8732          if not Is_Generic_Actual_Type (Parent_Type)
8733            or else In_Visible_Part (Scope (Parent_Type))
8734          then
8735             Error_Msg_N
8736               ("type derived from tagged type must have extension", Indic);
8737          end if;
8738       end if;
8739
8740       Build_Derived_Type (N, Parent_Type, T, Is_Completion);
8741    end Derived_Type_Declaration;
8742
8743    ----------------------------------
8744    -- Enumeration_Type_Declaration --
8745    ----------------------------------
8746
8747    procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
8748       Ev     : Uint;
8749       L      : Node_Id;
8750       R_Node : Node_Id;
8751       B_Node : Node_Id;
8752
8753    begin
8754       --  Create identifier node representing lower bound
8755
8756       B_Node := New_Node (N_Identifier, Sloc (Def));
8757       L := First (Literals (Def));
8758       Set_Chars (B_Node, Chars (L));
8759       Set_Entity (B_Node,  L);
8760       Set_Etype (B_Node, T);
8761       Set_Is_Static_Expression (B_Node, True);
8762
8763       R_Node := New_Node (N_Range, Sloc (Def));
8764       Set_Low_Bound  (R_Node, B_Node);
8765
8766       Set_Ekind (T, E_Enumeration_Type);
8767       Set_First_Literal (T, L);
8768       Set_Etype (T, T);
8769       Set_Is_Constrained (T);
8770
8771       Ev := Uint_0;
8772
8773       --  Loop through literals of enumeration type setting pos and rep values
8774       --  except that if the Ekind is already set, then it means that the
8775       --  literal was already constructed (case of a derived type declaration
8776       --  and we should not disturb the Pos and Rep values.
8777
8778       while Present (L) loop
8779          if Ekind (L) /= E_Enumeration_Literal then
8780             Set_Ekind (L, E_Enumeration_Literal);
8781             Set_Enumeration_Pos (L, Ev);
8782             Set_Enumeration_Rep (L, Ev);
8783             Set_Is_Known_Valid  (L, True);
8784          end if;
8785
8786          Set_Etype (L, T);
8787          New_Overloaded_Entity (L);
8788          Generate_Definition (L);
8789          Set_Convention (L, Convention_Intrinsic);
8790
8791          if Nkind (L) = N_Defining_Character_Literal then
8792             Set_Is_Character_Type (T, True);
8793          end if;
8794
8795          Ev := Ev + 1;
8796          Next (L);
8797       end loop;
8798
8799       --  Now create a node representing upper bound
8800
8801       B_Node := New_Node (N_Identifier, Sloc (Def));
8802       Set_Chars (B_Node, Chars (Last (Literals (Def))));
8803       Set_Entity (B_Node,  Last (Literals (Def)));
8804       Set_Etype (B_Node, T);
8805       Set_Is_Static_Expression (B_Node, True);
8806
8807       Set_High_Bound (R_Node, B_Node);
8808       Set_Scalar_Range (T, R_Node);
8809       Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
8810       Set_Enum_Esize (T);
8811
8812       --  Set Discard_Names if configuration pragma setg, or if there is
8813       --  a parameterless pragma in the current declarative region
8814
8815       if Global_Discard_Names
8816         or else Discard_Names (Scope (T))
8817       then
8818          Set_Discard_Names (T);
8819       end if;
8820    end Enumeration_Type_Declaration;
8821
8822    --------------------------
8823    -- Expand_Others_Choice --
8824    --------------------------
8825
8826    procedure Expand_Others_Choice
8827      (Case_Table    : Choice_Table_Type;
8828       Others_Choice : Node_Id;
8829       Choice_Type   : Entity_Id)
8830    is
8831       Choice      : Node_Id;
8832       Choice_List : List_Id := New_List;
8833       Exp_Lo      : Node_Id;
8834       Exp_Hi      : Node_Id;
8835       Hi          : Uint;
8836       Lo          : Uint;
8837       Loc         : Source_Ptr := Sloc (Others_Choice);
8838       Previous_Hi : Uint;
8839
8840       function Build_Choice (Value1, Value2 : Uint) return Node_Id;
8841       --  Builds a node representing the missing choices given by the
8842       --  Value1 and Value2. A N_Range node is built if there is more than
8843       --  one literal value missing. Otherwise a single N_Integer_Literal,
8844       --  N_Identifier or N_Character_Literal is built depending on what
8845       --  Choice_Type is.
8846
8847       function Lit_Of (Value : Uint) return Node_Id;
8848       --  Returns the Node_Id for the enumeration literal corresponding to the
8849       --  position given by Value within the enumeration type Choice_Type.
8850
8851       ------------------
8852       -- Build_Choice --
8853       ------------------
8854
8855       function Build_Choice (Value1, Value2 : Uint) return Node_Id is
8856          Lit_Node : Node_Id;
8857          Lo, Hi   : Node_Id;
8858
8859       begin
8860          --  If there is only one choice value missing between Value1 and
8861          --  Value2, build an integer or enumeration literal to represent it.
8862
8863          if (Value2 - Value1) = 0 then
8864             if Is_Integer_Type (Choice_Type) then
8865                Lit_Node := Make_Integer_Literal (Loc, Value1);
8866                Set_Etype (Lit_Node, Choice_Type);
8867             else
8868                Lit_Node := Lit_Of (Value1);
8869             end if;
8870
8871          --  Otherwise is more that one choice value that is missing between
8872          --  Value1 and Value2, therefore build a N_Range node of either
8873          --  integer or enumeration literals.
8874
8875          else
8876             if Is_Integer_Type (Choice_Type) then
8877                Lo := Make_Integer_Literal (Loc, Value1);
8878                Set_Etype (Lo, Choice_Type);
8879                Hi := Make_Integer_Literal (Loc, Value2);
8880                Set_Etype (Hi, Choice_Type);
8881                Lit_Node :=
8882                  Make_Range (Loc,
8883                    Low_Bound  => Lo,
8884                    High_Bound => Hi);
8885
8886             else
8887                Lit_Node :=
8888                  Make_Range (Loc,
8889                    Low_Bound  => Lit_Of (Value1),
8890                    High_Bound => Lit_Of (Value2));
8891             end if;
8892          end if;
8893
8894          return Lit_Node;
8895       end Build_Choice;
8896
8897       ------------
8898       -- Lit_Of --
8899       ------------
8900
8901       function Lit_Of (Value : Uint) return Node_Id is
8902          Lit : Entity_Id;
8903
8904       begin
8905          --  In the case where the literal is of type Character, there needs
8906          --  to be some special handling since there is no explicit chain
8907          --  of literals to search. Instead, a N_Character_Literal node
8908          --  is created with the appropriate Char_Code and Chars fields.
8909
8910          if Root_Type (Choice_Type) = Standard_Character then
8911             Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
8912             Lit := New_Node (N_Character_Literal, Loc);
8913             Set_Chars (Lit, Name_Find);
8914             Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
8915             Set_Etype (Lit, Choice_Type);
8916             Set_Is_Static_Expression (Lit, True);
8917             return Lit;
8918
8919          --  Otherwise, iterate through the literals list of Choice_Type
8920          --  "Value" number of times until the desired literal is reached
8921          --  and then return an occurrence of it.
8922
8923          else
8924             Lit := First_Literal (Choice_Type);
8925             for J in 1 .. UI_To_Int (Value) loop
8926                Next_Literal (Lit);
8927             end loop;
8928
8929             return New_Occurrence_Of (Lit, Loc);
8930          end if;
8931       end Lit_Of;
8932
8933    --  Start of processing for Expand_Others_Choice
8934
8935    begin
8936       if Case_Table'Length = 0 then
8937
8938          --  Pathological case: only an others case is present.
8939          --  The others case covers the full range of the type.
8940
8941          if Is_Static_Subtype (Choice_Type) then
8942             Choice := New_Occurrence_Of (Choice_Type, Loc);
8943          else
8944             Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
8945          end if;
8946
8947          Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
8948          return;
8949       end if;
8950
8951       --  Establish the bound values for the variant depending upon whether
8952       --  the type of the discriminant name is static or not.
8953
8954       if Is_OK_Static_Subtype (Choice_Type) then
8955          Exp_Lo := Type_Low_Bound (Choice_Type);
8956          Exp_Hi := Type_High_Bound (Choice_Type);
8957       else
8958          Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
8959          Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
8960       end if;
8961
8962       Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
8963       Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
8964       Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
8965
8966       --  Build the node for any missing choices that are smaller than any
8967       --  explicit choices given in the variant.
8968
8969       if Expr_Value (Exp_Lo) < Lo then
8970          Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
8971       end if;
8972
8973       --  Build the nodes representing any missing choices that lie between
8974       --  the explicit ones given in the variant.
8975
8976       for J in Case_Table'First + 1 .. Case_Table'Last loop
8977          Lo := Expr_Value (Case_Table (J).Lo);
8978          Hi := Expr_Value (Case_Table (J).Hi);
8979
8980          if Lo /= (Previous_Hi + 1) then
8981             Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
8982          end if;
8983
8984          Previous_Hi := Hi;
8985       end loop;
8986
8987       --  Build the node for any missing choices that are greater than any
8988       --  explicit choices given in the variant.
8989
8990       if Expr_Value (Exp_Hi) > Hi then
8991          Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
8992       end if;
8993
8994       Set_Others_Discrete_Choices (Others_Choice, Choice_List);
8995    end Expand_Others_Choice;
8996
8997    ---------------------------------
8998    -- Expand_To_Girder_Constraint --
8999    ---------------------------------
9000
9001    function Expand_To_Girder_Constraint
9002      (Typ        : Entity_Id;
9003       Constraint : Elist_Id)
9004       return       Elist_Id
9005    is
9006       Explicitly_Discriminated_Type : Entity_Id;
9007       Expansion    : Elist_Id;
9008       Discriminant : Entity_Id;
9009
9010       function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
9011       --  Find the nearest type that actually specifies discriminants.
9012
9013       ---------------------------------
9014       -- Type_With_Explicit_Discrims --
9015       ---------------------------------
9016
9017       function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
9018          Typ : constant E := Base_Type (Id);
9019
9020       begin
9021          if Ekind (Typ) in Incomplete_Or_Private_Kind then
9022             if Present (Full_View (Typ)) then
9023                return Type_With_Explicit_Discrims (Full_View (Typ));
9024             end if;
9025
9026          else
9027             if Has_Discriminants (Typ) then
9028                return Typ;
9029             end if;
9030          end if;
9031
9032          if Etype (Typ) = Typ then
9033             return Empty;
9034          elsif Has_Discriminants (Typ) then
9035             return Typ;
9036          else
9037             return Type_With_Explicit_Discrims (Etype (Typ));
9038          end if;
9039
9040       end Type_With_Explicit_Discrims;
9041
9042    --  Start of processing for Expand_To_Girder_Constraint
9043
9044    begin
9045       if No (Constraint)
9046         or else Is_Empty_Elmt_List (Constraint)
9047       then
9048          return No_Elist;
9049       end if;
9050
9051       Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
9052
9053       if No (Explicitly_Discriminated_Type) then
9054          return No_Elist;
9055       end if;
9056
9057       Expansion := New_Elmt_List;
9058
9059       Discriminant :=
9060          First_Girder_Discriminant (Explicitly_Discriminated_Type);
9061
9062       while Present (Discriminant) loop
9063
9064          Append_Elmt (
9065            Get_Discriminant_Value (
9066              Discriminant, Explicitly_Discriminated_Type, Constraint),
9067            Expansion);
9068
9069          Next_Girder_Discriminant (Discriminant);
9070       end loop;
9071
9072       return Expansion;
9073    end Expand_To_Girder_Constraint;
9074
9075    --------------------
9076    -- Find_Type_Name --
9077    --------------------
9078
9079    function Find_Type_Name (N : Node_Id) return Entity_Id is
9080       Id       : constant Entity_Id := Defining_Identifier (N);
9081       Prev     : Entity_Id;
9082       New_Id   : Entity_Id;
9083       Prev_Par : Node_Id;
9084
9085    begin
9086       --  Find incomplete declaration, if some was given.
9087
9088       Prev := Current_Entity_In_Scope (Id);
9089
9090       if Present (Prev) then
9091
9092          --  Previous declaration exists. Error if not incomplete/private case
9093          --  except if previous declaration is implicit, etc. Enter_Name will
9094          --  emit error if appropriate.
9095
9096          Prev_Par := Parent (Prev);
9097
9098          if not Is_Incomplete_Or_Private_Type (Prev) then
9099             Enter_Name (Id);
9100             New_Id := Id;
9101
9102          elsif Nkind (N) /= N_Full_Type_Declaration
9103            and then Nkind (N) /= N_Task_Type_Declaration
9104            and then Nkind (N) /= N_Protected_Type_Declaration
9105          then
9106             --  Completion must be a full type declarations (RM 7.3(4))
9107
9108             Error_Msg_Sloc := Sloc (Prev);
9109             Error_Msg_NE ("invalid completion of }", Id, Prev);
9110
9111             --  Set scope of Id to avoid cascaded errors. Entity is never
9112             --  examined again, except when saving globals in generics.
9113
9114             Set_Scope (Id, Current_Scope);
9115             New_Id := Id;
9116
9117          --  Case of full declaration of incomplete type
9118
9119          elsif Ekind (Prev) = E_Incomplete_Type then
9120
9121             --  Indicate that the incomplete declaration has a matching
9122             --  full declaration. The defining occurrence of the incomplete
9123             --  declaration remains the visible one, and the procedure
9124             --  Get_Full_View dereferences it whenever the type is used.
9125
9126             if Present (Full_View (Prev)) then
9127                Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
9128             end if;
9129
9130             Set_Full_View (Prev,  Id);
9131             Append_Entity (Id, Current_Scope);
9132             Set_Is_Public (Id, Is_Public (Prev));
9133             Set_Is_Internal (Id);
9134             New_Id := Prev;
9135
9136          --  Case of full declaration of private type
9137
9138          else
9139             if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
9140                if Etype (Prev) /= Prev then
9141
9142                   --  Prev is a private subtype or a derived type, and needs
9143                   --  no completion.
9144
9145                   Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
9146                   New_Id := Id;
9147
9148                elsif Ekind (Prev) = E_Private_Type
9149                  and then
9150                    (Nkind (N) = N_Task_Type_Declaration
9151                      or else Nkind (N) = N_Protected_Type_Declaration)
9152                then
9153                   Error_Msg_N
9154                    ("completion of nonlimited type cannot be limited", N);
9155                end if;
9156
9157             elsif Nkind (N) /= N_Full_Type_Declaration
9158               or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
9159             then
9160                Error_Msg_N ("full view of private extension must be"
9161                  & " an extension", N);
9162
9163             elsif not (Abstract_Present (Parent (Prev)))
9164               and then Abstract_Present (Type_Definition (N))
9165             then
9166                Error_Msg_N ("full view of non-abstract extension cannot"
9167                  & " be abstract", N);
9168             end if;
9169
9170             if not In_Private_Part (Current_Scope) then
9171                Error_Msg_N
9172                  ("declaration of full view must appear in private part",  N);
9173             end if;
9174
9175             Copy_And_Swap (Prev, Id);
9176             Set_Full_View (Id, Prev);
9177             Set_Has_Private_Declaration (Prev);
9178             Set_Has_Private_Declaration (Id);
9179             New_Id := Prev;
9180          end if;
9181
9182          --  Verify that full declaration conforms to incomplete one
9183
9184          if Is_Incomplete_Or_Private_Type (Prev)
9185            and then Present (Discriminant_Specifications (Prev_Par))
9186          then
9187             if Present (Discriminant_Specifications (N)) then
9188                if Ekind (Prev) = E_Incomplete_Type then
9189                   Check_Discriminant_Conformance (N, Prev, Prev);
9190                else
9191                   Check_Discriminant_Conformance (N, Prev, Id);
9192                end if;
9193
9194             else
9195                Error_Msg_N
9196                  ("missing discriminants in full type declaration", N);
9197
9198                --  To avoid cascaded errors on subsequent use, share the
9199                --  discriminants of the partial view.
9200
9201                Set_Discriminant_Specifications (N,
9202                  Discriminant_Specifications (Prev_Par));
9203             end if;
9204          end if;
9205
9206          --  A prior untagged private type can have an associated
9207          --  class-wide type due to use of the class attribute,
9208          --  and in this case also the full type is required to
9209          --  be tagged.
9210
9211          if Is_Type (Prev)
9212            and then (Is_Tagged_Type (Prev)
9213                       or else Present (Class_Wide_Type (Prev)))
9214          then
9215             --  The full declaration is either a tagged record or an
9216             --  extension otherwise this is an error
9217
9218             if Nkind (Type_Definition (N)) = N_Record_Definition then
9219                if not Tagged_Present (Type_Definition (N)) then
9220                   Error_Msg_NE
9221                     ("full declaration of } must be tagged", Prev, Id);
9222                   Set_Is_Tagged_Type (Id);
9223                   Set_Primitive_Operations (Id, New_Elmt_List);
9224                end if;
9225
9226             elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
9227                if No (Record_Extension_Part (Type_Definition (N))) then
9228                   Error_Msg_NE (
9229                     "full declaration of } must be a record extension",
9230                     Prev, Id);
9231                   Set_Is_Tagged_Type (Id);
9232                   Set_Primitive_Operations (Id, New_Elmt_List);
9233                end if;
9234
9235             else
9236                Error_Msg_NE
9237                  ("full declaration of } must be a tagged type", Prev, Id);
9238
9239             end if;
9240          end if;
9241
9242          return New_Id;
9243
9244       else
9245          --  New type declaration
9246
9247          Enter_Name (Id);
9248          return Id;
9249       end if;
9250    end Find_Type_Name;
9251
9252    -------------------------
9253    -- Find_Type_Of_Object --
9254    -------------------------
9255
9256    function Find_Type_Of_Object
9257      (Obj_Def     : Node_Id;
9258       Related_Nod : Node_Id)
9259       return        Entity_Id
9260    is
9261       Def_Kind : constant Node_Kind := Nkind (Obj_Def);
9262       P        : constant Node_Id   := Parent (Obj_Def);
9263       T        : Entity_Id;
9264       Nam      : Name_Id;
9265
9266    begin
9267       --  Case of an anonymous array subtype
9268
9269       if Def_Kind = N_Constrained_Array_Definition
9270         or else Def_Kind = N_Unconstrained_Array_Definition
9271       then
9272          T := Empty;
9273          Array_Type_Declaration (T, Obj_Def);
9274
9275       --  Create an explicit subtype whenever possible.
9276
9277       elsif Nkind (P) /= N_Component_Declaration
9278         and then Def_Kind = N_Subtype_Indication
9279       then
9280          --  Base name of subtype on object name, which will be unique in
9281          --  the current scope.
9282
9283          --  If this is a duplicate declaration, return base type, to avoid
9284          --  generating duplicate anonymous types.
9285
9286          if Error_Posted (P) then
9287             Analyze (Subtype_Mark (Obj_Def));
9288             return Entity (Subtype_Mark (Obj_Def));
9289          end if;
9290
9291          Nam :=
9292             New_External_Name
9293              (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
9294
9295          T := Make_Defining_Identifier (Sloc (P), Nam);
9296
9297          Insert_Action (Obj_Def,
9298            Make_Subtype_Declaration (Sloc (P),
9299              Defining_Identifier => T,
9300              Subtype_Indication  => Relocate_Node (Obj_Def)));
9301
9302          --  This subtype may need freezing and it will not be done
9303          --  automatically if the object declaration is not in a
9304          --  declarative part. Since this is an object declaration, the
9305          --  type cannot always be frozen here. Deferred constants do not
9306          --  freeze their type (which often enough will be private).
9307
9308          if Nkind (P) = N_Object_Declaration
9309            and then Constant_Present (P)
9310            and then No (Expression (P))
9311          then
9312             null;
9313
9314          else
9315             Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P)));
9316          end if;
9317
9318       else
9319          T := Process_Subtype (Obj_Def, Related_Nod);
9320       end if;
9321
9322       return T;
9323    end Find_Type_Of_Object;
9324
9325    --------------------------------
9326    -- Find_Type_Of_Subtype_Indic --
9327    --------------------------------
9328
9329    function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
9330       Typ : Entity_Id;
9331
9332    begin
9333       --  Case of subtype mark with a constraint
9334
9335       if Nkind (S) = N_Subtype_Indication then
9336          Find_Type (Subtype_Mark (S));
9337          Typ := Entity (Subtype_Mark (S));
9338
9339          if not
9340            Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
9341          then
9342             Error_Msg_N
9343               ("incorrect constraint for this kind of type", Constraint (S));
9344             Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
9345          end if;
9346
9347       --  Otherwise we have a subtype mark without a constraint
9348
9349       elsif Error_Posted (S) then
9350          Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
9351          return Any_Type;
9352
9353       else
9354          Find_Type (S);
9355          Typ := Entity (S);
9356       end if;
9357
9358       if Typ = Standard_Wide_Character
9359         or else Typ = Standard_Wide_String
9360       then
9361          Check_Restriction (No_Wide_Characters, S);
9362       end if;
9363
9364       return Typ;
9365    end Find_Type_Of_Subtype_Indic;
9366
9367    -------------------------------------
9368    -- Floating_Point_Type_Declaration --
9369    -------------------------------------
9370
9371    procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
9372       Digs          : constant Node_Id := Digits_Expression (Def);
9373       Digs_Val      : Uint;
9374       Base_Typ      : Entity_Id;
9375       Implicit_Base : Entity_Id;
9376       Bound         : Node_Id;
9377
9378       function Can_Derive_From (E : Entity_Id) return Boolean;
9379       --  Find if given digits value allows derivation from specified type
9380
9381       function Can_Derive_From (E : Entity_Id) return Boolean is
9382          Spec : constant Entity_Id := Real_Range_Specification (Def);
9383
9384       begin
9385          if Digs_Val > Digits_Value (E) then
9386             return False;
9387          end if;
9388
9389          if Present (Spec) then
9390             if Expr_Value_R (Type_Low_Bound (E)) >
9391                Expr_Value_R (Low_Bound (Spec))
9392             then
9393                return False;
9394             end if;
9395
9396             if Expr_Value_R (Type_High_Bound (E)) <
9397                Expr_Value_R (High_Bound (Spec))
9398             then
9399                return False;
9400             end if;
9401          end if;
9402
9403          return True;
9404       end Can_Derive_From;
9405
9406    --  Start of processing for Floating_Point_Type_Declaration
9407
9408    begin
9409       Check_Restriction (No_Floating_Point, Def);
9410
9411       --  Create an implicit base type
9412
9413       Implicit_Base :=
9414         Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
9415
9416       --  Analyze and verify digits value
9417
9418       Analyze_And_Resolve (Digs, Any_Integer);
9419       Check_Digits_Expression (Digs);
9420       Digs_Val := Expr_Value (Digs);
9421
9422       --  Process possible range spec and find correct type to derive from
9423
9424       Process_Real_Range_Specification (Def);
9425
9426       if Can_Derive_From (Standard_Short_Float) then
9427          Base_Typ := Standard_Short_Float;
9428       elsif Can_Derive_From (Standard_Float) then
9429          Base_Typ := Standard_Float;
9430       elsif Can_Derive_From (Standard_Long_Float) then
9431          Base_Typ := Standard_Long_Float;
9432       elsif Can_Derive_From (Standard_Long_Long_Float) then
9433          Base_Typ := Standard_Long_Long_Float;
9434
9435       --  If we can't derive from any existing type, use long long float
9436       --  and give appropriate message explaining the problem.
9437
9438       else
9439          Base_Typ := Standard_Long_Long_Float;
9440
9441          if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
9442             Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float);
9443             Error_Msg_N ("digits value out of range, maximum is ^", Digs);
9444
9445          else
9446             Error_Msg_N
9447               ("range too large for any predefined type",
9448                Real_Range_Specification (Def));
9449          end if;
9450       end if;
9451
9452       --  If there are bounds given in the declaration use them as the bounds
9453       --  of the type, otherwise use the bounds of the predefined base type
9454       --  that was chosen based on the Digits value.
9455
9456       if Present (Real_Range_Specification (Def)) then
9457          Set_Scalar_Range (T, Real_Range_Specification (Def));
9458          Set_Is_Constrained (T);
9459
9460          --  The bounds of this range must be converted to machine numbers
9461          --  in accordance with RM 4.9(38).
9462
9463          Bound := Type_Low_Bound (T);
9464
9465          if Nkind (Bound) = N_Real_Literal then
9466             Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
9467             Set_Is_Machine_Number (Bound);
9468          end if;
9469
9470          Bound := Type_High_Bound (T);
9471
9472          if Nkind (Bound) = N_Real_Literal then
9473             Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
9474             Set_Is_Machine_Number (Bound);
9475          end if;
9476
9477       else
9478          Set_Scalar_Range (T, Scalar_Range (Base_Typ));
9479       end if;
9480
9481       --  Complete definition of implicit base and declared first subtype
9482
9483       Set_Etype          (Implicit_Base, Base_Typ);
9484
9485       Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
9486       Set_Size_Info      (Implicit_Base,                (Base_Typ));
9487       Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
9488       Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
9489       Set_Digits_Value   (Implicit_Base, Digits_Value   (Base_Typ));
9490       Set_Vax_Float      (Implicit_Base, Vax_Float      (Base_Typ));
9491
9492       Set_Ekind          (T, E_Floating_Point_Subtype);
9493       Set_Etype          (T, Implicit_Base);
9494
9495       Set_Size_Info      (T,                (Implicit_Base));
9496       Set_RM_Size        (T, RM_Size        (Implicit_Base));
9497       Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
9498       Set_Digits_Value   (T, Digs_Val);
9499
9500    end Floating_Point_Type_Declaration;
9501
9502    ----------------------------
9503    -- Get_Discriminant_Value --
9504    ----------------------------
9505
9506    --  This is the situation...
9507
9508    --  There is a non-derived type
9509
9510    --       type T0 (Dx, Dy, Dz...)
9511
9512    --  There are zero or more levels of derivation, with each
9513    --  derivation either purely inheriting the discriminants, or
9514    --  defining its own.
9515
9516    --       type Ti      is new Ti-1
9517    --  or
9518    --       type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
9519    --  or
9520    --       subtype Ti is ...
9521
9522    --  The subtype issue is avoided by the use of
9523    --    Original_Record_Component, and the fact that derived subtypes
9524    --    also derive the constraits.
9525
9526    --  This chain leads back from
9527
9528    --       Typ_For_Constraint
9529
9530    --  Typ_For_Constraint has discriminants, and the value for each
9531    --  discriminant is given by its corresponding Elmt of Constraints.
9532
9533    --  Discriminant is some discriminant in this hierarchy.
9534
9535    --  We need to return its value.
9536
9537    --  We do this by recursively searching each level, and looking for
9538    --  Discriminant. Once we get to the bottom, we start backing up
9539    --  returning the value for it which may in turn be a discriminant
9540    --  further up, so on the backup we continue the substitution.
9541
9542    function Get_Discriminant_Value
9543      (Discriminant       : Entity_Id;
9544       Typ_For_Constraint : Entity_Id;
9545       Constraint         : Elist_Id)
9546       return               Node_Id
9547    is
9548       function Recurse
9549         (Ti                    : Entity_Id;
9550          Discrim_Values        : Elist_Id;
9551          Girder_Discrim_Values : Boolean)
9552          return                Node_Or_Entity_Id;
9553       --  This is the routine that performs the recursive search of levels
9554       --  as described above.
9555
9556       function Recurse
9557         (Ti                    : Entity_Id;
9558          Discrim_Values        : Elist_Id;
9559          Girder_Discrim_Values : Boolean)
9560          return                  Node_Or_Entity_Id
9561       is
9562          Assoc          : Elmt_Id;
9563          Disc           : Entity_Id;
9564          Result         : Node_Or_Entity_Id;
9565          Result_Entity  : Node_Id;
9566
9567       begin
9568          --  If inappropriate type, return Error, this happens only in
9569          --  cascaded error situations, and we want to avoid a blow up.
9570
9571          if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
9572             return Error;
9573          end if;
9574
9575          --  Look deeper if possible. Use Girder_Constraints only for
9576          --  untagged types. For tagged types use the given constraint.
9577          --  This asymmetry needs explanation???
9578
9579          if not Girder_Discrim_Values
9580            and then Present (Girder_Constraint (Ti))
9581            and then not Is_Tagged_Type (Ti)
9582          then
9583             Result := Recurse (Ti, Girder_Constraint (Ti), True);
9584          else
9585             declare
9586                Td : Entity_Id := Etype (Ti);
9587             begin
9588
9589                if Td = Ti then
9590                   Result := Discriminant;
9591
9592                else
9593                   if Present (Girder_Constraint (Ti)) then
9594                      Result :=
9595                         Recurse (Td, Girder_Constraint (Ti), True);
9596                   else
9597                      Result :=
9598                         Recurse (Td, Discrim_Values, Girder_Discrim_Values);
9599                   end if;
9600                end if;
9601             end;
9602          end if;
9603
9604          --  Extra underlying places to search, if not found above. For
9605          --  concurrent types, the relevant discriminant appears in the
9606          --  corresponding record. For a type derived from a private type
9607          --  without discriminant, the full view inherits the discriminants
9608          --  of the full view of the parent.
9609
9610          if Result = Discriminant then
9611             if Is_Concurrent_Type (Ti)
9612               and then Present (Corresponding_Record_Type (Ti))
9613             then
9614                Result :=
9615                  Recurse (
9616                    Corresponding_Record_Type (Ti),
9617                    Discrim_Values,
9618                    Girder_Discrim_Values);
9619
9620             elsif Is_Private_Type (Ti)
9621               and then not Has_Discriminants (Ti)
9622               and then Present (Full_View (Ti))
9623               and then Etype (Full_View (Ti)) /= Ti
9624             then
9625                Result :=
9626                  Recurse (
9627                    Full_View (Ti),
9628                    Discrim_Values,
9629                    Girder_Discrim_Values);
9630             end if;
9631          end if;
9632
9633          --  If Result is not a (reference to a) discriminant,
9634          --  return it, otherwise set Result_Entity to the discriminant.
9635
9636          if Nkind (Result) = N_Defining_Identifier then
9637
9638             pragma Assert (Result = Discriminant);
9639
9640             Result_Entity := Result;
9641
9642          else
9643             if not Denotes_Discriminant (Result) then
9644                return Result;
9645             end if;
9646
9647             Result_Entity := Entity (Result);
9648          end if;
9649
9650          --  See if this level of derivation actually has discriminants
9651          --  because tagged derivations can add them, hence the lower
9652          --  levels need not have any.
9653
9654          if not Has_Discriminants (Ti) then
9655             return Result;
9656          end if;
9657
9658          --  Scan Ti's discriminants for Result_Entity,
9659          --  and return its corresponding value, if any.
9660
9661          Result_Entity := Original_Record_Component (Result_Entity);
9662
9663          Assoc := First_Elmt (Discrim_Values);
9664
9665          if Girder_Discrim_Values then
9666             Disc := First_Girder_Discriminant (Ti);
9667          else
9668             Disc := First_Discriminant (Ti);
9669          end if;
9670
9671          while Present (Disc) loop
9672
9673             pragma Assert (Present (Assoc));
9674
9675             if Original_Record_Component (Disc) = Result_Entity then
9676                return Node (Assoc);
9677             end if;
9678
9679             Next_Elmt (Assoc);
9680
9681             if Girder_Discrim_Values then
9682                Next_Girder_Discriminant (Disc);
9683             else
9684                Next_Discriminant (Disc);
9685             end if;
9686          end loop;
9687
9688          --  Could not find it
9689          --
9690          return Result;
9691       end Recurse;
9692
9693       Result : Node_Or_Entity_Id;
9694
9695    --  Start of processing for Get_Discriminant_Value
9696
9697    begin
9698       --  ??? this routine is a gigantic mess and will be deleted.
9699       --  for the time being just test for the trivial case before calling
9700       --  recurse.
9701
9702       if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
9703          declare
9704             D : Entity_Id := First_Discriminant (Typ_For_Constraint);
9705             E : Elmt_Id   := First_Elmt (Constraint);
9706          begin
9707             while Present (D) loop
9708                if Chars (D) = Chars (Discriminant) then
9709                   return Node (E);
9710                end if;
9711
9712                Next_Discriminant (D);
9713                Next_Elmt (E);
9714             end loop;
9715          end;
9716       end if;
9717
9718       Result := Recurse (Typ_For_Constraint, Constraint, False);
9719
9720       --  ??? hack to disappear when this routine is gone
9721
9722       if  Nkind (Result) = N_Defining_Identifier then
9723          declare
9724             D : Entity_Id := First_Discriminant (Typ_For_Constraint);
9725             E : Elmt_Id   := First_Elmt (Constraint);
9726          begin
9727             while Present (D) loop
9728                if Corresponding_Discriminant (D) = Discriminant then
9729                   return Node (E);
9730                end if;
9731
9732                Next_Discriminant (D);
9733                Next_Elmt (E);
9734             end loop;
9735          end;
9736       end if;
9737
9738       pragma Assert (Nkind (Result) /= N_Defining_Identifier);
9739       return Result;
9740    end Get_Discriminant_Value;
9741
9742    --------------------------
9743    -- Has_Range_Constraint --
9744    --------------------------
9745
9746    function Has_Range_Constraint (N : Node_Id) return Boolean is
9747       C : constant Node_Id := Constraint (N);
9748
9749    begin
9750       if Nkind (C) = N_Range_Constraint then
9751          return True;
9752
9753       elsif Nkind (C) = N_Digits_Constraint then
9754          return
9755             Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
9756               or else
9757             Present (Range_Constraint (C));
9758
9759       elsif Nkind (C) = N_Delta_Constraint then
9760          return Present (Range_Constraint (C));
9761
9762       else
9763          return False;
9764       end if;
9765    end Has_Range_Constraint;
9766
9767    ------------------------
9768    -- Inherit_Components --
9769    ------------------------
9770
9771    function Inherit_Components
9772      (N             : Node_Id;
9773       Parent_Base   : Entity_Id;
9774       Derived_Base  : Entity_Id;
9775       Is_Tagged     : Boolean;
9776       Inherit_Discr : Boolean;
9777       Discs         : Elist_Id)
9778       return          Elist_Id
9779    is
9780       Assoc_List : Elist_Id := New_Elmt_List;
9781
9782       procedure Inherit_Component
9783         (Old_C          : Entity_Id;
9784          Plain_Discrim  : Boolean := False;
9785          Girder_Discrim : Boolean := False);
9786       --  Inherits component Old_C from Parent_Base to the Derived_Base.
9787       --  If Plain_Discrim is True, Old_C is a discriminant.
9788       --  If Girder_Discrim is True, Old_C is a girder discriminant.
9789       --  If they are both false then Old_C is a regular component.
9790
9791       -----------------------
9792       -- Inherit_Component --
9793       -----------------------
9794
9795       procedure Inherit_Component
9796         (Old_C          : Entity_Id;
9797          Plain_Discrim  : Boolean := False;
9798          Girder_Discrim : Boolean := False)
9799       is
9800          New_C : Entity_Id := New_Copy (Old_C);
9801
9802          Discrim      : Entity_Id;
9803          Corr_Discrim : Entity_Id;
9804
9805       begin
9806          pragma Assert (not Is_Tagged or else not Girder_Discrim);
9807
9808          Set_Parent (New_C, Parent (Old_C));
9809
9810          --  Regular discriminants and components must be inserted
9811          --  in the scope of the Derived_Base. Do it here.
9812
9813          if not Girder_Discrim then
9814             Enter_Name (New_C);
9815          end if;
9816
9817          --  For tagged types the Original_Record_Component must point to
9818          --  whatever this field was pointing to in the parent type. This has
9819          --  already been achieved by the call to New_Copy above.
9820
9821          if not Is_Tagged then
9822             Set_Original_Record_Component (New_C, New_C);
9823          end if;
9824
9825          --  If we have inherited a component then see if its Etype contains
9826          --  references to Parent_Base discriminants. In this case, replace
9827          --  these references with the constraints given in Discs. We do not
9828          --  do this for the partial view of private types because this is
9829          --  not needed (only the components of the full view will be used
9830          --  for code generation) and cause problem. We also avoid this
9831          --  transformation in some error situations.
9832
9833          if Ekind (New_C) = E_Component then
9834             if (Is_Private_Type (Derived_Base)
9835                   and then not Is_Generic_Type (Derived_Base))
9836               or else (Is_Empty_Elmt_List (Discs)
9837                        and then  not Expander_Active)
9838             then
9839                Set_Etype (New_C, Etype (Old_C));
9840             else
9841                Set_Etype (New_C, Constrain_Component_Type (Etype (Old_C),
9842                  Derived_Base, N, Parent_Base, Discs));
9843             end if;
9844          end if;
9845
9846          --  In derived tagged types it is illegal to reference a non
9847          --  discriminant component in the parent type. To catch this, mark
9848          --  these components with an Ekind of E_Void. This will be reset in
9849          --  Record_Type_Definition after processing the record extension of
9850          --  the derived type.
9851
9852          if Is_Tagged and then Ekind (New_C) = E_Component then
9853             Set_Ekind (New_C, E_Void);
9854          end if;
9855
9856          if Plain_Discrim then
9857             Set_Corresponding_Discriminant (New_C, Old_C);
9858             Build_Discriminal (New_C);
9859
9860          --  If we are explicitly inheriting a girder discriminant it will be
9861          --  completely hidden.
9862
9863          elsif Girder_Discrim then
9864             Set_Corresponding_Discriminant (New_C, Empty);
9865             Set_Discriminal (New_C, Empty);
9866             Set_Is_Completely_Hidden (New_C);
9867
9868             --  Set the Original_Record_Component of each discriminant in the
9869             --  derived base to point to the corresponding girder that we just
9870             --  created.
9871
9872             Discrim := First_Discriminant (Derived_Base);
9873             while Present (Discrim) loop
9874                Corr_Discrim := Corresponding_Discriminant (Discrim);
9875
9876                --  Corr_Discrimm could be missing in an error situation.
9877
9878                if Present (Corr_Discrim)
9879                  and then Original_Record_Component (Corr_Discrim) = Old_C
9880                then
9881                   Set_Original_Record_Component (Discrim, New_C);
9882                end if;
9883
9884                Next_Discriminant (Discrim);
9885             end loop;
9886
9887             Append_Entity (New_C, Derived_Base);
9888          end if;
9889
9890          if not Is_Tagged then
9891             Append_Elmt (Old_C, Assoc_List);
9892             Append_Elmt (New_C, Assoc_List);
9893          end if;
9894       end Inherit_Component;
9895
9896       --  Variables local to Inherit_Components.
9897
9898       Loc : constant Source_Ptr := Sloc (N);
9899
9900       Parent_Discrim : Entity_Id;
9901       Girder_Discrim : Entity_Id;
9902       D              : Entity_Id;
9903
9904       Component        : Entity_Id;
9905
9906    --  Start of processing for Inherit_Components
9907
9908    begin
9909       if not Is_Tagged then
9910          Append_Elmt (Parent_Base,  Assoc_List);
9911          Append_Elmt (Derived_Base, Assoc_List);
9912       end if;
9913
9914       --  Inherit parent discriminants if needed.
9915
9916       if Inherit_Discr then
9917          Parent_Discrim := First_Discriminant (Parent_Base);
9918          while Present (Parent_Discrim) loop
9919             Inherit_Component (Parent_Discrim, Plain_Discrim => True);
9920             Next_Discriminant (Parent_Discrim);
9921          end loop;
9922       end if;
9923
9924       --  Create explicit girder discrims for untagged types when necessary.
9925
9926       if not Has_Unknown_Discriminants (Derived_Base)
9927         and then Has_Discriminants (Parent_Base)
9928         and then not Is_Tagged
9929         and then
9930           (not Inherit_Discr
9931            or else First_Discriminant (Parent_Base) /=
9932                    First_Girder_Discriminant (Parent_Base))
9933       then
9934          Girder_Discrim := First_Girder_Discriminant (Parent_Base);
9935          while Present (Girder_Discrim) loop
9936             Inherit_Component (Girder_Discrim, Girder_Discrim => True);
9937             Next_Girder_Discriminant (Girder_Discrim);
9938          end loop;
9939       end if;
9940
9941       --  See if we can apply the second transformation for derived types, as
9942       --  explained in point 6. in the comments above Build_Derived_Record_Type
9943       --  This is achieved by appending Derived_Base discriminants into
9944       --  Discs, which has the side effect of returning a non empty Discs
9945       --  list to the caller of Inherit_Components, which is what we want.
9946
9947       if Inherit_Discr
9948         and then Is_Empty_Elmt_List (Discs)
9949         and then (not Is_Private_Type (Derived_Base)
9950                    or Is_Generic_Type (Derived_Base))
9951       then
9952          D := First_Discriminant (Derived_Base);
9953          while Present (D) loop
9954             Append_Elmt (New_Reference_To (D, Loc), Discs);
9955             Next_Discriminant (D);
9956          end loop;
9957       end if;
9958
9959       --  Finally, inherit non-discriminant components unless they are not
9960       --  visible because defined or inherited from the full view of the
9961       --  parent. Don't inherit the _parent field of the parent type.
9962
9963       Component := First_Entity (Parent_Base);
9964       while Present (Component) loop
9965          if Ekind (Component) /= E_Component
9966            or else Chars (Component) = Name_uParent
9967          then
9968             null;
9969
9970          --  If the derived type is within the parent type's declarative
9971          --  region, then the components can still be inherited even though
9972          --  they aren't visible at this point. This can occur for cases
9973          --  such as within public child units where the components must
9974          --  become visible upon entering the child unit's private part.
9975
9976          elsif not Is_Visible_Component (Component)
9977            and then not In_Open_Scopes (Scope (Parent_Base))
9978          then
9979             null;
9980
9981          elsif Ekind (Derived_Base) = E_Private_Type
9982            or else Ekind (Derived_Base) = E_Limited_Private_Type
9983          then
9984             null;
9985
9986          else
9987             Inherit_Component (Component);
9988          end if;
9989
9990          Next_Entity (Component);
9991       end loop;
9992
9993       --  For tagged derived types, inherited discriminants cannot be used in
9994       --  component declarations of the record extension part. To achieve this
9995       --  we mark the inherited discriminants as not visible.
9996
9997       if Is_Tagged and then Inherit_Discr then
9998          D := First_Discriminant (Derived_Base);
9999          while Present (D) loop
10000             Set_Is_Immediately_Visible (D, False);
10001             Next_Discriminant (D);
10002          end loop;
10003       end if;
10004
10005       return Assoc_List;
10006    end Inherit_Components;
10007
10008    ------------------------------
10009    -- Is_Valid_Constraint_Kind --
10010    ------------------------------
10011
10012    function Is_Valid_Constraint_Kind
10013      (T_Kind          : Type_Kind;
10014       Constraint_Kind : Node_Kind)
10015       return            Boolean
10016    is
10017    begin
10018       case T_Kind is
10019
10020          when Enumeration_Kind |
10021               Integer_Kind =>
10022             return Constraint_Kind = N_Range_Constraint;
10023
10024          when Decimal_Fixed_Point_Kind =>
10025             return
10026               Constraint_Kind = N_Digits_Constraint
10027                 or else
10028               Constraint_Kind = N_Range_Constraint;
10029
10030          when Ordinary_Fixed_Point_Kind =>
10031             return
10032               Constraint_Kind = N_Delta_Constraint
10033                 or else
10034               Constraint_Kind = N_Range_Constraint;
10035
10036          when Float_Kind =>
10037             return
10038               Constraint_Kind = N_Digits_Constraint
10039                 or else
10040               Constraint_Kind = N_Range_Constraint;
10041
10042          when Access_Kind       |
10043               Array_Kind        |
10044               E_Record_Type     |
10045               E_Record_Subtype  |
10046               Class_Wide_Kind   |
10047               E_Incomplete_Type |
10048               Private_Kind      |
10049               Concurrent_Kind  =>
10050             return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
10051
10052          when others =>
10053             return True; -- Error will be detected later.
10054       end case;
10055
10056    end Is_Valid_Constraint_Kind;
10057
10058    --------------------------
10059    -- Is_Visible_Component --
10060    --------------------------
10061
10062    function Is_Visible_Component (C : Entity_Id) return Boolean is
10063       Original_Comp  : constant Entity_Id := Original_Record_Component (C);
10064       Original_Scope : Entity_Id;
10065
10066    begin
10067       if No (Original_Comp) then
10068
10069          --  Premature usage, or previous error
10070
10071          return False;
10072
10073       else
10074          Original_Scope := Scope (Original_Comp);
10075       end if;
10076
10077       --  This test only concern tagged types
10078
10079       if not Is_Tagged_Type (Original_Scope) then
10080          return True;
10081
10082       --  If it is _Parent or _Tag, there is no visiblity issue
10083
10084       elsif not Comes_From_Source (Original_Comp) then
10085          return True;
10086
10087       --  If we are in the body of an instantiation, the component is
10088       --  visible even when the parent type (possibly defined in an
10089       --  enclosing unit or in a parent unit) might not.
10090
10091       elsif In_Instance_Body then
10092          return True;
10093
10094       --  Discriminants are always visible.
10095
10096       elsif Ekind (Original_Comp) = E_Discriminant
10097         and then not Has_Unknown_Discriminants (Original_Scope)
10098       then
10099          return True;
10100
10101       --  If the component has been declared in an ancestor which is
10102       --  currently a private type, then it is not visible. The same
10103       --  applies if the component's containing type is not in an
10104       --  open scope and the original component's enclosing type
10105       --  is a visible full type of a private type (which can occur
10106       --  in cases where an attempt is being made to reference a
10107       --  component in a sibling package that is inherited from
10108       --  a visible component of a type in an ancestor package;
10109       --  the component in the sibling package should not be
10110       --  visible even though the component it inherited from
10111       --  is visible). This does not apply however in the case
10112       --  where the scope of the type is a private child unit.
10113       --  The latter suppression of visibility is needed for cases
10114       --  that are tested in B730006.
10115
10116       elsif (Ekind (Original_Comp) /= E_Discriminant
10117               or else Has_Unknown_Discriminants (Original_Scope))
10118         and then
10119           (Is_Private_Type (Original_Scope)
10120             or else
10121               (not Is_Private_Descendant (Scope (Base_Type (Scope (C))))
10122                 and then not In_Open_Scopes (Scope (Base_Type (Scope (C))))
10123                 and then Has_Private_Declaration (Original_Scope)))
10124       then
10125          return False;
10126
10127       --  There is another weird way in which a component may be invisible
10128       --  when the private and the full view are not derived from the same
10129       --  ancestor. Here is an example :
10130
10131       --       type A1 is tagged      record F1 : integer; end record;
10132       --       type A2 is new A1 with record F2 : integer; end record;
10133       --       type T is new A1 with private;
10134       --     private
10135       --       type T is new A2 with private;
10136
10137       --  In this case, the full view of T inherits F1 and F2 but the
10138       --  private view inherits only F1
10139
10140       else
10141          declare
10142             Ancestor : Entity_Id := Scope (C);
10143
10144          begin
10145             loop
10146                if Ancestor = Original_Scope then
10147                   return True;
10148                elsif Ancestor = Etype (Ancestor) then
10149                   return False;
10150                end if;
10151
10152                Ancestor := Etype (Ancestor);
10153             end loop;
10154
10155             return True;
10156          end;
10157       end if;
10158    end Is_Visible_Component;
10159
10160    --------------------------
10161    -- Make_Class_Wide_Type --
10162    --------------------------
10163
10164    procedure Make_Class_Wide_Type (T : Entity_Id) is
10165       CW_Type : Entity_Id;
10166       CW_Name : Name_Id;
10167       Next_E  : Entity_Id;
10168
10169    begin
10170       --  The class wide type can have been defined by the partial view in
10171       --  which case everything is already done
10172
10173       if Present (Class_Wide_Type (T)) then
10174          return;
10175       end if;
10176
10177       CW_Type :=
10178         New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
10179
10180       --  Inherit root type characteristics
10181
10182       CW_Name := Chars (CW_Type);
10183       Next_E  := Next_Entity (CW_Type);
10184       Copy_Node (T, CW_Type);
10185       Set_Comes_From_Source (CW_Type, False);
10186       Set_Chars (CW_Type, CW_Name);
10187       Set_Parent (CW_Type, Parent (T));
10188       Set_Next_Entity (CW_Type, Next_E);
10189       Set_Has_Delayed_Freeze (CW_Type);
10190
10191       --  Customize the class-wide type: It has no prim. op., it cannot be
10192       --  abstract and its Etype points back to the root type
10193
10194       Set_Ekind                (CW_Type, E_Class_Wide_Type);
10195       Set_Is_Tagged_Type       (CW_Type, True);
10196       Set_Primitive_Operations (CW_Type, New_Elmt_List);
10197       Set_Is_Abstract          (CW_Type, False);
10198       Set_Etype                (CW_Type, T);
10199       Set_Is_Constrained       (CW_Type, False);
10200       Set_Is_First_Subtype     (CW_Type, Is_First_Subtype (T));
10201       Init_Size_Align          (CW_Type);
10202
10203       --  If this is the class_wide type of a constrained subtype, it does
10204       --  not have discriminants.
10205
10206       Set_Has_Discriminants (CW_Type,
10207         Has_Discriminants (T) and then not Is_Constrained (T));
10208
10209       Set_Has_Unknown_Discriminants (CW_Type, True);
10210       Set_Class_Wide_Type (T, CW_Type);
10211       Set_Equivalent_Type (CW_Type, Empty);
10212
10213       --  The class-wide type of a class-wide type is itself (RM 3.9(14))
10214
10215       Set_Class_Wide_Type (CW_Type, CW_Type);
10216
10217    end Make_Class_Wide_Type;
10218
10219    ----------------
10220    -- Make_Index --
10221    ----------------
10222
10223    procedure Make_Index
10224      (I            : Node_Id;
10225       Related_Nod  : Node_Id;
10226       Related_Id   : Entity_Id := Empty;
10227       Suffix_Index : Nat := 1)
10228    is
10229       R      : Node_Id;
10230       T      : Entity_Id;
10231       Def_Id : Entity_Id := Empty;
10232       Found  : Boolean := False;
10233
10234    begin
10235       --  For a discrete range used in a constrained array definition and
10236       --  defined by a range, an implicit conversion to the predefined type
10237       --  INTEGER is assumed if each bound is either a numeric literal, a named
10238       --  number, or an attribute, and the type of both bounds (prior to the
10239       --  implicit conversion) is the type universal_integer. Otherwise, both
10240       --  bounds must be of the same discrete type, other than universal
10241       --  integer; this type must be determinable independently of the
10242       --  context, but using the fact that the type must be discrete and that
10243       --  both bounds must have the same type.
10244
10245       --  Character literals also have a universal type in the absence of
10246       --  of additional context,  and are resolved to Standard_Character.
10247
10248       if Nkind (I) = N_Range then
10249
10250          --  The index is given by a range constraint. The bounds are known
10251          --  to be of a consistent type.
10252
10253          if not Is_Overloaded (I) then
10254             T := Etype (I);
10255
10256             --  If the bounds are universal, choose the specific predefined
10257             --  type.
10258
10259             if T = Universal_Integer then
10260                T := Standard_Integer;
10261
10262             elsif T = Any_Character then
10263
10264                if not Ada_83 then
10265                   Error_Msg_N
10266                     ("ambiguous character literals (could be Wide_Character)",
10267                       I);
10268                end if;
10269
10270                T := Standard_Character;
10271             end if;
10272
10273          else
10274             T := Any_Type;
10275
10276             declare
10277                Ind : Interp_Index;
10278                It  : Interp;
10279
10280             begin
10281                Get_First_Interp (I, Ind, It);
10282
10283                while Present (It.Typ) loop
10284                   if Is_Discrete_Type (It.Typ) then
10285
10286                      if Found
10287                        and then not Covers (It.Typ, T)
10288                        and then not Covers (T, It.Typ)
10289                      then
10290                         Error_Msg_N ("ambiguous bounds in discrete range", I);
10291                         exit;
10292                      else
10293                         T := It.Typ;
10294                         Found := True;
10295                      end if;
10296                   end if;
10297
10298                   Get_Next_Interp (Ind, It);
10299                end loop;
10300
10301                if T = Any_Type then
10302                   Error_Msg_N ("discrete type required for range", I);
10303                   Set_Etype (I, Any_Type);
10304                   return;
10305
10306                elsif T = Universal_Integer then
10307                   T := Standard_Integer;
10308                end if;
10309             end;
10310          end if;
10311
10312          if not Is_Discrete_Type (T) then
10313             Error_Msg_N ("discrete type required for range", I);
10314             Set_Etype (I, Any_Type);
10315             return;
10316          end if;
10317
10318          R := I;
10319          Process_Range_Expr_In_Decl (R, T, Related_Nod);
10320
10321       elsif Nkind (I) = N_Subtype_Indication then
10322
10323          --  The index is given by a subtype with a range constraint.
10324
10325          T :=  Base_Type (Entity (Subtype_Mark (I)));
10326
10327          if not Is_Discrete_Type (T) then
10328             Error_Msg_N ("discrete type required for range", I);
10329             Set_Etype (I, Any_Type);
10330             return;
10331          end if;
10332
10333          R := Range_Expression (Constraint (I));
10334
10335          Resolve (R, T);
10336          Process_Range_Expr_In_Decl (R,
10337            Entity (Subtype_Mark (I)), Related_Nod);
10338
10339       elsif Nkind (I) = N_Attribute_Reference then
10340
10341          --  The parser guarantees that the attribute is a RANGE attribute
10342
10343          Analyze_And_Resolve (I);
10344          T := Etype (I);
10345          R := I;
10346
10347       --  If none of the above, must be a subtype. We convert this to a
10348       --  range attribute reference because in the case of declared first
10349       --  named subtypes, the types in the range reference can be different
10350       --  from the type of the entity. A range attribute normalizes the
10351       --  reference and obtains the correct types for the bounds.
10352
10353       --  This transformation is in the nature of an expansion, is only
10354       --  done if expansion is active. In particular, it is not done on
10355       --  formal generic types,  because we need to retain the name of the
10356       --  original index for instantiation purposes.
10357
10358       else
10359          if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
10360             Error_Msg_N ("invalid subtype mark in discrete range ", I);
10361             Set_Etype (I, Any_Integer);
10362             return;
10363          else
10364             --  The type mark may be that of an incomplete type. It is only
10365             --  now that we can get the full view, previous analysis does
10366             --  not look specifically for a type mark.
10367
10368             Set_Entity (I, Get_Full_View (Entity (I)));
10369             Set_Etype  (I, Entity (I));
10370             Def_Id := Entity (I);
10371
10372             if not Is_Discrete_Type (Def_Id) then
10373                Error_Msg_N ("discrete type required for index", I);
10374                Set_Etype (I, Any_Type);
10375                return;
10376             end if;
10377          end if;
10378
10379          if Expander_Active then
10380             Rewrite (I,
10381               Make_Attribute_Reference (Sloc (I),
10382                 Attribute_Name => Name_Range,
10383                 Prefix         => Relocate_Node (I)));
10384
10385             --  The original was a subtype mark that does not freeze. This
10386             --  means that the rewritten version must not freeze either.
10387
10388             Set_Must_Not_Freeze (I);
10389             Set_Must_Not_Freeze (Prefix (I));
10390
10391             --  Is order critical??? if so, document why, if not
10392             --  use Analyze_And_Resolve
10393
10394             Analyze (I);
10395             T := Etype (I);
10396             Resolve (I, T);
10397             R := I;
10398
10399          else
10400             --  Type is legal, nothing else to construct.
10401             return;
10402          end if;
10403       end if;
10404
10405       if not Is_Discrete_Type (T) then
10406          Error_Msg_N ("discrete type required for range", I);
10407          Set_Etype (I, Any_Type);
10408          return;
10409
10410       elsif T = Any_Type then
10411          Set_Etype (I, Any_Type);
10412          return;
10413       end if;
10414
10415       --  We will now create the appropriate Itype to describe the
10416       --  range, but first a check. If we originally had a subtype,
10417       --  then we just label the range with this subtype. Not only
10418       --  is there no need to construct a new subtype, but it is wrong
10419       --  to do so for two reasons:
10420
10421       --    1. A legality concern, if we have a subtype, it must not
10422       --       freeze, and the Itype would cause freezing incorrectly
10423
10424       --    2. An efficiency concern, if we created an Itype, it would
10425       --       not be recognized as the same type for the purposes of
10426       --       eliminating checks in some circumstances.
10427
10428       --  We signal this case by setting the subtype entity in Def_Id.
10429
10430       --  It would be nice to also do this optimization for the cases
10431       --  of X'Range and also the explicit range X'First .. X'Last,
10432       --  but that is not done yet (it is just an efficiency concern) ???
10433
10434       if No (Def_Id) then
10435
10436          Def_Id :=
10437            Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
10438          Set_Etype (Def_Id, Base_Type (T));
10439
10440          if Is_Signed_Integer_Type (T) then
10441             Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
10442
10443          elsif Is_Modular_Integer_Type (T) then
10444             Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
10445
10446          else
10447             Set_Ekind             (Def_Id, E_Enumeration_Subtype);
10448             Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
10449          end if;
10450
10451          Set_Size_Info      (Def_Id,                  (T));
10452          Set_RM_Size        (Def_Id, RM_Size          (T));
10453          Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
10454
10455          Set_Scalar_Range   (Def_Id, R);
10456          Conditional_Delay  (Def_Id, T);
10457
10458          --  In the subtype indication case, if the immediate parent of the
10459          --  new subtype is non-static, then the subtype we create is non-
10460          --  static, even if its bounds are static.
10461
10462          if Nkind (I) = N_Subtype_Indication
10463            and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
10464          then
10465             Set_Is_Non_Static_Subtype (Def_Id);
10466          end if;
10467       end if;
10468
10469       --  Final step is to label the index with this constructed type
10470
10471       Set_Etype (I, Def_Id);
10472    end Make_Index;
10473
10474    ------------------------------
10475    -- Modular_Type_Declaration --
10476    ------------------------------
10477
10478    procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
10479       Mod_Expr : constant Node_Id := Expression (Def);
10480       M_Val    : Uint;
10481
10482       procedure Set_Modular_Size (Bits : Int);
10483       --  Sets RM_Size to Bits, and Esize to normal word size above this
10484
10485       procedure Set_Modular_Size (Bits : Int) is
10486       begin
10487          Set_RM_Size (T, UI_From_Int (Bits));
10488
10489          if Bits <= 8 then
10490             Init_Esize (T, 8);
10491
10492          elsif Bits <= 16 then
10493             Init_Esize (T, 16);
10494
10495          elsif Bits <= 32 then
10496             Init_Esize (T, 32);
10497
10498          else
10499             Init_Esize (T, System_Max_Binary_Modulus_Power);
10500          end if;
10501       end Set_Modular_Size;
10502
10503    --  Start of processing for Modular_Type_Declaration
10504
10505    begin
10506       Analyze_And_Resolve (Mod_Expr, Any_Integer);
10507       Set_Etype (T, T);
10508       Set_Ekind (T, E_Modular_Integer_Type);
10509       Init_Alignment (T);
10510       Set_Is_Constrained (T);
10511
10512       if not Is_OK_Static_Expression (Mod_Expr) then
10513          Error_Msg_N
10514            ("non-static expression used for modular type bound", Mod_Expr);
10515          M_Val := 2 ** System_Max_Binary_Modulus_Power;
10516       else
10517          M_Val := Expr_Value (Mod_Expr);
10518       end if;
10519
10520       if M_Val < 1 then
10521          Error_Msg_N ("modulus value must be positive", Mod_Expr);
10522          M_Val := 2 ** System_Max_Binary_Modulus_Power;
10523       end if;
10524
10525       Set_Modulus (T, M_Val);
10526
10527       --   Create bounds for the modular type based on the modulus given in
10528       --   the type declaration and then analyze and resolve those bounds.
10529
10530       Set_Scalar_Range (T,
10531         Make_Range (Sloc (Mod_Expr),
10532           Low_Bound  =>
10533             Make_Integer_Literal (Sloc (Mod_Expr), 0),
10534           High_Bound =>
10535             Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
10536
10537       --  Properly analyze the literals for the range. We do this manually
10538       --  because we can't go calling Resolve, since we are resolving these
10539       --  bounds with the type, and this type is certainly not complete yet!
10540
10541       Set_Etype (Low_Bound  (Scalar_Range (T)), T);
10542       Set_Etype (High_Bound (Scalar_Range (T)), T);
10543       Set_Is_Static_Expression (Low_Bound  (Scalar_Range (T)));
10544       Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
10545
10546       --  Loop through powers of two to find number of bits required
10547
10548       for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
10549
10550          --  Binary case
10551
10552          if M_Val = 2 ** Bits then
10553             Set_Modular_Size (Bits);
10554             return;
10555
10556          --  Non-binary case
10557
10558          elsif M_Val < 2 ** Bits then
10559             Set_Non_Binary_Modulus (T);
10560
10561             if Bits > System_Max_Nonbinary_Modulus_Power then
10562                Error_Msg_Uint_1 :=
10563                  UI_From_Int (System_Max_Nonbinary_Modulus_Power);
10564                Error_Msg_N
10565                  ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
10566                Set_Modular_Size (System_Max_Binary_Modulus_Power);
10567                return;
10568
10569             else
10570                --  In the non-binary case, set size as per RM 13.3(55).
10571
10572                Set_Modular_Size (Bits);
10573                return;
10574             end if;
10575          end if;
10576
10577       end loop;
10578
10579       --  If we fall through, then the size exceed System.Max_Binary_Modulus
10580       --  so we just signal an error and set the maximum size.
10581
10582       Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
10583       Error_Msg_N ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
10584
10585       Set_Modular_Size (System_Max_Binary_Modulus_Power);
10586       Init_Alignment (T);
10587
10588    end Modular_Type_Declaration;
10589
10590    -------------------------
10591    -- New_Binary_Operator --
10592    -------------------------
10593
10594    procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
10595       Loc : constant Source_Ptr := Sloc (Typ);
10596       Op  : Entity_Id;
10597
10598       function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
10599       --  Create abbreviated declaration for the formal of a predefined
10600       --  Operator 'Op' of type 'Typ'
10601
10602       --------------------
10603       -- Make_Op_Formal --
10604       --------------------
10605
10606       function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
10607          Formal : Entity_Id;
10608
10609       begin
10610          Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
10611          Set_Etype (Formal, Typ);
10612          Set_Mechanism (Formal, Default_Mechanism);
10613          return Formal;
10614       end Make_Op_Formal;
10615
10616    --  Start of processing for New_Binary_Operator
10617
10618    begin
10619       Op := Make_Defining_Operator_Symbol (Loc, Op_Name);
10620
10621       Set_Ekind                   (Op, E_Operator);
10622       Set_Scope                   (Op, Current_Scope);
10623       Set_Etype                   (Op, Typ);
10624       Set_Homonym                 (Op, Get_Name_Entity_Id (Op_Name));
10625       Set_Is_Immediately_Visible  (Op);
10626       Set_Is_Intrinsic_Subprogram (Op);
10627       Set_Has_Completion          (Op);
10628       Append_Entity               (Op, Current_Scope);
10629
10630       Set_Name_Entity_Id (Op_Name, Op);
10631
10632       Append_Entity (Make_Op_Formal (Typ, Op), Op);
10633       Append_Entity (Make_Op_Formal (Typ, Op), Op);
10634
10635    end New_Binary_Operator;
10636
10637    -------------------------------------------
10638    -- Ordinary_Fixed_Point_Type_Declaration --
10639    -------------------------------------------
10640
10641    procedure Ordinary_Fixed_Point_Type_Declaration
10642      (T   : Entity_Id;
10643       Def : Node_Id)
10644    is
10645       Loc           : constant Source_Ptr := Sloc (Def);
10646       Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
10647       RRS           : constant Node_Id    := Real_Range_Specification (Def);
10648       Implicit_Base : Entity_Id;
10649       Delta_Val     : Ureal;
10650       Small_Val     : Ureal;
10651       Low_Val       : Ureal;
10652       High_Val      : Ureal;
10653
10654    begin
10655       Check_Restriction (No_Fixed_Point, Def);
10656
10657       --  Create implicit base type
10658
10659       Implicit_Base :=
10660         Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
10661       Set_Etype (Implicit_Base, Implicit_Base);
10662
10663       --  Analyze and process delta expression
10664
10665       Analyze_And_Resolve (Delta_Expr, Any_Real);
10666
10667       Check_Delta_Expression (Delta_Expr);
10668       Delta_Val := Expr_Value_R (Delta_Expr);
10669
10670       Set_Delta_Value (Implicit_Base, Delta_Val);
10671
10672       --  Compute default small from given delta, which is the largest
10673       --  power of two that does not exceed the given delta value.
10674
10675       declare
10676          Tmp   : Ureal := Ureal_1;
10677          Scale : Int   := 0;
10678
10679       begin
10680          if Delta_Val < Ureal_1 then
10681             while Delta_Val < Tmp loop
10682                Tmp := Tmp / Ureal_2;
10683                Scale := Scale + 1;
10684             end loop;
10685
10686          else
10687             loop
10688                Tmp := Tmp * Ureal_2;
10689                exit when Tmp > Delta_Val;
10690                Scale := Scale - 1;
10691             end loop;
10692          end if;
10693
10694          Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
10695       end;
10696
10697       Set_Small_Value (Implicit_Base, Small_Val);
10698
10699       --  If no range was given, set a dummy range
10700
10701       if RRS <= Empty_Or_Error then
10702          Low_Val  := -Small_Val;
10703          High_Val := Small_Val;
10704
10705       --  Otherwise analyze and process given range
10706
10707       else
10708          declare
10709             Low  : constant Node_Id := Low_Bound  (RRS);
10710             High : constant Node_Id := High_Bound (RRS);
10711
10712          begin
10713             Analyze_And_Resolve (Low, Any_Real);
10714             Analyze_And_Resolve (High, Any_Real);
10715             Check_Real_Bound (Low);
10716             Check_Real_Bound (High);
10717
10718             --  Obtain and set the range
10719
10720             Low_Val  := Expr_Value_R (Low);
10721             High_Val := Expr_Value_R (High);
10722
10723             if Low_Val > High_Val then
10724                Error_Msg_NE ("?fixed point type& has null range", Def, T);
10725             end if;
10726          end;
10727       end if;
10728
10729       --  The range for both the implicit base and the declared first
10730       --  subtype cannot be set yet, so we use the special routine
10731       --  Set_Fixed_Range to set a temporary range in place. Note that
10732       --  the bounds of the base type will be widened to be symmetrical
10733       --  and to fill the available bits when the type is frozen.
10734
10735       --  We could do this with all discrete types, and probably should, but
10736       --  we absolutely have to do it for fixed-point, since the end-points
10737       --  of the range and the size are determined by the small value, which
10738       --  could be reset before the freeze point.
10739
10740       Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
10741       Set_Fixed_Range (T, Loc, Low_Val, High_Val);
10742
10743       Init_Size_Align (Implicit_Base);
10744
10745       --  Complete definition of first subtype
10746
10747       Set_Ekind          (T, E_Ordinary_Fixed_Point_Subtype);
10748       Set_Etype          (T, Implicit_Base);
10749       Init_Size_Align    (T);
10750       Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
10751       Set_Small_Value    (T, Small_Val);
10752       Set_Delta_Value    (T, Delta_Val);
10753       Set_Is_Constrained (T);
10754
10755    end Ordinary_Fixed_Point_Type_Declaration;
10756
10757    ----------------------------------------
10758    -- Prepare_Private_Subtype_Completion --
10759    ----------------------------------------
10760
10761    procedure Prepare_Private_Subtype_Completion
10762      (Id          : Entity_Id;
10763       Related_Nod : Node_Id)
10764    is
10765       Id_B   : constant Entity_Id := Base_Type (Id);
10766       Full_B : constant Entity_Id := Full_View (Id_B);
10767       Full   : Entity_Id;
10768
10769    begin
10770       if Present (Full_B) then
10771
10772          --  The Base_Type is already completed, we can complete the
10773          --  subtype now. We have to create a new entity with the same name,
10774          --  Thus we can't use Create_Itype.
10775          --  This is messy, should be fixed ???
10776
10777          Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
10778          Set_Is_Itype (Full);
10779          Set_Associated_Node_For_Itype (Full, Related_Nod);
10780          Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
10781       end if;
10782
10783       --  The parent subtype may be private, but the base might not, in some
10784       --  nested instances. In that case, the subtype does not need to be
10785       --  exchanged. It would still be nice to make private subtypes and their
10786       --  bases consistent at all times ???
10787
10788       if Is_Private_Type (Id_B) then
10789          Append_Elmt (Id, Private_Dependents (Id_B));
10790       end if;
10791
10792    end Prepare_Private_Subtype_Completion;
10793
10794    ---------------------------
10795    -- Process_Discriminants --
10796    ---------------------------
10797
10798    procedure Process_Discriminants (N : Node_Id) is
10799       Id                  : Node_Id;
10800       Discr               : Node_Id;
10801       Discr_Number        : Uint;
10802       Discr_Type          : Entity_Id;
10803       Default_Present     : Boolean := False;
10804       Default_Not_Present : Boolean := False;
10805       Elist               : Elist_Id := New_Elmt_List;
10806
10807    begin
10808       --  A composite type other than an array type can have discriminants.
10809       --  Discriminants of non-limited types must have a discrete type.
10810       --  On entry, the current scope is the composite type.
10811
10812       --  The discriminants are initially entered into the scope of the type
10813       --  via Enter_Name with the default Ekind of E_Void to prevent premature
10814       --  use, as explained at the end of this procedure.
10815
10816       Discr := First (Discriminant_Specifications (N));
10817       while Present (Discr) loop
10818          Enter_Name (Defining_Identifier (Discr));
10819
10820          if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
10821             Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
10822
10823          else
10824             Find_Type (Discriminant_Type (Discr));
10825             Discr_Type := Etype (Discriminant_Type (Discr));
10826
10827             if Error_Posted (Discriminant_Type (Discr)) then
10828                Discr_Type := Any_Type;
10829             end if;
10830          end if;
10831
10832          if Is_Access_Type (Discr_Type) then
10833             Check_Access_Discriminant_Requires_Limited
10834               (Discr, Discriminant_Type (Discr));
10835
10836             if Ada_83 and then Comes_From_Source (Discr) then
10837                Error_Msg_N
10838                  ("(Ada 83) access discriminant not allowed", Discr);
10839             end if;
10840
10841          elsif not Is_Discrete_Type (Discr_Type) then
10842             Error_Msg_N ("discriminants must have a discrete or access type",
10843               Discriminant_Type (Discr));
10844          end if;
10845
10846          Set_Etype (Defining_Identifier (Discr), Discr_Type);
10847
10848          --  If a discriminant specification includes the assignment compound
10849          --  delimiter followed by an expression, the expression is the default
10850          --  expression of the discriminant; the default expression must be of
10851          --  the type of the discriminant. (RM 3.7.1) Since this expression is
10852          --  a default expression, we do the special preanalysis, since this
10853          --  expression does not freeze (see "Handling of Default Expressions"
10854          --  in spec of package Sem).
10855
10856          if Present (Expression (Discr)) then
10857             Analyze_Default_Expression (Expression (Discr), Discr_Type);
10858
10859             if Nkind (N) = N_Formal_Type_Declaration then
10860                Error_Msg_N
10861                  ("discriminant defaults not allowed for formal type",
10862                   Expression (Discr));
10863
10864             elsif Is_Tagged_Type (Current_Scope) then
10865                Error_Msg_N
10866                  ("discriminants of tagged type cannot have defaults",
10867                   Expression (Discr));
10868
10869             else
10870                Default_Present := True;
10871                Append_Elmt (Expression (Discr), Elist);
10872
10873                --  Tag the defining identifiers for the discriminants with
10874                --  their corresponding default expressions from the tree.
10875
10876                Set_Discriminant_Default_Value
10877                  (Defining_Identifier (Discr), Expression (Discr));
10878             end if;
10879
10880          else
10881             Default_Not_Present := True;
10882          end if;
10883
10884          Next (Discr);
10885       end loop;
10886
10887       --  An element list consisting of the default expressions of the
10888       --  discriminants is constructed in the above loop and used to set
10889       --  the Discriminant_Constraint attribute for the type. If an object
10890       --  is declared of this (record or task) type without any explicit
10891       --  discriminant constraint given, this element list will form the
10892       --  actual parameters for the corresponding initialization procedure
10893       --  for the type.
10894
10895       Set_Discriminant_Constraint (Current_Scope, Elist);
10896       Set_Girder_Constraint (Current_Scope, No_Elist);
10897
10898       --  Default expressions must be provided either for all or for none
10899       --  of the discriminants of a discriminant part. (RM 3.7.1)
10900
10901       if Default_Present and then Default_Not_Present then
10902          Error_Msg_N
10903            ("incomplete specification of defaults for discriminants", N);
10904       end if;
10905
10906       --  The use of the name of a discriminant is not allowed in default
10907       --  expressions of a discriminant part if the specification of the
10908       --  discriminant is itself given in the discriminant part. (RM 3.7.1)
10909
10910       --  To detect this, the discriminant names are entered initially with an
10911       --  Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
10912       --  attempt to use a void entity (for example in an expression that is
10913       --  type-checked) produces the error message: premature usage. Now after
10914       --  completing the semantic analysis of the discriminant part, we can set
10915       --  the Ekind of all the discriminants appropriately.
10916
10917       Discr := First (Discriminant_Specifications (N));
10918       Discr_Number := Uint_1;
10919
10920       while Present (Discr) loop
10921          Id := Defining_Identifier (Discr);
10922          Set_Ekind (Id, E_Discriminant);
10923          Init_Component_Location (Id);
10924          Init_Esize (Id);
10925          Set_Discriminant_Number (Id, Discr_Number);
10926
10927          --  Make sure this is always set, even in illegal programs
10928
10929          Set_Corresponding_Discriminant (Id, Empty);
10930
10931          --  Initialize the Original_Record_Component to the entity itself.
10932          --  Inherit_Components will propagate the right value to
10933          --  discriminants in derived record types.
10934
10935          Set_Original_Record_Component (Id, Id);
10936
10937          --  Create the discriminal for the discriminant.
10938
10939          Build_Discriminal (Id);
10940
10941          Next (Discr);
10942          Discr_Number := Discr_Number + 1;
10943       end loop;
10944
10945       Set_Has_Discriminants (Current_Scope);
10946    end Process_Discriminants;
10947
10948    -----------------------
10949    -- Process_Full_View --
10950    -----------------------
10951
10952    procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
10953       Priv_Parent : Entity_Id;
10954       Full_Parent : Entity_Id;
10955       Full_Indic  : Node_Id;
10956
10957    begin
10958       --  First some sanity checks that must be done after semantic
10959       --  decoration of the full view and thus cannot be placed with other
10960       --  similar checks in Find_Type_Name
10961
10962       if not Is_Limited_Type (Priv_T)
10963         and then (Is_Limited_Type (Full_T)
10964                    or else Is_Limited_Composite (Full_T))
10965       then
10966          Error_Msg_N
10967            ("completion of nonlimited type cannot be limited", Full_T);
10968
10969       elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then
10970          Error_Msg_N
10971            ("completion of nonabstract type cannot be abstract", Full_T);
10972
10973       elsif Is_Tagged_Type (Priv_T)
10974         and then Is_Limited_Type (Priv_T)
10975         and then not Is_Limited_Type (Full_T)
10976       then
10977          --  GNAT allow its own definition of Limited_Controlled to disobey
10978          --  this rule in order in ease the implementation. The next test is
10979          --  safe because Root_Controlled is defined in a private system child
10980
10981          if Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
10982             Set_Is_Limited_Composite (Full_T);
10983          else
10984             Error_Msg_N
10985               ("completion of limited tagged type must be limited", Full_T);
10986          end if;
10987
10988       elsif Is_Generic_Type (Priv_T) then
10989          Error_Msg_N ("generic type cannot have a completion", Full_T);
10990       end if;
10991
10992       if Is_Tagged_Type (Priv_T)
10993         and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
10994         and then Is_Derived_Type (Full_T)
10995       then
10996          Priv_Parent := Etype (Priv_T);
10997
10998          --  The full view of a private extension may have been transformed
10999          --  into an unconstrained derived type declaration and a subtype
11000          --  declaration (see build_derived_record_type for details).
11001
11002          if Nkind (N) = N_Subtype_Declaration then
11003             Full_Indic  := Subtype_Indication (N);
11004             Full_Parent := Etype (Base_Type (Full_T));
11005          else
11006             Full_Indic  := Subtype_Indication (Type_Definition (N));
11007             Full_Parent := Etype (Full_T);
11008          end if;
11009
11010          --  Check that the parent type of the full type is a descendant of
11011          --  the ancestor subtype given in the private extension. If either
11012          --  entity has an Etype equal to Any_Type then we had some previous
11013          --  error situation [7.3(8)].
11014
11015          if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
11016             return;
11017
11018          elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
11019             Error_Msg_N
11020               ("parent of full type must descend from parent"
11021                   & " of private extension", Full_Indic);
11022
11023          --  Check the rules of 7.3(10): if the private extension inherits
11024          --  known discriminants, then the full type must also inherit those
11025          --  discriminants from the same (ancestor) type, and the parent
11026          --  subtype of the full type must be constrained if and only if
11027          --  the ancestor subtype of the private extension is constrained.
11028
11029          elsif not Present (Discriminant_Specifications (Parent (Priv_T)))
11030            and then not Has_Unknown_Discriminants (Priv_T)
11031            and then Has_Discriminants (Base_Type (Priv_Parent))
11032          then
11033             declare
11034                Priv_Indic  : constant Node_Id :=
11035                                Subtype_Indication (Parent (Priv_T));
11036
11037                Priv_Constr : constant Boolean :=
11038                                Is_Constrained (Priv_Parent)
11039                                  or else
11040                                    Nkind (Priv_Indic) = N_Subtype_Indication
11041                                  or else Is_Constrained (Entity (Priv_Indic));
11042
11043                Full_Constr : constant Boolean :=
11044                                Is_Constrained (Full_Parent)
11045                                  or else
11046                                    Nkind (Full_Indic) = N_Subtype_Indication
11047                                  or else Is_Constrained (Entity (Full_Indic));
11048
11049                Priv_Discr : Entity_Id;
11050                Full_Discr : Entity_Id;
11051
11052             begin
11053                Priv_Discr := First_Discriminant (Priv_Parent);
11054                Full_Discr := First_Discriminant (Full_Parent);
11055
11056                while Present (Priv_Discr) and then Present (Full_Discr) loop
11057                   if Original_Record_Component (Priv_Discr) =
11058                      Original_Record_Component (Full_Discr)
11059                     or else
11060                      Corresponding_Discriminant (Priv_Discr) =
11061                      Corresponding_Discriminant (Full_Discr)
11062                   then
11063                      null;
11064                   else
11065                      exit;
11066                   end if;
11067
11068                   Next_Discriminant (Priv_Discr);
11069                   Next_Discriminant (Full_Discr);
11070                end loop;
11071
11072                if Present (Priv_Discr) or else Present (Full_Discr) then
11073                   Error_Msg_N
11074                     ("full view must inherit discriminants of the parent type"
11075                      & " used in the private extension", Full_Indic);
11076
11077                elsif Priv_Constr and then not Full_Constr then
11078                   Error_Msg_N
11079                     ("parent subtype of full type must be constrained",
11080                      Full_Indic);
11081
11082                elsif Full_Constr and then not Priv_Constr then
11083                   Error_Msg_N
11084                     ("parent subtype of full type must be unconstrained",
11085                      Full_Indic);
11086                end if;
11087             end;
11088
11089          --  Check the rules of 7.3(12): if a partial view has neither known
11090          --  or unknown discriminants, then the full type declaration shall
11091          --  define a definite subtype.
11092
11093          elsif      not Has_Unknown_Discriminants (Priv_T)
11094            and then not Has_Discriminants (Priv_T)
11095            and then not Is_Constrained (Full_T)
11096          then
11097             Error_Msg_N
11098               ("full view must define a constrained type if partial view"
11099                & " has no discriminants", Full_T);
11100          end if;
11101
11102          --  ??????? Do we implement the following properly ?????
11103          --  If the ancestor subtype of a private extension has constrained
11104          --  discriminants, then the parent subtype of the full view shall
11105          --  impose a statically matching constraint on those discriminants
11106          --  [7.3(13)].
11107
11108       else
11109          --  For untagged types, verify that a type without discriminants
11110          --  is not completed with an unconstrained type.
11111
11112          if not Is_Indefinite_Subtype (Priv_T)
11113            and then Is_Indefinite_Subtype (Full_T)
11114          then
11115             Error_Msg_N ("full view of type must be definite subtype", Full_T);
11116          end if;
11117       end if;
11118
11119       --  Create a full declaration for all its subtypes recorded in
11120       --  Private_Dependents and swap them similarly to the base type.
11121       --  These are subtypes that have been define before the full
11122       --  declaration of the private type. We also swap the entry in
11123       --  Private_Dependents list so we can properly restore the
11124       --  private view on exit from the scope.
11125
11126       declare
11127          Priv_Elmt : Elmt_Id;
11128          Priv      : Entity_Id;
11129          Full      : Entity_Id;
11130
11131       begin
11132          Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
11133          while Present (Priv_Elmt) loop
11134             Priv := Node (Priv_Elmt);
11135
11136             if Ekind (Priv) = E_Private_Subtype
11137               or else Ekind (Priv) = E_Limited_Private_Subtype
11138               or else Ekind (Priv) = E_Record_Subtype_With_Private
11139             then
11140                Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
11141                Set_Is_Itype (Full);
11142                Set_Parent (Full, Parent (Priv));
11143                Set_Associated_Node_For_Itype (Full, N);
11144
11145                --  Now we need to complete the private subtype, but since the
11146                --  base type has already been swapped, we must also swap the
11147                --  subtypes (and thus, reverse the arguments in the call to
11148                --  Complete_Private_Subtype).
11149
11150                Copy_And_Swap (Priv, Full);
11151                Complete_Private_Subtype (Full, Priv, Full_T, N);
11152                Replace_Elmt (Priv_Elmt, Full);
11153             end if;
11154
11155             Next_Elmt (Priv_Elmt);
11156          end loop;
11157       end;
11158
11159       --  If the private view was tagged, copy the new Primitive
11160       --  operations from the private view to the full view.
11161
11162       if Is_Tagged_Type (Full_T) then
11163          declare
11164             Priv_List : Elist_Id;
11165             Full_List : constant Elist_Id := Primitive_Operations (Full_T);
11166             P1, P2    : Elmt_Id;
11167             Prim      : Entity_Id;
11168             D_Type    : Entity_Id;
11169
11170          begin
11171             if Is_Tagged_Type (Priv_T) then
11172                Priv_List := Primitive_Operations (Priv_T);
11173
11174                P1 := First_Elmt (Priv_List);
11175                while Present (P1) loop
11176                   Prim := Node (P1);
11177
11178                   --  Transfer explicit primitives, not those inherited from
11179                   --  parent of partial view, which will be re-inherited on
11180                   --  the full view.
11181
11182                   if Comes_From_Source (Prim) then
11183                      P2 := First_Elmt (Full_List);
11184                      while Present (P2) and then Node (P2) /= Prim loop
11185                         Next_Elmt (P2);
11186                      end loop;
11187
11188                      --  If not found, that is a new one
11189
11190                      if No (P2) then
11191                         Append_Elmt (Prim, Full_List);
11192                      end if;
11193                   end if;
11194
11195                   Next_Elmt (P1);
11196                end loop;
11197
11198             else
11199                --  In this case the partial view is untagged, so here we
11200                --  locate all of the earlier primitives that need to be
11201                --  treated as dispatching (those that appear between the
11202                --  two views). Note that these additional operations must
11203                --  all be new operations (any earlier operations that
11204                --  override inherited operations of the full view will
11205                --  already have been inserted in the primitives list and
11206                --  marked as dispatching by Check_Operation_From_Private_View.
11207                --  Note that implicit "/=" operators are excluded from being
11208                --  added to the primitives list since they shouldn't be
11209                --  treated as dispatching (tagged "/=" is handled specially).
11210
11211                Prim := Next_Entity (Full_T);
11212                while Present (Prim) and then Prim /= Priv_T loop
11213                   if (Ekind (Prim) = E_Procedure
11214                        or else Ekind (Prim) = E_Function)
11215                   then
11216
11217                      D_Type := Find_Dispatching_Type (Prim);
11218
11219                      if D_Type = Full_T
11220                        and then (Chars (Prim) /= Name_Op_Ne
11221                                   or else Comes_From_Source (Prim))
11222                      then
11223                         Check_Controlling_Formals (Full_T, Prim);
11224
11225                         if not Is_Dispatching_Operation (Prim) then
11226                            Append_Elmt (Prim, Full_List);
11227                            Set_Is_Dispatching_Operation (Prim, True);
11228                            Set_DT_Position (Prim, No_Uint);
11229                         end if;
11230
11231                      elsif Is_Dispatching_Operation (Prim)
11232                        and then D_Type  /= Full_T
11233                      then
11234
11235                         --  Verify that it is not otherwise controlled by
11236                         --  a formal or a return value ot type T.
11237
11238                         Check_Controlling_Formals (D_Type, Prim);
11239                      end if;
11240                   end if;
11241
11242                   Next_Entity (Prim);
11243                end loop;
11244             end if;
11245
11246             --  For the tagged case, the two views can share the same
11247             --  Primitive Operation list and the same class wide type.
11248             --  Update attributes of the class-wide type which depend on
11249             --  the full declaration.
11250
11251             if Is_Tagged_Type (Priv_T) then
11252                Set_Primitive_Operations (Priv_T, Full_List);
11253                Set_Class_Wide_Type
11254                  (Base_Type (Full_T), Class_Wide_Type (Priv_T));
11255
11256                --  Any other attributes should be propagated to C_W ???
11257
11258                Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
11259
11260             end if;
11261          end;
11262       end if;
11263    end Process_Full_View;
11264
11265    -----------------------------------
11266    -- Process_Incomplete_Dependents --
11267    -----------------------------------
11268
11269    procedure Process_Incomplete_Dependents
11270      (N      : Node_Id;
11271       Full_T : Entity_Id;
11272       Inc_T  : Entity_Id)
11273    is
11274       Inc_Elmt : Elmt_Id;
11275       Priv_Dep : Entity_Id;
11276       New_Subt : Entity_Id;
11277
11278       Disc_Constraint : Elist_Id;
11279
11280    begin
11281       if No (Private_Dependents (Inc_T)) then
11282          return;
11283
11284       else
11285          Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
11286
11287          --  Itypes that may be generated by the completion of an incomplete
11288          --  subtype are not used by the back-end and not attached to the tree.
11289          --  They are created only for constraint-checking purposes.
11290       end if;
11291
11292       while Present (Inc_Elmt) loop
11293          Priv_Dep := Node (Inc_Elmt);
11294
11295          if Ekind (Priv_Dep) = E_Subprogram_Type then
11296
11297             --  An Access_To_Subprogram type may have a return type or a
11298             --  parameter type that is incomplete. Replace with the full view.
11299
11300             if Etype (Priv_Dep) = Inc_T then
11301                Set_Etype (Priv_Dep, Full_T);
11302             end if;
11303
11304             declare
11305                Formal : Entity_Id;
11306
11307             begin
11308                Formal := First_Formal (Priv_Dep);
11309
11310                while Present (Formal) loop
11311
11312                   if Etype (Formal) = Inc_T then
11313                      Set_Etype (Formal, Full_T);
11314                   end if;
11315
11316                   Next_Formal (Formal);
11317                end loop;
11318             end;
11319
11320          elsif  Is_Overloadable (Priv_Dep) then
11321
11322             if Is_Tagged_Type (Full_T) then
11323
11324                --  Subprogram has an access parameter whose designated type
11325                --  was incomplete. Reexamine declaration now, because it may
11326                --  be a primitive operation of the full type.
11327
11328                Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
11329                Set_Is_Dispatching_Operation (Priv_Dep);
11330                Check_Controlling_Formals (Full_T, Priv_Dep);
11331             end if;
11332
11333          elsif Ekind (Priv_Dep) = E_Subprogram_Body then
11334
11335             --  Can happen during processing of a body before the completion
11336             --  of a TA type. Ignore, because spec is also on dependent list.
11337
11338             return;
11339
11340          --  Dependent is a subtype
11341
11342          else
11343             --  We build a new subtype indication using the full view of the
11344             --  incomplete parent. The discriminant constraints have been
11345             --  elaborated already at the point of the subtype declaration.
11346
11347             New_Subt := Create_Itype (E_Void, N);
11348
11349             if Has_Discriminants (Full_T) then
11350                Disc_Constraint := Discriminant_Constraint (Priv_Dep);
11351             else
11352                Disc_Constraint := No_Elist;
11353             end if;
11354
11355             Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
11356             Set_Full_View (Priv_Dep, New_Subt);
11357          end if;
11358
11359          Next_Elmt (Inc_Elmt);
11360       end loop;
11361
11362    end Process_Incomplete_Dependents;
11363
11364    --------------------------------
11365    -- Process_Range_Expr_In_Decl --
11366    --------------------------------
11367
11368    procedure Process_Range_Expr_In_Decl
11369      (R           : Node_Id;
11370       T           : Entity_Id;
11371       Related_Nod : Node_Id;
11372       Check_List  : List_Id := Empty_List;
11373       R_Check_Off : Boolean := False)
11374    is
11375       Lo, Hi    : Node_Id;
11376       R_Checks  : Check_Result;
11377       Type_Decl : Node_Id;
11378       Def_Id    : Entity_Id;
11379
11380    begin
11381       Analyze_And_Resolve (R, Base_Type (T));
11382
11383       if Nkind (R) = N_Range then
11384          Lo := Low_Bound (R);
11385          Hi := High_Bound (R);
11386
11387          --  If there were errors in the declaration, try and patch up some
11388          --  common mistakes in the bounds. The cases handled are literals
11389          --  which are Integer where the expected type is Real and vice versa.
11390          --  These corrections allow the compilation process to proceed further
11391          --  along since some basic assumptions of the format of the bounds
11392          --  are guaranteed.
11393
11394          if Etype (R) = Any_Type then
11395
11396             if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
11397                Rewrite (Lo,
11398                  Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
11399
11400             elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
11401                Rewrite (Hi,
11402                  Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
11403
11404             elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
11405                Rewrite (Lo,
11406                  Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
11407
11408             elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
11409                Rewrite (Hi,
11410                  Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
11411             end if;
11412
11413             Set_Etype (Lo, T);
11414             Set_Etype (Hi, T);
11415          end if;
11416
11417          --  If the bounds of the range have been mistakenly given as
11418          --  string literals (perhaps in place of character literals),
11419          --  then an error has already been reported, but we rewrite
11420          --  the string literal as a bound of the range's type to
11421          --  avoid blowups in later processing that looks at static
11422          --  values.
11423
11424          if Nkind (Lo) = N_String_Literal then
11425             Rewrite (Lo,
11426               Make_Attribute_Reference (Sloc (Lo),
11427                 Attribute_Name => Name_First,
11428                 Prefix => New_Reference_To (T, Sloc (Lo))));
11429             Analyze_And_Resolve (Lo);
11430          end if;
11431
11432          if Nkind (Hi) = N_String_Literal then
11433             Rewrite (Hi,
11434               Make_Attribute_Reference (Sloc (Hi),
11435                 Attribute_Name => Name_First,
11436                 Prefix => New_Reference_To (T, Sloc (Hi))));
11437             Analyze_And_Resolve (Hi);
11438          end if;
11439
11440          --  If bounds aren't scalar at this point then exit, avoiding
11441          --  problems with further processing of the range in this procedure.
11442
11443          if not Is_Scalar_Type (Etype (Lo)) then
11444             return;
11445          end if;
11446
11447          --  Resolve (actually Sem_Eval) has checked that the bounds are in
11448          --  then range of the base type. Here we check whether the bounds
11449          --  are in the range of the subtype itself. Note that if the bounds
11450          --  represent the null range the Constraint_Error exception should
11451          --  not be raised.
11452
11453          --  ??? The following code should be cleaned up as follows
11454          --  1. The Is_Null_Range (Lo, Hi) test should disapper since it
11455          --     is done in the call to Range_Check (R, T); below
11456          --  2. The use of R_Check_Off should be investigated and possibly
11457          --     removed, this would clean up things a bit.
11458
11459          if Is_Null_Range (Lo, Hi) then
11460             null;
11461
11462          else
11463             --  We use a flag here instead of suppressing checks on the
11464             --  type because the type we check against isn't necessarily the
11465             --  place where we put the check.
11466
11467             if not R_Check_Off then
11468                R_Checks := Range_Check (R, T);
11469                Type_Decl := Parent (R);
11470
11471                --  Look up tree to find an appropriate insertion point.
11472                --  This seems really junk code, and very brittle, couldn't
11473                --  we just use an insert actions call of some kind ???
11474
11475                while Present (Type_Decl) and then not
11476                  (Nkind (Type_Decl) = N_Full_Type_Declaration
11477                     or else
11478                   Nkind (Type_Decl) = N_Subtype_Declaration
11479                     or else
11480                   Nkind (Type_Decl) = N_Loop_Statement
11481                     or else
11482                   Nkind (Type_Decl) = N_Task_Type_Declaration
11483                     or else
11484                   Nkind (Type_Decl) = N_Single_Task_Declaration
11485                     or else
11486                   Nkind (Type_Decl) = N_Protected_Type_Declaration
11487                     or else
11488                   Nkind (Type_Decl) = N_Single_Protected_Declaration)
11489                loop
11490                   Type_Decl := Parent (Type_Decl);
11491                end loop;
11492
11493                --  Why would Type_Decl not be present???  Without this test,
11494                --  short regression tests fail.
11495
11496                if Present (Type_Decl) then
11497                   if Nkind (Type_Decl) = N_Loop_Statement then
11498                      declare
11499                         Indic : Node_Id := Parent (R);
11500                      begin
11501                         while Present (Indic) and then not
11502                           (Nkind (Indic) = N_Subtype_Indication)
11503                         loop
11504                            Indic := Parent (Indic);
11505                         end loop;
11506
11507                         if Present (Indic) then
11508                            Def_Id := Etype (Subtype_Mark (Indic));
11509
11510                            Insert_Range_Checks
11511                              (R_Checks,
11512                               Type_Decl,
11513                               Def_Id,
11514                               Sloc (Type_Decl),
11515                               R,
11516                               Do_Before => True);
11517                         end if;
11518                      end;
11519                   else
11520                      Def_Id := Defining_Identifier (Type_Decl);
11521
11522                      if (Ekind (Def_Id) = E_Record_Type
11523                           and then Depends_On_Discriminant (R))
11524                        or else
11525                         (Ekind (Def_Id) = E_Protected_Type
11526                           and then Has_Discriminants (Def_Id))
11527                      then
11528                         Append_Range_Checks
11529                           (R_Checks, Check_List, Def_Id, Sloc (Type_Decl), R);
11530
11531                      else
11532                         Insert_Range_Checks
11533                           (R_Checks, Type_Decl, Def_Id, Sloc (Type_Decl), R);
11534
11535                      end if;
11536                   end if;
11537                end if;
11538             end if;
11539          end if;
11540       end if;
11541
11542       Get_Index_Bounds (R, Lo, Hi);
11543
11544       if Expander_Active then
11545          Force_Evaluation (Lo);
11546          Force_Evaluation (Hi);
11547       end if;
11548
11549    end Process_Range_Expr_In_Decl;
11550
11551    --------------------------------------
11552    -- Process_Real_Range_Specification --
11553    --------------------------------------
11554
11555    procedure Process_Real_Range_Specification (Def : Node_Id) is
11556       Spec : constant Node_Id := Real_Range_Specification (Def);
11557       Lo   : Node_Id;
11558       Hi   : Node_Id;
11559       Err  : Boolean := False;
11560
11561       procedure Analyze_Bound (N : Node_Id);
11562       --  Analyze and check one bound
11563
11564       procedure Analyze_Bound (N : Node_Id) is
11565       begin
11566          Analyze_And_Resolve (N, Any_Real);
11567
11568          if not Is_OK_Static_Expression (N) then
11569             Error_Msg_N
11570               ("bound in real type definition is not static", N);
11571             Err := True;
11572          end if;
11573       end Analyze_Bound;
11574
11575    begin
11576       if Present (Spec) then
11577          Lo := Low_Bound (Spec);
11578          Hi := High_Bound (Spec);
11579          Analyze_Bound (Lo);
11580          Analyze_Bound (Hi);
11581
11582          --  If error, clear away junk range specification
11583
11584          if Err then
11585             Set_Real_Range_Specification (Def, Empty);
11586          end if;
11587       end if;
11588    end Process_Real_Range_Specification;
11589
11590    ---------------------
11591    -- Process_Subtype --
11592    ---------------------
11593
11594    function Process_Subtype
11595      (S           : Node_Id;
11596       Related_Nod : Node_Id;
11597       Related_Id  : Entity_Id := Empty;
11598       Suffix      : Character := ' ')
11599       return        Entity_Id
11600    is
11601       P               : Node_Id;
11602       Def_Id          : Entity_Id;
11603       Full_View_Id    : Entity_Id;
11604       Subtype_Mark_Id : Entity_Id;
11605       N_Dynamic_Ityp  : Node_Id := Empty;
11606
11607    begin
11608       --  Case of constraint present, so that we have an N_Subtype_Indication
11609       --  node (this node is created only if constraints are present).
11610
11611       if Nkind (S) = N_Subtype_Indication then
11612          Find_Type (Subtype_Mark (S));
11613
11614          if Nkind (Parent (S)) /= N_Access_To_Object_Definition
11615            and then not
11616             (Nkind (Parent (S)) = N_Subtype_Declaration
11617               and then
11618              Is_Itype (Defining_Identifier (Parent (S))))
11619          then
11620             Check_Incomplete (Subtype_Mark (S));
11621          end if;
11622
11623          P := Parent (S);
11624          Subtype_Mark_Id := Entity (Subtype_Mark (S));
11625
11626          if Is_Unchecked_Union (Subtype_Mark_Id)
11627            and then Comes_From_Source (Related_Nod)
11628          then
11629             Error_Msg_N
11630               ("cannot create subtype of Unchecked_Union", Related_Nod);
11631          end if;
11632
11633          --  Explicit subtype declaration case
11634
11635          if Nkind (P) = N_Subtype_Declaration then
11636             Def_Id := Defining_Identifier (P);
11637
11638          --  Explicit derived type definition case
11639
11640          elsif Nkind (P) = N_Derived_Type_Definition then
11641             Def_Id := Defining_Identifier (Parent (P));
11642
11643          --  Implicit case, the Def_Id must be created as an implicit type.
11644          --  The one exception arises in the case of concurrent types,
11645          --  array and access types, where other subsidiary implicit types
11646          --  may be created and must appear before the main implicit type.
11647          --  In these cases we leave Def_Id set to Empty as a signal that
11648          --  Create_Itype has not yet been called to create Def_Id.
11649
11650          else
11651             if Is_Array_Type (Subtype_Mark_Id)
11652               or else Is_Concurrent_Type (Subtype_Mark_Id)
11653               or else Is_Access_Type (Subtype_Mark_Id)
11654             then
11655                Def_Id := Empty;
11656
11657             --  For the other cases, we create a new unattached Itype,
11658             --  and set the indication to ensure it gets attached later.
11659
11660             else
11661                Def_Id :=
11662                  Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
11663             end if;
11664
11665             N_Dynamic_Ityp := Related_Nod;
11666          end if;
11667
11668          --  If the kind of constraint is invalid for this kind of type,
11669          --  then give an error, and then pretend no constraint was given.
11670
11671          if not Is_Valid_Constraint_Kind
11672                    (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
11673          then
11674             Error_Msg_N
11675               ("incorrect constraint for this kind of type", Constraint (S));
11676
11677             Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
11678
11679             --  Make recursive call, having got rid of the bogus constraint
11680
11681             return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
11682          end if;
11683
11684          --  Remaining processing depends on type
11685
11686          case Ekind (Subtype_Mark_Id) is
11687
11688             when Access_Kind =>
11689                Constrain_Access (Def_Id, S, Related_Nod);
11690
11691             when Array_Kind =>
11692                Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
11693
11694             when Decimal_Fixed_Point_Kind =>
11695                Constrain_Decimal (Def_Id, S, N_Dynamic_Ityp);
11696
11697             when Enumeration_Kind =>
11698                Constrain_Enumeration (Def_Id, S, N_Dynamic_Ityp);
11699
11700             when Ordinary_Fixed_Point_Kind =>
11701                Constrain_Ordinary_Fixed (Def_Id, S, N_Dynamic_Ityp);
11702
11703             when Float_Kind =>
11704                Constrain_Float (Def_Id, S, N_Dynamic_Ityp);
11705
11706             when Integer_Kind =>
11707                Constrain_Integer (Def_Id, S, N_Dynamic_Ityp);
11708
11709             when E_Record_Type     |
11710                  E_Record_Subtype  |
11711                  Class_Wide_Kind   |
11712                  E_Incomplete_Type =>
11713                Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
11714
11715             when Private_Kind =>
11716                Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
11717                Set_Private_Dependents (Def_Id, New_Elmt_List);
11718
11719                --  In case of an invalid constraint prevent further processing
11720                --  since the type constructed is missing expected fields.
11721
11722                if Etype (Def_Id) = Any_Type then
11723                   return Def_Id;
11724                end if;
11725
11726                --  If the full view is that of a task with discriminants,
11727                --  we must constrain both the concurrent type and its
11728                --  corresponding record type. Otherwise we will just propagate
11729                --  the constraint to the full view, if available.
11730
11731                if Present (Full_View (Subtype_Mark_Id))
11732                  and then Has_Discriminants (Subtype_Mark_Id)
11733                  and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
11734                then
11735                   Full_View_Id :=
11736                     Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
11737
11738                   Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
11739                   Constrain_Concurrent (Full_View_Id, S,
11740                     Related_Nod, Related_Id, Suffix);
11741                   Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
11742                   Set_Full_View (Def_Id, Full_View_Id);
11743
11744                else
11745                   Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
11746                end if;
11747
11748             when Concurrent_Kind  =>
11749                Constrain_Concurrent (Def_Id, S,
11750                  Related_Nod, Related_Id, Suffix);
11751
11752             when others =>
11753                Error_Msg_N ("invalid subtype mark in subtype indication", S);
11754          end case;
11755
11756          --  Size and Convention are always inherited from the base type
11757
11758          Set_Size_Info  (Def_Id,            (Subtype_Mark_Id));
11759          Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
11760
11761          return Def_Id;
11762
11763       --  Case of no constraints present
11764
11765       else
11766          Find_Type (S);
11767          Check_Incomplete (S);
11768          return Entity (S);
11769       end if;
11770    end Process_Subtype;
11771
11772    -----------------------------
11773    -- Record_Type_Declaration --
11774    -----------------------------
11775
11776    procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
11777       Def : constant Node_Id := Type_Definition (N);
11778       Range_Checks_Suppressed_Flag : Boolean := False;
11779
11780       Is_Tagged : Boolean;
11781       Tag_Comp  : Entity_Id;
11782
11783    begin
11784       --  The flag Is_Tagged_Type might have already been set by Find_Type_Name
11785       --  if it detected an error for declaration T. This arises in the case of
11786       --  private tagged types where the full view omits the word tagged.
11787
11788       Is_Tagged := Tagged_Present (Def)
11789         or else (Errors_Detected > 0 and then Is_Tagged_Type (T));
11790
11791       --  Records constitute a scope for the component declarations within.
11792       --  The scope is created prior to the processing of these declarations.
11793       --  Discriminants are processed first, so that they are visible when
11794       --  processing the other components. The Ekind of the record type itself
11795       --  is set to E_Record_Type (subtypes appear as E_Record_Subtype).
11796
11797       --  Enter record scope
11798
11799       New_Scope (T);
11800
11801       --  These flags must be initialized before calling Process_Discriminants
11802       --  because this routine makes use of them.
11803
11804       Set_Is_Tagged_Type     (T, Is_Tagged);
11805       Set_Is_Limited_Record  (T, Limited_Present (Def));
11806
11807       --  Type is abstract if full declaration carries keyword, or if
11808       --  previous partial view did.
11809
11810       Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def));
11811
11812       Set_Ekind       (T, E_Record_Type);
11813       Set_Etype       (T, T);
11814       Init_Size_Align (T);
11815
11816       Set_Girder_Constraint (T, No_Elist);
11817
11818       --  If an incomplete or private type declaration was already given for
11819       --  the type, then this scope already exists, and the discriminants have
11820       --  been declared within. We must verify that the full declaration
11821       --  matches the incomplete one.
11822
11823       Check_Or_Process_Discriminants (N, T);
11824
11825       Set_Is_Constrained     (T, not Has_Discriminants (T));
11826       Set_Has_Delayed_Freeze (T, True);
11827
11828       --  For tagged types add a manually analyzed component corresponding
11829       --  to the component _tag, the corresponding piece of tree will be
11830       --  expanded as part of the freezing actions if it is not a CPP_Class.
11831
11832       if Is_Tagged then
11833          --  Do not add the tag unless we are in expansion mode.
11834
11835          if Expander_Active then
11836             Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
11837             Enter_Name (Tag_Comp);
11838
11839             Set_Is_Tag                    (Tag_Comp);
11840             Set_Ekind                     (Tag_Comp, E_Component);
11841             Set_Etype                     (Tag_Comp, RTE (RE_Tag));
11842             Set_DT_Entry_Count            (Tag_Comp, No_Uint);
11843             Set_Original_Record_Component (Tag_Comp, Tag_Comp);
11844             Init_Component_Location       (Tag_Comp);
11845          end if;
11846
11847          Make_Class_Wide_Type (T);
11848          Set_Primitive_Operations (T, New_Elmt_List);
11849       end if;
11850
11851       --  We must suppress range checks when processing the components
11852       --  of a record in the presence of discriminants, since we don't
11853       --  want spurious checks to be generated during their analysis, but
11854       --  must reset the Suppress_Range_Checks flags after having procesed
11855       --  the record definition.
11856
11857       if Has_Discriminants (T) and then not Suppress_Range_Checks (T) then
11858          Set_Suppress_Range_Checks (T, True);
11859          Range_Checks_Suppressed_Flag := True;
11860       end if;
11861
11862       Record_Type_Definition (Def, T);
11863
11864       if Range_Checks_Suppressed_Flag then
11865          Set_Suppress_Range_Checks (T, False);
11866          Range_Checks_Suppressed_Flag := False;
11867       end if;
11868
11869       --  Exit from record scope
11870
11871       End_Scope;
11872    end Record_Type_Declaration;
11873
11874    ----------------------------
11875    -- Record_Type_Definition --
11876    ----------------------------
11877
11878    procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is
11879       Component          : Entity_Id;
11880       Ctrl_Components    : Boolean := False;
11881       Final_Storage_Only : Boolean := not Is_Controlled (T);
11882
11883    begin
11884       --  If the component list of a record type is defined by the reserved
11885       --  word null and there is no discriminant part, then the record type has
11886       --  no components and all records of the type are null records (RM 3.7)
11887       --  This procedure is also called to process the extension part of a
11888       --  record extension, in which case the current scope may have inherited
11889       --  components.
11890
11891       if No (Def)
11892         or else No (Component_List (Def))
11893         or else Null_Present (Component_List (Def))
11894       then
11895          null;
11896
11897       else
11898          Analyze_Declarations (Component_Items (Component_List (Def)));
11899
11900          if Present (Variant_Part (Component_List (Def))) then
11901             Analyze (Variant_Part (Component_List (Def)));
11902          end if;
11903       end if;
11904
11905       --  After completing the semantic analysis of the record definition,
11906       --  record components, both new and inherited, are accessible. Set
11907       --  their kind accordingly.
11908
11909       Component := First_Entity (Current_Scope);
11910       while Present (Component) loop
11911
11912          if Ekind (Component) = E_Void then
11913             Set_Ekind (Component, E_Component);
11914             Init_Component_Location (Component);
11915          end if;
11916
11917          if Has_Task (Etype (Component)) then
11918             Set_Has_Task (T);
11919          end if;
11920
11921          if Ekind (Component) /= E_Component then
11922             null;
11923
11924          elsif Has_Controlled_Component (Etype (Component))
11925            or else (Chars (Component) /= Name_uParent
11926                     and then Is_Controlled (Etype (Component)))
11927          then
11928             Set_Has_Controlled_Component (T, True);
11929             Final_Storage_Only := Final_Storage_Only
11930               and then Finalize_Storage_Only (Etype (Component));
11931             Ctrl_Components := True;
11932          end if;
11933
11934          Next_Entity (Component);
11935       end loop;
11936
11937       --  A type is Finalize_Storage_Only only if all its controlled
11938       --  components are so.
11939
11940       if Ctrl_Components then
11941          Set_Finalize_Storage_Only (T, Final_Storage_Only);
11942       end if;
11943
11944       if Present (Def) then
11945          Process_End_Label (Def, 'e');
11946       end if;
11947    end Record_Type_Definition;
11948
11949    ---------------------
11950    -- Set_Fixed_Range --
11951    ---------------------
11952
11953    --  The range for fixed-point types is complicated by the fact that we
11954    --  do not know the exact end points at the time of the declaration. This
11955    --  is true for three reasons:
11956
11957    --     A size clause may affect the fudging of the end-points
11958    --     A small clause may affect the values of the end-points
11959    --     We try to include the end-points if it does not affect the size
11960
11961    --  This means that the actual end-points must be established at the
11962    --  point when the type is frozen. Meanwhile, we first narrow the range
11963    --  as permitted (so that it will fit if necessary in a small specified
11964    --  size), and then build a range subtree with these narrowed bounds.
11965
11966    --  Set_Fixed_Range constructs the range from real literal values, and
11967    --  sets the range as the Scalar_Range of the given fixed-point type
11968    --  entity.
11969
11970    --  The parent of this range is set to point to the entity so that it
11971    --  is properly hooked into the tree (unlike normal Scalar_Range entries
11972    --  for other scalar types, which are just pointers to the range in the
11973    --  original tree, this would otherwise be an orphan).
11974
11975    --  The tree is left unanalyzed. When the type is frozen, the processing
11976    --  in Freeze.Freeze_Fixed_Point_Type notices that the range is not
11977    --  analyzed, and uses this as an indication that it should complete
11978    --  work on the range (it will know the final small and size values).
11979
11980    procedure Set_Fixed_Range
11981      (E   : Entity_Id;
11982       Loc : Source_Ptr;
11983       Lo  : Ureal;
11984       Hi  : Ureal)
11985    is
11986       S : constant Node_Id :=
11987             Make_Range (Loc,
11988               Low_Bound  => Make_Real_Literal (Loc, Lo),
11989               High_Bound => Make_Real_Literal (Loc, Hi));
11990
11991    begin
11992       Set_Scalar_Range (E, S);
11993       Set_Parent (S, E);
11994    end Set_Fixed_Range;
11995
11996    --------------------------------------------------------
11997    -- Set_Girder_Constraint_From_Discriminant_Constraint --
11998    --------------------------------------------------------
11999
12000    procedure Set_Girder_Constraint_From_Discriminant_Constraint
12001      (E : Entity_Id)
12002    is
12003    begin
12004       --  Make sure set if encountered during
12005       --  Expand_To_Girder_Constraint
12006
12007       Set_Girder_Constraint (E, No_Elist);
12008
12009       --  Give it the right value
12010
12011       if Is_Constrained (E) and then Has_Discriminants (E) then
12012          Set_Girder_Constraint (E,
12013            Expand_To_Girder_Constraint (E, Discriminant_Constraint (E)));
12014       end if;
12015
12016    end Set_Girder_Constraint_From_Discriminant_Constraint;
12017
12018    ----------------------------------
12019    -- Set_Scalar_Range_For_Subtype --
12020    ----------------------------------
12021
12022    procedure Set_Scalar_Range_For_Subtype
12023      (Def_Id      : Entity_Id;
12024       R           : Node_Id;
12025       Subt        : Entity_Id;
12026       Related_Nod : Node_Id)
12027    is
12028       Kind : constant Entity_Kind :=  Ekind (Def_Id);
12029    begin
12030       Set_Scalar_Range (Def_Id, R);
12031
12032       --  We need to link the range into the tree before resolving it so
12033       --  that types that are referenced, including importantly the subtype
12034       --  itself, are properly frozen (Freeze_Expression requires that the
12035       --  expression be properly linked into the tree). Of course if it is
12036       --  already linked in, then we do not disturb the current link.
12037
12038       if No (Parent (R)) then
12039          Set_Parent (R, Def_Id);
12040       end if;
12041
12042       --  Reset the kind of the subtype during analysis of the range, to
12043       --  catch possible premature use in the bounds themselves.
12044
12045       Set_Ekind (Def_Id, E_Void);
12046       Process_Range_Expr_In_Decl (R, Subt, Related_Nod);
12047       Set_Ekind (Def_Id, Kind);
12048
12049    end Set_Scalar_Range_For_Subtype;
12050
12051    -------------------------------------
12052    -- Signed_Integer_Type_Declaration --
12053    -------------------------------------
12054
12055    procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
12056       Implicit_Base : Entity_Id;
12057       Base_Typ      : Entity_Id;
12058       Lo_Val        : Uint;
12059       Hi_Val        : Uint;
12060       Errs          : Boolean := False;
12061       Lo            : Node_Id;
12062       Hi            : Node_Id;
12063
12064       function Can_Derive_From (E : Entity_Id) return Boolean;
12065       --  Determine whether given bounds allow derivation from specified type
12066
12067       procedure Check_Bound (Expr : Node_Id);
12068       --  Check bound to make sure it is integral and static. If not, post
12069       --  appropriate error message and set Errs flag
12070
12071       function Can_Derive_From (E : Entity_Id) return Boolean is
12072          Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
12073          Hi : constant Uint := Expr_Value (Type_High_Bound (E));
12074
12075       begin
12076          --  Note we check both bounds against both end values, to deal with
12077          --  strange types like ones with a range of 0 .. -12341234.
12078
12079          return Lo <= Lo_Val and then Lo_Val <= Hi
12080                   and then
12081                 Lo <= Hi_Val and then Hi_Val <= Hi;
12082       end Can_Derive_From;
12083
12084       procedure Check_Bound (Expr : Node_Id) is
12085       begin
12086          --  If a range constraint is used as an integer type definition, each
12087          --  bound of the range must be defined by a static expression of some
12088          --  integer type, but the two bounds need not have the same integer
12089          --  type (Negative bounds are allowed.) (RM 3.5.4)
12090
12091          if not Is_Integer_Type (Etype (Expr)) then
12092             Error_Msg_N
12093               ("integer type definition bounds must be of integer type", Expr);
12094             Errs := True;
12095
12096          elsif not Is_OK_Static_Expression (Expr) then
12097             Error_Msg_N
12098               ("non-static expression used for integer type bound", Expr);
12099             Errs := True;
12100
12101          --  The bounds are folded into literals, and we set their type to be
12102          --  universal, to avoid typing difficulties: we cannot set the type
12103          --  of the literal to the new type, because this would be a forward
12104          --  reference for the back end,  and if the original type is user-
12105          --  defined this can lead to spurious semantic errors (e.g. 2928-003).
12106
12107          else
12108             if Is_Entity_Name (Expr) then
12109                Fold_Uint (Expr, Expr_Value (Expr));
12110             end if;
12111
12112             Set_Etype (Expr, Universal_Integer);
12113          end if;
12114       end Check_Bound;
12115
12116    --  Start of processing for Signed_Integer_Type_Declaration
12117
12118    begin
12119       --  Create an anonymous base type
12120
12121       Implicit_Base :=
12122         Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
12123
12124       --  Analyze and check the bounds, they can be of any integer type
12125
12126       Lo := Low_Bound (Def);
12127       Hi := High_Bound (Def);
12128
12129       --  Arbitrarily use Integer as the type if either bound had an error
12130
12131       if Hi = Error or else Lo = Error then
12132          Base_Typ := Any_Integer;
12133          Set_Error_Posted (T, True);
12134
12135       --  Here both bounds are OK expressions
12136
12137       else
12138          Analyze_And_Resolve (Lo, Any_Integer);
12139          Analyze_And_Resolve (Hi, Any_Integer);
12140
12141          Check_Bound (Lo);
12142          Check_Bound (Hi);
12143
12144          if Errs then
12145             Hi := Type_High_Bound (Standard_Long_Long_Integer);
12146             Lo := Type_Low_Bound (Standard_Long_Long_Integer);
12147          end if;
12148
12149          --  Find type to derive from
12150
12151          Lo_Val := Expr_Value (Lo);
12152          Hi_Val := Expr_Value (Hi);
12153
12154          if Can_Derive_From (Standard_Short_Short_Integer) then
12155             Base_Typ := Base_Type (Standard_Short_Short_Integer);
12156
12157          elsif Can_Derive_From (Standard_Short_Integer) then
12158             Base_Typ := Base_Type (Standard_Short_Integer);
12159
12160          elsif Can_Derive_From (Standard_Integer) then
12161             Base_Typ := Base_Type (Standard_Integer);
12162
12163          elsif Can_Derive_From (Standard_Long_Integer) then
12164             Base_Typ := Base_Type (Standard_Long_Integer);
12165
12166          elsif Can_Derive_From (Standard_Long_Long_Integer) then
12167             Base_Typ := Base_Type (Standard_Long_Long_Integer);
12168
12169          else
12170             Base_Typ := Base_Type (Standard_Long_Long_Integer);
12171             Error_Msg_N ("integer type definition bounds out of range", Def);
12172             Hi := Type_High_Bound (Standard_Long_Long_Integer);
12173             Lo := Type_Low_Bound (Standard_Long_Long_Integer);
12174          end if;
12175       end if;
12176
12177       --  Complete both implicit base and declared first subtype entities
12178
12179       Set_Etype          (Implicit_Base, Base_Typ);
12180       Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
12181       Set_Size_Info      (Implicit_Base,                (Base_Typ));
12182       Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
12183       Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
12184
12185       Set_Ekind          (T, E_Signed_Integer_Subtype);
12186       Set_Etype          (T, Implicit_Base);
12187
12188       Set_Size_Info      (T,                (Implicit_Base));
12189       Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
12190       Set_Scalar_Range   (T, Def);
12191       Set_RM_Size        (T, UI_From_Int (Minimum_Size (T)));
12192       Set_Is_Constrained (T);
12193
12194    end Signed_Integer_Type_Declaration;
12195
12196 end Sem_Ch3;