OSDN Git Service

6bddb202db960f4cef67ac15f2fde5635891284e
[pf3gnuchains/gcc-fork.git] / 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 --          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 with Atree;    use Atree;
27 with Checks;   use Checks;
28 with Debug;    use Debug;
29 with Elists;   use Elists;
30 with Einfo;    use Einfo;
31 with Errout;   use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Ch3;  use Exp_Ch3;
34 with Exp_Dist; use Exp_Dist;
35 with Exp_Tss;  use Exp_Tss;
36 with Exp_Util; use Exp_Util;
37 with Fname;    use Fname;
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 Rident;   use Rident;
48 with Rtsfind;  use Rtsfind;
49 with Sem;      use Sem;
50 with Sem_Case; use Sem_Case;
51 with Sem_Cat;  use Sem_Cat;
52 with Sem_Ch6;  use Sem_Ch6;
53 with Sem_Ch7;  use Sem_Ch7;
54 with Sem_Ch8;  use Sem_Ch8;
55 with Sem_Ch13; use Sem_Ch13;
56 with Sem_Disp; use Sem_Disp;
57 with Sem_Dist; use Sem_Dist;
58 with Sem_Elim; use Sem_Elim;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Mech; use Sem_Mech;
61 with Sem_Res;  use Sem_Res;
62 with Sem_Smem; use Sem_Smem;
63 with Sem_Type; use Sem_Type;
64 with Sem_Util; use Sem_Util;
65 with Sem_Warn; use Sem_Warn;
66 with Stand;    use Stand;
67 with Sinfo;    use Sinfo;
68 with Snames;   use Snames;
69 with Targparm; use Targparm;
70 with Tbuild;   use Tbuild;
71 with Ttypes;   use Ttypes;
72 with Uintp;    use Uintp;
73 with Urealp;   use Urealp;
74
75 package body Sem_Ch3 is
76
77    -----------------------
78    -- Local Subprograms --
79    -----------------------
80
81    procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id);
82    --  Ada 2005 (AI-251): Add the tag components corresponding to all the
83    --  abstract interface types implemented by a record type or a derived
84    --  record type.
85
86    procedure Build_Derived_Type
87      (N             : Node_Id;
88       Parent_Type   : Entity_Id;
89       Derived_Type  : Entity_Id;
90       Is_Completion : Boolean;
91       Derive_Subps  : Boolean := True);
92    --  Create and decorate a Derived_Type given the Parent_Type entity. N is
93    --  the N_Full_Type_Declaration node containing the derived type definition.
94    --  Parent_Type is the entity for the parent type in the derived type
95    --  definition and Derived_Type the actual derived type. Is_Completion must
96    --  be set to False if Derived_Type is the N_Defining_Identifier node in N
97    --  (ie Derived_Type = Defining_Identifier (N)). In this case N is not the
98    --  completion of a private type declaration. If Is_Completion is set to
99    --  True, N is the completion of a private type declaration and Derived_Type
100    --  is different from the defining identifier inside N (i.e. Derived_Type /=
101    --  Defining_Identifier (N)). Derive_Subps indicates whether the parent
102    --  subprograms should be derived. The only case where this parameter is
103    --  False is when Build_Derived_Type is recursively called to process an
104    --  implicit derived full type for a type derived from a private type (in
105    --  that case the subprograms must only be derived for the private view of
106    --  the type).
107    --
108    --  ??? These flags need a bit of re-examination and re-documentation:
109    --  ???  are they both necessary (both seem related to the recursion)?
110
111    procedure Build_Derived_Access_Type
112      (N            : Node_Id;
113       Parent_Type  : Entity_Id;
114       Derived_Type : Entity_Id);
115    --  Subsidiary procedure to Build_Derived_Type. For a derived access type,
116    --  create an implicit base if the parent type is constrained or if the
117    --  subtype indication has a constraint.
118
119    procedure Build_Derived_Array_Type
120      (N            : Node_Id;
121       Parent_Type  : Entity_Id;
122       Derived_Type : Entity_Id);
123    --  Subsidiary procedure to Build_Derived_Type. For a derived array type,
124    --  create an implicit base if the parent type is constrained or if the
125    --  subtype indication has a constraint.
126
127    procedure Build_Derived_Concurrent_Type
128      (N            : Node_Id;
129       Parent_Type  : Entity_Id;
130       Derived_Type : Entity_Id);
131    --  Subsidiary procedure to Build_Derived_Type. For a derived task or
132    --  protected type, inherit entries and protected subprograms, check
133    --  legality of discriminant constraints if any.
134
135    procedure Build_Derived_Enumeration_Type
136      (N            : Node_Id;
137       Parent_Type  : Entity_Id;
138       Derived_Type : Entity_Id);
139    --  Subsidiary procedure to Build_Derived_Type. For a derived enumeration
140    --  type, we must create a new list of literals. Types derived from
141    --  Character and Wide_Character are special-cased.
142
143    procedure Build_Derived_Numeric_Type
144      (N            : Node_Id;
145       Parent_Type  : Entity_Id;
146       Derived_Type : Entity_Id);
147    --  Subsidiary procedure to Build_Derived_Type. For numeric types, create
148    --  an anonymous base type, and propagate constraint to subtype if needed.
149
150    procedure Build_Derived_Private_Type
151      (N             : Node_Id;
152       Parent_Type   : Entity_Id;
153       Derived_Type  : Entity_Id;
154       Is_Completion : Boolean;
155       Derive_Subps  : Boolean := True);
156    --  Subsidiary procedure to Build_Derived_Type. This procedure is complex
157    --  because the parent may or may not have a completion, and the derivation
158    --  may itself be a completion.
159
160    procedure Build_Derived_Record_Type
161      (N            : Node_Id;
162       Parent_Type  : Entity_Id;
163       Derived_Type : Entity_Id;
164       Derive_Subps : Boolean := True);
165    --  Subsidiary procedure for Build_Derived_Type and
166    --  Analyze_Private_Extension_Declaration used for tagged and untagged
167    --  record types. All parameters are as in Build_Derived_Type except that
168    --  N, in addition to being an N_Full_Type_Declaration node, can also be an
169    --  N_Private_Extension_Declaration node. See the definition of this routine
170    --  for much more info. Derive_Subps indicates whether subprograms should
171    --  be derived from the parent type. The only case where Derive_Subps is
172    --  False is for an implicit derived full type for a type derived from a
173    --  private type (see Build_Derived_Type).
174
175    procedure Build_Discriminal (Discrim : Entity_Id);
176    --  Create the discriminal corresponding to discriminant Discrim, that is
177    --  the parameter corresponding to Discrim to be used in initialization
178    --  procedures for the type where Discrim is a discriminant. Discriminals
179    --  are not used during semantic analysis, and are not fully defined
180    --  entities until expansion. Thus they are not given a scope until
181    --  initialization procedures are built.
182
183    function Build_Discriminant_Constraints
184      (T           : Entity_Id;
185       Def         : Node_Id;
186       Derived_Def : Boolean := False) return Elist_Id;
187    --  Validate discriminant constraints and return the list of the constraints
188    --  in order of discriminant declarations, where T is the discriminated
189    --  unconstrained type. Def is the N_Subtype_Indication node where the
190    --  discriminants constraints for T are specified. Derived_Def is True
191    --  when building the discriminant constraints in a derived type definition
192    --  of the form "type D (...) is new T (xxx)". In this case T is the parent
193    --  type and Def is the constraint "(xxx)" on T and this routine sets the
194    --  Corresponding_Discriminant field of the discriminants in the derived
195    --  type D to point to the corresponding discriminants in the parent type T.
196
197    procedure Build_Discriminated_Subtype
198      (T           : Entity_Id;
199       Def_Id      : Entity_Id;
200       Elist       : Elist_Id;
201       Related_Nod : Node_Id;
202       For_Access  : Boolean := False);
203    --  Subsidiary procedure to Constrain_Discriminated_Type and to
204    --  Process_Incomplete_Dependents. Given
205    --
206    --     T (a possibly discriminated base type)
207    --     Def_Id (a very partially built subtype for T),
208    --
209    --  the call completes Def_Id to be the appropriate E_*_Subtype.
210    --
211    --  The Elist is the list of discriminant constraints if any (it is set
212    --  to No_Elist if T is not a discriminated type, and to an empty list if
213    --  T has discriminants but there are no discriminant constraints). The
214    --  Related_Nod is the same as Decl_Node in Create_Constrained_Components.
215    --  The For_Access says whether or not this subtype is really constraining
216    --  an access type. That is its sole purpose is the designated type of an
217    --  access type -- in which case a Private_Subtype Is_For_Access_Subtype
218    --  is built to avoid freezing T when the access subtype is frozen.
219
220    function Build_Scalar_Bound
221      (Bound : Node_Id;
222       Par_T : Entity_Id;
223       Der_T : Entity_Id) return Node_Id;
224    --  The bounds of a derived scalar type are conversions of the bounds of
225    --  the parent type. Optimize the representation if the bounds are literals.
226    --  Needs a more complete spec--what are the parameters exactly, and what
227    --  exactly is the returned value, and how is Bound affected???
228
229    procedure Build_Itype_Reference
230      (Ityp : Entity_Id;
231       Nod  : Node_Id);
232    --  Create a reference to an internal type, for use by Gigi. The back-end
233    --  elaborates itypes on demand, i.e. when their first use is seen. This
234    --  can lead to scope anomalies if the first use is within a scope that is
235    --  nested within the scope that contains  the point of definition of the
236    --  itype. The Itype_Reference node forces the elaboration of the itype
237    --  in the proper scope. The node is inserted after Nod, which is the
238    --  enclosing declaration that generated Ityp.
239    --  A related mechanism is used during expansion, for itypes created in
240    --  branches of conditionals. See Ensure_Defined in exp_util.
241    --  Could both mechanisms be merged ???
242
243    procedure Build_Underlying_Full_View
244      (N   : Node_Id;
245       Typ : Entity_Id;
246       Par : Entity_Id);
247    --  If the completion of a private type is itself derived from a private
248    --  type, or if the full view of a private subtype is itself private, the
249    --  back-end has no way to compute the actual size of this type. We build
250    --  an internal subtype declaration of the proper parent type to convey
251    --  this information. This extra mechanism is needed because a full
252    --  view cannot itself have a full view (it would get clobbered during
253    --  view exchanges).
254
255    procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id);
256    --  Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
257
258    procedure Check_Access_Discriminant_Requires_Limited
259      (D   : Node_Id;
260       Loc : Node_Id);
261    --  Check the restriction that the type to which an access discriminant
262    --  belongs must be a concurrent type or a descendant of a type with
263    --  the reserved word 'limited' in its declaration.
264
265    procedure Check_Anonymous_Access_Components
266       (Typ_Decl  : Node_Id;
267        Typ       : Entity_Id;
268        Prev      : Entity_Id;
269        Comp_List : Node_Id);
270    --  Ada 2005 AI-382: an access component in a record definition can refer to
271    --  the enclosing record, in which case it denotes the type itself, and not
272    --  the current instance of the type. We create an anonymous access type for
273    --  the component, and flag it as an access to a component, so accessibility
274    --  checks are properly performed on it. The declaration of the access type
275    --  is placed ahead of that of the record to prevent order-of-elaboration
276    --  circularity issues in Gigi. We create an incomplete type for the record
277    --  declaration, which is the designated type of the anonymous access.
278
279    procedure Check_Delta_Expression (E : Node_Id);
280    --  Check that the expression represented by E is suitable for use as a
281    --  delta expression, i.e. it is of real type and is static.
282
283    procedure Check_Digits_Expression (E : Node_Id);
284    --  Check that the expression represented by E is suitable for use as a
285    --  digits expression, i.e. it is of integer type, positive and static.
286
287    procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
288    --  Validate the initialization of an object declaration. T is the required
289    --  type, and Exp is the initialization expression.
290
291    procedure Check_Or_Process_Discriminants
292      (N    : Node_Id;
293       T    : Entity_Id;
294       Prev : Entity_Id := Empty);
295    --  If T is the full declaration of an incomplete or private type, check the
296    --  conformance of the discriminants, otherwise process them. Prev is the
297    --  entity of the partial declaration, if any.
298
299    procedure Check_Real_Bound (Bound : Node_Id);
300    --  Check given bound for being of real type and static. If not, post an
301    --  appropriate message, and rewrite the bound with the real literal zero.
302
303    procedure Constant_Redeclaration
304      (Id : Entity_Id;
305       N  : Node_Id;
306       T  : out Entity_Id);
307    --  Various checks on legality of full declaration of deferred constant.
308    --  Id is the entity for the redeclaration, N is the N_Object_Declaration,
309    --  node. The caller has not yet set any attributes of this entity.
310
311    function Contain_Interface
312      (Iface  : Entity_Id;
313       Ifaces : Elist_Id) return Boolean;
314    --  Ada 2005: Determine whether Iface is present in the list Ifaces
315
316    procedure Convert_Scalar_Bounds
317      (N            : Node_Id;
318       Parent_Type  : Entity_Id;
319       Derived_Type : Entity_Id;
320       Loc          : Source_Ptr);
321    --  For derived scalar types, convert the bounds in the type definition to
322    --  the derived type, and complete their analysis. Given a constraint of the
323    --  form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with
324    --  T'Base, the parent_type. The bounds of the derived type (the anonymous
325    --  base) are copies of Lo and Hi. Finally, the bounds of the derived
326    --  subtype are conversions of those bounds to the derived_type, so that
327    --  their typing is consistent.
328
329    procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
330    --  Copies attributes from array base type T2 to array base type T1. Copies
331    --  only attributes that apply to base types, but not subtypes.
332
333    procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
334    --  Copies attributes from array subtype T2 to array subtype T1. Copies
335    --  attributes that apply to both subtypes and base types.
336
337    procedure Create_Constrained_Components
338      (Subt        : Entity_Id;
339       Decl_Node   : Node_Id;
340       Typ         : Entity_Id;
341       Constraints : Elist_Id);
342    --  Build the list of entities for a constrained discriminated record
343    --  subtype. If a component depends on a discriminant, replace its subtype
344    --  using the discriminant values in the discriminant constraint. Subt is
345    --  the defining identifier for the subtype whose list of constrained
346    --  entities we will create. Decl_Node is the type declaration node where we
347    --  will attach all the itypes created. Typ is the base discriminated type
348    --  for the subtype Subt. Constraints is the list of discriminant
349    --  constraints for Typ.
350
351    function Constrain_Component_Type
352      (Comp            : Entity_Id;
353       Constrained_Typ : Entity_Id;
354       Related_Node    : Node_Id;
355       Typ             : Entity_Id;
356       Constraints     : Elist_Id) return Entity_Id;
357    --  Given a discriminated base type Typ, a list of discriminant constraint
358    --  Constraints for Typ and a component of Typ, with type Compon_Type,
359    --  create and return the type corresponding to Compon_type where all
360    --  discriminant references are replaced with the corresponding constraint.
361    --  If no discriminant references occur in Compon_Typ then return it as is.
362    --  Constrained_Typ is the final constrained subtype to which the
363    --  constrained Compon_Type belongs. Related_Node is the node where we will
364    --  attach all the itypes created.
365    --  Above description is confused, what is Compon_Type???
366
367    procedure Constrain_Access
368      (Def_Id      : in out Entity_Id;
369       S           : Node_Id;
370       Related_Nod : Node_Id);
371    --  Apply a list of constraints to an access type. If Def_Id is empty, it is
372    --  an anonymous type created for a subtype indication. In that case it is
373    --  created in the procedure and attached to Related_Nod.
374
375    procedure Constrain_Array
376      (Def_Id      : in out Entity_Id;
377       SI          : Node_Id;
378       Related_Nod : Node_Id;
379       Related_Id  : Entity_Id;
380       Suffix      : Character);
381    --  Apply a list of index constraints to an unconstrained array type. The
382    --  first parameter is the entity for the resulting subtype. A value of
383    --  Empty for Def_Id indicates that an implicit type must be created, but
384    --  creation is delayed (and must be done by this procedure) because other
385    --  subsidiary implicit types must be created first (which is why Def_Id
386    --  is an in/out parameter). The second parameter is a subtype indication
387    --  node for the constrained array to be created (e.g. something of the
388    --  form string (1 .. 10)). Related_Nod gives the place where this type
389    --  has to be inserted in the tree. The Related_Id and Suffix parameters
390    --  are used to build the associated Implicit type name.
391
392    procedure Constrain_Concurrent
393      (Def_Id      : in out Entity_Id;
394       SI          : Node_Id;
395       Related_Nod : Node_Id;
396       Related_Id  : Entity_Id;
397       Suffix      : Character);
398    --  Apply list of discriminant constraints to an unconstrained concurrent
399    --  type.
400    --
401    --    SI is the N_Subtype_Indication node containing the constraint and
402    --    the unconstrained type to constrain.
403    --
404    --    Def_Id is the entity for the resulting constrained subtype. A value
405    --    of Empty for Def_Id indicates that an implicit type must be created,
406    --    but creation is delayed (and must be done by this procedure) because
407    --    other subsidiary implicit types must be created first (which is why
408    --    Def_Id is an in/out parameter).
409    --
410    --    Related_Nod gives the place where this type has to be inserted
411    --    in the tree
412    --
413    --  The last two arguments are used to create its external name if needed.
414
415    function Constrain_Corresponding_Record
416      (Prot_Subt   : Entity_Id;
417       Corr_Rec    : Entity_Id;
418       Related_Nod : Node_Id;
419       Related_Id  : Entity_Id) return Entity_Id;
420    --  When constraining a protected type or task type with discriminants,
421    --  constrain the corresponding record with the same discriminant values.
422
423    procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id);
424    --  Constrain a decimal fixed point type with a digits constraint and/or a
425    --  range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
426
427    procedure Constrain_Discriminated_Type
428      (Def_Id      : Entity_Id;
429       S           : Node_Id;
430       Related_Nod : Node_Id;
431       For_Access  : Boolean := False);
432    --  Process discriminant constraints of composite type. Verify that values
433    --  have been provided for all discriminants, that the original type is
434    --  unconstrained, and that the types of the supplied expressions match
435    --  the discriminant types. The first three parameters are like in routine
436    --  Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
437    --  of For_Access.
438
439    procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
440    --  Constrain an enumeration type with a range constraint. This is identical
441    --  to Constrain_Integer, but for the Ekind of the resulting subtype.
442
443    procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id);
444    --  Constrain a floating point type with either a digits constraint
445    --  and/or a range constraint, building a E_Floating_Point_Subtype.
446
447    procedure Constrain_Index
448      (Index        : Node_Id;
449       S            : Node_Id;
450       Related_Nod  : Node_Id;
451       Related_Id   : Entity_Id;
452       Suffix       : Character;
453       Suffix_Index : Nat);
454    --  Process an index constraint in a constrained array declaration. The
455    --  constraint can be a subtype name, or a range with or without an explicit
456    --  subtype mark. The index is the corresponding index of the unconstrained
457    --  array. The Related_Id and Suffix parameters are used to build the
458    --  associated Implicit type name.
459
460    procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
461    --  Build subtype of a signed or modular integer type
462
463    procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
464    --  Constrain an ordinary fixed point type with a range constraint, and
465    --  build an E_Ordinary_Fixed_Point_Subtype entity.
466
467    procedure Copy_And_Swap (Priv, Full : Entity_Id);
468    --  Copy the Priv entity into the entity of its full declaration then swap
469    --  the two entities in such a manner that the former private type is now
470    --  seen as a full type.
471
472    procedure Decimal_Fixed_Point_Type_Declaration
473      (T   : Entity_Id;
474       Def : Node_Id);
475    --  Create a new decimal fixed point type, and apply the constraint to
476    --  obtain a subtype of this new type.
477
478    procedure Complete_Private_Subtype
479      (Priv        : Entity_Id;
480       Full        : Entity_Id;
481       Full_Base   : Entity_Id;
482       Related_Nod : Node_Id);
483    --  Complete the implicit full view of a private subtype by setting the
484    --  appropriate semantic fields. If the full view of the parent is a record
485    --  type, build constrained components of subtype.
486
487    procedure Derive_Interface_Subprograms
488      (Parent_Type : Entity_Id;
489       Tagged_Type : Entity_Id;
490       Ifaces_List : Elist_Id);
491    --  Ada 2005 (AI-251): Derive primitives of abstract interface types that
492    --  are not immediate ancestors of Tagged type and associate them their
493    --  aliased primitive. Ifaces_List contains the abstract interface
494    --  primitives that have been derived from Parent_Type.
495
496    procedure Derived_Standard_Character
497      (N             : Node_Id;
498       Parent_Type   : Entity_Id;
499       Derived_Type  : Entity_Id);
500    --  Subsidiary procedure to Build_Derived_Enumeration_Type which handles
501    --  derivations from types Standard.Character and Standard.Wide_Character.
502
503    procedure Derived_Type_Declaration
504      (T             : Entity_Id;
505       N             : Node_Id;
506       Is_Completion : Boolean);
507    --  Process a derived type declaration. This routine will invoke
508    --  Build_Derived_Type to process the actual derived type definition.
509    --  Parameters N and Is_Completion have the same meaning as in
510    --  Build_Derived_Type. T is the N_Defining_Identifier for the entity
511    --  defined in the N_Full_Type_Declaration node N, that is T is the derived
512    --  type.
513
514    procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
515    --  Insert each literal in symbol table, as an overloadable identifier. Each
516    --  enumeration type is mapped into a sequence of integers, and each literal
517    --  is defined as a constant with integer value. If any of the literals are
518    --  character literals, the type is a character type, which means that
519    --  strings are legal aggregates for arrays of components of the type.
520
521    function Expand_To_Stored_Constraint
522      (Typ        : Entity_Id;
523       Constraint : Elist_Id) return Elist_Id;
524    --  Given a Constraint (i.e. a list of expressions) on the discriminants of
525    --  Typ, expand it into a constraint on the stored discriminants and return
526    --  the new list of expressions constraining the stored discriminants.
527
528    function Find_Type_Of_Object
529      (Obj_Def     : Node_Id;
530       Related_Nod : Node_Id) return Entity_Id;
531    --  Get type entity for object referenced by Obj_Def, attaching the
532    --  implicit types generated to Related_Nod
533
534    procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
535    --  Create a new float, and apply the constraint to obtain subtype of it
536
537    function Has_Range_Constraint (N : Node_Id) return Boolean;
538    --  Given an N_Subtype_Indication node N, return True if a range constraint
539    --  is present, either directly, or as part of a digits or delta constraint.
540    --  In addition, a digits constraint in the decimal case returns True, since
541    --  it establishes a default range if no explicit range is present.
542
543    function Inherit_Components
544      (N             : Node_Id;
545       Parent_Base   : Entity_Id;
546       Derived_Base  : Entity_Id;
547       Is_Tagged     : Boolean;
548       Inherit_Discr : Boolean;
549       Discs         : Elist_Id) return Elist_Id;
550    --  Called from Build_Derived_Record_Type to inherit the components of
551    --  Parent_Base (a base type) into the Derived_Base (the derived base type).
552    --  For more information on derived types and component inheritance please
553    --  consult the comment above the body of Build_Derived_Record_Type.
554    --
555    --    N is the original derived type declaration
556    --
557    --    Is_Tagged is set if we are dealing with tagged types
558    --
559    --    If Inherit_Discr is set, Derived_Base inherits its discriminants from
560    --    Parent_Base, otherwise no discriminants are inherited.
561    --
562    --    Discs gives the list of constraints that apply to Parent_Base in the
563    --    derived type declaration. If Discs is set to No_Elist, then we have
564    --    the following situation:
565    --
566    --      type Parent (D1..Dn : ..) is [tagged] record ...;
567    --      type Derived is new Parent [with ...];
568    --
569    --    which gets treated as
570    --
571    --      type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
572    --
573    --  For untagged types the returned value is an association list. The list
574    --  starts from the association (Parent_Base => Derived_Base), and then it
575    --  contains a sequence of the associations of the form
576    --
577    --    (Old_Component => New_Component),
578    --
579    --  where Old_Component is the Entity_Id of a component in Parent_Base and
580    --  New_Component is the Entity_Id of the corresponding component in
581    --  Derived_Base. For untagged records, this association list is needed when
582    --  copying the record declaration for the derived base. In the tagged case
583    --  the value returned is irrelevant.
584
585    function Is_Valid_Constraint_Kind
586      (T_Kind          : Type_Kind;
587       Constraint_Kind : Node_Kind) return Boolean;
588    --  Returns True if it is legal to apply the given kind of constraint to the
589    --  given kind of type (index constraint to an array type, for example).
590
591    procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
592    --  Create new modular type. Verify that modulus is in  bounds and is
593    --  a power of two (implementation restriction).
594
595    procedure New_Concatenation_Op (Typ : Entity_Id);
596    --  Create an abbreviated declaration for an operator in order to
597    --  materialize concatenation on array types.
598
599    procedure Ordinary_Fixed_Point_Type_Declaration
600      (T   : Entity_Id;
601       Def : Node_Id);
602    --  Create a new ordinary fixed point type, and apply the constraint to
603    --  obtain subtype of it.
604
605    procedure Prepare_Private_Subtype_Completion
606      (Id          : Entity_Id;
607       Related_Nod : Node_Id);
608    --  Id is a subtype of some private type. Creates the full declaration
609    --  associated with Id whenever possible, i.e. when the full declaration
610    --  of the base type is already known. Records each subtype into
611    --  Private_Dependents of the base type.
612
613    procedure Process_Incomplete_Dependents
614      (N      : Node_Id;
615       Full_T : Entity_Id;
616       Inc_T  : Entity_Id);
617    --  Process all entities that depend on an incomplete type. There include
618    --  subtypes, subprogram types that mention the incomplete type in their
619    --  profiles, and subprogram with access parameters that designate the
620    --  incomplete type.
621
622    --  Inc_T is the defining identifier of an incomplete type declaration, its
623    --  Ekind is E_Incomplete_Type.
624    --
625    --    N is the corresponding N_Full_Type_Declaration for Inc_T.
626    --
627    --    Full_T is N's defining identifier.
628    --
629    --  Subtypes of incomplete types with discriminants are completed when the
630    --  parent type is. This is simpler than private subtypes, because they can
631    --  only appear in the same scope, and there is no need to exchange views.
632    --  Similarly, access_to_subprogram types may have a parameter or a return
633    --  type that is an incomplete type, and that must be replaced with the
634    --  full type.
635
636    --  If the full type is tagged, subprogram with access parameters that
637    --  designated the incomplete may be primitive operations of the full type,
638    --  and have to be processed accordingly.
639
640    procedure Process_Real_Range_Specification (Def : Node_Id);
641    --  Given the type definition for a real type, this procedure processes
642    --  and checks the real range specification of this type definition if
643    --  one is present. If errors are found, error messages are posted, and
644    --  the Real_Range_Specification of Def is reset to Empty.
645
646    procedure Record_Type_Declaration
647      (T    : Entity_Id;
648       N    : Node_Id;
649       Prev : Entity_Id);
650    --  Process a record type declaration (for both untagged and tagged
651    --  records). Parameters T and N are exactly like in procedure
652    --  Derived_Type_Declaration, except that no flag Is_Completion is needed
653    --  for this routine. If this is the completion of an incomplete type
654    --  declaration, Prev is the entity of the incomplete declaration, used for
655    --  cross-referencing. Otherwise Prev = T.
656
657    procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id);
658    --  This routine is used to process the actual record type definition
659    --  (both for untagged and tagged records). Def is a record type
660    --  definition node. This procedure analyzes the components in this
661    --  record type definition. Prev_T is the entity for the enclosing record
662    --  type. It is provided so that its Has_Task flag can be set if any of
663    --  the component have Has_Task set. If the declaration is the completion
664    --  of an incomplete type declaration, Prev_T is the original incomplete
665    --  type, whose full view is the record type.
666
667    procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
668    --  Subsidiary to Build_Derived_Record_Type. For untagged records, we
669    --  build a copy of the declaration tree of the parent, and we create
670    --  independently the list of components for the derived type. Semantic
671    --  information uses the component entities, but record representation
672    --  clauses are validated on the declaration tree. This procedure replaces
673    --  discriminants and components in the declaration with those that have
674    --  been created by Inherit_Components.
675
676    procedure Set_Fixed_Range
677      (E   : Entity_Id;
678       Loc : Source_Ptr;
679       Lo  : Ureal;
680       Hi  : Ureal);
681    --  Build a range node with the given bounds and set it as the Scalar_Range
682    --  of the given fixed-point type entity. Loc is the source location used
683    --  for the constructed range. See body for further details.
684
685    procedure Set_Scalar_Range_For_Subtype
686      (Def_Id : Entity_Id;
687       R      : Node_Id;
688       Subt   : Entity_Id);
689    --  This routine is used to set the scalar range field for a subtype given
690    --  Def_Id, the entity for the subtype, and R, the range expression for the
691    --  scalar range. Subt provides the parent subtype to be used to analyze,
692    --  resolve, and check the given range.
693
694    procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
695    --  Create a new signed integer entity, and apply the constraint to obtain
696    --  the required first named subtype of this type.
697
698    procedure Set_Stored_Constraint_From_Discriminant_Constraint
699      (E : Entity_Id);
700    --  E is some record type. This routine computes E's Stored_Constraint
701    --  from its Discriminant_Constraint.
702
703    -----------------------
704    -- Access_Definition --
705    -----------------------
706
707    function Access_Definition
708      (Related_Nod : Node_Id;
709       N           : Node_Id) return Entity_Id
710    is
711       Loc        : constant Source_Ptr := Sloc (Related_Nod);
712       Anon_Type  : Entity_Id;
713       Anon_Scope : Entity_Id;
714       Desig_Type : Entity_Id;
715       Decl       : Entity_Id;
716
717    begin
718       if Is_Entry (Current_Scope)
719         and then Is_Task_Type (Etype (Scope (Current_Scope)))
720       then
721          Error_Msg_N ("task entries cannot have access parameters", N);
722          return Empty;
723       end if;
724
725       --  Ada 2005: for an object declaration the corresponding anonymous
726       --  type is declared in the current scope.
727
728       --  If the access definition is the return type of another access to
729       --  function, scope is the current one, because it is the one of the
730       --  current type declaration.
731
732       if Nkind (Related_Nod) = N_Object_Declaration
733         or else Nkind (Related_Nod) = N_Access_Function_Definition
734       then
735          Anon_Scope := Current_Scope;
736
737       --  For the anonymous function result case, retrieve the scope of the
738       --  function specification's associated entity rather than using the
739       --  current scope. The current scope will be the function itself if the
740       --  formal part is currently being analyzed, but will be the parent scope
741       --  in the case of a parameterless function, and we always want to use
742       --  the function's parent scope. Finally, if the function is a child
743       --  unit, we must traverse the the tree to retrieve the proper entity.
744
745       elsif Nkind (Related_Nod) = N_Function_Specification
746          and then Nkind (Parent (N)) /= N_Parameter_Specification
747       then
748          --  If the current scope is a protected type, the anonymous access
749          --  is associated with one of the protected operations, and must
750          --  be available in the scope that encloses the protected declaration.
751          --  Otherwise the type is is in the scope enclosing the subprogram.
752
753          if Ekind (Current_Scope) = E_Protected_Type then
754             Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod)));
755          else
756             Anon_Scope := Scope (Defining_Entity (Related_Nod));
757          end if;
758
759       else
760          --  For access formals, access components, and access discriminants,
761          --  the scope is that of the enclosing declaration,
762
763          Anon_Scope := Scope (Current_Scope);
764       end if;
765
766       Anon_Type :=
767         Create_Itype
768          (E_Anonymous_Access_Type, Related_Nod, Scope_Id =>  Anon_Scope);
769
770       if All_Present (N)
771         and then Ada_Version >= Ada_05
772       then
773          Error_Msg_N ("ALL is not permitted for anonymous access types", N);
774       end if;
775
776       --  Ada 2005 (AI-254): In case of anonymous access to subprograms call
777       --  the corresponding semantic routine
778
779       if Present (Access_To_Subprogram_Definition (N)) then
780          Access_Subprogram_Declaration
781            (T_Name => Anon_Type,
782             T_Def  => Access_To_Subprogram_Definition (N));
783
784          if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
785             Set_Ekind
786               (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
787          else
788             Set_Ekind
789               (Anon_Type, E_Anonymous_Access_Subprogram_Type);
790          end if;
791
792          --  If the anonymous access is associated with a protected operation
793          --  create a reference to it after the enclosing protected definition
794          --  because the itype will be used in the subsequent bodies.
795
796          if Ekind (Current_Scope) = E_Protected_Type then
797             Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
798          end if;
799
800          return Anon_Type;
801       end if;
802
803       Find_Type (Subtype_Mark (N));
804       Desig_Type := Entity (Subtype_Mark (N));
805
806       Set_Directly_Designated_Type
807                              (Anon_Type, Desig_Type);
808       Set_Etype              (Anon_Type, Anon_Type);
809       Init_Size_Align        (Anon_Type);
810       Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
811
812       --  Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
813       --  from Ada 95 semantics. In Ada 2005, anonymous access must specify if
814       --  the null value is allowed. In Ada 95 the null value is never allowed.
815
816       if Ada_Version >= Ada_05 then
817          Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
818       else
819          Set_Can_Never_Be_Null (Anon_Type, True);
820       end if;
821
822       --  The anonymous access type is as public as the discriminated type or
823       --  subprogram that defines it. It is imported (for back-end purposes)
824       --  if the designated type is.
825
826       Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
827
828       --  Ada 2005 (AI-50217): Propagate the attribute that indicates that the
829       --  designated type comes from the limited view.
830
831       Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
832
833       --  Ada 2005 (AI-231): Propagate the access-constant attribute
834
835       Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
836
837       --  The context is either a subprogram declaration, object declaration,
838       --  or an access discriminant, in a private or a full type declaration.
839       --  In the case of a subprogram, if the designated type is incomplete,
840       --  the operation will be a primitive operation of the full type, to be
841       --  updated subsequently. If the type is imported through a limited_with
842       --  clause, the subprogram is not a primitive operation of the type
843       --  (which is declared elsewhere in some other scope).
844
845       if Ekind (Desig_Type) = E_Incomplete_Type
846         and then not From_With_Type (Desig_Type)
847         and then Is_Overloadable (Current_Scope)
848       then
849          Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
850          Set_Has_Delayed_Freeze (Current_Scope);
851       end if;
852
853       --  Ada 2005: if the designated type is an interface that may contain
854       --  tasks, create a Master entity for the declaration. This must be done
855       --  before expansion of the full declaration, because the declaration may
856       --  include an expression that is an allocator, whose expansion needs the
857       --  proper Master for the created tasks.
858
859       if Nkind (Related_Nod) = N_Object_Declaration
860          and then Expander_Active
861       then
862          if Is_Interface (Desig_Type)
863            and then Is_Limited_Record (Desig_Type)
864          then
865             Build_Class_Wide_Master (Anon_Type);
866
867          --  Similarly, if the type is an anonymous access that designates
868          --  tasks, create a master entity for it in the current context.
869
870          elsif Has_Task (Desig_Type)
871            and then Comes_From_Source (Related_Nod)
872          then
873             if not Has_Master_Entity (Current_Scope) then
874                Decl :=
875                  Make_Object_Declaration (Loc,
876                    Defining_Identifier =>
877                      Make_Defining_Identifier (Loc, Name_uMaster),
878                    Constant_Present => True,
879                    Object_Definition =>
880                      New_Reference_To (RTE (RE_Master_Id), Loc),
881                    Expression =>
882                      Make_Explicit_Dereference (Loc,
883                        New_Reference_To (RTE (RE_Current_Master), Loc)));
884
885                Insert_Before (Related_Nod, Decl);
886                Analyze (Decl);
887
888                Set_Master_Id (Anon_Type, Defining_Identifier (Decl));
889                Set_Has_Master_Entity (Current_Scope);
890             else
891                Build_Master_Renaming (Related_Nod, Anon_Type);
892             end if;
893          end if;
894       end if;
895
896       --  For a private component of a protected type, it is imperative that
897       --  the back-end elaborate the type immediately after the protected
898       --  declaration, because this type will be used in the declarations
899       --  created for the component within each protected body, so we must
900       --  create an itype reference for it now.
901
902       if Nkind (Parent (Related_Nod)) = N_Protected_Definition then
903          Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
904       end if;
905
906       return Anon_Type;
907    end Access_Definition;
908
909    -----------------------------------
910    -- Access_Subprogram_Declaration --
911    -----------------------------------
912
913    procedure Access_Subprogram_Declaration
914      (T_Name : Entity_Id;
915       T_Def  : Node_Id)
916    is
917       Formals : constant List_Id := Parameter_Specifications (T_Def);
918       Formal  : Entity_Id;
919       D_Ityp  : Node_Id;
920
921       Desig_Type : constant Entity_Id :=
922                      Create_Itype (E_Subprogram_Type, Parent (T_Def));
923
924    begin
925       --  Associate the Itype node with the inner full-type declaration or
926       --  subprogram spec. This is required to handle nested anonymous
927       --  declarations. For example:
928
929       --      procedure P
930       --       (X : access procedure
931       --                     (Y : access procedure
932       --                                   (Z : access T)))
933
934       D_Ityp := Associated_Node_For_Itype (Desig_Type);
935       while Nkind (D_Ityp) /= N_Full_Type_Declaration
936          and then Nkind (D_Ityp) /= N_Private_Type_Declaration
937          and then Nkind (D_Ityp) /= N_Private_Extension_Declaration
938          and then Nkind (D_Ityp) /= N_Procedure_Specification
939          and then Nkind (D_Ityp) /= N_Function_Specification
940          and then Nkind (D_Ityp) /= N_Object_Declaration
941          and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration
942          and then Nkind (D_Ityp) /= N_Formal_Type_Declaration
943          and then Nkind (D_Ityp) /= N_Task_Type_Declaration
944          and then Nkind (D_Ityp) /= N_Protected_Type_Declaration
945       loop
946          D_Ityp := Parent (D_Ityp);
947          pragma Assert (D_Ityp /= Empty);
948       end loop;
949
950       Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
951
952       if Nkind (D_Ityp) = N_Procedure_Specification
953         or else Nkind (D_Ityp) = N_Function_Specification
954       then
955          Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
956
957       elsif Nkind (D_Ityp) = N_Full_Type_Declaration
958         or else Nkind (D_Ityp) = N_Object_Declaration
959         or else Nkind (D_Ityp) = N_Object_Renaming_Declaration
960         or else Nkind (D_Ityp) = N_Formal_Type_Declaration
961       then
962          Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
963       end if;
964
965       if Nkind (T_Def) = N_Access_Function_Definition then
966          if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
967
968             declare
969                Acc : constant Node_Id := Result_Definition (T_Def);
970
971             begin
972                if Present (Access_To_Subprogram_Definition (Acc))
973                  and then
974                    Protected_Present (Access_To_Subprogram_Definition (Acc))
975                then
976                   Set_Etype
977                     (Desig_Type,
978                        Replace_Anonymous_Access_To_Protected_Subprogram
979                          (T_Def));
980
981                else
982                   Set_Etype
983                     (Desig_Type,
984                        Access_Definition (T_Def, Result_Definition (T_Def)));
985                end if;
986             end;
987
988          else
989             Analyze (Result_Definition (T_Def));
990             Set_Etype (Desig_Type, Entity (Result_Definition (T_Def)));
991          end if;
992
993          if not (Is_Type (Etype (Desig_Type))) then
994             Error_Msg_N
995               ("expect type in function specification",
996                Result_Definition (T_Def));
997          end if;
998
999       else
1000          Set_Etype (Desig_Type, Standard_Void_Type);
1001       end if;
1002
1003       if Present (Formals) then
1004          Push_Scope (Desig_Type);
1005          Process_Formals (Formals, Parent (T_Def));
1006
1007          --  A bit of a kludge here, End_Scope requires that the parent
1008          --  pointer be set to something reasonable, but Itypes don't have
1009          --  parent pointers. So we set it and then unset it ??? If and when
1010          --  Itypes have proper parent pointers to their declarations, this
1011          --  kludge can be removed.
1012
1013          Set_Parent (Desig_Type, T_Name);
1014          End_Scope;
1015          Set_Parent (Desig_Type, Empty);
1016       end if;
1017
1018       --  The return type and/or any parameter type may be incomplete. Mark
1019       --  the subprogram_type as depending on the incomplete type, so that
1020       --  it can be updated when the full type declaration is seen. This
1021       --  only applies to incomplete types declared in some enclosing scope,
1022       --  not to limited views from other packages.
1023
1024       if Present (Formals) then
1025          Formal := First_Formal (Desig_Type);
1026          while Present (Formal) loop
1027             if Ekind (Formal) /= E_In_Parameter
1028               and then Nkind (T_Def) = N_Access_Function_Definition
1029             then
1030                Error_Msg_N ("functions can only have IN parameters", Formal);
1031             end if;
1032
1033             if Ekind (Etype (Formal)) = E_Incomplete_Type
1034               and then In_Open_Scopes (Scope (Etype (Formal)))
1035             then
1036                Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
1037                Set_Has_Delayed_Freeze (Desig_Type);
1038             end if;
1039
1040             Next_Formal (Formal);
1041          end loop;
1042       end if;
1043
1044       if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
1045         and then not Has_Delayed_Freeze (Desig_Type)
1046       then
1047          Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
1048          Set_Has_Delayed_Freeze (Desig_Type);
1049       end if;
1050
1051       Check_Delayed_Subprogram (Desig_Type);
1052
1053       if Protected_Present (T_Def) then
1054          Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
1055          Set_Convention (Desig_Type, Convention_Protected);
1056       else
1057          Set_Ekind (T_Name, E_Access_Subprogram_Type);
1058       end if;
1059
1060       Set_Etype                    (T_Name, T_Name);
1061       Init_Size_Align              (T_Name);
1062       Set_Directly_Designated_Type (T_Name, Desig_Type);
1063
1064       --  Ada 2005 (AI-231): Propagate the null-excluding attribute
1065
1066       Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
1067
1068       Check_Restriction (No_Access_Subprograms, T_Def);
1069    end Access_Subprogram_Declaration;
1070
1071    ----------------------------
1072    -- Access_Type_Declaration --
1073    ----------------------------
1074
1075    procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
1076       S : constant Node_Id := Subtype_Indication (Def);
1077       P : constant Node_Id := Parent (Def);
1078
1079       Desig : Entity_Id;
1080       --  Designated type
1081
1082    begin
1083       --  Check for permissible use of incomplete type
1084
1085       if Nkind (S) /= N_Subtype_Indication then
1086          Analyze (S);
1087
1088          if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
1089             Set_Directly_Designated_Type (T, Entity (S));
1090          else
1091             Set_Directly_Designated_Type (T,
1092               Process_Subtype (S, P, T, 'P'));
1093          end if;
1094
1095       else
1096          Set_Directly_Designated_Type (T,
1097            Process_Subtype (S, P, T, 'P'));
1098       end if;
1099
1100       if All_Present (Def) or Constant_Present (Def) then
1101          Set_Ekind (T, E_General_Access_Type);
1102       else
1103          Set_Ekind (T, E_Access_Type);
1104       end if;
1105
1106       if Base_Type (Designated_Type (T)) = T then
1107          Error_Msg_N ("access type cannot designate itself", S);
1108
1109       --  In Ada 2005, the type may have a limited view through some unit
1110       --  in its own context, allowing the following circularity that cannot
1111       --  be detected earlier
1112
1113       elsif Is_Class_Wide_Type (Designated_Type (T))
1114         and then Etype (Designated_Type (T)) = T
1115       then
1116          Error_Msg_N
1117            ("access type cannot designate its own classwide type", S);
1118
1119          --  Clean up indication of tagged status to prevent cascaded errors
1120
1121          Set_Is_Tagged_Type (T, False);
1122       end if;
1123
1124       Set_Etype (T, T);
1125
1126       --  If the type has appeared already in a with_type clause, it is
1127       --  frozen and the pointer size is already set. Else, initialize.
1128
1129       if not From_With_Type (T) then
1130          Init_Size_Align (T);
1131       end if;
1132
1133       Desig := Designated_Type (T);
1134
1135       --  If designated type is an imported tagged type, indicate that the
1136       --  access type is also imported, and therefore restricted in its use.
1137       --  The access type may already be imported, so keep setting otherwise.
1138
1139       --  Ada 2005 (AI-50217): If the non-limited view of the designated type
1140       --  is available, use it as the designated type of the access type, so
1141       --  that the back-end gets a usable entity.
1142
1143       if From_With_Type (Desig)
1144         and then Ekind (Desig) /= E_Access_Type
1145       then
1146          Set_From_With_Type (T);
1147       end if;
1148
1149       --  Note that Has_Task is always false, since the access type itself
1150       --  is not a task type. See Einfo for more description on this point.
1151       --  Exactly the same consideration applies to Has_Controlled_Component.
1152
1153       Set_Has_Task (T, False);
1154       Set_Has_Controlled_Component (T, False);
1155
1156       --  Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1157       --  attributes
1158
1159       Set_Can_Never_Be_Null  (T, Null_Exclusion_Present (Def));
1160       Set_Is_Access_Constant (T, Constant_Present (Def));
1161    end Access_Type_Declaration;
1162
1163    ----------------------------------
1164    -- Add_Interface_Tag_Components --
1165    ----------------------------------
1166
1167    procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is
1168       Loc      : constant Source_Ptr := Sloc (N);
1169       Elmt     : Elmt_Id;
1170       Ext      : Node_Id;
1171       L        : List_Id;
1172       Last_Tag : Node_Id;
1173       Comp     : Node_Id;
1174
1175       procedure Add_Sync_Iface_Tags (T : Entity_Id);
1176       --  Local subprogram used to recursively climb through the parents
1177       --  of T to add the tags of all the progenitor interfaces.
1178
1179       procedure Add_Tag (Iface : Entity_Id);
1180       --  Add tag for one of the progenitor interfaces
1181
1182       -------------------------
1183       -- Add_Sync_Iface_Tags --
1184       -------------------------
1185
1186       procedure Add_Sync_Iface_Tags (T : Entity_Id) is
1187       begin
1188          if Etype (T) /= T then
1189             Add_Sync_Iface_Tags (Etype (T));
1190          end if;
1191
1192          Elmt := First_Elmt (Abstract_Interfaces (T));
1193          while Present (Elmt) loop
1194             Add_Tag (Node (Elmt));
1195             Next_Elmt (Elmt);
1196          end loop;
1197       end Add_Sync_Iface_Tags;
1198
1199       -------------
1200       -- Add_Tag --
1201       -------------
1202
1203       procedure Add_Tag (Iface : Entity_Id) is
1204          Decl   : Node_Id;
1205          Def    : Node_Id;
1206          Tag    : Entity_Id;
1207          Offset : Entity_Id;
1208
1209       begin
1210          pragma Assert (Is_Tagged_Type (Iface)
1211            and then Is_Interface (Iface));
1212
1213          Def :=
1214            Make_Component_Definition (Loc,
1215              Aliased_Present    => True,
1216              Subtype_Indication =>
1217                New_Occurrence_Of (RTE (RE_Interface_Tag), Loc));
1218
1219          Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
1220
1221          Decl :=
1222            Make_Component_Declaration (Loc,
1223              Defining_Identifier  => Tag,
1224              Component_Definition => Def);
1225
1226          Analyze_Component_Declaration (Decl);
1227
1228          Set_Analyzed (Decl);
1229          Set_Ekind               (Tag, E_Component);
1230          Set_Is_Tag              (Tag);
1231          Set_Is_Aliased          (Tag);
1232          Set_Related_Interface   (Tag, Iface);
1233          Init_Component_Location (Tag);
1234
1235          pragma Assert (Is_Frozen (Iface));
1236
1237          Set_DT_Entry_Count    (Tag,
1238            DT_Entry_Count (First_Entity (Iface)));
1239
1240          if No (Last_Tag) then
1241             Prepend (Decl, L);
1242          else
1243             Insert_After (Last_Tag, Decl);
1244          end if;
1245
1246          Last_Tag := Decl;
1247
1248          --  If the ancestor has discriminants we need to give special support
1249          --  to store the offset_to_top value of the secondary dispatch tables.
1250          --  For this purpose we add a supplementary component just after the
1251          --  field that contains the tag associated with each secondary DT.
1252
1253          if Typ /= Etype (Typ)
1254            and then Has_Discriminants (Etype (Typ))
1255          then
1256             Def :=
1257               Make_Component_Definition (Loc,
1258                 Subtype_Indication =>
1259                   New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
1260
1261             Offset :=
1262               Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
1263
1264             Decl :=
1265               Make_Component_Declaration (Loc,
1266                 Defining_Identifier  => Offset,
1267                 Component_Definition => Def);
1268
1269             Analyze_Component_Declaration (Decl);
1270
1271             Set_Analyzed (Decl);
1272             Set_Ekind               (Offset, E_Component);
1273             Set_Is_Aliased          (Offset);
1274             Set_Related_Interface   (Offset, Iface);
1275             Init_Component_Location (Offset);
1276             Insert_After (Last_Tag, Decl);
1277             Last_Tag := Decl;
1278          end if;
1279       end Add_Tag;
1280
1281       --  Local variables
1282
1283       Iface_List : List_Id;
1284
1285    --  Start of processing for Add_Interface_Tag_Components
1286
1287    begin
1288       if not RTE_Available (RE_Interface_Tag) then
1289          Error_Msg
1290            ("(Ada 2005) interface types not supported by this run-time!",
1291             Sloc (N));
1292          return;
1293       end if;
1294
1295       if Ekind (Typ) /= E_Record_Type
1296         or else (Is_Concurrent_Record_Type (Typ)
1297                   and then Is_Empty_List (Abstract_Interface_List (Typ)))
1298         or else (not Is_Concurrent_Record_Type (Typ)
1299                   and then No (Abstract_Interfaces (Typ))
1300                   and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
1301       then
1302          return;
1303       end if;
1304
1305       --  Find the current last tag
1306
1307       if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1308          Ext := Record_Extension_Part (Type_Definition (N));
1309       else
1310          pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
1311          Ext := Type_Definition (N);
1312       end if;
1313
1314       Last_Tag := Empty;
1315
1316       if not (Present (Component_List (Ext))) then
1317          Set_Null_Present (Ext, False);
1318          L := New_List;
1319          Set_Component_List (Ext,
1320            Make_Component_List (Loc,
1321              Component_Items => L,
1322              Null_Present => False));
1323       else
1324          if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1325             L := Component_Items
1326                    (Component_List
1327                      (Record_Extension_Part
1328                        (Type_Definition (N))));
1329          else
1330             L := Component_Items
1331                    (Component_List
1332                      (Type_Definition (N)));
1333          end if;
1334
1335          --  Find the last tag component
1336
1337          Comp := First (L);
1338          while Present (Comp) loop
1339             if Nkind (Comp) = N_Component_Declaration
1340               and then Is_Tag (Defining_Identifier (Comp))
1341             then
1342                Last_Tag := Comp;
1343             end if;
1344
1345             Next (Comp);
1346          end loop;
1347       end if;
1348
1349       --  At this point L references the list of components and Last_Tag
1350       --  references the current last tag (if any). Now we add the tag
1351       --  corresponding with all the interfaces that are not implemented
1352       --  by the parent.
1353
1354       if Is_Concurrent_Record_Type (Typ) then
1355          Iface_List := Abstract_Interface_List (Typ);
1356
1357          if Is_Non_Empty_List (Iface_List) then
1358             Add_Sync_Iface_Tags (Etype (First (Iface_List)));
1359          end if;
1360       end if;
1361
1362       if Present (Abstract_Interfaces (Typ)) then
1363          Elmt := First_Elmt (Abstract_Interfaces (Typ));
1364          while Present (Elmt) loop
1365             Add_Tag (Node (Elmt));
1366             Next_Elmt (Elmt);
1367          end loop;
1368       end if;
1369    end Add_Interface_Tag_Components;
1370
1371    -----------------------------------
1372    -- Analyze_Component_Declaration --
1373    -----------------------------------
1374
1375    procedure Analyze_Component_Declaration (N : Node_Id) is
1376       Id : constant Entity_Id := Defining_Identifier (N);
1377       E  : constant Node_Id   := Expression (N);
1378       T  : Entity_Id;
1379       P  : Entity_Id;
1380
1381       function Contains_POC (Constr : Node_Id) return Boolean;
1382       --  Determines whether a constraint uses the discriminant of a record
1383       --  type thus becoming a per-object constraint (POC).
1384
1385       function Is_Known_Limited (Typ : Entity_Id) return Boolean;
1386       --  Typ is the type of the current component, check whether this type is
1387       --  a limited type. Used to validate declaration against that of
1388       --  enclosing record.
1389
1390       ------------------
1391       -- Contains_POC --
1392       ------------------
1393
1394       function Contains_POC (Constr : Node_Id) return Boolean is
1395       begin
1396          --  Prevent cascaded errors
1397
1398          if Error_Posted (Constr) then
1399             return False;
1400          end if;
1401
1402          case Nkind (Constr) is
1403             when N_Attribute_Reference =>
1404                return
1405                  Attribute_Name (Constr) = Name_Access
1406                    and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
1407
1408             when N_Discriminant_Association =>
1409                return Denotes_Discriminant (Expression (Constr));
1410
1411             when N_Identifier =>
1412                return Denotes_Discriminant (Constr);
1413
1414             when N_Index_Or_Discriminant_Constraint =>
1415                declare
1416                   IDC : Node_Id;
1417
1418                begin
1419                   IDC := First (Constraints (Constr));
1420                   while Present (IDC) loop
1421
1422                      --  One per-object constraint is sufficient
1423
1424                      if Contains_POC (IDC) then
1425                         return True;
1426                      end if;
1427
1428                      Next (IDC);
1429                   end loop;
1430
1431                   return False;
1432                end;
1433
1434             when N_Range =>
1435                return Denotes_Discriminant (Low_Bound (Constr))
1436                         or else
1437                       Denotes_Discriminant (High_Bound (Constr));
1438
1439             when N_Range_Constraint =>
1440                return Denotes_Discriminant (Range_Expression (Constr));
1441
1442             when others =>
1443                return False;
1444
1445          end case;
1446       end Contains_POC;
1447
1448       ----------------------
1449       -- Is_Known_Limited --
1450       ----------------------
1451
1452       function Is_Known_Limited (Typ : Entity_Id) return Boolean is
1453          P : constant Entity_Id := Etype (Typ);
1454          R : constant Entity_Id := Root_Type (Typ);
1455
1456       begin
1457          if Is_Limited_Record (Typ) then
1458             return True;
1459
1460          --  If the root type is limited (and not a limited interface)
1461          --  so is the current type
1462
1463          elsif Is_Limited_Record (R)
1464            and then
1465              (not Is_Interface (R)
1466                or else not Is_Limited_Interface (R))
1467          then
1468             return True;
1469
1470          --  Else the type may have a limited interface progenitor, but a
1471          --  limited record parent.
1472
1473          elsif R /= P
1474            and then Is_Limited_Record (P)
1475          then
1476             return True;
1477
1478          else
1479             return False;
1480          end if;
1481       end Is_Known_Limited;
1482
1483    --  Start of processing for Analyze_Component_Declaration
1484
1485    begin
1486       Generate_Definition (Id);
1487       Enter_Name (Id);
1488
1489       if Present (Subtype_Indication (Component_Definition (N))) then
1490          T := Find_Type_Of_Object
1491                 (Subtype_Indication (Component_Definition (N)), N);
1492
1493       --  Ada 2005 (AI-230): Access Definition case
1494
1495       else
1496          pragma Assert (Present
1497                           (Access_Definition (Component_Definition (N))));
1498
1499          T := Access_Definition
1500                 (Related_Nod => N,
1501                  N => Access_Definition (Component_Definition (N)));
1502          Set_Is_Local_Anonymous_Access (T);
1503
1504          --  Ada 2005 (AI-254)
1505
1506          if Present (Access_To_Subprogram_Definition
1507                       (Access_Definition (Component_Definition (N))))
1508            and then Protected_Present (Access_To_Subprogram_Definition
1509                                         (Access_Definition
1510                                           (Component_Definition (N))))
1511          then
1512             T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1513          end if;
1514       end if;
1515
1516       --  If the subtype is a constrained subtype of the enclosing record,
1517       --  (which must have a partial view) the back-end does not properly
1518       --  handle the recursion. Rewrite the component declaration with an
1519       --  explicit subtype indication, which is acceptable to Gigi. We can copy
1520       --  the tree directly because side effects have already been removed from
1521       --  discriminant constraints.
1522
1523       if Ekind (T) = E_Access_Subtype
1524         and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
1525         and then Comes_From_Source (T)
1526         and then Nkind (Parent (T)) = N_Subtype_Declaration
1527         and then Etype (Directly_Designated_Type (T)) = Current_Scope
1528       then
1529          Rewrite
1530            (Subtype_Indication (Component_Definition (N)),
1531              New_Copy_Tree (Subtype_Indication (Parent (T))));
1532          T := Find_Type_Of_Object
1533                  (Subtype_Indication (Component_Definition (N)), N);
1534       end if;
1535
1536       --  If the component declaration includes a default expression, then we
1537       --  check that the component is not of a limited type (RM 3.7(5)),
1538       --  and do the special preanalysis of the expression (see section on
1539       --  "Handling of Default and Per-Object Expressions" in the spec of
1540       --  package Sem).
1541
1542       if Present (E) then
1543          Analyze_Per_Use_Expression (E, T);
1544          Check_Initialization (T, E);
1545
1546          if Ada_Version >= Ada_05
1547            and then Ekind (T) = E_Anonymous_Access_Type
1548          then
1549             --  Check RM 3.9.2(9): "if the expected type for an expression is
1550             --  an anonymous access-to-specific tagged type, then the object
1551             --  designated by the expression shall not be dynamically tagged
1552             --  unless it is a controlling operand in a call on a dispatching
1553             --  operation"
1554
1555             if Is_Tagged_Type (Directly_Designated_Type (T))
1556               and then
1557                 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
1558               and then
1559                 Ekind (Directly_Designated_Type (Etype (E))) =
1560                   E_Class_Wide_Type
1561             then
1562                Error_Msg_N
1563                  ("access to specific tagged type required (RM 3.9.2(9))", E);
1564             end if;
1565
1566             --  (Ada 2005: AI-230): Accessibility check for anonymous
1567             --  components
1568
1569             if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then
1570                Error_Msg_N
1571                  ("expression has deeper access level than component " &
1572                   "(RM 3.10.2 (12.2))", E);
1573             end if;
1574
1575             --  The initialization expression is a reference to an access
1576             --  discriminant. The type of the discriminant is always deeper
1577             --  than any access type.
1578
1579             if Ekind (Etype (E)) = E_Anonymous_Access_Type
1580               and then Is_Entity_Name (E)
1581               and then Ekind (Entity (E)) = E_In_Parameter
1582               and then Present (Discriminal_Link (Entity (E)))
1583             then
1584                Error_Msg_N
1585                  ("discriminant has deeper accessibility level than target",
1586                   E);
1587             end if;
1588          end if;
1589       end if;
1590
1591       --  The parent type may be a private view with unknown discriminants,
1592       --  and thus unconstrained. Regular components must be constrained.
1593
1594       if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
1595          if Is_Class_Wide_Type (T) then
1596             Error_Msg_N
1597                ("class-wide subtype with unknown discriminants" &
1598                  " in component declaration",
1599                  Subtype_Indication (Component_Definition (N)));
1600          else
1601             Error_Msg_N
1602               ("unconstrained subtype in component declaration",
1603                Subtype_Indication (Component_Definition (N)));
1604          end if;
1605
1606       --  Components cannot be abstract, except for the special case of
1607       --  the _Parent field (case of extending an abstract tagged type)
1608
1609       elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then
1610          Error_Msg_N ("type of a component cannot be abstract", N);
1611       end if;
1612
1613       Set_Etype (Id, T);
1614       Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
1615
1616       --  The component declaration may have a per-object constraint, set
1617       --  the appropriate flag in the defining identifier of the subtype.
1618
1619       if Present (Subtype_Indication (Component_Definition (N))) then
1620          declare
1621             Sindic : constant Node_Id :=
1622                        Subtype_Indication (Component_Definition (N));
1623
1624          begin
1625             if Nkind (Sindic) = N_Subtype_Indication
1626               and then Present (Constraint (Sindic))
1627               and then Contains_POC (Constraint (Sindic))
1628             then
1629                Set_Has_Per_Object_Constraint (Id);
1630             end if;
1631          end;
1632       end if;
1633
1634       --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1635       --  out some static checks.
1636
1637       if Ada_Version >= Ada_05
1638         and then Can_Never_Be_Null (T)
1639       then
1640          Null_Exclusion_Static_Checks (N);
1641       end if;
1642
1643       --  If this component is private (or depends on a private type), flag the
1644       --  record type to indicate that some operations are not available.
1645
1646       P := Private_Component (T);
1647
1648       if Present (P) then
1649
1650          --  Check for circular definitions
1651
1652          if P = Any_Type then
1653             Set_Etype (Id, Any_Type);
1654
1655          --  There is a gap in the visibility of operations only if the
1656          --  component type is not defined in the scope of the record type.
1657
1658          elsif Scope (P) = Scope (Current_Scope) then
1659             null;
1660
1661          elsif Is_Limited_Type (P) then
1662             Set_Is_Limited_Composite (Current_Scope);
1663
1664          else
1665             Set_Is_Private_Composite (Current_Scope);
1666          end if;
1667       end if;
1668
1669       if P /= Any_Type
1670         and then Is_Limited_Type (T)
1671         and then Chars (Id) /= Name_uParent
1672         and then Is_Tagged_Type (Current_Scope)
1673       then
1674          if Is_Derived_Type (Current_Scope)
1675            and then not Is_Known_Limited (Current_Scope)
1676          then
1677             Error_Msg_N
1678               ("extension of nonlimited type cannot have limited components",
1679                N);
1680
1681             if Is_Interface (Root_Type (Current_Scope)) then
1682                Error_Msg_N
1683                  ("\limitedness is not inherited from limited interface", N);
1684                Error_Msg_N
1685                  ("\add LIMITED to type indication", N);
1686             end if;
1687
1688             Explain_Limited_Type (T, N);
1689             Set_Etype (Id, Any_Type);
1690             Set_Is_Limited_Composite (Current_Scope, False);
1691
1692          elsif not Is_Derived_Type (Current_Scope)
1693            and then not Is_Limited_Record (Current_Scope)
1694            and then not Is_Concurrent_Type (Current_Scope)
1695          then
1696             Error_Msg_N
1697               ("nonlimited tagged type cannot have limited components", N);
1698             Explain_Limited_Type (T, N);
1699             Set_Etype (Id, Any_Type);
1700             Set_Is_Limited_Composite (Current_Scope, False);
1701          end if;
1702       end if;
1703
1704       Set_Original_Record_Component (Id, Id);
1705    end Analyze_Component_Declaration;
1706
1707    --------------------------
1708    -- Analyze_Declarations --
1709    --------------------------
1710
1711    procedure Analyze_Declarations (L : List_Id) is
1712       D           : Node_Id;
1713       Freeze_From : Entity_Id := Empty;
1714       Next_Node   : Node_Id;
1715
1716       procedure Adjust_D;
1717       --  Adjust D not to include implicit label declarations, since these
1718       --  have strange Sloc values that result in elaboration check problems.
1719       --  (They have the sloc of the label as found in the source, and that
1720       --  is ahead of the current declarative part).
1721
1722       --------------
1723       -- Adjust_D --
1724       --------------
1725
1726       procedure Adjust_D is
1727       begin
1728          while Present (Prev (D))
1729            and then Nkind (D) = N_Implicit_Label_Declaration
1730          loop
1731             Prev (D);
1732          end loop;
1733       end Adjust_D;
1734
1735    --  Start of processing for Analyze_Declarations
1736
1737    begin
1738       D := First (L);
1739       while Present (D) loop
1740
1741          --  Complete analysis of declaration
1742
1743          Analyze (D);
1744          Next_Node := Next (D);
1745
1746          if No (Freeze_From) then
1747             Freeze_From := First_Entity (Current_Scope);
1748          end if;
1749
1750          --  At the end of a declarative part, freeze remaining entities
1751          --  declared in it. The end of the visible declarations of package
1752          --  specification is not the end of a declarative part if private
1753          --  declarations are present. The end of a package declaration is a
1754          --  freezing point only if it a library package. A task definition or
1755          --  protected type definition is not a freeze point either. Finally,
1756          --  we do not freeze entities in generic scopes, because there is no
1757          --  code generated for them and freeze nodes will be generated for
1758          --  the instance.
1759
1760          --  The end of a package instantiation is not a freeze point, but
1761          --  for now we make it one, because the generic body is inserted
1762          --  (currently) immediately after. Generic instantiations will not
1763          --  be a freeze point once delayed freezing of bodies is implemented.
1764          --  (This is needed in any case for early instantiations ???).
1765
1766          if No (Next_Node) then
1767             if Nkind (Parent (L)) = N_Component_List
1768               or else Nkind (Parent (L)) = N_Task_Definition
1769               or else Nkind (Parent (L)) = N_Protected_Definition
1770             then
1771                null;
1772
1773             elsif Nkind (Parent (L)) /= N_Package_Specification then
1774                if Nkind (Parent (L)) = N_Package_Body then
1775                   Freeze_From := First_Entity (Current_Scope);
1776                end if;
1777
1778                Adjust_D;
1779                Freeze_All (Freeze_From, D);
1780                Freeze_From := Last_Entity (Current_Scope);
1781
1782             elsif Scope (Current_Scope) /= Standard_Standard
1783               and then not Is_Child_Unit (Current_Scope)
1784               and then No (Generic_Parent (Parent (L)))
1785             then
1786                null;
1787
1788             elsif L /= Visible_Declarations (Parent (L))
1789                or else No (Private_Declarations (Parent (L)))
1790                or else Is_Empty_List (Private_Declarations (Parent (L)))
1791             then
1792                Adjust_D;
1793                Freeze_All (Freeze_From, D);
1794                Freeze_From := Last_Entity (Current_Scope);
1795             end if;
1796
1797          --  If next node is a body then freeze all types before the body.
1798          --  An exception occurs for some expander-generated bodies. If these
1799          --  are generated at places where in general language rules would not
1800          --  allow a freeze point, then we assume that the expander has
1801          --  explicitly checked that all required types are properly frozen,
1802          --  and we do not cause general freezing here. This special circuit
1803          --  is used when the encountered body is marked as having already
1804          --  been analyzed.
1805
1806          --  In all other cases (bodies that come from source, and expander
1807          --  generated bodies that have not been analyzed yet), freeze all
1808          --  types now. Note that in the latter case, the expander must take
1809          --  care to attach the bodies at a proper place in the tree so as to
1810          --  not cause unwanted freezing at that point.
1811
1812          elsif not Analyzed (Next_Node)
1813            and then (Nkind (Next_Node) = N_Subprogram_Body
1814              or else Nkind (Next_Node) = N_Entry_Body
1815              or else Nkind (Next_Node) = N_Package_Body
1816              or else Nkind (Next_Node) = N_Protected_Body
1817              or else Nkind (Next_Node) = N_Task_Body
1818              or else Nkind (Next_Node) in N_Body_Stub)
1819          then
1820             Adjust_D;
1821             Freeze_All (Freeze_From, D);
1822             Freeze_From := Last_Entity (Current_Scope);
1823          end if;
1824
1825          D := Next_Node;
1826       end loop;
1827    end Analyze_Declarations;
1828
1829    ----------------------------------
1830    -- Analyze_Incomplete_Type_Decl --
1831    ----------------------------------
1832
1833    procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
1834       F : constant Boolean := Is_Pure (Current_Scope);
1835       T : Entity_Id;
1836
1837    begin
1838       Generate_Definition (Defining_Identifier (N));
1839
1840       --  Process an incomplete declaration. The identifier must not have been
1841       --  declared already in the scope. However, an incomplete declaration may
1842       --  appear in the private part of a package, for a private type that has
1843       --  already been declared.
1844
1845       --  In this case, the discriminants (if any) must match
1846
1847       T := Find_Type_Name (N);
1848
1849       Set_Ekind (T, E_Incomplete_Type);
1850       Init_Size_Align (T);
1851       Set_Is_First_Subtype (T, True);
1852       Set_Etype (T, T);
1853
1854       --  Ada 2005 (AI-326): Minimum decoration to give support to tagged
1855       --  incomplete types.
1856
1857       if Tagged_Present (N) then
1858          Set_Is_Tagged_Type (T);
1859          Make_Class_Wide_Type (T);
1860          Set_Primitive_Operations (T, New_Elmt_List);
1861       end if;
1862
1863       Push_Scope (T);
1864
1865       Set_Stored_Constraint (T, No_Elist);
1866
1867       if Present (Discriminant_Specifications (N)) then
1868          Process_Discriminants (N);
1869       end if;
1870
1871       End_Scope;
1872
1873       --  If the type has discriminants, non-trivial subtypes may be be
1874       --  declared before the full view of the type. The full views of those
1875       --  subtypes will be built after the full view of the type.
1876
1877       Set_Private_Dependents (T, New_Elmt_List);
1878       Set_Is_Pure (T, F);
1879    end Analyze_Incomplete_Type_Decl;
1880
1881    -----------------------------------
1882    -- Analyze_Interface_Declaration --
1883    -----------------------------------
1884
1885    procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
1886       CW : constant Entity_Id := Class_Wide_Type (T);
1887
1888    begin
1889       Set_Is_Tagged_Type      (T);
1890
1891       Set_Is_Limited_Record   (T, Limited_Present (Def)
1892                                    or else Task_Present (Def)
1893                                    or else Protected_Present (Def)
1894                                    or else Synchronized_Present (Def));
1895
1896       --  Type is abstract if full declaration carries keyword, or if previous
1897       --  partial view did.
1898
1899       Set_Is_Abstract_Type (T);
1900       Set_Is_Interface     (T);
1901
1902       --  Type is a limited interface if it includes the keyword limited, task,
1903       --  protected, or synchronized.
1904
1905       Set_Is_Limited_Interface
1906         (T, Limited_Present (Def)
1907               or else Protected_Present (Def)
1908               or else Synchronized_Present (Def)
1909               or else Task_Present (Def));
1910
1911       Set_Is_Protected_Interface    (T, Protected_Present (Def));
1912       Set_Is_Task_Interface         (T, Task_Present (Def));
1913
1914       --  Type is a synchronized interface if it includes the keyword task,
1915       --  protected, or synchronized.
1916
1917       Set_Is_Synchronized_Interface
1918         (T, Synchronized_Present (Def)
1919               or else Protected_Present (Def)
1920               or else Task_Present (Def));
1921
1922       Set_Abstract_Interfaces       (T, New_Elmt_List);
1923       Set_Primitive_Operations      (T, New_Elmt_List);
1924
1925       --  Complete the decoration of the class-wide entity if it was already
1926       --  built (ie. during the creation of the limited view)
1927
1928       if Present (CW) then
1929          Set_Is_Interface (CW);
1930          Set_Is_Limited_Interface      (CW, Is_Limited_Interface (T));
1931          Set_Is_Protected_Interface    (CW, Is_Protected_Interface (T));
1932          Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T));
1933          Set_Is_Task_Interface         (CW, Is_Task_Interface (T));
1934       end if;
1935    end Analyze_Interface_Declaration;
1936
1937    -----------------------------
1938    -- Analyze_Itype_Reference --
1939    -----------------------------
1940
1941    --  Nothing to do. This node is placed in the tree only for the benefit of
1942    --  back end processing, and has no effect on the semantic processing.
1943
1944    procedure Analyze_Itype_Reference (N : Node_Id) is
1945    begin
1946       pragma Assert (Is_Itype (Itype (N)));
1947       null;
1948    end Analyze_Itype_Reference;
1949
1950    --------------------------------
1951    -- Analyze_Number_Declaration --
1952    --------------------------------
1953
1954    procedure Analyze_Number_Declaration (N : Node_Id) is
1955       Id    : constant Entity_Id := Defining_Identifier (N);
1956       E     : constant Node_Id   := Expression (N);
1957       T     : Entity_Id;
1958       Index : Interp_Index;
1959       It    : Interp;
1960
1961    begin
1962       Generate_Definition (Id);
1963       Enter_Name (Id);
1964
1965       --  This is an optimization of a common case of an integer literal
1966
1967       if Nkind (E) = N_Integer_Literal then
1968          Set_Is_Static_Expression (E, True);
1969          Set_Etype                (E, Universal_Integer);
1970
1971          Set_Etype     (Id, Universal_Integer);
1972          Set_Ekind     (Id, E_Named_Integer);
1973          Set_Is_Frozen (Id, True);
1974          return;
1975       end if;
1976
1977       Set_Is_Pure (Id, Is_Pure (Current_Scope));
1978
1979       --  Process expression, replacing error by integer zero, to avoid
1980       --  cascaded errors or aborts further along in the processing
1981
1982       --  Replace Error by integer zero, which seems least likely to
1983       --  cause cascaded errors.
1984
1985       if E = Error then
1986          Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
1987          Set_Error_Posted (E);
1988       end if;
1989
1990       Analyze (E);
1991
1992       --  Verify that the expression is static and numeric. If
1993       --  the expression is overloaded, we apply the preference
1994       --  rule that favors root numeric types.
1995
1996       if not Is_Overloaded (E) then
1997          T := Etype (E);
1998
1999       else
2000          T := Any_Type;
2001
2002          Get_First_Interp (E, Index, It);
2003          while Present (It.Typ) loop
2004             if (Is_Integer_Type (It.Typ)
2005                  or else Is_Real_Type (It.Typ))
2006               and then (Scope (Base_Type (It.Typ))) = Standard_Standard
2007             then
2008                if T = Any_Type then
2009                   T := It.Typ;
2010
2011                elsif It.Typ = Universal_Real
2012                  or else It.Typ = Universal_Integer
2013                then
2014                   --  Choose universal interpretation over any other
2015
2016                   T := It.Typ;
2017                   exit;
2018                end if;
2019             end if;
2020
2021             Get_Next_Interp (Index, It);
2022          end loop;
2023       end if;
2024
2025       if Is_Integer_Type (T)  then
2026          Resolve (E, T);
2027          Set_Etype (Id, Universal_Integer);
2028          Set_Ekind (Id, E_Named_Integer);
2029
2030       elsif Is_Real_Type (T) then
2031
2032          --  Because the real value is converted to universal_real, this is a
2033          --  legal context for a universal fixed expression.
2034
2035          if T = Universal_Fixed then
2036             declare
2037                Loc  : constant Source_Ptr := Sloc (N);
2038                Conv : constant Node_Id := Make_Type_Conversion (Loc,
2039                         Subtype_Mark =>
2040                           New_Occurrence_Of (Universal_Real, Loc),
2041                         Expression => Relocate_Node (E));
2042
2043             begin
2044                Rewrite (E, Conv);
2045                Analyze (E);
2046             end;
2047
2048          elsif T = Any_Fixed then
2049             Error_Msg_N ("illegal context for mixed mode operation", E);
2050
2051             --  Expression is of the form : universal_fixed * integer. Try to
2052             --  resolve as universal_real.
2053
2054             T := Universal_Real;
2055             Set_Etype (E, T);
2056          end if;
2057
2058          Resolve (E, T);
2059          Set_Etype (Id, Universal_Real);
2060          Set_Ekind (Id, E_Named_Real);
2061
2062       else
2063          Wrong_Type (E, Any_Numeric);
2064          Resolve (E, T);
2065
2066          Set_Etype               (Id, T);
2067          Set_Ekind               (Id, E_Constant);
2068          Set_Never_Set_In_Source (Id, True);
2069          Set_Is_True_Constant    (Id, True);
2070          return;
2071       end if;
2072
2073       if Nkind (E) = N_Integer_Literal
2074         or else Nkind (E) = N_Real_Literal
2075       then
2076          Set_Etype (E, Etype (Id));
2077       end if;
2078
2079       if not Is_OK_Static_Expression (E) then
2080          Flag_Non_Static_Expr
2081            ("non-static expression used in number declaration!", E);
2082          Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
2083          Set_Etype (E, Any_Type);
2084       end if;
2085    end Analyze_Number_Declaration;
2086
2087    --------------------------------
2088    -- Analyze_Object_Declaration --
2089    --------------------------------
2090
2091    procedure Analyze_Object_Declaration (N : Node_Id) is
2092       Loc   : constant Source_Ptr := Sloc (N);
2093       Id    : constant Entity_Id  := Defining_Identifier (N);
2094       T     : Entity_Id;
2095       Act_T : Entity_Id;
2096
2097       E : Node_Id := Expression (N);
2098       --  E is set to Expression (N) throughout this routine. When
2099       --  Expression (N) is modified, E is changed accordingly.
2100
2101       Prev_Entity : Entity_Id := Empty;
2102
2103       function Count_Tasks (T : Entity_Id) return Uint;
2104       --  This function is called when a library level object of type is
2105       --  declared. It's function is to count the static number of tasks
2106       --  declared within the type (it is only called if Has_Tasks is set for
2107       --  T). As a side effect, if an array of tasks with non-static bounds or
2108       --  a variant record type is encountered, Check_Restrictions is called
2109       --  indicating the count is unknown.
2110
2111       -----------------
2112       -- Count_Tasks --
2113       -----------------
2114
2115       function Count_Tasks (T : Entity_Id) return Uint is
2116          C : Entity_Id;
2117          X : Node_Id;
2118          V : Uint;
2119
2120       begin
2121          if Is_Task_Type (T) then
2122             return Uint_1;
2123
2124          elsif Is_Record_Type (T) then
2125             if Has_Discriminants (T) then
2126                Check_Restriction (Max_Tasks, N);
2127                return Uint_0;
2128
2129             else
2130                V := Uint_0;
2131                C := First_Component (T);
2132                while Present (C) loop
2133                   V := V + Count_Tasks (Etype (C));
2134                   Next_Component (C);
2135                end loop;
2136
2137                return V;
2138             end if;
2139
2140          elsif Is_Array_Type (T) then
2141             X := First_Index (T);
2142             V := Count_Tasks (Component_Type (T));
2143             while Present (X) loop
2144                C := Etype (X);
2145
2146                if not Is_Static_Subtype (C) then
2147                   Check_Restriction (Max_Tasks, N);
2148                   return Uint_0;
2149                else
2150                   V := V * (UI_Max (Uint_0,
2151                                     Expr_Value (Type_High_Bound (C)) -
2152                                     Expr_Value (Type_Low_Bound (C)) + Uint_1));
2153                end if;
2154
2155                Next_Index (X);
2156             end loop;
2157
2158             return V;
2159
2160          else
2161             return Uint_0;
2162          end if;
2163       end Count_Tasks;
2164
2165    --  Start of processing for Analyze_Object_Declaration
2166
2167    begin
2168       --  There are three kinds of implicit types generated by an
2169       --  object declaration:
2170
2171       --   1. Those for generated by the original Object Definition
2172
2173       --   2. Those generated by the Expression
2174
2175       --   3. Those used to constrained the Object Definition with the
2176       --       expression constraints when it is unconstrained
2177
2178       --  They must be generated in this order to avoid order of elaboration
2179       --  issues. Thus the first step (after entering the name) is to analyze
2180       --  the object definition.
2181
2182       if Constant_Present (N) then
2183          Prev_Entity := Current_Entity_In_Scope (Id);
2184
2185          --  If homograph is an implicit subprogram, it is overridden by the
2186          --  current declaration.
2187
2188          if Present (Prev_Entity)
2189            and then Is_Overloadable (Prev_Entity)
2190            and then Is_Inherited_Operation (Prev_Entity)
2191          then
2192             Prev_Entity := Empty;
2193          end if;
2194       end if;
2195
2196       if Present (Prev_Entity) then
2197          Constant_Redeclaration (Id, N, T);
2198
2199          Generate_Reference (Prev_Entity, Id, 'c');
2200          Set_Completion_Referenced (Id);
2201
2202          if Error_Posted (N) then
2203
2204             --  Type mismatch or illegal redeclaration, Do not analyze
2205             --  expression to avoid cascaded errors.
2206
2207             T := Find_Type_Of_Object (Object_Definition (N), N);
2208             Set_Etype (Id, T);
2209             Set_Ekind (Id, E_Variable);
2210             return;
2211          end if;
2212
2213       --  In the normal case, enter identifier at the start to catch premature
2214       --  usage in the initialization expression.
2215
2216       else
2217          Generate_Definition (Id);
2218          Enter_Name (Id);
2219
2220          Mark_Coextensions (N, Object_Definition (N));
2221
2222          T := Find_Type_Of_Object (Object_Definition (N), N);
2223
2224          if Nkind (Object_Definition (N)) = N_Access_Definition
2225            and then Present
2226              (Access_To_Subprogram_Definition (Object_Definition (N)))
2227            and then Protected_Present
2228              (Access_To_Subprogram_Definition (Object_Definition (N)))
2229          then
2230             T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
2231          end if;
2232
2233          if Error_Posted (Id) then
2234             Set_Etype (Id, T);
2235             Set_Ekind (Id, E_Variable);
2236             return;
2237          end if;
2238       end if;
2239
2240       --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
2241       --  out some static checks
2242
2243       if Ada_Version >= Ada_05
2244         and then Can_Never_Be_Null (T)
2245       then
2246          --  In case of aggregates we must also take care of the correct
2247          --  initialization of nested aggregates bug this is done at the
2248          --  point of the analysis of the aggregate (see sem_aggr.adb)
2249
2250          if Present (Expression (N))
2251            and then Nkind (Expression (N)) = N_Aggregate
2252          then
2253             null;
2254
2255          else
2256             declare
2257                Save_Typ : constant Entity_Id := Etype (Id);
2258             begin
2259                Set_Etype (Id, T); --  Temp. decoration for static checks
2260                Null_Exclusion_Static_Checks (N);
2261                Set_Etype (Id, Save_Typ);
2262             end;
2263          end if;
2264       end if;
2265
2266       Set_Is_Pure (Id, Is_Pure (Current_Scope));
2267
2268       --  If deferred constant, make sure context is appropriate. We detect
2269       --  a deferred constant as a constant declaration with no expression.
2270       --  A deferred constant can appear in a package body if its completion
2271       --  is by means of an interface pragma.
2272
2273       if Constant_Present (N)
2274         and then No (E)
2275       then
2276          --  We exclude forward references to tags
2277
2278          if Is_Imported (Defining_Identifier (N))
2279            and then
2280             (T = RTE (RE_Tag)
2281               or else (Present (Full_View (T))
2282                         and then Full_View (T) = RTE (RE_Tag)))
2283          then
2284             null;
2285
2286          elsif not Is_Package_Or_Generic_Package (Current_Scope) then
2287             Error_Msg_N
2288               ("invalid context for deferred constant declaration (RM 7.4)",
2289                 N);
2290             Error_Msg_N
2291               ("\declaration requires an initialization expression",
2292                 N);
2293             Set_Constant_Present (N, False);
2294
2295          --  In Ada 83, deferred constant must be of private type
2296
2297          elsif not Is_Private_Type (T) then
2298             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2299                Error_Msg_N
2300                  ("(Ada 83) deferred constant must be private type", N);
2301             end if;
2302          end if;
2303
2304       --  If not a deferred constant, then object declaration freezes its type
2305
2306       else
2307          Check_Fully_Declared (T, N);
2308          Freeze_Before (N, T);
2309       end if;
2310
2311       --  If the object was created by a constrained array definition, then
2312       --  set the link in both the anonymous base type and anonymous subtype
2313       --  that are built to represent the array type to point to the object.
2314
2315       if Nkind (Object_Definition (Declaration_Node (Id))) =
2316                         N_Constrained_Array_Definition
2317       then
2318          Set_Related_Array_Object (T, Id);
2319          Set_Related_Array_Object (Base_Type (T), Id);
2320       end if;
2321
2322       --  Special checks for protected objects not at library level
2323
2324       if Is_Protected_Type (T)
2325         and then not Is_Library_Level_Entity (Id)
2326       then
2327          Check_Restriction (No_Local_Protected_Objects, Id);
2328
2329          --  Protected objects with interrupt handlers must be at library level
2330
2331          --  Ada 2005: this test is not needed (and the corresponding clause
2332          --  in the RM is removed) because accessibility checks are sufficient
2333          --  to make handlers not at the library level illegal.
2334
2335          if Has_Interrupt_Handler (T)
2336            and then Ada_Version < Ada_05
2337          then
2338             Error_Msg_N
2339               ("interrupt object can only be declared at library level", Id);
2340          end if;
2341       end if;
2342
2343       --  The actual subtype of the object is the nominal subtype, unless
2344       --  the nominal one is unconstrained and obtained from the expression.
2345
2346       Act_T := T;
2347
2348       --  Process initialization expression if present and not in error
2349
2350       if Present (E) and then E /= Error then
2351          Mark_Coextensions (N, E);
2352          Analyze (E);
2353
2354          --  In case of errors detected in the analysis of the expression,
2355          --  decorate it with the expected type to avoid cascade errors
2356
2357          if No (Etype (E)) then
2358             Set_Etype (E, T);
2359          end if;
2360
2361          --  If an initialization expression is present, then we set the
2362          --  Is_True_Constant flag. It will be reset if this is a variable
2363          --  and it is indeed modified.
2364
2365          Set_Is_True_Constant (Id, True);
2366
2367          --  If we are analyzing a constant declaration, set its completion
2368          --  flag after analyzing the expression.
2369
2370          if Constant_Present (N) then
2371             Set_Has_Completion (Id);
2372          end if;
2373
2374          Set_Etype (Id, T);             --  may be overridden later on
2375          Resolve (E, T);
2376
2377          if not Assignment_OK (N) then
2378             Check_Initialization (T, E);
2379          end if;
2380
2381          Check_Unset_Reference (E);
2382
2383          --  If this is a variable, then set current value
2384
2385          if not Constant_Present (N) then
2386             if Compile_Time_Known_Value (E) then
2387                Set_Current_Value (Id, E);
2388             end if;
2389          end if;
2390
2391          --  Deal with setting of null flags
2392
2393          if Is_Access_Type (T) then
2394             if Known_Non_Null (E) then
2395                Set_Is_Known_Non_Null (Id, True);
2396             elsif Known_Null (E)
2397               and then not Can_Never_Be_Null (Id)
2398             then
2399                Set_Is_Known_Null (Id, True);
2400             end if;
2401          end if;
2402
2403          --  Check incorrect use of dynamically tagged expressions. Note
2404          --  the use of Is_Tagged_Type (T) which seems redundant but is in
2405          --  fact important to avoid spurious errors due to expanded code
2406          --  for dispatching functions over an anonymous access type
2407
2408          if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
2409            and then Is_Tagged_Type (T)
2410            and then not Is_Class_Wide_Type (T)
2411          then
2412             Error_Msg_N ("dynamically tagged expression not allowed!", E);
2413          end if;
2414
2415          Apply_Scalar_Range_Check (E, T);
2416          Apply_Static_Length_Check (E, T);
2417       end if;
2418
2419       --  If the No_Streams restriction is set, check that the type of the
2420       --  object is not, and does not contain, any subtype derived from
2421       --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
2422       --  Has_Stream just for efficiency reasons. There is no point in
2423       --  spending time on a Has_Stream check if the restriction is not set.
2424
2425       if Restrictions.Set (No_Streams) then
2426          if Has_Stream (T) then
2427             Check_Restriction (No_Streams, N);
2428          end if;
2429       end if;
2430
2431       --  Abstract type is never permitted for a variable or constant.
2432       --  Note: we inhibit this check for objects that do not come from
2433       --  source because there is at least one case (the expansion of
2434       --  x'class'input where x is abstract) where we legitimately
2435       --  generate an abstract object.
2436
2437       if Is_Abstract_Type (T) and then Comes_From_Source (N) then
2438          Error_Msg_N ("type of object cannot be abstract",
2439                       Object_Definition (N));
2440
2441          if Is_CPP_Class (T) then
2442             Error_Msg_NE ("\} may need a cpp_constructor",
2443               Object_Definition (N), T);
2444          end if;
2445
2446       --  Case of unconstrained type
2447
2448       elsif Is_Indefinite_Subtype (T) then
2449
2450          --  Nothing to do in deferred constant case
2451
2452          if Constant_Present (N) and then No (E) then
2453             null;
2454
2455          --  Case of no initialization present
2456
2457          elsif No (E) then
2458             if No_Initialization (N) then
2459                null;
2460
2461             elsif Is_Class_Wide_Type (T) then
2462                Error_Msg_N
2463                  ("initialization required in class-wide declaration ", N);
2464
2465             else
2466                Error_Msg_N
2467                  ("unconstrained subtype not allowed (need initialization)",
2468                   Object_Definition (N));
2469             end if;
2470
2471          --  Case of initialization present but in error. Set initial
2472          --  expression as absent (but do not make above complaints)
2473
2474          elsif E = Error then
2475             Set_Expression (N, Empty);
2476             E := Empty;
2477
2478          --  Case of initialization present
2479
2480          else
2481             --  Not allowed in Ada 83
2482
2483             if not Constant_Present (N) then
2484                if Ada_Version = Ada_83
2485                  and then Comes_From_Source (Object_Definition (N))
2486                then
2487                   Error_Msg_N
2488                     ("(Ada 83) unconstrained variable not allowed",
2489                      Object_Definition (N));
2490                end if;
2491             end if;
2492
2493             --  Now we constrain the variable from the initializing expression
2494
2495             --  If the expression is an aggregate, it has been expanded into
2496             --  individual assignments. Retrieve the actual type from the
2497             --  expanded construct.
2498
2499             if Is_Array_Type (T)
2500               and then No_Initialization (N)
2501               and then Nkind (Original_Node (E)) = N_Aggregate
2502             then
2503                Act_T := Etype (E);
2504
2505             else
2506                Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
2507                Act_T := Find_Type_Of_Object (Object_Definition (N), N);
2508             end if;
2509
2510             Set_Is_Constr_Subt_For_U_Nominal (Act_T);
2511
2512             if Aliased_Present (N) then
2513                Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
2514             end if;
2515
2516             Freeze_Before (N, Act_T);
2517             Freeze_Before (N, T);
2518          end if;
2519
2520       elsif Is_Array_Type (T)
2521         and then No_Initialization (N)
2522         and then Nkind (Original_Node (E)) = N_Aggregate
2523       then
2524          if not Is_Entity_Name (Object_Definition (N)) then
2525             Act_T := Etype (E);
2526             Check_Compile_Time_Size (Act_T);
2527
2528             if Aliased_Present (N) then
2529                Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
2530             end if;
2531          end if;
2532
2533          --  When the given object definition and the aggregate are specified
2534          --  independently, and their lengths might differ do a length check.
2535          --  This cannot happen if the aggregate is of the form (others =>...)
2536
2537          if not Is_Constrained (T) then
2538             null;
2539
2540          elsif Nkind (E) = N_Raise_Constraint_Error then
2541
2542             --  Aggregate is statically illegal. Place back in declaration
2543
2544             Set_Expression (N, E);
2545             Set_No_Initialization (N, False);
2546
2547          elsif T = Etype (E) then
2548             null;
2549
2550          elsif Nkind (E) = N_Aggregate
2551            and then Present (Component_Associations (E))
2552            and then Present (Choices (First (Component_Associations (E))))
2553            and then Nkind (First
2554             (Choices (First (Component_Associations (E))))) = N_Others_Choice
2555          then
2556             null;
2557
2558          else
2559             Apply_Length_Check (E, T);
2560          end if;
2561
2562       --  If the type is limited unconstrained with defaulted discriminants
2563       --  and there is no expression, then the object is constrained by the
2564       --  defaults, so it is worthwhile building the corresponding subtype.
2565
2566       elsif (Is_Limited_Record (T)
2567                or else Is_Concurrent_Type (T))
2568         and then not Is_Constrained (T)
2569         and then Has_Discriminants (T)
2570       then
2571          if No (E) then
2572             Act_T := Build_Default_Subtype (T, N);
2573          else
2574             --  Ada 2005:  a limited object may be initialized by means of an
2575             --  aggregate. If the type has default discriminants it has an
2576             --  unconstrained nominal type, Its actual subtype will be obtained
2577             --  from the aggregate, and not from the default discriminants.
2578
2579             Act_T := Etype (E);
2580          end if;
2581
2582          Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
2583
2584       elsif Present (Underlying_Type (T))
2585         and then not Is_Constrained (Underlying_Type (T))
2586         and then Has_Discriminants (Underlying_Type (T))
2587         and then Nkind (E) = N_Function_Call
2588         and then Constant_Present (N)
2589       then
2590          --  The back-end has problems with constants of a discriminated type
2591          --  with defaults, if the initial value is a function call. We
2592          --  generate an intermediate temporary for the result of the call.
2593          --  It is unclear why this should make it acceptable to gcc. ???
2594
2595          Remove_Side_Effects (E);
2596       end if;
2597
2598       if T = Standard_Wide_Character or else T = Standard_Wide_Wide_Character
2599         or else Root_Type (T) = Standard_Wide_String
2600         or else Root_Type (T) = Standard_Wide_Wide_String
2601       then
2602          Check_Restriction (No_Wide_Characters, Object_Definition (N));
2603       end if;
2604
2605       --  Indicate this is not set in source. Certainly true for constants,
2606       --  and true for variables so far (will be reset for a variable if and
2607       --  when we encounter a modification in the source).
2608
2609       Set_Never_Set_In_Source (Id, True);
2610
2611       --  Now establish the proper kind and type of the object
2612
2613       if Constant_Present (N) then
2614          Set_Ekind            (Id, E_Constant);
2615          Set_Is_True_Constant (Id, True);
2616
2617       else
2618          Set_Ekind (Id, E_Variable);
2619
2620          --  A variable is set as shared passive if it appears in a shared
2621          --  passive package, and is at the outer level. This is not done
2622          --  for entities generated during expansion, because those are
2623          --  always manipulated locally.
2624
2625          if Is_Shared_Passive (Current_Scope)
2626            and then Is_Library_Level_Entity (Id)
2627            and then Comes_From_Source (Id)
2628          then
2629             Set_Is_Shared_Passive (Id);
2630             Check_Shared_Var (Id, T, N);
2631          end if;
2632
2633          --  Set Has_Initial_Value if initializing expression present. Note
2634          --  that if there is no initializating expression, we leave the state
2635          --  of this flag unchanged (usually it will be False, but notably in
2636          --  the case of exception choice variables, it will already be true).
2637
2638          if Present (E) then
2639             Set_Has_Initial_Value (Id, True);
2640          end if;
2641       end if;
2642
2643       --  Initialize alignment and size
2644
2645       Init_Alignment (Id);
2646       Init_Esize     (Id);
2647
2648       --  Deal with aliased case
2649
2650       if Aliased_Present (N) then
2651          Set_Is_Aliased (Id);
2652
2653          --  If the object is aliased and the type is unconstrained with
2654          --  defaulted discriminants and there is no expression, then the
2655          --  object is constrained by the defaults, so it is worthwhile
2656          --  building the corresponding subtype.
2657
2658          --  Ada 2005 (AI-363): If the aliased object is discriminated and
2659          --  unconstrained, then only establish an actual subtype if the
2660          --  nominal subtype is indefinite. In definite cases the object is
2661          --  unconstrained in Ada 2005.
2662
2663          if No (E)
2664            and then Is_Record_Type (T)
2665            and then not Is_Constrained (T)
2666            and then Has_Discriminants (T)
2667            and then (Ada_Version < Ada_05 or else Is_Indefinite_Subtype (T))
2668          then
2669             Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
2670          end if;
2671       end if;
2672
2673       --  Now we can set the type of the object
2674
2675       Set_Etype (Id, Act_T);
2676
2677       --  Deal with controlled types
2678
2679       if Has_Controlled_Component (Etype (Id))
2680         or else Is_Controlled (Etype (Id))
2681       then
2682          if not Is_Library_Level_Entity (Id) then
2683             Check_Restriction (No_Nested_Finalization, N);
2684          else
2685             Validate_Controlled_Object (Id);
2686          end if;
2687
2688          --  Generate a warning when an initialization causes an obvious ABE
2689          --  violation. If the init expression is a simple aggregate there
2690          --  shouldn't be any initialize/adjust call generated. This will be
2691          --  true as soon as aggregates are built in place when possible.
2692
2693          --  ??? at the moment we do not generate warnings for temporaries
2694          --  created for those aggregates although Program_Error might be
2695          --  generated if compiled with -gnato.
2696
2697          if Is_Controlled (Etype (Id))
2698             and then Comes_From_Source (Id)
2699          then
2700             declare
2701                BT : constant Entity_Id := Base_Type (Etype (Id));
2702
2703                Implicit_Call : Entity_Id;
2704                pragma Warnings (Off, Implicit_Call);
2705                --  ??? what is this for (never referenced!)
2706
2707                function Is_Aggr (N : Node_Id) return Boolean;
2708                --  Check that N is an aggregate
2709
2710                -------------
2711                -- Is_Aggr --
2712                -------------
2713
2714                function Is_Aggr (N : Node_Id) return Boolean is
2715                begin
2716                   case Nkind (Original_Node (N)) is
2717                      when N_Aggregate | N_Extension_Aggregate =>
2718                         return True;
2719
2720                      when N_Qualified_Expression |
2721                           N_Type_Conversion      |
2722                           N_Unchecked_Type_Conversion =>
2723                         return Is_Aggr (Expression (Original_Node (N)));
2724
2725                      when others =>
2726                         return False;
2727                   end case;
2728                end Is_Aggr;
2729
2730             begin
2731                --  If no underlying type, we already are in an error situation.
2732                --  Do not try to add a warning since we do not have access to
2733                --  prim-op list.
2734
2735                if No (Underlying_Type (BT)) then
2736                   Implicit_Call := Empty;
2737
2738                --  A generic type does not have usable primitive operators.
2739                --  Initialization calls are built for instances.
2740
2741                elsif Is_Generic_Type (BT) then
2742                   Implicit_Call := Empty;
2743
2744                --  If the init expression is not an aggregate, an adjust call
2745                --  will be generated
2746
2747                elsif Present (E) and then not Is_Aggr (E) then
2748                   Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
2749
2750                --  If no init expression and we are not in the deferred
2751                --  constant case, an Initialize call will be generated
2752
2753                elsif No (E) and then not Constant_Present (N) then
2754                   Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
2755
2756                else
2757                   Implicit_Call := Empty;
2758                end if;
2759             end;
2760          end if;
2761       end if;
2762
2763       if Has_Task (Etype (Id)) then
2764          Check_Restriction (No_Tasking, N);
2765
2766          if Is_Library_Level_Entity (Id) then
2767             Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
2768          else
2769             Check_Restriction (Max_Tasks, N);
2770             Check_Restriction (No_Task_Hierarchy, N);
2771             Check_Potentially_Blocking_Operation (N);
2772          end if;
2773
2774          --  A rather specialized test. If we see two tasks being declared
2775          --  of the same type in the same object declaration, and the task
2776          --  has an entry with an address clause, we know that program error
2777          --  will be raised at run-time since we can't have two tasks with
2778          --  entries at the same address.
2779
2780          if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
2781             declare
2782                E : Entity_Id;
2783
2784             begin
2785                E := First_Entity (Etype (Id));
2786                while Present (E) loop
2787                   if Ekind (E) = E_Entry
2788                     and then Present (Get_Attribute_Definition_Clause
2789                                         (E, Attribute_Address))
2790                   then
2791                      Error_Msg_N
2792                        ("?more than one task with same entry address", N);
2793                      Error_Msg_N
2794                        ("\?Program_Error will be raised at run time", N);
2795                      Insert_Action (N,
2796                        Make_Raise_Program_Error (Loc,
2797                          Reason => PE_Duplicated_Entry_Address));
2798                      exit;
2799                   end if;
2800
2801                   Next_Entity (E);
2802                end loop;
2803             end;
2804          end if;
2805       end if;
2806
2807       --  Some simple constant-propagation: if the expression is a constant
2808       --  string initialized with a literal, share the literal. This avoids
2809       --  a run-time copy.
2810
2811       if Present (E)
2812         and then Is_Entity_Name (E)
2813         and then Ekind (Entity (E)) = E_Constant
2814         and then Base_Type (Etype (E)) = Standard_String
2815       then
2816          declare
2817             Val : constant Node_Id := Constant_Value (Entity (E));
2818          begin
2819             if Present (Val)
2820               and then Nkind (Val) = N_String_Literal
2821             then
2822                Rewrite (E, New_Copy (Val));
2823             end if;
2824          end;
2825       end if;
2826
2827       --  Another optimization: if the nominal subtype is unconstrained and
2828       --  the expression is a function call that returns an unconstrained
2829       --  type, rewrite the declaration as a renaming of the result of the
2830       --  call. The exceptions below are cases where the copy is expected,
2831       --  either by the back end (Aliased case) or by the semantics, as for
2832       --  initializing controlled types or copying tags for classwide types.
2833
2834       if Present (E)
2835         and then Nkind (E) = N_Explicit_Dereference
2836         and then Nkind (Original_Node (E)) = N_Function_Call
2837         and then not Is_Library_Level_Entity (Id)
2838         and then not Is_Constrained (Underlying_Type (T))
2839         and then not Is_Aliased (Id)
2840         and then not Is_Class_Wide_Type (T)
2841         and then not Is_Controlled (T)
2842         and then not Has_Controlled_Component (Base_Type (T))
2843         and then Expander_Active
2844       then
2845          Rewrite (N,
2846            Make_Object_Renaming_Declaration (Loc,
2847              Defining_Identifier => Id,
2848              Access_Definition   => Empty,
2849              Subtype_Mark        => New_Occurrence_Of
2850                                       (Base_Type (Etype (Id)), Loc),
2851              Name                => E));
2852
2853          Set_Renamed_Object (Id, E);
2854
2855          --  Force generation of debugging information for the constant and for
2856          --  the renamed function call.
2857
2858          Set_Needs_Debug_Info (Id);
2859          Set_Needs_Debug_Info (Entity (Prefix (E)));
2860       end if;
2861
2862       if Present (Prev_Entity)
2863         and then Is_Frozen (Prev_Entity)
2864         and then not Error_Posted (Id)
2865       then
2866          Error_Msg_N ("full constant declaration appears too late", N);
2867       end if;
2868
2869       Check_Eliminated (Id);
2870
2871       --  Deal with setting In_Private_Part flag if in private part
2872
2873       if Ekind (Scope (Id)) = E_Package
2874         and then In_Private_Part (Scope (Id))
2875       then
2876          Set_In_Private_Part (Id);
2877       end if;
2878    end Analyze_Object_Declaration;
2879
2880    ---------------------------
2881    -- Analyze_Others_Choice --
2882    ---------------------------
2883
2884    --  Nothing to do for the others choice node itself, the semantic analysis
2885    --  of the others choice will occur as part of the processing of the parent
2886
2887    procedure Analyze_Others_Choice (N : Node_Id) is
2888       pragma Warnings (Off, N);
2889    begin
2890       null;
2891    end Analyze_Others_Choice;
2892
2893    --------------------------------
2894    -- Analyze_Per_Use_Expression --
2895    --------------------------------
2896
2897    procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id) is
2898       Save_In_Default_Expression : constant Boolean := In_Default_Expression;
2899    begin
2900       In_Default_Expression := True;
2901       Pre_Analyze_And_Resolve (N, T);
2902       In_Default_Expression := Save_In_Default_Expression;
2903    end Analyze_Per_Use_Expression;
2904
2905    -------------------------------------------
2906    -- Analyze_Private_Extension_Declaration --
2907    -------------------------------------------
2908
2909    procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
2910       T           : constant Entity_Id := Defining_Identifier (N);
2911       Indic       : constant Node_Id   := Subtype_Indication (N);
2912       Parent_Type : Entity_Id;
2913       Parent_Base : Entity_Id;
2914
2915    begin
2916       --  Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
2917
2918       if Is_Non_Empty_List (Interface_List (N)) then
2919          declare
2920             Intf : Node_Id;
2921             T    : Entity_Id;
2922
2923          begin
2924             Intf := First (Interface_List (N));
2925             while Present (Intf) loop
2926                T := Find_Type_Of_Subtype_Indic (Intf);
2927
2928                if not Is_Interface (T) then
2929                   Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T);
2930                end if;
2931
2932                Next (Intf);
2933             end loop;
2934          end;
2935       end if;
2936
2937       Generate_Definition (T);
2938       Enter_Name (T);
2939
2940       Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
2941       Parent_Base := Base_Type (Parent_Type);
2942
2943       if Parent_Type = Any_Type
2944         or else Etype (Parent_Type) = Any_Type
2945       then
2946          Set_Ekind (T, Ekind (Parent_Type));
2947          Set_Etype (T, Any_Type);
2948          return;
2949
2950       elsif not Is_Tagged_Type (Parent_Type) then
2951          Error_Msg_N
2952            ("parent of type extension must be a tagged type ", Indic);
2953          return;
2954
2955       elsif Ekind (Parent_Type) = E_Void
2956         or else Ekind (Parent_Type) = E_Incomplete_Type
2957       then
2958          Error_Msg_N ("premature derivation of incomplete type", Indic);
2959          return;
2960
2961       elsif Is_Concurrent_Type (Parent_Type) then
2962          Error_Msg_N
2963            ("parent type of a private extension cannot be "
2964             & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
2965
2966          Set_Etype              (T, Any_Type);
2967          Set_Ekind              (T, E_Limited_Private_Type);
2968          Set_Private_Dependents (T, New_Elmt_List);
2969          Set_Error_Posted       (T);
2970          return;
2971       end if;
2972
2973       --  Perhaps the parent type should be changed to the class-wide type's
2974       --  specific type in this case to prevent cascading errors ???
2975
2976       if Is_Class_Wide_Type (Parent_Type) then
2977          Error_Msg_N
2978            ("parent of type extension must not be a class-wide type", Indic);
2979          return;
2980       end if;
2981
2982       if (not Is_Package_Or_Generic_Package (Current_Scope)
2983            and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
2984         or else In_Private_Part (Current_Scope)
2985
2986       then
2987          Error_Msg_N ("invalid context for private extension", N);
2988       end if;
2989
2990       --  Set common attributes
2991
2992       Set_Is_Pure          (T, Is_Pure (Current_Scope));
2993       Set_Scope            (T, Current_Scope);
2994       Set_Ekind            (T, E_Record_Type_With_Private);
2995       Init_Size_Align      (T);
2996
2997       Set_Etype            (T,            Parent_Base);
2998       Set_Has_Task         (T, Has_Task  (Parent_Base));
2999
3000       Set_Convention       (T, Convention     (Parent_Type));
3001       Set_First_Rep_Item   (T, First_Rep_Item (Parent_Type));
3002       Set_Is_First_Subtype (T);
3003       Make_Class_Wide_Type (T);
3004
3005       if Unknown_Discriminants_Present (N) then
3006          Set_Discriminant_Constraint (T, No_Elist);
3007       end if;
3008
3009       Build_Derived_Record_Type (N, Parent_Type, T);
3010
3011       --  Ada 2005 (AI-443): Synchronized private extension or a rewritten
3012       --  synchronized formal derived type.
3013
3014       if Ada_Version >= Ada_05
3015         and then Synchronized_Present (N)
3016       then
3017          Set_Is_Limited_Record (T);
3018
3019          --  Formal derived type case
3020
3021          if Is_Generic_Type (T) then
3022
3023             --  The parent must be a tagged limited type or a synchronized
3024             --  interface.
3025
3026             if (not Is_Tagged_Type (Parent_Type)
3027                   or else not Is_Limited_Type (Parent_Type))
3028               and then
3029                (not Is_Interface (Parent_Type)
3030                   or else not Is_Synchronized_Interface (Parent_Type))
3031             then
3032                Error_Msg_NE ("parent type of & must be tagged limited " &
3033                              "or synchronized", N, T);
3034             end if;
3035
3036             --  The progenitors (if any) must be limited or synchronized
3037             --  interfaces.
3038
3039             if Present (Abstract_Interfaces (T)) then
3040                declare
3041                   Iface      : Entity_Id;
3042                   Iface_Elmt : Elmt_Id;
3043
3044                begin
3045                   Iface_Elmt := First_Elmt (Abstract_Interfaces (T));
3046                   while Present (Iface_Elmt) loop
3047                      Iface := Node (Iface_Elmt);
3048
3049                      if not Is_Limited_Interface (Iface)
3050                        and then not Is_Synchronized_Interface (Iface)
3051                      then
3052                         Error_Msg_NE ("progenitor & must be limited " &
3053                                       "or synchronized", N, Iface);
3054                      end if;
3055
3056                      Next_Elmt (Iface_Elmt);
3057                   end loop;
3058                end;
3059             end if;
3060
3061          --  Regular derived extension, the parent must be a limited or
3062          --  synchronized interface.
3063
3064          else
3065             if not Is_Interface (Parent_Type)
3066               or else (not Is_Limited_Interface (Parent_Type)
3067                          and then
3068                        not Is_Synchronized_Interface (Parent_Type))
3069             then
3070                Error_Msg_NE
3071                  ("parent type of & must be limited interface", N, T);
3072             end if;
3073          end if;
3074
3075       elsif Limited_Present (N) then
3076          Set_Is_Limited_Record (T);
3077
3078          if not Is_Limited_Type (Parent_Type)
3079            and then
3080              (not Is_Interface (Parent_Type)
3081                or else not Is_Limited_Interface (Parent_Type))
3082          then
3083             Error_Msg_NE ("parent type& of limited extension must be limited",
3084               N, Parent_Type);
3085          end if;
3086       end if;
3087    end Analyze_Private_Extension_Declaration;
3088
3089    ---------------------------------
3090    -- Analyze_Subtype_Declaration --
3091    ---------------------------------
3092
3093    procedure Analyze_Subtype_Declaration
3094      (N    : Node_Id;
3095       Skip : Boolean := False)
3096    is
3097       Id       : constant Entity_Id := Defining_Identifier (N);
3098       T        : Entity_Id;
3099       R_Checks : Check_Result;
3100
3101    begin
3102       Generate_Definition (Id);
3103       Set_Is_Pure (Id, Is_Pure (Current_Scope));
3104       Init_Size_Align (Id);
3105
3106       --  The following guard condition on Enter_Name is to handle cases where
3107       --  the defining identifier has already been entered into the scope but
3108       --  the declaration as a whole needs to be analyzed.
3109
3110       --  This case in particular happens for derived enumeration types. The
3111       --  derived enumeration type is processed as an inserted enumeration type
3112       --  declaration followed by a rewritten subtype declaration. The defining
3113       --  identifier, however, is entered into the name scope very early in the
3114       --  processing of the original type declaration and therefore needs to be
3115       --  avoided here, when the created subtype declaration is analyzed. (See
3116       --  Build_Derived_Types)
3117
3118       --  This also happens when the full view of a private type is derived
3119       --  type with constraints. In this case the entity has been introduced
3120       --  in the private declaration.
3121
3122       if Skip
3123         or else (Present (Etype (Id))
3124                    and then (Is_Private_Type (Etype (Id))
3125                                or else Is_Task_Type (Etype (Id))
3126                                or else Is_Rewrite_Substitution (N)))
3127       then
3128          null;
3129
3130       else
3131          Enter_Name (Id);
3132       end if;
3133
3134       T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
3135
3136       --  Inherit common attributes
3137
3138       Set_Is_Generic_Type   (Id, Is_Generic_Type   (Base_Type (T)));
3139       Set_Is_Volatile       (Id, Is_Volatile       (T));
3140       Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
3141       Set_Is_Atomic         (Id, Is_Atomic         (T));
3142       Set_Is_Ada_2005_Only  (Id, Is_Ada_2005_Only  (T));
3143
3144       --  In the case where there is no constraint given in the subtype
3145       --  indication, Process_Subtype just returns the Subtype_Mark, so its
3146       --  semantic attributes must be established here.
3147
3148       if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
3149          Set_Etype (Id, Base_Type (T));
3150
3151          case Ekind (T) is
3152             when Array_Kind =>
3153                Set_Ekind                       (Id, E_Array_Subtype);
3154                Copy_Array_Subtype_Attributes   (Id, T);
3155
3156             when Decimal_Fixed_Point_Kind =>
3157                Set_Ekind                (Id, E_Decimal_Fixed_Point_Subtype);
3158                Set_Digits_Value         (Id, Digits_Value       (T));
3159                Set_Delta_Value          (Id, Delta_Value        (T));
3160                Set_Scale_Value          (Id, Scale_Value        (T));
3161                Set_Small_Value          (Id, Small_Value        (T));
3162                Set_Scalar_Range         (Id, Scalar_Range       (T));
3163                Set_Machine_Radix_10     (Id, Machine_Radix_10   (T));
3164                Set_Is_Constrained       (Id, Is_Constrained     (T));
3165                Set_RM_Size              (Id, RM_Size            (T));
3166
3167             when Enumeration_Kind =>
3168                Set_Ekind                (Id, E_Enumeration_Subtype);
3169                Set_First_Literal        (Id, First_Literal (Base_Type (T)));
3170                Set_Scalar_Range         (Id, Scalar_Range       (T));
3171                Set_Is_Character_Type    (Id, Is_Character_Type  (T));
3172                Set_Is_Constrained       (Id, Is_Constrained     (T));
3173                Set_RM_Size              (Id, RM_Size            (T));
3174
3175             when Ordinary_Fixed_Point_Kind =>
3176                Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
3177                Set_Scalar_Range         (Id, Scalar_Range       (T));
3178                Set_Small_Value          (Id, Small_Value        (T));
3179                Set_Delta_Value          (Id, Delta_Value        (T));
3180                Set_Is_Constrained       (Id, Is_Constrained     (T));
3181                Set_RM_Size              (Id, RM_Size            (T));
3182
3183             when Float_Kind =>
3184                Set_Ekind                (Id, E_Floating_Point_Subtype);
3185                Set_Scalar_Range         (Id, Scalar_Range       (T));
3186                Set_Digits_Value         (Id, Digits_Value       (T));
3187                Set_Is_Constrained       (Id, Is_Constrained     (T));
3188
3189             when Signed_Integer_Kind =>
3190                Set_Ekind                (Id, E_Signed_Integer_Subtype);
3191                Set_Scalar_Range         (Id, Scalar_Range       (T));
3192                Set_Is_Constrained       (Id, Is_Constrained     (T));
3193                Set_RM_Size              (Id, RM_Size            (T));
3194
3195             when Modular_Integer_Kind =>
3196                Set_Ekind                (Id, E_Modular_Integer_Subtype);
3197                Set_Scalar_Range         (Id, Scalar_Range       (T));
3198                Set_Is_Constrained       (Id, Is_Constrained     (T));
3199                Set_RM_Size              (Id, RM_Size            (T));
3200
3201             when Class_Wide_Kind =>
3202                Set_Ekind                (Id, E_Class_Wide_Subtype);
3203                Set_First_Entity         (Id, First_Entity       (T));
3204                Set_Last_Entity          (Id, Last_Entity        (T));
3205                Set_Class_Wide_Type      (Id, Class_Wide_Type    (T));
3206                Set_Cloned_Subtype       (Id, T);
3207                Set_Is_Tagged_Type       (Id, True);
3208                Set_Has_Unknown_Discriminants
3209                                         (Id, True);
3210
3211                if Ekind (T) = E_Class_Wide_Subtype then
3212                   Set_Equivalent_Type   (Id, Equivalent_Type    (T));
3213                end if;
3214
3215             when E_Record_Type | E_Record_Subtype =>
3216                Set_Ekind                (Id, E_Record_Subtype);
3217
3218                if Ekind (T) = E_Record_Subtype
3219                  and then Present (Cloned_Subtype (T))
3220                then
3221                   Set_Cloned_Subtype    (Id, Cloned_Subtype (T));
3222                else
3223                   Set_Cloned_Subtype    (Id, T);
3224                end if;
3225
3226                Set_First_Entity         (Id, First_Entity       (T));
3227                Set_Last_Entity          (Id, Last_Entity        (T));
3228                Set_Has_Discriminants    (Id, Has_Discriminants  (T));
3229                Set_Is_Constrained       (Id, Is_Constrained     (T));
3230                Set_Is_Limited_Record    (Id, Is_Limited_Record  (T));
3231                Set_Has_Unknown_Discriminants
3232                                         (Id, Has_Unknown_Discriminants (T));
3233
3234                if Has_Discriminants (T) then
3235                   Set_Discriminant_Constraint
3236                                         (Id, Discriminant_Constraint (T));
3237                   Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3238
3239                elsif Has_Unknown_Discriminants (Id) then
3240                   Set_Discriminant_Constraint (Id, No_Elist);
3241                end if;
3242
3243                if Is_Tagged_Type (T) then
3244                   Set_Is_Tagged_Type    (Id);
3245                   Set_Is_Abstract_Type  (Id, Is_Abstract_Type (T));
3246                   Set_Primitive_Operations
3247                                         (Id, Primitive_Operations (T));
3248                   Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
3249
3250                   if Is_Interface (T) then
3251                      Set_Is_Interface (Id);
3252                      Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
3253                   end if;
3254                end if;
3255
3256             when Private_Kind =>
3257                Set_Ekind              (Id, Subtype_Kind (Ekind   (T)));
3258                Set_Has_Discriminants  (Id, Has_Discriminants     (T));
3259                Set_Is_Constrained     (Id, Is_Constrained        (T));
3260                Set_First_Entity       (Id, First_Entity          (T));
3261                Set_Last_Entity        (Id, Last_Entity           (T));
3262                Set_Private_Dependents (Id, New_Elmt_List);
3263                Set_Is_Limited_Record  (Id, Is_Limited_Record     (T));
3264                Set_Has_Unknown_Discriminants
3265                                       (Id, Has_Unknown_Discriminants (T));
3266
3267                if Is_Tagged_Type (T) then
3268                   Set_Is_Tagged_Type       (Id);
3269                   Set_Is_Abstract_Type     (Id, Is_Abstract_Type (T));
3270                   Set_Primitive_Operations (Id, Primitive_Operations (T));
3271                   Set_Class_Wide_Type      (Id, Class_Wide_Type (T));
3272                end if;
3273
3274                --  In general the attributes of the subtype of a private type
3275                --  are the attributes of the partial view of parent. However,
3276                --  the full view may be a discriminated type, and the subtype
3277                --  must share the discriminant constraint to generate correct
3278                --  calls to initialization procedures.
3279
3280                if Has_Discriminants (T) then
3281                   Set_Discriminant_Constraint
3282                                      (Id, Discriminant_Constraint (T));
3283                   Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3284
3285                elsif Present (Full_View (T))
3286                  and then Has_Discriminants (Full_View (T))
3287                then
3288                   Set_Discriminant_Constraint
3289                                (Id, Discriminant_Constraint (Full_View (T)));
3290                   Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3291
3292                   --  This would seem semantically correct, but apparently
3293                   --  confuses the back-end (4412-009). To be explained ???
3294
3295                   --  Set_Has_Discriminants (Id);
3296                end if;
3297
3298                Prepare_Private_Subtype_Completion (Id, N);
3299
3300             when Access_Kind =>
3301                Set_Ekind             (Id, E_Access_Subtype);
3302                Set_Is_Constrained    (Id, Is_Constrained        (T));
3303                Set_Is_Access_Constant
3304                                      (Id, Is_Access_Constant    (T));
3305                Set_Directly_Designated_Type
3306                                      (Id, Designated_Type       (T));
3307                Set_Can_Never_Be_Null (Id, Can_Never_Be_Null     (T));
3308
3309                --  A Pure library_item must not contain the declaration of a
3310                --  named access type, except within a subprogram, generic
3311                --  subprogram, task unit, or protected unit (RM 10.2.1(16)).
3312
3313                if Comes_From_Source (Id)
3314                  and then In_Pure_Unit
3315                  and then not In_Subprogram_Task_Protected_Unit
3316                then
3317                   Error_Msg_N
3318                     ("named access types not allowed in pure unit", N);
3319                end if;
3320
3321             when Concurrent_Kind =>
3322                Set_Ekind                (Id, Subtype_Kind (Ekind   (T)));
3323                Set_Corresponding_Record_Type (Id,
3324                                          Corresponding_Record_Type (T));
3325                Set_First_Entity         (Id, First_Entity          (T));
3326                Set_First_Private_Entity (Id, First_Private_Entity  (T));
3327                Set_Has_Discriminants    (Id, Has_Discriminants     (T));
3328                Set_Is_Constrained       (Id, Is_Constrained        (T));
3329                Set_Is_Tagged_Type       (Id, Is_Tagged_Type        (T));
3330                Set_Last_Entity          (Id, Last_Entity           (T));
3331
3332                if Has_Discriminants (T) then
3333                   Set_Discriminant_Constraint (Id,
3334                                            Discriminant_Constraint (T));
3335                   Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3336                end if;
3337
3338             when E_Incomplete_Type =>
3339                if Ada_Version >= Ada_05 then
3340                   Set_Ekind (Id, E_Incomplete_Subtype);
3341
3342                   --  Ada 2005 (AI-412): Decorate an incomplete subtype
3343                   --  of an incomplete type visible through a limited
3344                   --  with clause.
3345
3346                   if From_With_Type (T)
3347                     and then Present (Non_Limited_View (T))
3348                   then
3349                      Set_From_With_Type   (Id);
3350                      Set_Non_Limited_View (Id, Non_Limited_View (T));
3351
3352                   --  Ada 2005 (AI-412): Add the regular incomplete subtype
3353                   --  to the private dependents of the original incomplete
3354                   --  type for future transformation.
3355
3356                   else
3357                      Append_Elmt (Id, Private_Dependents (T));
3358                   end if;
3359
3360                --  If the subtype name denotes an incomplete type an error
3361                --  was already reported by Process_Subtype.
3362
3363                else
3364                   Set_Etype (Id, Any_Type);
3365                end if;
3366
3367             when others =>
3368                raise Program_Error;
3369          end case;
3370       end if;
3371
3372       if Etype (Id) = Any_Type then
3373          return;
3374       end if;
3375
3376       --  Some common processing on all types
3377
3378       Set_Size_Info      (Id,                 T);
3379       Set_First_Rep_Item (Id, First_Rep_Item (T));
3380
3381       T := Etype (Id);
3382
3383       Set_Is_Immediately_Visible   (Id, True);
3384       Set_Depends_On_Private       (Id, Has_Private_Component (T));
3385       Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
3386
3387       if Is_Interface (T) then
3388          Set_Is_Interface (Id);
3389       end if;
3390
3391       if Present (Generic_Parent_Type (N))
3392         and then
3393           (Nkind
3394              (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
3395             or else Nkind
3396               (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
3397                 /=  N_Formal_Private_Type_Definition)
3398       then
3399          if Is_Tagged_Type (Id) then
3400
3401             --  If this is a generic actual subtype for a synchronized type,
3402             --  the primitive operations are those of the corresponding record
3403             --  for which there is a separate subtype declaration.
3404
3405             if Is_Concurrent_Type (Id) then
3406                null;
3407             elsif Is_Class_Wide_Type (Id) then
3408                Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
3409             else
3410                Derive_Subprograms (Generic_Parent_Type (N), Id, T);
3411             end if;
3412
3413          elsif Scope (Etype (Id)) /= Standard_Standard then
3414             Derive_Subprograms (Generic_Parent_Type (N), Id);
3415          end if;
3416       end if;
3417
3418       if Is_Private_Type (T)
3419         and then Present (Full_View (T))
3420       then
3421          Conditional_Delay (Id, Full_View (T));
3422
3423       --  The subtypes of components or subcomponents of protected types
3424       --  do not need freeze nodes, which would otherwise appear in the
3425       --  wrong scope (before the freeze node for the protected type). The
3426       --  proper subtypes are those of the subcomponents of the corresponding
3427       --  record.
3428
3429       elsif Ekind (Scope (Id)) /= E_Protected_Type
3430         and then Present (Scope (Scope (Id))) -- error defense!
3431         and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
3432       then
3433          Conditional_Delay (Id, T);
3434       end if;
3435
3436       --  Check that constraint_error is raised for a scalar subtype
3437       --  indication when the lower or upper bound of a non-null range
3438       --  lies outside the range of the type mark.
3439
3440       if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
3441          if Is_Scalar_Type (Etype (Id))
3442             and then Scalar_Range (Id) /=
3443                      Scalar_Range (Etype (Subtype_Mark
3444                                            (Subtype_Indication (N))))
3445          then
3446             Apply_Range_Check
3447               (Scalar_Range (Id),
3448                Etype (Subtype_Mark (Subtype_Indication (N))));
3449
3450          elsif Is_Array_Type (Etype (Id))
3451            and then Present (First_Index (Id))
3452          then
3453             --  This really should be a subprogram that finds the indications
3454             --  to check???
3455
3456             if ((Nkind (First_Index (Id)) = N_Identifier
3457                    and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
3458                  or else Nkind (First_Index (Id)) = N_Subtype_Indication)
3459               and then
3460                 Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
3461             then
3462                declare
3463                   Target_Typ : constant Entity_Id :=
3464                                  Etype
3465                                    (First_Index (Etype
3466                                      (Subtype_Mark (Subtype_Indication (N)))));
3467                begin
3468                   R_Checks :=
3469                     Get_Range_Checks
3470                       (Scalar_Range (Etype (First_Index (Id))),
3471                        Target_Typ,
3472                        Etype (First_Index (Id)),
3473                        Defining_Identifier (N));
3474
3475                   Insert_Range_Checks
3476                     (R_Checks,
3477                      N,
3478                      Target_Typ,
3479                      Sloc (Defining_Identifier (N)));
3480                end;
3481             end if;
3482          end if;
3483       end if;
3484
3485       Check_Eliminated (Id);
3486    end Analyze_Subtype_Declaration;
3487
3488    --------------------------------
3489    -- Analyze_Subtype_Indication --
3490    --------------------------------
3491
3492    procedure Analyze_Subtype_Indication (N : Node_Id) is
3493       T : constant Entity_Id := Subtype_Mark (N);
3494       R : constant Node_Id   := Range_Expression (Constraint (N));
3495
3496    begin
3497       Analyze (T);
3498
3499       if R /= Error then
3500          Analyze (R);
3501          Set_Etype (N, Etype (R));
3502          Resolve (R, Entity (T));
3503       else
3504          Set_Error_Posted (R);
3505          Set_Error_Posted (T);
3506       end if;
3507    end Analyze_Subtype_Indication;
3508
3509    ------------------------------
3510    -- Analyze_Type_Declaration --
3511    ------------------------------
3512
3513    procedure Analyze_Type_Declaration (N : Node_Id) is
3514       Def    : constant Node_Id   := Type_Definition (N);
3515       Def_Id : constant Entity_Id := Defining_Identifier (N);
3516       T      : Entity_Id;
3517       Prev   : Entity_Id;
3518
3519       Is_Remote : constant Boolean :=
3520                     (Is_Remote_Types (Current_Scope)
3521                        or else Is_Remote_Call_Interface (Current_Scope))
3522                     and then not (In_Private_Part (Current_Scope)
3523                                     or else In_Package_Body (Current_Scope));
3524
3525       procedure Check_Ops_From_Incomplete_Type;
3526       --  If there is a tagged incomplete partial view of the type, transfer
3527       --  its operations to the full view, and indicate that the type of the
3528       --  controlling parameter (s) is this full view.
3529
3530       ------------------------------------
3531       -- Check_Ops_From_Incomplete_Type --
3532       ------------------------------------
3533
3534       procedure Check_Ops_From_Incomplete_Type is
3535          Elmt   : Elmt_Id;
3536          Formal : Entity_Id;
3537          Op     : Entity_Id;
3538
3539       begin
3540          if Prev /= T
3541            and then Ekind (Prev) = E_Incomplete_Type
3542            and then Is_Tagged_Type (Prev)
3543            and then Is_Tagged_Type (T)
3544          then
3545             Elmt := First_Elmt (Primitive_Operations (Prev));
3546             while Present (Elmt) loop
3547                Op := Node (Elmt);
3548                Prepend_Elmt (Op, Primitive_Operations (T));
3549
3550                Formal := First_Formal (Op);
3551                while Present (Formal) loop
3552                   if Etype (Formal) = Prev then
3553                      Set_Etype (Formal, T);
3554                   end if;
3555
3556                   Next_Formal (Formal);
3557                end loop;
3558
3559                if Etype (Op) = Prev then
3560                   Set_Etype (Op, T);
3561                end if;
3562
3563                Next_Elmt (Elmt);
3564             end loop;
3565          end if;
3566       end Check_Ops_From_Incomplete_Type;
3567
3568    --  Start of processing for Analyze_Type_Declaration
3569
3570    begin
3571       Prev := Find_Type_Name (N);
3572
3573       --  The full view, if present, now points to the current type
3574
3575       --  Ada 2005 (AI-50217): If the type was previously decorated when
3576       --  imported through a LIMITED WITH clause, it appears as incomplete
3577       --  but has no full view.
3578       --  If the incomplete view is tagged, a class_wide type has been
3579       --  created already. Use it for the full view as well, to prevent
3580       --  multiple incompatible class-wide types that may be  created for
3581       --  self-referential anonymous access components.
3582
3583       if Ekind (Prev) = E_Incomplete_Type
3584         and then Present (Full_View (Prev))
3585       then
3586          T := Full_View (Prev);
3587
3588          if Is_Tagged_Type (Prev)
3589            and then Present (Class_Wide_Type (Prev))
3590          then
3591             Set_Ekind (T, Ekind (Prev));         --  will be reset later
3592             Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
3593             Set_Etype (Class_Wide_Type (T), T);
3594          end if;
3595
3596       else
3597          T := Prev;
3598       end if;
3599
3600       Set_Is_Pure (T, Is_Pure (Current_Scope));
3601
3602       --  We set the flag Is_First_Subtype here. It is needed to set the
3603       --  corresponding flag for the Implicit class-wide-type created
3604       --  during tagged types processing.
3605
3606       Set_Is_First_Subtype (T, True);
3607
3608       --  Only composite types other than array types are allowed to have
3609       --  discriminants.
3610
3611       case Nkind (Def) is
3612
3613          --  For derived types, the rule will be checked once we've figured
3614          --  out the parent type.
3615
3616          when N_Derived_Type_Definition =>
3617             null;
3618
3619          --  For record types, discriminants are allowed
3620
3621          when N_Record_Definition =>
3622             null;
3623
3624          when others =>
3625             if Present (Discriminant_Specifications (N)) then
3626                Error_Msg_N
3627                  ("elementary or array type cannot have discriminants",
3628                   Defining_Identifier
3629                   (First (Discriminant_Specifications (N))));
3630             end if;
3631       end case;
3632
3633       --  Elaborate the type definition according to kind, and generate
3634       --  subsidiary (implicit) subtypes where needed. We skip this if it was
3635       --  already done (this happens during the reanalysis that follows a call
3636       --  to the high level optimizer).
3637
3638       if not Analyzed (T) then
3639          Set_Analyzed (T);
3640
3641          case Nkind (Def) is
3642
3643             when N_Access_To_Subprogram_Definition =>
3644                Access_Subprogram_Declaration (T, Def);
3645
3646                --  If this is a remote access to subprogram, we must create the
3647                --  equivalent fat pointer type, and related subprograms.
3648
3649                if Is_Remote then
3650                   Process_Remote_AST_Declaration (N);
3651                end if;
3652
3653                --  Validate categorization rule against access type declaration
3654                --  usually a violation in Pure unit, Shared_Passive unit.
3655
3656                Validate_Access_Type_Declaration (T, N);
3657
3658             when N_Access_To_Object_Definition =>
3659                Access_Type_Declaration (T, Def);
3660
3661                --  Validate categorization rule against access type declaration
3662                --  usually a violation in Pure unit, Shared_Passive unit.
3663
3664                Validate_Access_Type_Declaration (T, N);
3665
3666                --  If we are in a Remote_Call_Interface package and define
3667                --  a RACW, Read and Write attribute must be added.
3668
3669                if Is_Remote
3670                  and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
3671                then
3672                   Add_RACW_Features (Def_Id);
3673                end if;
3674
3675                --  Set no strict aliasing flag if config pragma seen
3676
3677                if Opt.No_Strict_Aliasing then
3678                   Set_No_Strict_Aliasing (Base_Type (Def_Id));
3679                end if;
3680
3681             when N_Array_Type_Definition =>
3682                Array_Type_Declaration (T, Def);
3683
3684             when N_Derived_Type_Definition =>
3685                Derived_Type_Declaration (T, N, T /= Def_Id);
3686
3687             when N_Enumeration_Type_Definition =>
3688                Enumeration_Type_Declaration (T, Def);
3689
3690             when N_Floating_Point_Definition =>
3691                Floating_Point_Type_Declaration (T, Def);
3692
3693             when N_Decimal_Fixed_Point_Definition =>
3694                Decimal_Fixed_Point_Type_Declaration (T, Def);
3695
3696             when N_Ordinary_Fixed_Point_Definition =>
3697                Ordinary_Fixed_Point_Type_Declaration (T, Def);
3698
3699             when N_Signed_Integer_Type_Definition =>
3700                Signed_Integer_Type_Declaration (T, Def);
3701
3702             when N_Modular_Type_Definition =>
3703                Modular_Type_Declaration (T, Def);
3704
3705             when N_Record_Definition =>
3706                Record_Type_Declaration (T, N, Prev);
3707
3708             when others =>
3709                raise Program_Error;
3710
3711          end case;
3712       end if;
3713
3714       if Etype (T) = Any_Type then
3715          return;
3716       end if;
3717
3718       --  Some common processing for all types
3719
3720       Set_Depends_On_Private (T, Has_Private_Component (T));
3721       Check_Ops_From_Incomplete_Type;
3722
3723       --  Both the declared entity, and its anonymous base type if one
3724       --  was created, need freeze nodes allocated.
3725
3726       declare
3727          B : constant Entity_Id := Base_Type (T);
3728
3729       begin
3730          --  In the case where the base type is different from the first
3731          --  subtype, we pre-allocate a freeze node, and set the proper link
3732          --  to the first subtype. Freeze_Entity will use this preallocated
3733          --  freeze node when it freezes the entity.
3734
3735          if B /= T then
3736             Ensure_Freeze_Node (B);
3737             Set_First_Subtype_Link (Freeze_Node (B), T);
3738          end if;
3739
3740          if not From_With_Type (T) then
3741             Set_Has_Delayed_Freeze (T);
3742          end if;
3743       end;
3744
3745       --  Case of T is the full declaration of some private type which has
3746       --  been swapped in Defining_Identifier (N).
3747
3748       if T /= Def_Id and then Is_Private_Type (Def_Id) then
3749          Process_Full_View (N, T, Def_Id);
3750
3751          --  Record the reference. The form of this is a little strange,
3752          --  since the full declaration has been swapped in. So the first
3753          --  parameter here represents the entity to which a reference is
3754          --  made which is the "real" entity, i.e. the one swapped in,
3755          --  and the second parameter provides the reference location.
3756
3757          --  Also, we want to kill Has_Pragma_Unreferenced temporarily here
3758          --  since we don't want a complaint about the full type being an
3759          --  unwanted reference to the private type
3760
3761          declare
3762             B : constant Boolean := Has_Pragma_Unreferenced (T);
3763          begin
3764             Set_Has_Pragma_Unreferenced (T, False);
3765             Generate_Reference (T, T, 'c');
3766             Set_Has_Pragma_Unreferenced (T, B);
3767          end;
3768
3769          Set_Completion_Referenced (Def_Id);
3770
3771       --  For completion of incomplete type, process incomplete dependents
3772       --  and always mark the full type as referenced (it is the incomplete
3773       --  type that we get for any real reference).
3774
3775       elsif Ekind (Prev) = E_Incomplete_Type then
3776          Process_Incomplete_Dependents (N, T, Prev);
3777          Generate_Reference (Prev, Def_Id, 'c');
3778          Set_Completion_Referenced (Def_Id);
3779
3780       --  If not private type or incomplete type completion, this is a real
3781       --  definition of a new entity, so record it.
3782
3783       else
3784          Generate_Definition (Def_Id);
3785       end if;
3786
3787       if Chars (Scope (Def_Id)) =  Name_System
3788         and then Chars (Def_Id) = Name_Address
3789         and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
3790       then
3791          Set_Is_Descendent_Of_Address (Def_Id);
3792          Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
3793          Set_Is_Descendent_Of_Address (Prev);
3794       end if;
3795
3796       Check_Eliminated (Def_Id);