OSDN Git Service

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