OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_ch3.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ C H 3                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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
      --  Object is marked pure if it is in a pure scope
2997
 
2998
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
2999
 
3000
      --  If deferred constant, make sure context is appropriate. We detect
3001
      --  a deferred constant as a constant declaration with no expression.
3002
      --  A deferred constant can appear in a package body if its completion
3003
      --  is by means of an interface pragma.
3004
 
3005
      if Constant_Present (N)
3006
        and then No (E)
3007
      then
3008
         --  A deferred constant may appear in the declarative part of the
3009
         --  following constructs:
3010
 
3011
         --     blocks
3012
         --     entry bodies
3013
         --     extended return statements
3014
         --     package specs
3015
         --     package bodies
3016
         --     subprogram bodies
3017
         --     task bodies
3018
 
3019
         --  When declared inside a package spec, a deferred constant must be
3020
         --  completed by a full constant declaration or pragma Import. In all
3021
         --  other cases, the only proper completion is pragma Import. Extended
3022
         --  return statements are flagged as invalid contexts because they do
3023
         --  not have a declarative part and so cannot accommodate the pragma.
3024
 
3025
         if Ekind (Current_Scope) = E_Return_Statement then
3026
            Error_Msg_N
3027
              ("invalid context for deferred constant declaration (RM 7.4)",
3028
               N);
3029
            Error_Msg_N
3030
              ("\declaration requires an initialization expression",
3031
                N);
3032
            Set_Constant_Present (N, False);
3033
 
3034
         --  In Ada 83, deferred constant must be of private type
3035
 
3036
         elsif not Is_Private_Type (T) then
3037
            if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3038
               Error_Msg_N
3039
                 ("(Ada 83) deferred constant must be private type", N);
3040
            end if;
3041
         end if;
3042
 
3043
      --  If not a deferred constant, then object declaration freezes its type
3044
 
3045
      else
3046
         Check_Fully_Declared (T, N);
3047
         Freeze_Before (N, T);
3048
      end if;
3049
 
3050
      --  If the object was created by a constrained array definition, then
3051
      --  set the link in both the anonymous base type and anonymous subtype
3052
      --  that are built to represent the array type to point to the object.
3053
 
3054
      if Nkind (Object_Definition (Declaration_Node (Id))) =
3055
                        N_Constrained_Array_Definition
3056
      then
3057
         Set_Related_Array_Object (T, Id);
3058
         Set_Related_Array_Object (Base_Type (T), Id);
3059
      end if;
3060
 
3061
      --  Special checks for protected objects not at library level
3062
 
3063
      if Is_Protected_Type (T)
3064
        and then not Is_Library_Level_Entity (Id)
3065
      then
3066
         Check_Restriction (No_Local_Protected_Objects, Id);
3067
 
3068
         --  Protected objects with interrupt handlers must be at library level
3069
 
3070
         --  Ada 2005: this test is not needed (and the corresponding clause
3071
         --  in the RM is removed) because accessibility checks are sufficient
3072
         --  to make handlers not at the library level illegal.
3073
 
3074
         if Has_Interrupt_Handler (T)
3075
           and then Ada_Version < Ada_2005
3076
         then
3077
            Error_Msg_N
3078
              ("interrupt object can only be declared at library level", Id);
3079
         end if;
3080
      end if;
3081
 
3082
      --  The actual subtype of the object is the nominal subtype, unless
3083
      --  the nominal one is unconstrained and obtained from the expression.
3084
 
3085
      Act_T := T;
3086
 
3087
      --  These checks should be performed before the initialization expression
3088
      --  is considered, so that the Object_Definition node is still the same
3089
      --  as in source code.
3090
 
3091
      --  In SPARK, the nominal subtype shall be given by a subtype mark and
3092
      --  shall not be unconstrained. (The only exception to this is the
3093
      --  admission of declarations of constants of type String.)
3094
 
3095
      if not
3096
        Nkind_In (Object_Definition (N), N_Identifier, N_Expanded_Name)
3097
      then
3098
         Check_SPARK_Restriction
3099
           ("subtype mark required", Object_Definition (N));
3100
 
3101
      elsif Is_Array_Type (T)
3102
        and then not Is_Constrained (T)
3103
        and then T /= Standard_String
3104
      then
3105
         Check_SPARK_Restriction
3106
           ("subtype mark of constrained type expected",
3107
            Object_Definition (N));
3108
      end if;
3109
 
3110
      --  There are no aliased objects in SPARK
3111
 
3112
      if Aliased_Present (N) then
3113
         Check_SPARK_Restriction ("aliased object is not allowed", N);
3114
      end if;
3115
 
3116
      --  Process initialization expression if present and not in error
3117
 
3118
      if Present (E) and then E /= Error then
3119
 
3120
         --  Generate an error in case of CPP class-wide object initialization.
3121
         --  Required because otherwise the expansion of the class-wide
3122
         --  assignment would try to use 'size to initialize the object
3123
         --  (primitive that is not available in CPP tagged types).
3124
 
3125
         if Is_Class_Wide_Type (Act_T)
3126
           and then
3127
             (Is_CPP_Class (Root_Type (Etype (Act_T)))
3128
               or else
3129
                 (Present (Full_View (Root_Type (Etype (Act_T))))
3130
                   and then
3131
                     Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
3132
         then
3133
            Error_Msg_N
3134
              ("predefined assignment not available for 'C'P'P tagged types",
3135
               E);
3136
         end if;
3137
 
3138
         Mark_Coextensions (N, E);
3139
         Analyze (E);
3140
 
3141
         --  In case of errors detected in the analysis of the expression,
3142
         --  decorate it with the expected type to avoid cascaded errors
3143
 
3144
         if No (Etype (E)) then
3145
            Set_Etype (E, T);
3146
         end if;
3147
 
3148
         --  If an initialization expression is present, then we set the
3149
         --  Is_True_Constant flag. It will be reset if this is a variable
3150
         --  and it is indeed modified.
3151
 
3152
         Set_Is_True_Constant (Id, True);
3153
 
3154
         --  If we are analyzing a constant declaration, set its completion
3155
         --  flag after analyzing and resolving the expression.
3156
 
3157
         if Constant_Present (N) then
3158
            Set_Has_Completion (Id);
3159
         end if;
3160
 
3161
         --  Set type and resolve (type may be overridden later on)
3162
 
3163
         Set_Etype (Id, T);
3164
         Resolve (E, T);
3165
 
3166
         --  If E is null and has been replaced by an N_Raise_Constraint_Error
3167
         --  node (which was marked already-analyzed), we need to set the type
3168
         --  to something other than Any_Access in order to keep gigi happy.
3169
 
3170
         if Etype (E) = Any_Access then
3171
            Set_Etype (E, T);
3172
         end if;
3173
 
3174
         --  If the object is an access to variable, the initialization
3175
         --  expression cannot be an access to constant.
3176
 
3177
         if Is_Access_Type (T)
3178
           and then not Is_Access_Constant (T)
3179
           and then Is_Access_Type (Etype (E))
3180
           and then Is_Access_Constant (Etype (E))
3181
         then
3182
            Error_Msg_N
3183
              ("access to variable cannot be initialized "
3184
               & "with an access-to-constant expression", E);
3185
         end if;
3186
 
3187
         if not Assignment_OK (N) then
3188
            Check_Initialization (T, E);
3189
         end if;
3190
 
3191
         Check_Unset_Reference (E);
3192
 
3193
         --  If this is a variable, then set current value. If this is a
3194
         --  declared constant of a scalar type with a static expression,
3195
         --  indicate that it is always valid.
3196
 
3197
         if not Constant_Present (N) then
3198
            if Compile_Time_Known_Value (E) then
3199
               Set_Current_Value (Id, E);
3200
            end if;
3201
 
3202
         elsif Is_Scalar_Type (T)
3203
           and then Is_OK_Static_Expression (E)
3204
         then
3205
            Set_Is_Known_Valid (Id);
3206
         end if;
3207
 
3208
         --  Deal with setting of null flags
3209
 
3210
         if Is_Access_Type (T) then
3211
            if Known_Non_Null (E) then
3212
               Set_Is_Known_Non_Null (Id, True);
3213
            elsif Known_Null (E)
3214
              and then not Can_Never_Be_Null (Id)
3215
            then
3216
               Set_Is_Known_Null (Id, True);
3217
            end if;
3218
         end if;
3219
 
3220
         --  Check incorrect use of dynamically tagged expressions.
3221
 
3222
         if Is_Tagged_Type (T) then
3223
            Check_Dynamically_Tagged_Expression
3224
              (Expr        => E,
3225
               Typ         => T,
3226
               Related_Nod => N);
3227
         end if;
3228
 
3229
         Apply_Scalar_Range_Check (E, T);
3230
         Apply_Static_Length_Check (E, T);
3231
 
3232
         if Nkind (Original_Node (N)) = N_Object_Declaration
3233
           and then Comes_From_Source (Original_Node (N))
3234
 
3235
           --  Only call test if needed
3236
 
3237
           and then Restriction_Check_Required (SPARK)
3238
           and then not Is_SPARK_Initialization_Expr (E)
3239
         then
3240
            Check_SPARK_Restriction
3241
              ("initialization expression is not appropriate", E);
3242
         end if;
3243
      end if;
3244
 
3245
      --  If the No_Streams restriction is set, check that the type of the
3246
      --  object is not, and does not contain, any subtype derived from
3247
      --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
3248
      --  Has_Stream just for efficiency reasons. There is no point in
3249
      --  spending time on a Has_Stream check if the restriction is not set.
3250
 
3251
      if Restriction_Check_Required (No_Streams) then
3252
         if Has_Stream (T) then
3253
            Check_Restriction (No_Streams, N);
3254
         end if;
3255
      end if;
3256
 
3257
      --  Deal with predicate check before we start to do major rewriting.
3258
      --  it is OK to initialize and then check the initialized value, since
3259
      --  the object goes out of scope if we get a predicate failure. Note
3260
      --  that we do this in the analyzer and not the expander because the
3261
      --  analyzer does some substantial rewriting in some cases.
3262
 
3263
      --  We need a predicate check if the type has predicates, and if either
3264
      --  there is an initializing expression, or for default initialization
3265
      --  when we have at least one case of an explicit default initial value.
3266
 
3267
      if not Suppress_Assignment_Checks (N)
3268
        and then Present (Predicate_Function (T))
3269
        and then
3270
          (Present (E)
3271
            or else
3272
              Is_Partially_Initialized_Type (T, Include_Implicit => False))
3273
      then
3274
         Insert_After (N,
3275
           Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
3276
      end if;
3277
 
3278
      --  Case of unconstrained type
3279
 
3280
      if Is_Indefinite_Subtype (T) then
3281
 
3282
         --  In SPARK, a declaration of unconstrained type is allowed
3283
         --  only for constants of type string.
3284
 
3285
         if Is_String_Type (T) and then not Constant_Present (N) then
3286
            Check_SPARK_Restriction
3287
              ("declaration of object of unconstrained type not allowed",
3288
               N);
3289
         end if;
3290
 
3291
         --  Nothing to do in deferred constant case
3292
 
3293
         if Constant_Present (N) and then No (E) then
3294
            null;
3295
 
3296
         --  Case of no initialization present
3297
 
3298
         elsif No (E) then
3299
            if No_Initialization (N) then
3300
               null;
3301
 
3302
            elsif Is_Class_Wide_Type (T) then
3303
               Error_Msg_N
3304
                 ("initialization required in class-wide declaration ", N);
3305
 
3306
            else
3307
               Error_Msg_N
3308
                 ("unconstrained subtype not allowed (need initialization)",
3309
                  Object_Definition (N));
3310
 
3311
               if Is_Record_Type (T) and then Has_Discriminants (T) then
3312
                  Error_Msg_N
3313
                    ("\provide initial value or explicit discriminant values",
3314
                     Object_Definition (N));
3315
 
3316
                  Error_Msg_NE
3317
                    ("\or give default discriminant values for type&",
3318
                     Object_Definition (N), T);
3319
 
3320
               elsif Is_Array_Type (T) then
3321
                  Error_Msg_N
3322
                    ("\provide initial value or explicit array bounds",
3323
                     Object_Definition (N));
3324
               end if;
3325
            end if;
3326
 
3327
         --  Case of initialization present but in error. Set initial
3328
         --  expression as absent (but do not make above complaints)
3329
 
3330
         elsif E = Error then
3331
            Set_Expression (N, Empty);
3332
            E := Empty;
3333
 
3334
         --  Case of initialization present
3335
 
3336
         else
3337
            --  Check restrictions in Ada 83
3338
 
3339
            if not Constant_Present (N) then
3340
 
3341
               --  Unconstrained variables not allowed in Ada 83 mode
3342
 
3343
               if Ada_Version = Ada_83
3344
                 and then Comes_From_Source (Object_Definition (N))
3345
               then
3346
                  Error_Msg_N
3347
                    ("(Ada 83) unconstrained variable not allowed",
3348
                     Object_Definition (N));
3349
               end if;
3350
            end if;
3351
 
3352
            --  Now we constrain the variable from the initializing expression
3353
 
3354
            --  If the expression is an aggregate, it has been expanded into
3355
            --  individual assignments. Retrieve the actual type from the
3356
            --  expanded construct.
3357
 
3358
            if Is_Array_Type (T)
3359
              and then No_Initialization (N)
3360
              and then Nkind (Original_Node (E)) = N_Aggregate
3361
            then
3362
               Act_T := Etype (E);
3363
 
3364
            --  In case of class-wide interface object declarations we delay
3365
            --  the generation of the equivalent record type declarations until
3366
            --  its expansion because there are cases in they are not required.
3367
 
3368
            elsif Is_Interface (T) then
3369
               null;
3370
 
3371
            else
3372
               Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
3373
               Act_T := Find_Type_Of_Object (Object_Definition (N), N);
3374
            end if;
3375
 
3376
            Set_Is_Constr_Subt_For_U_Nominal (Act_T);
3377
 
3378
            if Aliased_Present (N) then
3379
               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
3380
            end if;
3381
 
3382
            Freeze_Before (N, Act_T);
3383
            Freeze_Before (N, T);
3384
         end if;
3385
 
3386
      elsif Is_Array_Type (T)
3387
        and then No_Initialization (N)
3388
        and then Nkind (Original_Node (E)) = N_Aggregate
3389
      then
3390
         if not Is_Entity_Name (Object_Definition (N)) then
3391
            Act_T := Etype (E);
3392
            Check_Compile_Time_Size (Act_T);
3393
 
3394
            if Aliased_Present (N) then
3395
               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
3396
            end if;
3397
         end if;
3398
 
3399
         --  When the given object definition and the aggregate are specified
3400
         --  independently, and their lengths might differ do a length check.
3401
         --  This cannot happen if the aggregate is of the form (others =>...)
3402
 
3403
         if not Is_Constrained (T) then
3404
            null;
3405
 
3406
         elsif Nkind (E) = N_Raise_Constraint_Error then
3407
 
3408
            --  Aggregate is statically illegal. Place back in declaration
3409
 
3410
            Set_Expression (N, E);
3411
            Set_No_Initialization (N, False);
3412
 
3413
         elsif T = Etype (E) then
3414
            null;
3415
 
3416
         elsif Nkind (E) = N_Aggregate
3417
           and then Present (Component_Associations (E))
3418
           and then Present (Choices (First (Component_Associations (E))))
3419
           and then Nkind (First
3420
            (Choices (First (Component_Associations (E))))) = N_Others_Choice
3421
         then
3422
            null;
3423
 
3424
         else
3425
            Apply_Length_Check (E, T);
3426
         end if;
3427
 
3428
      --  If the type is limited unconstrained with defaulted discriminants and
3429
      --  there is no expression, then the object is constrained by the
3430
      --  defaults, so it is worthwhile building the corresponding subtype.
3431
 
3432
      elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T))
3433
        and then not Is_Constrained (T)
3434
        and then Has_Discriminants (T)
3435
      then
3436
         if No (E) then
3437
            Act_T := Build_Default_Subtype (T, N);
3438
         else
3439
            --  Ada 2005:  a limited object may be initialized by means of an
3440
            --  aggregate. If the type has default discriminants it has an
3441
            --  unconstrained nominal type, Its actual subtype will be obtained
3442
            --  from the aggregate, and not from the default discriminants.
3443
 
3444
            Act_T := Etype (E);
3445
         end if;
3446
 
3447
         Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
3448
 
3449
      elsif Present (Underlying_Type (T))
3450
        and then not Is_Constrained (Underlying_Type (T))
3451
        and then Has_Discriminants (Underlying_Type (T))
3452
        and then Nkind (E) = N_Function_Call
3453
        and then Constant_Present (N)
3454
      then
3455
         --  The back-end has problems with constants of a discriminated type
3456
         --  with defaults, if the initial value is a function call. We
3457
         --  generate an intermediate temporary for the result of the call.
3458
         --  It is unclear why this should make it acceptable to gcc. ???
3459
 
3460
         Remove_Side_Effects (E);
3461
 
3462
      --  If this is a constant declaration of an unconstrained type and
3463
      --  the initialization is an aggregate, we can use the subtype of the
3464
      --  aggregate for the declared entity because it is immutable.
3465
 
3466
      elsif not Is_Constrained (T)
3467
        and then Has_Discriminants (T)
3468
        and then Constant_Present (N)
3469
        and then not Has_Unchecked_Union (T)
3470
        and then Nkind (E) = N_Aggregate
3471
      then
3472
         Act_T := Etype (E);
3473
      end if;
3474
 
3475
      --  Check No_Wide_Characters restriction
3476
 
3477
      Check_Wide_Character_Restriction (T, Object_Definition (N));
3478
 
3479
      --  Indicate this is not set in source. Certainly true for constants, and
3480
      --  true for variables so far (will be reset for a variable if and when
3481
      --  we encounter a modification in the source).
3482
 
3483
      Set_Never_Set_In_Source (Id, True);
3484
 
3485
      --  Now establish the proper kind and type of the object
3486
 
3487
      if Constant_Present (N) then
3488
         Set_Ekind            (Id, E_Constant);
3489
         Set_Is_True_Constant (Id, True);
3490
 
3491
      else
3492
         Set_Ekind (Id, E_Variable);
3493
 
3494
         --  A variable is set as shared passive if it appears in a shared
3495
         --  passive package, and is at the outer level. This is not done for
3496
         --  entities generated during expansion, because those are always
3497
         --  manipulated locally.
3498
 
3499
         if Is_Shared_Passive (Current_Scope)
3500
           and then Is_Library_Level_Entity (Id)
3501
           and then Comes_From_Source (Id)
3502
         then
3503
            Set_Is_Shared_Passive (Id);
3504
            Check_Shared_Var (Id, T, N);
3505
         end if;
3506
 
3507
         --  Set Has_Initial_Value if initializing expression present. Note
3508
         --  that if there is no initializing expression, we leave the state
3509
         --  of this flag unchanged (usually it will be False, but notably in
3510
         --  the case of exception choice variables, it will already be true).
3511
 
3512
         if Present (E) then
3513
            Set_Has_Initial_Value (Id, True);
3514
         end if;
3515
      end if;
3516
 
3517
      --  Initialize alignment and size and capture alignment setting
3518
 
3519
      Init_Alignment               (Id);
3520
      Init_Esize                   (Id);
3521
      Set_Optimize_Alignment_Flags (Id);
3522
 
3523
      --  Deal with aliased case
3524
 
3525
      if Aliased_Present (N) then
3526
         Set_Is_Aliased (Id);
3527
 
3528
         --  If the object is aliased and the type is unconstrained with
3529
         --  defaulted discriminants and there is no expression, then the
3530
         --  object is constrained by the defaults, so it is worthwhile
3531
         --  building the corresponding subtype.
3532
 
3533
         --  Ada 2005 (AI-363): If the aliased object is discriminated and
3534
         --  unconstrained, then only establish an actual subtype if the
3535
         --  nominal subtype is indefinite. In definite cases the object is
3536
         --  unconstrained in Ada 2005.
3537
 
3538
         if No (E)
3539
           and then Is_Record_Type (T)
3540
           and then not Is_Constrained (T)
3541
           and then Has_Discriminants (T)
3542
           and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T))
3543
         then
3544
            Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
3545
         end if;
3546
      end if;
3547
 
3548
      --  Now we can set the type of the object
3549
 
3550
      Set_Etype (Id, Act_T);
3551
 
3552
      --  Object is marked to be treated as volatile if type is volatile and
3553
      --  we clear the Current_Value setting that may have been set above.
3554
 
3555
      if Treat_As_Volatile (Etype (Id)) then
3556
         Set_Treat_As_Volatile (Id);
3557
         Set_Current_Value (Id, Empty);
3558
      end if;
3559
 
3560
      --  Deal with controlled types
3561
 
3562
      if Has_Controlled_Component (Etype (Id))
3563
        or else Is_Controlled (Etype (Id))
3564
      then
3565
         if not Is_Library_Level_Entity (Id) then
3566
            Check_Restriction (No_Nested_Finalization, N);
3567
         else
3568
            Validate_Controlled_Object (Id);
3569
         end if;
3570
 
3571
         --  Generate a warning when an initialization causes an obvious ABE
3572
         --  violation. If the init expression is a simple aggregate there
3573
         --  shouldn't be any initialize/adjust call generated. This will be
3574
         --  true as soon as aggregates are built in place when possible.
3575
 
3576
         --  ??? at the moment we do not generate warnings for temporaries
3577
         --  created for those aggregates although Program_Error might be
3578
         --  generated if compiled with -gnato.
3579
 
3580
         if Is_Controlled (Etype (Id))
3581
            and then Comes_From_Source (Id)
3582
         then
3583
            declare
3584
               BT : constant Entity_Id := Base_Type (Etype (Id));
3585
 
3586
               Implicit_Call : Entity_Id;
3587
               pragma Warnings (Off, Implicit_Call);
3588
               --  ??? what is this for (never referenced!)
3589
 
3590
               function Is_Aggr (N : Node_Id) return Boolean;
3591
               --  Check that N is an aggregate
3592
 
3593
               -------------
3594
               -- Is_Aggr --
3595
               -------------
3596
 
3597
               function Is_Aggr (N : Node_Id) return Boolean is
3598
               begin
3599
                  case Nkind (Original_Node (N)) is
3600
                     when N_Aggregate | N_Extension_Aggregate =>
3601
                        return True;
3602
 
3603
                     when N_Qualified_Expression |
3604
                          N_Type_Conversion      |
3605
                          N_Unchecked_Type_Conversion =>
3606
                        return Is_Aggr (Expression (Original_Node (N)));
3607
 
3608
                     when others =>
3609
                        return False;
3610
                  end case;
3611
               end Is_Aggr;
3612
 
3613
            begin
3614
               --  If no underlying type, we already are in an error situation.
3615
               --  Do not try to add a warning since we do not have access to
3616
               --  prim-op list.
3617
 
3618
               if No (Underlying_Type (BT)) then
3619
                  Implicit_Call := Empty;
3620
 
3621
               --  A generic type does not have usable primitive operators.
3622
               --  Initialization calls are built for instances.
3623
 
3624
               elsif Is_Generic_Type (BT) then
3625
                  Implicit_Call := Empty;
3626
 
3627
               --  If the init expression is not an aggregate, an adjust call
3628
               --  will be generated
3629
 
3630
               elsif Present (E) and then not Is_Aggr (E) then
3631
                  Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
3632
 
3633
               --  If no init expression and we are not in the deferred
3634
               --  constant case, an Initialize call will be generated
3635
 
3636
               elsif No (E) and then not Constant_Present (N) then
3637
                  Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
3638
 
3639
               else
3640
                  Implicit_Call := Empty;
3641
               end if;
3642
            end;
3643
         end if;
3644
      end if;
3645
 
3646
      if Has_Task (Etype (Id)) then
3647
         Check_Restriction (No_Tasking, N);
3648
 
3649
         --  Deal with counting max tasks
3650
 
3651
         --  Nothing to do if inside a generic
3652
 
3653
         if Inside_A_Generic then
3654
            null;
3655
 
3656
         --  If library level entity, then count tasks
3657
 
3658
         elsif Is_Library_Level_Entity (Id) then
3659
            Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
3660
 
3661
         --  If not library level entity, then indicate we don't know max
3662
         --  tasks and also check task hierarchy restriction and blocking
3663
         --  operation (since starting a task is definitely blocking!)
3664
 
3665
         else
3666
            Check_Restriction (Max_Tasks, N);
3667
            Check_Restriction (No_Task_Hierarchy, N);
3668
            Check_Potentially_Blocking_Operation (N);
3669
         end if;
3670
 
3671
         --  A rather specialized test. If we see two tasks being declared
3672
         --  of the same type in the same object declaration, and the task
3673
         --  has an entry with an address clause, we know that program error
3674
         --  will be raised at run time since we can't have two tasks with
3675
         --  entries at the same address.
3676
 
3677
         if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
3678
            declare
3679
               E : Entity_Id;
3680
 
3681
            begin
3682
               E := First_Entity (Etype (Id));
3683
               while Present (E) loop
3684
                  if Ekind (E) = E_Entry
3685
                    and then Present (Get_Attribute_Definition_Clause
3686
                                        (E, Attribute_Address))
3687
                  then
3688
                     Error_Msg_N
3689
                       ("?more than one task with same entry address", N);
3690
                     Error_Msg_N
3691
                       ("\?Program_Error will be raised at run time", N);
3692
                     Insert_Action (N,
3693
                       Make_Raise_Program_Error (Loc,
3694
                         Reason => PE_Duplicated_Entry_Address));
3695
                     exit;
3696
                  end if;
3697
 
3698
                  Next_Entity (E);
3699
               end loop;
3700
            end;
3701
         end if;
3702
      end if;
3703
 
3704
      --  Some simple constant-propagation: if the expression is a constant
3705
      --  string initialized with a literal, share the literal. This avoids
3706
      --  a run-time copy.
3707
 
3708
      if Present (E)
3709
        and then Is_Entity_Name (E)
3710
        and then Ekind (Entity (E)) = E_Constant
3711
        and then Base_Type (Etype (E)) = Standard_String
3712
      then
3713
         declare
3714
            Val : constant Node_Id := Constant_Value (Entity (E));
3715
         begin
3716
            if Present (Val)
3717
              and then Nkind (Val) = N_String_Literal
3718
            then
3719
               Rewrite (E, New_Copy (Val));
3720
            end if;
3721
         end;
3722
      end if;
3723
 
3724
      --  Another optimization: if the nominal subtype is unconstrained and
3725
      --  the expression is a function call that returns an unconstrained
3726
      --  type, rewrite the declaration as a renaming of the result of the
3727
      --  call. The exceptions below are cases where the copy is expected,
3728
      --  either by the back end (Aliased case) or by the semantics, as for
3729
      --  initializing controlled types or copying tags for classwide types.
3730
 
3731
      if Present (E)
3732
        and then Nkind (E) = N_Explicit_Dereference
3733
        and then Nkind (Original_Node (E)) = N_Function_Call
3734
        and then not Is_Library_Level_Entity (Id)
3735
        and then not Is_Constrained (Underlying_Type (T))
3736
        and then not Is_Aliased (Id)
3737
        and then not Is_Class_Wide_Type (T)
3738
        and then not Is_Controlled (T)
3739
        and then not Has_Controlled_Component (Base_Type (T))
3740
        and then Expander_Active
3741
      then
3742
         Rewrite (N,
3743
           Make_Object_Renaming_Declaration (Loc,
3744
             Defining_Identifier => Id,
3745
             Access_Definition   => Empty,
3746
             Subtype_Mark        => New_Occurrence_Of
3747
                                      (Base_Type (Etype (Id)), Loc),
3748
             Name                => E));
3749
 
3750
         Set_Renamed_Object (Id, E);
3751
 
3752
         --  Force generation of debugging information for the constant and for
3753
         --  the renamed function call.
3754
 
3755
         Set_Debug_Info_Needed (Id);
3756
         Set_Debug_Info_Needed (Entity (Prefix (E)));
3757
      end if;
3758
 
3759
      if Present (Prev_Entity)
3760
        and then Is_Frozen (Prev_Entity)
3761
        and then not Error_Posted (Id)
3762
      then
3763
         Error_Msg_N ("full constant declaration appears too late", N);
3764
      end if;
3765
 
3766
      Check_Eliminated (Id);
3767
 
3768
      --  Deal with setting In_Private_Part flag if in private part
3769
 
3770
      if Ekind (Scope (Id)) = E_Package
3771
        and then In_Private_Part (Scope (Id))
3772
      then
3773
         Set_In_Private_Part (Id);
3774
      end if;
3775
 
3776
      --  Check for violation of No_Local_Timing_Events
3777
 
3778
      if Restriction_Check_Required (No_Local_Timing_Events)
3779
        and then not Is_Library_Level_Entity (Id)
3780
        and then Is_RTE (Etype (Id), RE_Timing_Event)
3781
      then
3782
         Check_Restriction (No_Local_Timing_Events, N);
3783
      end if;
3784
 
3785
   <<Leave>>
3786
      if Has_Aspects (N) then
3787
         Analyze_Aspect_Specifications (N, Id);
3788
      end if;
3789
 
3790
      Analyze_Dimension (N);
3791
   end Analyze_Object_Declaration;
3792
 
3793
   ---------------------------
3794
   -- Analyze_Others_Choice --
3795
   ---------------------------
3796
 
3797
   --  Nothing to do for the others choice node itself, the semantic analysis
3798
   --  of the others choice will occur as part of the processing of the parent
3799
 
3800
   procedure Analyze_Others_Choice (N : Node_Id) is
3801
      pragma Warnings (Off, N);
3802
   begin
3803
      null;
3804
   end Analyze_Others_Choice;
3805
 
3806
   -------------------------------------------
3807
   -- Analyze_Private_Extension_Declaration --
3808
   -------------------------------------------
3809
 
3810
   procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
3811
      T           : constant Entity_Id := Defining_Identifier (N);
3812
      Indic       : constant Node_Id   := Subtype_Indication (N);
3813
      Parent_Type : Entity_Id;
3814
      Parent_Base : Entity_Id;
3815
 
3816
   begin
3817
      --  Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
3818
 
3819
      if Is_Non_Empty_List (Interface_List (N)) then
3820
         declare
3821
            Intf : Node_Id;
3822
            T    : Entity_Id;
3823
 
3824
         begin
3825
            Intf := First (Interface_List (N));
3826
            while Present (Intf) loop
3827
               T := Find_Type_Of_Subtype_Indic (Intf);
3828
 
3829
               Diagnose_Interface (Intf, T);
3830
               Next (Intf);
3831
            end loop;
3832
         end;
3833
      end if;
3834
 
3835
      Generate_Definition (T);
3836
 
3837
      --  For other than Ada 2012, just enter the name in the current scope
3838
 
3839
      if Ada_Version < Ada_2012 then
3840
         Enter_Name (T);
3841
 
3842
      --  Ada 2012 (AI05-0162): Enter the name in the current scope handling
3843
      --  case of private type that completes an incomplete type.
3844
 
3845
      else
3846
         declare
3847
            Prev : Entity_Id;
3848
 
3849
         begin
3850
            Prev := Find_Type_Name (N);
3851
 
3852
            pragma Assert (Prev = T
3853
              or else (Ekind (Prev) = E_Incomplete_Type
3854
                         and then Present (Full_View (Prev))
3855
                         and then Full_View (Prev) = T));
3856
         end;
3857
      end if;
3858
 
3859
      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
3860
      Parent_Base := Base_Type (Parent_Type);
3861
 
3862
      if Parent_Type = Any_Type
3863
        or else Etype (Parent_Type) = Any_Type
3864
      then
3865
         Set_Ekind (T, Ekind (Parent_Type));
3866
         Set_Etype (T, Any_Type);
3867
         goto Leave;
3868
 
3869
      elsif not Is_Tagged_Type (Parent_Type) then
3870
         Error_Msg_N
3871
           ("parent of type extension must be a tagged type ", Indic);
3872
         goto Leave;
3873
 
3874
      elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
3875
         Error_Msg_N ("premature derivation of incomplete type", Indic);
3876
         goto Leave;
3877
 
3878
      elsif Is_Concurrent_Type (Parent_Type) then
3879
         Error_Msg_N
3880
           ("parent type of a private extension cannot be "
3881
            & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
3882
 
3883
         Set_Etype              (T, Any_Type);
3884
         Set_Ekind              (T, E_Limited_Private_Type);
3885
         Set_Private_Dependents (T, New_Elmt_List);
3886
         Set_Error_Posted       (T);
3887
         goto Leave;
3888
      end if;
3889
 
3890
      --  Perhaps the parent type should be changed to the class-wide type's
3891
      --  specific type in this case to prevent cascading errors ???
3892
 
3893
      if Is_Class_Wide_Type (Parent_Type) then
3894
         Error_Msg_N
3895
           ("parent of type extension must not be a class-wide type", Indic);
3896
         goto Leave;
3897
      end if;
3898
 
3899
      if (not Is_Package_Or_Generic_Package (Current_Scope)
3900
           and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
3901
        or else In_Private_Part (Current_Scope)
3902
 
3903
      then
3904
         Error_Msg_N ("invalid context for private extension", N);
3905
      end if;
3906
 
3907
      --  Set common attributes
3908
 
3909
      Set_Is_Pure          (T, Is_Pure (Current_Scope));
3910
      Set_Scope            (T, Current_Scope);
3911
      Set_Ekind            (T, E_Record_Type_With_Private);
3912
      Init_Size_Align      (T);
3913
 
3914
      Set_Etype            (T,            Parent_Base);
3915
      Set_Has_Task         (T, Has_Task  (Parent_Base));
3916
 
3917
      Set_Convention       (T, Convention     (Parent_Type));
3918
      Set_First_Rep_Item   (T, First_Rep_Item (Parent_Type));
3919
      Set_Is_First_Subtype (T);
3920
      Make_Class_Wide_Type (T);
3921
 
3922
      if Unknown_Discriminants_Present (N) then
3923
         Set_Discriminant_Constraint (T, No_Elist);
3924
      end if;
3925
 
3926
      Build_Derived_Record_Type (N, Parent_Type, T);
3927
 
3928
      --  Propagate inherited invariant information. The new type has
3929
      --  invariants, if the parent type has inheritable invariants,
3930
      --  and these invariants can in turn be inherited.
3931
 
3932
      if Has_Inheritable_Invariants (Parent_Type) then
3933
         Set_Has_Inheritable_Invariants (T);
3934
         Set_Has_Invariants (T);
3935
      end if;
3936
 
3937
      --  Ada 2005 (AI-443): Synchronized private extension or a rewritten
3938
      --  synchronized formal derived type.
3939
 
3940
      if Ada_Version >= Ada_2005
3941
        and then Synchronized_Present (N)
3942
      then
3943
         Set_Is_Limited_Record (T);
3944
 
3945
         --  Formal derived type case
3946
 
3947
         if Is_Generic_Type (T) then
3948
 
3949
            --  The parent must be a tagged limited type or a synchronized
3950
            --  interface.
3951
 
3952
            if (not Is_Tagged_Type (Parent_Type)
3953
                  or else not Is_Limited_Type (Parent_Type))
3954
              and then
3955
               (not Is_Interface (Parent_Type)
3956
                  or else not Is_Synchronized_Interface (Parent_Type))
3957
            then
3958
               Error_Msg_NE ("parent type of & must be tagged limited " &
3959
                             "or synchronized", N, T);
3960
            end if;
3961
 
3962
            --  The progenitors (if any) must be limited or synchronized
3963
            --  interfaces.
3964
 
3965
            if Present (Interfaces (T)) then
3966
               declare
3967
                  Iface      : Entity_Id;
3968
                  Iface_Elmt : Elmt_Id;
3969
 
3970
               begin
3971
                  Iface_Elmt := First_Elmt (Interfaces (T));
3972
                  while Present (Iface_Elmt) loop
3973
                     Iface := Node (Iface_Elmt);
3974
 
3975
                     if not Is_Limited_Interface (Iface)
3976
                       and then not Is_Synchronized_Interface (Iface)
3977
                     then
3978
                        Error_Msg_NE ("progenitor & must be limited " &
3979
                                      "or synchronized", N, Iface);
3980
                     end if;
3981
 
3982
                     Next_Elmt (Iface_Elmt);
3983
                  end loop;
3984
               end;
3985
            end if;
3986
 
3987
         --  Regular derived extension, the parent must be a limited or
3988
         --  synchronized interface.
3989
 
3990
         else
3991
            if not Is_Interface (Parent_Type)
3992
              or else (not Is_Limited_Interface (Parent_Type)
3993
                         and then
3994
                       not Is_Synchronized_Interface (Parent_Type))
3995
            then
3996
               Error_Msg_NE
3997
                 ("parent type of & must be limited interface", N, T);
3998
            end if;
3999
         end if;
4000
 
4001
      --  A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
4002
      --  extension with a synchronized parent must be explicitly declared
4003
      --  synchronized, because the full view will be a synchronized type.
4004
      --  This must be checked before the check for limited types below,
4005
      --  to ensure that types declared limited are not allowed to extend
4006
      --  synchronized interfaces.
4007
 
4008
      elsif Is_Interface (Parent_Type)
4009
        and then Is_Synchronized_Interface (Parent_Type)
4010
        and then not Synchronized_Present (N)
4011
      then
4012
         Error_Msg_NE
4013
           ("private extension of& must be explicitly synchronized",
4014
             N, Parent_Type);
4015
 
4016
      elsif Limited_Present (N) then
4017
         Set_Is_Limited_Record (T);
4018
 
4019
         if not Is_Limited_Type (Parent_Type)
4020
           and then
4021
             (not Is_Interface (Parent_Type)
4022
               or else not Is_Limited_Interface (Parent_Type))
4023
         then
4024
            Error_Msg_NE ("parent type& of limited extension must be limited",
4025
              N, Parent_Type);
4026
         end if;
4027
      end if;
4028
 
4029
   <<Leave>>
4030
      if Has_Aspects (N) then
4031
         Analyze_Aspect_Specifications (N, T);
4032
      end if;
4033
   end Analyze_Private_Extension_Declaration;
4034
 
4035
   ---------------------------------
4036
   -- Analyze_Subtype_Declaration --
4037
   ---------------------------------
4038
 
4039
   procedure Analyze_Subtype_Declaration
4040
     (N    : Node_Id;
4041
      Skip : Boolean := False)
4042
   is
4043
      Id       : constant Entity_Id := Defining_Identifier (N);
4044
      T        : Entity_Id;
4045
      R_Checks : Check_Result;
4046
 
4047
   begin
4048
      Generate_Definition (Id);
4049
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
4050
      Init_Size_Align (Id);
4051
 
4052
      --  The following guard condition on Enter_Name is to handle cases where
4053
      --  the defining identifier has already been entered into the scope but
4054
      --  the declaration as a whole needs to be analyzed.
4055
 
4056
      --  This case in particular happens for derived enumeration types. The
4057
      --  derived enumeration type is processed as an inserted enumeration type
4058
      --  declaration followed by a rewritten subtype declaration. The defining
4059
      --  identifier, however, is entered into the name scope very early in the
4060
      --  processing of the original type declaration and therefore needs to be
4061
      --  avoided here, when the created subtype declaration is analyzed. (See
4062
      --  Build_Derived_Types)
4063
 
4064
      --  This also happens when the full view of a private type is derived
4065
      --  type with constraints. In this case the entity has been introduced
4066
      --  in the private declaration.
4067
 
4068
      if Skip
4069
        or else (Present (Etype (Id))
4070
                  and then (Is_Private_Type (Etype (Id))
4071
                             or else Is_Task_Type (Etype (Id))
4072
                             or else Is_Rewrite_Substitution (N)))
4073
      then
4074
         null;
4075
 
4076
      else
4077
         Enter_Name (Id);
4078
      end if;
4079
 
4080
      T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
4081
 
4082
      --  Class-wide equivalent types of records with unknown discriminants
4083
      --  involve the generation of an itype which serves as the private view
4084
      --  of a constrained record subtype. In such cases the base type of the
4085
      --  current subtype we are processing is the private itype. Use the full
4086
      --  of the private itype when decorating various attributes.
4087
 
4088
      if Is_Itype (T)
4089
        and then Is_Private_Type (T)
4090
        and then Present (Full_View (T))
4091
      then
4092
         T := Full_View (T);
4093
      end if;
4094
 
4095
      --  Inherit common attributes
4096
 
4097
      Set_Is_Generic_Type   (Id, Is_Generic_Type   (Base_Type (T)));
4098
      Set_Is_Volatile       (Id, Is_Volatile       (T));
4099
      Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
4100
      Set_Is_Atomic         (Id, Is_Atomic         (T));
4101
      Set_Is_Ada_2005_Only  (Id, Is_Ada_2005_Only  (T));
4102
      Set_Is_Ada_2012_Only  (Id, Is_Ada_2012_Only  (T));
4103
      Set_Convention        (Id, Convention        (T));
4104
 
4105
      --  If ancestor has predicates then so does the subtype, and in addition
4106
      --  we must delay the freeze to properly arrange predicate inheritance.
4107
 
4108
      --  The Ancestor_Type test is a big kludge, there seem to be cases in
4109
      --  which T = ID, so the above tests and assignments do nothing???
4110
 
4111
      if Has_Predicates (T)
4112
        or else (Present (Ancestor_Subtype (T))
4113
                  and then Has_Predicates (Ancestor_Subtype (T)))
4114
      then
4115
         Set_Has_Predicates (Id);
4116
         Set_Has_Delayed_Freeze (Id);
4117
      end if;
4118
 
4119
      --  Subtype of Boolean cannot have a constraint in SPARK
4120
 
4121
      if Is_Boolean_Type (T)
4122
        and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication
4123
      then
4124
         Check_SPARK_Restriction
4125
           ("subtype of Boolean cannot have constraint", N);
4126
      end if;
4127
 
4128
      if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
4129
         declare
4130
            Cstr     : constant Node_Id := Constraint (Subtype_Indication (N));
4131
            One_Cstr : Node_Id;
4132
            Low      : Node_Id;
4133
            High     : Node_Id;
4134
 
4135
         begin
4136
            if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint then
4137
               One_Cstr := First (Constraints (Cstr));
4138
               while Present (One_Cstr) loop
4139
 
4140
                  --  Index or discriminant constraint in SPARK must be a
4141
                  --  subtype mark.
4142
 
4143
                  if not
4144
                    Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name)
4145
                  then
4146
                     Check_SPARK_Restriction
4147
                       ("subtype mark required", One_Cstr);
4148
 
4149
                  --  String subtype must have a lower bound of 1 in SPARK.
4150
                  --  Note that we do not need to test for the non-static case
4151
                  --  here, since that was already taken care of in
4152
                  --  Process_Range_Expr_In_Decl.
4153
 
4154
                  elsif Base_Type (T) = Standard_String then
4155
                     Get_Index_Bounds (One_Cstr, Low, High);
4156
 
4157
                     if Is_OK_Static_Expression (Low)
4158
                       and then Expr_Value (Low) /= 1
4159
                     then
4160
                        Check_SPARK_Restriction
4161
                          ("String subtype must have lower bound of 1", N);
4162
                     end if;
4163
                  end if;
4164
 
4165
                  Next (One_Cstr);
4166
               end loop;
4167
            end if;
4168
         end;
4169
      end if;
4170
 
4171
      --  In the case where there is no constraint given in the subtype
4172
      --  indication, Process_Subtype just returns the Subtype_Mark, so its
4173
      --  semantic attributes must be established here.
4174
 
4175
      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
4176
         Set_Etype (Id, Base_Type (T));
4177
 
4178
         --  Subtype of unconstrained array without constraint is not allowed
4179
         --  in SPARK.
4180
 
4181
         if Is_Array_Type (T)
4182
           and then not Is_Constrained (T)
4183
         then
4184
            Check_SPARK_Restriction
4185
              ("subtype of unconstrained array must have constraint", N);
4186
         end if;
4187
 
4188
         case Ekind (T) is
4189
            when Array_Kind =>
4190
               Set_Ekind                       (Id, E_Array_Subtype);
4191
               Copy_Array_Subtype_Attributes   (Id, T);
4192
 
4193
            when Decimal_Fixed_Point_Kind =>
4194
               Set_Ekind                (Id, E_Decimal_Fixed_Point_Subtype);
4195
               Set_Digits_Value         (Id, Digits_Value       (T));
4196
               Set_Delta_Value          (Id, Delta_Value        (T));
4197
               Set_Scale_Value          (Id, Scale_Value        (T));
4198
               Set_Small_Value          (Id, Small_Value        (T));
4199
               Set_Scalar_Range         (Id, Scalar_Range       (T));
4200
               Set_Machine_Radix_10     (Id, Machine_Radix_10   (T));
4201
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4202
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
4203
               Set_RM_Size              (Id, RM_Size            (T));
4204
 
4205
            when Enumeration_Kind =>
4206
               Set_Ekind                (Id, E_Enumeration_Subtype);
4207
               Set_First_Literal        (Id, First_Literal (Base_Type (T)));
4208
               Set_Scalar_Range         (Id, Scalar_Range       (T));
4209
               Set_Is_Character_Type    (Id, Is_Character_Type  (T));
4210
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4211
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
4212
               Set_RM_Size              (Id, RM_Size            (T));
4213
 
4214
            when Ordinary_Fixed_Point_Kind =>
4215
               Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
4216
               Set_Scalar_Range         (Id, Scalar_Range       (T));
4217
               Set_Small_Value          (Id, Small_Value        (T));
4218
               Set_Delta_Value          (Id, Delta_Value        (T));
4219
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4220
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
4221
               Set_RM_Size              (Id, RM_Size            (T));
4222
 
4223
            when Float_Kind =>
4224
               Set_Ekind                (Id, E_Floating_Point_Subtype);
4225
               Set_Scalar_Range         (Id, Scalar_Range       (T));
4226
               Set_Digits_Value         (Id, Digits_Value       (T));
4227
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4228
 
4229
            when Signed_Integer_Kind =>
4230
               Set_Ekind                (Id, E_Signed_Integer_Subtype);
4231
               Set_Scalar_Range         (Id, Scalar_Range       (T));
4232
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4233
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
4234
               Set_RM_Size              (Id, RM_Size            (T));
4235
 
4236
            when Modular_Integer_Kind =>
4237
               Set_Ekind                (Id, E_Modular_Integer_Subtype);
4238
               Set_Scalar_Range         (Id, Scalar_Range       (T));
4239
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4240
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
4241
               Set_RM_Size              (Id, RM_Size            (T));
4242
 
4243
            when Class_Wide_Kind =>
4244
               Set_Ekind                (Id, E_Class_Wide_Subtype);
4245
               Set_First_Entity         (Id, First_Entity       (T));
4246
               Set_Last_Entity          (Id, Last_Entity        (T));
4247
               Set_Class_Wide_Type      (Id, Class_Wide_Type    (T));
4248
               Set_Cloned_Subtype       (Id, T);
4249
               Set_Is_Tagged_Type       (Id, True);
4250
               Set_Has_Unknown_Discriminants
4251
                                        (Id, True);
4252
 
4253
               if Ekind (T) = E_Class_Wide_Subtype then
4254
                  Set_Equivalent_Type   (Id, Equivalent_Type    (T));
4255
               end if;
4256
 
4257
            when E_Record_Type | E_Record_Subtype =>
4258
               Set_Ekind                (Id, E_Record_Subtype);
4259
 
4260
               if Ekind (T) = E_Record_Subtype
4261
                 and then Present (Cloned_Subtype (T))
4262
               then
4263
                  Set_Cloned_Subtype    (Id, Cloned_Subtype (T));
4264
               else
4265
                  Set_Cloned_Subtype    (Id, T);
4266
               end if;
4267
 
4268
               Set_First_Entity         (Id, First_Entity       (T));
4269
               Set_Last_Entity          (Id, Last_Entity        (T));
4270
               Set_Has_Discriminants    (Id, Has_Discriminants  (T));
4271
               Set_Is_Constrained       (Id, Is_Constrained     (T));
4272
               Set_Is_Limited_Record    (Id, Is_Limited_Record  (T));
4273
               Set_Has_Implicit_Dereference
4274
                                        (Id, Has_Implicit_Dereference (T));
4275
               Set_Has_Unknown_Discriminants
4276
                                        (Id, Has_Unknown_Discriminants (T));
4277
 
4278
               if Has_Discriminants (T) then
4279
                  Set_Discriminant_Constraint
4280
                                        (Id, Discriminant_Constraint (T));
4281
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
4282
 
4283
               elsif Has_Unknown_Discriminants (Id) then
4284
                  Set_Discriminant_Constraint (Id, No_Elist);
4285
               end if;
4286
 
4287
               if Is_Tagged_Type (T) then
4288
                  Set_Is_Tagged_Type    (Id);
4289
                  Set_Is_Abstract_Type  (Id, Is_Abstract_Type (T));
4290
                  Set_Direct_Primitive_Operations
4291
                                        (Id, Direct_Primitive_Operations (T));
4292
                  Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
4293
 
4294
                  if Is_Interface (T) then
4295
                     Set_Is_Interface (Id);
4296
                     Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
4297
                  end if;
4298
               end if;
4299
 
4300
            when Private_Kind =>
4301
               Set_Ekind              (Id, Subtype_Kind (Ekind        (T)));
4302
               Set_Has_Discriminants  (Id, Has_Discriminants          (T));
4303
               Set_Is_Constrained     (Id, Is_Constrained             (T));
4304
               Set_First_Entity       (Id, First_Entity               (T));
4305
               Set_Last_Entity        (Id, Last_Entity                (T));
4306
               Set_Private_Dependents (Id, New_Elmt_List);
4307
               Set_Is_Limited_Record  (Id, Is_Limited_Record          (T));
4308
               Set_Has_Implicit_Dereference
4309
                                      (Id, Has_Implicit_Dereference   (T));
4310
               Set_Has_Unknown_Discriminants
4311
                                      (Id, Has_Unknown_Discriminants  (T));
4312
               Set_Known_To_Have_Preelab_Init
4313
                                      (Id, Known_To_Have_Preelab_Init (T));
4314
 
4315
               if Is_Tagged_Type (T) then
4316
                  Set_Is_Tagged_Type              (Id);
4317
                  Set_Is_Abstract_Type            (Id, Is_Abstract_Type (T));
4318
                  Set_Class_Wide_Type             (Id, Class_Wide_Type  (T));
4319
                  Set_Direct_Primitive_Operations (Id,
4320
                    Direct_Primitive_Operations (T));
4321
               end if;
4322
 
4323
               --  In general the attributes of the subtype of a private type
4324
               --  are the attributes of the partial view of parent. However,
4325
               --  the full view may be a discriminated type, and the subtype
4326
               --  must share the discriminant constraint to generate correct
4327
               --  calls to initialization procedures.
4328
 
4329
               if Has_Discriminants (T) then
4330
                  Set_Discriminant_Constraint
4331
                    (Id, Discriminant_Constraint (T));
4332
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
4333
 
4334
               elsif Present (Full_View (T))
4335
                 and then Has_Discriminants (Full_View (T))
4336
               then
4337
                  Set_Discriminant_Constraint
4338
                    (Id, Discriminant_Constraint (Full_View (T)));
4339
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
4340
 
4341
                  --  This would seem semantically correct, but apparently
4342
                  --  confuses the back-end. To be explained and checked with
4343
                  --  current version ???
4344
 
4345
                  --  Set_Has_Discriminants (Id);
4346
               end if;
4347
 
4348
               Prepare_Private_Subtype_Completion (Id, N);
4349
 
4350
            when Access_Kind =>
4351
               Set_Ekind             (Id, E_Access_Subtype);
4352
               Set_Is_Constrained    (Id, Is_Constrained        (T));
4353
               Set_Is_Access_Constant
4354
                                     (Id, Is_Access_Constant    (T));
4355
               Set_Directly_Designated_Type
4356
                                     (Id, Designated_Type       (T));
4357
               Set_Can_Never_Be_Null (Id, Can_Never_Be_Null     (T));
4358
 
4359
               --  A Pure library_item must not contain the declaration of a
4360
               --  named access type, except within a subprogram, generic
4361
               --  subprogram, task unit, or protected unit, or if it has
4362
               --  a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
4363
 
4364
               if Comes_From_Source (Id)
4365
                 and then In_Pure_Unit
4366
                 and then not In_Subprogram_Task_Protected_Unit
4367
                 and then not No_Pool_Assigned (Id)
4368
               then
4369
                  Error_Msg_N
4370
                    ("named access types not allowed in pure unit", N);
4371
               end if;
4372
 
4373
            when Concurrent_Kind =>
4374
               Set_Ekind                (Id, Subtype_Kind (Ekind   (T)));
4375
               Set_Corresponding_Record_Type (Id,
4376
                                         Corresponding_Record_Type (T));
4377
               Set_First_Entity         (Id, First_Entity          (T));
4378
               Set_First_Private_Entity (Id, First_Private_Entity  (T));
4379
               Set_Has_Discriminants    (Id, Has_Discriminants     (T));
4380
               Set_Is_Constrained       (Id, Is_Constrained        (T));
4381
               Set_Is_Tagged_Type       (Id, Is_Tagged_Type        (T));
4382
               Set_Last_Entity          (Id, Last_Entity           (T));
4383
 
4384
               if Has_Discriminants (T) then
4385
                  Set_Discriminant_Constraint (Id,
4386
                                           Discriminant_Constraint (T));
4387
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
4388
               end if;
4389
 
4390
            when E_Incomplete_Type =>
4391
               if Ada_Version >= Ada_2005 then
4392
                  Set_Ekind (Id, E_Incomplete_Subtype);
4393
 
4394
                  --  Ada 2005 (AI-412): Decorate an incomplete subtype
4395
                  --  of an incomplete type visible through a limited
4396
                  --  with clause.
4397
 
4398
                  if From_With_Type (T)
4399
                    and then Present (Non_Limited_View (T))
4400
                  then
4401
                     Set_From_With_Type   (Id);
4402
                     Set_Non_Limited_View (Id, Non_Limited_View (T));
4403
 
4404
                  --  Ada 2005 (AI-412): Add the regular incomplete subtype
4405
                  --  to the private dependents of the original incomplete
4406
                  --  type for future transformation.
4407
 
4408
                  else
4409
                     Append_Elmt (Id, Private_Dependents (T));
4410
                  end if;
4411
 
4412
               --  If the subtype name denotes an incomplete type an error
4413
               --  was already reported by Process_Subtype.
4414
 
4415
               else
4416
                  Set_Etype (Id, Any_Type);
4417
               end if;
4418
 
4419
            when others =>
4420
               raise Program_Error;
4421
         end case;
4422
      end if;
4423
 
4424
      if Etype (Id) = Any_Type then
4425
         goto Leave;
4426
      end if;
4427
 
4428
      --  Some common processing on all types
4429
 
4430
      Set_Size_Info      (Id,                 T);
4431
      Set_First_Rep_Item (Id, First_Rep_Item (T));
4432
 
4433
      T := Etype (Id);
4434
 
4435
      Set_Is_Immediately_Visible   (Id, True);
4436
      Set_Depends_On_Private       (Id, Has_Private_Component (T));
4437
      Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
4438
 
4439
      if Is_Interface (T) then
4440
         Set_Is_Interface (Id);
4441
      end if;
4442
 
4443
      if Present (Generic_Parent_Type (N))
4444
        and then
4445
          (Nkind
4446
            (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
4447
            or else Nkind
4448
              (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
4449
                /= N_Formal_Private_Type_Definition)
4450
      then
4451
         if Is_Tagged_Type (Id) then
4452
 
4453
            --  If this is a generic actual subtype for a synchronized type,
4454
            --  the primitive operations are those of the corresponding record
4455
            --  for which there is a separate subtype declaration.
4456
 
4457
            if Is_Concurrent_Type (Id) then
4458
               null;
4459
            elsif Is_Class_Wide_Type (Id) then
4460
               Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
4461
            else
4462
               Derive_Subprograms (Generic_Parent_Type (N), Id, T);
4463
            end if;
4464
 
4465
         elsif Scope (Etype (Id)) /= Standard_Standard then
4466
            Derive_Subprograms (Generic_Parent_Type (N), Id);
4467
         end if;
4468
      end if;
4469
 
4470
      if Is_Private_Type (T)
4471
        and then Present (Full_View (T))
4472
      then
4473
         Conditional_Delay (Id, Full_View (T));
4474
 
4475
      --  The subtypes of components or subcomponents of protected types
4476
      --  do not need freeze nodes, which would otherwise appear in the
4477
      --  wrong scope (before the freeze node for the protected type). The
4478
      --  proper subtypes are those of the subcomponents of the corresponding
4479
      --  record.
4480
 
4481
      elsif Ekind (Scope (Id)) /= E_Protected_Type
4482
        and then Present (Scope (Scope (Id))) -- error defense!
4483
        and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
4484
      then
4485
         Conditional_Delay (Id, T);
4486
      end if;
4487
 
4488
      --  Check that Constraint_Error is raised for a scalar subtype indication
4489
      --  when the lower or upper bound of a non-null range lies outside the
4490
      --  range of the type mark.
4491
 
4492
      if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
4493
         if Is_Scalar_Type (Etype (Id))
4494
            and then Scalar_Range (Id) /=
4495
                     Scalar_Range (Etype (Subtype_Mark
4496
                                           (Subtype_Indication (N))))
4497
         then
4498
            Apply_Range_Check
4499
              (Scalar_Range (Id),
4500
               Etype (Subtype_Mark (Subtype_Indication (N))));
4501
 
4502
         --  In the array case, check compatibility for each index
4503
 
4504
         elsif Is_Array_Type (Etype (Id))
4505
           and then Present (First_Index (Id))
4506
         then
4507
            --  This really should be a subprogram that finds the indications
4508
            --  to check???
4509
 
4510
            declare
4511
               Subt_Index   : Node_Id := First_Index (Id);
4512
               Target_Index : Node_Id :=
4513
                                First_Index (Etype
4514
                                  (Subtype_Mark (Subtype_Indication (N))));
4515
               Has_Dyn_Chk  : Boolean := Has_Dynamic_Range_Check (N);
4516
 
4517
            begin
4518
               while Present (Subt_Index) loop
4519
                  if ((Nkind (Subt_Index) = N_Identifier
4520
                         and then Ekind (Entity (Subt_Index)) in Scalar_Kind)
4521
                       or else Nkind (Subt_Index) = N_Subtype_Indication)
4522
                    and then
4523
                      Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range
4524
                  then
4525
                     declare
4526
                        Target_Typ : constant Entity_Id :=
4527
                                       Etype (Target_Index);
4528
                     begin
4529
                        R_Checks :=
4530
                          Get_Range_Checks
4531
                            (Scalar_Range (Etype (Subt_Index)),
4532
                             Target_Typ,
4533
                             Etype (Subt_Index),
4534
                             Defining_Identifier (N));
4535
 
4536
                        --  Reset Has_Dynamic_Range_Check on the subtype to
4537
                        --  prevent elision of the index check due to a dynamic
4538
                        --  check generated for a preceding index (needed since
4539
                        --  Insert_Range_Checks tries to avoid generating
4540
                        --  redundant checks on a given declaration).
4541
 
4542
                        Set_Has_Dynamic_Range_Check (N, False);
4543
 
4544
                        Insert_Range_Checks
4545
                          (R_Checks,
4546
                           N,
4547
                           Target_Typ,
4548
                           Sloc (Defining_Identifier (N)));
4549
 
4550
                        --  Record whether this index involved a dynamic check
4551
 
4552
                        Has_Dyn_Chk :=
4553
                          Has_Dyn_Chk or else Has_Dynamic_Range_Check (N);
4554
                     end;
4555
                  end if;
4556
 
4557
                  Next_Index (Subt_Index);
4558
                  Next_Index (Target_Index);
4559
               end loop;
4560
 
4561
               --  Finally, mark whether the subtype involves dynamic checks
4562
 
4563
               Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk);
4564
            end;
4565
         end if;
4566
      end if;
4567
 
4568
      --  Make sure that generic actual types are properly frozen. The subtype
4569
      --  is marked as a generic actual type when the enclosing instance is
4570
      --  analyzed, so here we identify the subtype from the tree structure.
4571
 
4572
      if Expander_Active
4573
        and then Is_Generic_Actual_Type (Id)
4574
        and then In_Instance
4575
        and then not Comes_From_Source (N)
4576
        and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication
4577
        and then Is_Frozen (T)
4578
      then
4579
         Freeze_Before (N, Id);
4580
      end if;
4581
 
4582
      Set_Optimize_Alignment_Flags (Id);
4583
      Check_Eliminated (Id);
4584
 
4585
   <<Leave>>
4586
      if Has_Aspects (N) then
4587
         Analyze_Aspect_Specifications (N, Id);
4588
      end if;
4589
 
4590
      Analyze_Dimension (N);
4591
   end Analyze_Subtype_Declaration;
4592
 
4593
   --------------------------------
4594
   -- Analyze_Subtype_Indication --
4595
   --------------------------------
4596
 
4597
   procedure Analyze_Subtype_Indication (N : Node_Id) is
4598
      T : constant Entity_Id := Subtype_Mark (N);
4599
      R : constant Node_Id   := Range_Expression (Constraint (N));
4600
 
4601
   begin
4602
      Analyze (T);
4603
 
4604
      if R /= Error then
4605
         Analyze (R);
4606
         Set_Etype (N, Etype (R));
4607
         Resolve (R, Entity (T));
4608
      else
4609
         Set_Error_Posted (R);
4610
         Set_Error_Posted (T);
4611
      end if;
4612
   end Analyze_Subtype_Indication;
4613
 
4614
   --------------------------
4615
   -- Analyze_Variant_Part --
4616
   --------------------------
4617
 
4618
   procedure Analyze_Variant_Part (N : Node_Id) is
4619
 
4620
      procedure Non_Static_Choice_Error (Choice : Node_Id);
4621
      --  Error routine invoked by the generic instantiation below when the
4622
      --  variant part has a non static choice.
4623
 
4624
      procedure Process_Declarations (Variant : Node_Id);
4625
      --  Analyzes all the declarations associated with a Variant. Needed by
4626
      --  the generic instantiation below.
4627
 
4628
      package Variant_Choices_Processing is new
4629
        Generic_Choices_Processing
4630
          (Get_Alternatives          => Variants,
4631
           Get_Choices               => Discrete_Choices,
4632
           Process_Empty_Choice      => No_OP,
4633
           Process_Non_Static_Choice => Non_Static_Choice_Error,
4634
           Process_Associated_Node   => Process_Declarations);
4635
      use Variant_Choices_Processing;
4636
      --  Instantiation of the generic choice processing package
4637
 
4638
      -----------------------------
4639
      -- Non_Static_Choice_Error --
4640
      -----------------------------
4641
 
4642
      procedure Non_Static_Choice_Error (Choice : Node_Id) is
4643
      begin
4644
         Flag_Non_Static_Expr
4645
           ("choice given in variant part is not static!", Choice);
4646
      end Non_Static_Choice_Error;
4647
 
4648
      --------------------------
4649
      -- Process_Declarations --
4650
      --------------------------
4651
 
4652
      procedure Process_Declarations (Variant : Node_Id) is
4653
      begin
4654
         if not Null_Present (Component_List (Variant)) then
4655
            Analyze_Declarations (Component_Items (Component_List (Variant)));
4656
 
4657
            if Present (Variant_Part (Component_List (Variant))) then
4658
               Analyze (Variant_Part (Component_List (Variant)));
4659
            end if;
4660
         end if;
4661
      end Process_Declarations;
4662
 
4663
      --  Local Variables
4664
 
4665
      Discr_Name : Node_Id;
4666
      Discr_Type : Entity_Id;
4667
 
4668
      Dont_Care      : Boolean;
4669
      Others_Present : Boolean := False;
4670
 
4671
      pragma Warnings (Off, Dont_Care);
4672
      pragma Warnings (Off, Others_Present);
4673
      --  We don't care about the assigned values of any of these
4674
 
4675
   --  Start of processing for Analyze_Variant_Part
4676
 
4677
   begin
4678
      Discr_Name := Name (N);
4679
      Analyze (Discr_Name);
4680
 
4681
      --  If Discr_Name bad, get out (prevent cascaded errors)
4682
 
4683
      if Etype (Discr_Name) = Any_Type then
4684
         return;
4685
      end if;
4686
 
4687
      --  Check invalid discriminant in variant part
4688
 
4689
      if Ekind (Entity (Discr_Name)) /= E_Discriminant then
4690
         Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
4691
      end if;
4692
 
4693
      Discr_Type := Etype (Entity (Discr_Name));
4694
 
4695
      if not Is_Discrete_Type (Discr_Type) then
4696
         Error_Msg_N
4697
           ("discriminant in a variant part must be of a discrete type",
4698
             Name (N));
4699
         return;
4700
      end if;
4701
 
4702
      --  Call the instantiated Analyze_Choices which does the rest of the work
4703
 
4704
      Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present);
4705
   end Analyze_Variant_Part;
4706
 
4707
   ----------------------------
4708
   -- Array_Type_Declaration --
4709
   ----------------------------
4710
 
4711
   procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
4712
      Component_Def : constant Node_Id := Component_Definition (Def);
4713
      Component_Typ : constant Node_Id := Subtype_Indication (Component_Def);
4714
      Element_Type  : Entity_Id;
4715
      Implicit_Base : Entity_Id;
4716
      Index         : Node_Id;
4717
      Related_Id    : Entity_Id := Empty;
4718
      Nb_Index      : Nat;
4719
      P             : constant Node_Id := Parent (Def);
4720
      Priv          : Entity_Id;
4721
 
4722
   begin
4723
      if Nkind (Def) = N_Constrained_Array_Definition then
4724
         Index := First (Discrete_Subtype_Definitions (Def));
4725
      else
4726
         Index := First (Subtype_Marks (Def));
4727
      end if;
4728
 
4729
      --  Find proper names for the implicit types which may be public. In case
4730
      --  of anonymous arrays we use the name of the first object of that type
4731
      --  as prefix.
4732
 
4733
      if No (T) then
4734
         Related_Id := Defining_Identifier (P);
4735
      else
4736
         Related_Id := T;
4737
      end if;
4738
 
4739
      Nb_Index := 1;
4740
      while Present (Index) loop
4741
         Analyze (Index);
4742
 
4743
         if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then
4744
            Check_SPARK_Restriction ("subtype mark required", Index);
4745
         end if;
4746
 
4747
         --  Add a subtype declaration for each index of private array type
4748
         --  declaration whose etype is also private. For example:
4749
 
4750
         --     package Pkg is
4751
         --        type Index is private;
4752
         --     private
4753
         --        type Table is array (Index) of ...
4754
         --     end;
4755
 
4756
         --  This is currently required by the expander for the internally
4757
         --  generated equality subprogram of records with variant parts in
4758
         --  which the etype of some component is such private type.
4759
 
4760
         if Ekind (Current_Scope) = E_Package
4761
           and then In_Private_Part (Current_Scope)
4762
           and then Has_Private_Declaration (Etype (Index))
4763
         then
4764
            declare
4765
               Loc   : constant Source_Ptr := Sloc (Def);
4766
               New_E : Entity_Id;
4767
               Decl  : Entity_Id;
4768
 
4769
            begin
4770
               New_E := Make_Temporary (Loc, 'T');
4771
               Set_Is_Internal (New_E);
4772
 
4773
               Decl :=
4774
                 Make_Subtype_Declaration (Loc,
4775
                   Defining_Identifier => New_E,
4776
                   Subtype_Indication  =>
4777
                     New_Occurrence_Of (Etype (Index), Loc));
4778
 
4779
               Insert_Before (Parent (Def), Decl);
4780
               Analyze (Decl);
4781
               Set_Etype (Index, New_E);
4782
 
4783
               --  If the index is a range the Entity attribute is not
4784
               --  available. Example:
4785
 
4786
               --     package Pkg is
4787
               --        type T is private;
4788
               --     private
4789
               --        type T is new Natural;
4790
               --        Table : array (T(1) .. T(10)) of Boolean;
4791
               --     end Pkg;
4792
 
4793
               if Nkind (Index) /= N_Range then
4794
                  Set_Entity (Index, New_E);
4795
               end if;
4796
            end;
4797
         end if;
4798
 
4799
         Make_Index (Index, P, Related_Id, Nb_Index);
4800
 
4801
         --  Check error of subtype with predicate for index type
4802
 
4803
         Bad_Predicated_Subtype_Use
4804
           ("subtype& has predicate, not allowed as index subtype",
4805
            Index, Etype (Index));
4806
 
4807
         --  Move to next index
4808
 
4809
         Next_Index (Index);
4810
         Nb_Index := Nb_Index + 1;
4811
      end loop;
4812
 
4813
      --  Process subtype indication if one is present
4814
 
4815
      if Present (Component_Typ) then
4816
         Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C');
4817
 
4818
         Set_Etype (Component_Typ, Element_Type);
4819
 
4820
         if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then
4821
            Check_SPARK_Restriction ("subtype mark required", Component_Typ);
4822
         end if;
4823
 
4824
      --  Ada 2005 (AI-230): Access Definition case
4825
 
4826
      else pragma Assert (Present (Access_Definition (Component_Def)));
4827
 
4828
         --  Indicate that the anonymous access type is created by the
4829
         --  array type declaration.
4830
 
4831
         Element_Type := Access_Definition
4832
                           (Related_Nod => P,
4833
                            N           => Access_Definition (Component_Def));
4834
         Set_Is_Local_Anonymous_Access (Element_Type);
4835
 
4836
         --  Propagate the parent. This field is needed if we have to generate
4837
         --  the master_id associated with an anonymous access to task type
4838
         --  component (see Expand_N_Full_Type_Declaration.Build_Master)
4839
 
4840
         Set_Parent (Element_Type, Parent (T));
4841
 
4842
         --  Ada 2005 (AI-230): In case of components that are anonymous access
4843
         --  types the level of accessibility depends on the enclosing type
4844
         --  declaration
4845
 
4846
         Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
4847
 
4848
         --  Ada 2005 (AI-254)
4849
 
4850
         declare
4851
            CD : constant Node_Id :=
4852
                   Access_To_Subprogram_Definition
4853
                     (Access_Definition (Component_Def));
4854
         begin
4855
            if Present (CD) and then Protected_Present (CD) then
4856
               Element_Type :=
4857
                 Replace_Anonymous_Access_To_Protected_Subprogram (Def);
4858
            end if;
4859
         end;
4860
      end if;
4861
 
4862
      --  Constrained array case
4863
 
4864
      if No (T) then
4865
         T := Create_Itype (E_Void, P, Related_Id, 'T');
4866
      end if;
4867
 
4868
      if Nkind (Def) = N_Constrained_Array_Definition then
4869
 
4870
         --  Establish Implicit_Base as unconstrained base type
4871
 
4872
         Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
4873
 
4874
         Set_Etype              (Implicit_Base, Implicit_Base);
4875
         Set_Scope              (Implicit_Base, Current_Scope);
4876
         Set_Has_Delayed_Freeze (Implicit_Base);
4877
 
4878
         --  The constrained array type is a subtype of the unconstrained one
4879
 
4880
         Set_Ekind          (T, E_Array_Subtype);
4881
         Init_Size_Align    (T);
4882
         Set_Etype          (T, Implicit_Base);
4883
         Set_Scope          (T, Current_Scope);
4884
         Set_Is_Constrained (T, True);
4885
         Set_First_Index    (T, First (Discrete_Subtype_Definitions (Def)));
4886
         Set_Has_Delayed_Freeze (T);
4887
 
4888
         --  Complete setup of implicit base type
4889
 
4890
         Set_First_Index       (Implicit_Base, First_Index (T));
4891
         Set_Component_Type    (Implicit_Base, Element_Type);
4892
         Set_Has_Task          (Implicit_Base, Has_Task (Element_Type));
4893
         Set_Component_Size    (Implicit_Base, Uint_0);
4894
         Set_Packed_Array_Type (Implicit_Base, Empty);
4895
         Set_Has_Controlled_Component
4896
                               (Implicit_Base, Has_Controlled_Component
4897
                                                        (Element_Type)
4898
                                                 or else Is_Controlled
4899
                                                        (Element_Type));
4900
         Set_Finalize_Storage_Only
4901
                               (Implicit_Base, Finalize_Storage_Only
4902
                                                        (Element_Type));
4903
 
4904
      --  Unconstrained array case
4905
 
4906
      else
4907
         Set_Ekind                    (T, E_Array_Type);
4908
         Init_Size_Align              (T);
4909
         Set_Etype                    (T, T);
4910
         Set_Scope                    (T, Current_Scope);
4911
         Set_Component_Size           (T, Uint_0);
4912
         Set_Is_Constrained           (T, False);
4913
         Set_First_Index              (T, First (Subtype_Marks (Def)));
4914
         Set_Has_Delayed_Freeze       (T, True);
4915
         Set_Has_Task                 (T, Has_Task      (Element_Type));
4916
         Set_Has_Controlled_Component (T, Has_Controlled_Component
4917
                                                        (Element_Type)
4918
                                            or else
4919
                                          Is_Controlled (Element_Type));
4920
         Set_Finalize_Storage_Only    (T, Finalize_Storage_Only
4921
                                                        (Element_Type));
4922
      end if;
4923
 
4924
      --  Common attributes for both cases
4925
 
4926
      Set_Component_Type (Base_Type (T), Element_Type);
4927
      Set_Packed_Array_Type (T, Empty);
4928
 
4929
      if Aliased_Present (Component_Definition (Def)) then
4930
         Check_SPARK_Restriction
4931
           ("aliased is not allowed", Component_Definition (Def));
4932
         Set_Has_Aliased_Components (Etype (T));
4933
      end if;
4934
 
4935
      --  Ada 2005 (AI-231): Propagate the null-excluding attribute to the
4936
      --  array type to ensure that objects of this type are initialized.
4937
 
4938
      if Ada_Version >= Ada_2005
4939
        and then Can_Never_Be_Null (Element_Type)
4940
      then
4941
         Set_Can_Never_Be_Null (T);
4942
 
4943
         if Null_Exclusion_Present (Component_Definition (Def))
4944
 
4945
            --  No need to check itypes because in their case this check was
4946
            --  done at their point of creation
4947
 
4948
           and then not Is_Itype (Element_Type)
4949
         then
4950
            Error_Msg_N
4951
              ("`NOT NULL` not allowed (null already excluded)",
4952
               Subtype_Indication (Component_Definition (Def)));
4953
         end if;
4954
      end if;
4955
 
4956
      Priv := Private_Component (Element_Type);
4957
 
4958
      if Present (Priv) then
4959
 
4960
         --  Check for circular definitions
4961
 
4962
         if Priv = Any_Type then
4963
            Set_Component_Type (Etype (T), Any_Type);
4964
 
4965
         --  There is a gap in the visibility of operations on the composite
4966
         --  type only if the component type is defined in a different scope.
4967
 
4968
         elsif Scope (Priv) = Current_Scope then
4969
            null;
4970
 
4971
         elsif Is_Limited_Type (Priv) then
4972
            Set_Is_Limited_Composite (Etype (T));
4973
            Set_Is_Limited_Composite (T);
4974
         else
4975
            Set_Is_Private_Composite (Etype (T));
4976
            Set_Is_Private_Composite (T);
4977
         end if;
4978
      end if;
4979
 
4980
      --  A syntax error in the declaration itself may lead to an empty index
4981
      --  list, in which case do a minimal patch.
4982
 
4983
      if No (First_Index (T)) then
4984
         Error_Msg_N ("missing index definition in array type declaration", T);
4985
 
4986
         declare
4987
            Indexes : constant List_Id :=
4988
                        New_List (New_Occurrence_Of (Any_Id, Sloc (T)));
4989
         begin
4990
            Set_Discrete_Subtype_Definitions (Def, Indexes);
4991
            Set_First_Index (T, First (Indexes));
4992
            return;
4993
         end;
4994
      end if;
4995
 
4996
      --  Create a concatenation operator for the new type. Internal array
4997
      --  types created for packed entities do not need such, they are
4998
      --  compatible with the user-defined type.
4999
 
5000
      if Number_Dimensions (T) = 1
5001
         and then not Is_Packed_Array_Type (T)
5002
      then
5003
         New_Concatenation_Op (T);
5004
      end if;
5005
 
5006
      --  In the case of an unconstrained array the parser has already verified
5007
      --  that all the indexes are unconstrained but we still need to make sure
5008
      --  that the element type is constrained.
5009
 
5010
      if Is_Indefinite_Subtype (Element_Type) then
5011
         Error_Msg_N
5012
           ("unconstrained element type in array declaration",
5013
            Subtype_Indication (Component_Def));
5014
 
5015
      elsif Is_Abstract_Type (Element_Type) then
5016
         Error_Msg_N
5017
           ("the type of a component cannot be abstract",
5018
            Subtype_Indication (Component_Def));
5019
      end if;
5020
   end Array_Type_Declaration;
5021
 
5022
   ------------------------------------------------------
5023
   -- Replace_Anonymous_Access_To_Protected_Subprogram --
5024
   ------------------------------------------------------
5025
 
5026
   function Replace_Anonymous_Access_To_Protected_Subprogram
5027
     (N : Node_Id) return Entity_Id
5028
   is
5029
      Loc : constant Source_Ptr := Sloc (N);
5030
 
5031
      Curr_Scope : constant Scope_Stack_Entry :=
5032
                     Scope_Stack.Table (Scope_Stack.Last);
5033
 
5034
      Anon : constant Entity_Id := Make_Temporary (Loc, 'S');
5035
      Acc  : Node_Id;
5036
      Comp : Node_Id;
5037
      Decl : Node_Id;
5038
      P    : Node_Id;
5039
 
5040
   begin
5041
      Set_Is_Internal (Anon);
5042
 
5043
      case Nkind (N) is
5044
         when N_Component_Declaration       |
5045
           N_Unconstrained_Array_Definition |
5046
           N_Constrained_Array_Definition   =>
5047
            Comp := Component_Definition (N);
5048
            Acc  := Access_Definition (Comp);
5049
 
5050
         when N_Discriminant_Specification =>
5051
            Comp := Discriminant_Type (N);
5052
            Acc  := Comp;
5053
 
5054
         when N_Parameter_Specification =>
5055
            Comp := Parameter_Type (N);
5056
            Acc  := Comp;
5057
 
5058
         when N_Access_Function_Definition  =>
5059
            Comp := Result_Definition (N);
5060
            Acc  := Comp;
5061
 
5062
         when N_Object_Declaration  =>
5063
            Comp := Object_Definition (N);
5064
            Acc  := Comp;
5065
 
5066
         when N_Function_Specification =>
5067
            Comp := Result_Definition (N);
5068
            Acc  := Comp;
5069
 
5070
         when others =>
5071
            raise Program_Error;
5072
      end case;
5073
 
5074
      Decl := Make_Full_Type_Declaration (Loc,
5075
                Defining_Identifier => Anon,
5076
                Type_Definition   =>
5077
                  Copy_Separate_Tree (Access_To_Subprogram_Definition (Acc)));
5078
 
5079
      Mark_Rewrite_Insertion (Decl);
5080
 
5081
      --  Insert the new declaration in the nearest enclosing scope. If the
5082
      --  node is a body and N is its return type, the declaration belongs in
5083
      --  the enclosing scope.
5084
 
5085
      P := Parent (N);
5086
 
5087
      if Nkind (P) = N_Subprogram_Body
5088
        and then Nkind (N) = N_Function_Specification
5089
      then
5090
         P := Parent (P);
5091
      end if;
5092
 
5093
      while Present (P) and then not Has_Declarations (P) loop
5094
         P := Parent (P);
5095
      end loop;
5096
 
5097
      pragma Assert (Present (P));
5098
 
5099
      if Nkind (P) = N_Package_Specification then
5100
         Prepend (Decl, Visible_Declarations (P));
5101
      else
5102
         Prepend (Decl, Declarations (P));
5103
      end if;
5104
 
5105
      --  Replace the anonymous type with an occurrence of the new declaration.
5106
      --  In all cases the rewritten node does not have the null-exclusion
5107
      --  attribute because (if present) it was already inherited by the
5108
      --  anonymous entity (Anon). Thus, in case of components we do not
5109
      --  inherit this attribute.
5110
 
5111
      if Nkind (N) = N_Parameter_Specification then
5112
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
5113
         Set_Etype (Defining_Identifier (N), Anon);
5114
         Set_Null_Exclusion_Present (N, False);
5115
 
5116
      elsif Nkind (N) = N_Object_Declaration then
5117
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
5118
         Set_Etype (Defining_Identifier (N), Anon);
5119
 
5120
      elsif Nkind (N) = N_Access_Function_Definition then
5121
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
5122
 
5123
      elsif Nkind (N) = N_Function_Specification then
5124
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
5125
         Set_Etype (Defining_Unit_Name (N), Anon);
5126
 
5127
      else
5128
         Rewrite (Comp,
5129
           Make_Component_Definition (Loc,
5130
             Subtype_Indication => New_Occurrence_Of (Anon, Loc)));
5131
      end if;
5132
 
5133
      Mark_Rewrite_Insertion (Comp);
5134
 
5135
      if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
5136
         Analyze (Decl);
5137
 
5138
      else
5139
         --  Temporarily remove the current scope (record or subprogram) from
5140
         --  the stack to add the new declarations to the enclosing scope.
5141
 
5142
         Scope_Stack.Decrement_Last;
5143
         Analyze (Decl);
5144
         Set_Is_Itype (Anon);
5145
         Scope_Stack.Append (Curr_Scope);
5146
      end if;
5147
 
5148
      Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
5149
      Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target);
5150
      return Anon;
5151
   end Replace_Anonymous_Access_To_Protected_Subprogram;
5152
 
5153
   -------------------------------
5154
   -- Build_Derived_Access_Type --
5155
   -------------------------------
5156
 
5157
   procedure Build_Derived_Access_Type
5158
     (N            : Node_Id;
5159
      Parent_Type  : Entity_Id;
5160
      Derived_Type : Entity_Id)
5161
   is
5162
      S : constant Node_Id := Subtype_Indication (Type_Definition (N));
5163
 
5164
      Desig_Type      : Entity_Id;
5165
      Discr           : Entity_Id;
5166
      Discr_Con_Elist : Elist_Id;
5167
      Discr_Con_El    : Elmt_Id;
5168
      Subt            : Entity_Id;
5169
 
5170
   begin
5171
      --  Set the designated type so it is available in case this is an access
5172
      --  to a self-referential type, e.g. a standard list type with a next
5173
      --  pointer. Will be reset after subtype is built.
5174
 
5175
      Set_Directly_Designated_Type
5176
        (Derived_Type, Designated_Type (Parent_Type));
5177
 
5178
      Subt := Process_Subtype (S, N);
5179
 
5180
      if Nkind (S) /= N_Subtype_Indication
5181
        and then Subt /= Base_Type (Subt)
5182
      then
5183
         Set_Ekind (Derived_Type, E_Access_Subtype);
5184
      end if;
5185
 
5186
      if Ekind (Derived_Type) = E_Access_Subtype then
5187
         declare
5188
            Pbase      : constant Entity_Id := Base_Type (Parent_Type);
5189
            Ibase      : constant Entity_Id :=
5190
                           Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
5191
            Svg_Chars  : constant Name_Id   := Chars (Ibase);
5192
            Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
5193
 
5194
         begin
5195
            Copy_Node (Pbase, Ibase);
5196
 
5197
            Set_Chars             (Ibase, Svg_Chars);
5198
            Set_Next_Entity       (Ibase, Svg_Next_E);
5199
            Set_Sloc              (Ibase, Sloc (Derived_Type));
5200
            Set_Scope             (Ibase, Scope (Derived_Type));
5201
            Set_Freeze_Node       (Ibase, Empty);
5202
            Set_Is_Frozen         (Ibase, False);
5203
            Set_Comes_From_Source (Ibase, False);
5204
            Set_Is_First_Subtype  (Ibase, False);
5205
 
5206
            Set_Etype (Ibase, Pbase);
5207
            Set_Etype (Derived_Type, Ibase);
5208
         end;
5209
      end if;
5210
 
5211
      Set_Directly_Designated_Type
5212
        (Derived_Type, Designated_Type (Subt));
5213
 
5214
      Set_Is_Constrained     (Derived_Type, Is_Constrained (Subt));
5215
      Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
5216
      Set_Size_Info          (Derived_Type,                     Parent_Type);
5217
      Set_RM_Size            (Derived_Type, RM_Size            (Parent_Type));
5218
      Set_Depends_On_Private (Derived_Type,
5219
                              Has_Private_Component (Derived_Type));
5220
      Conditional_Delay      (Derived_Type, Subt);
5221
 
5222
      --  Ada 2005 (AI-231): Set the null-exclusion attribute, and verify
5223
      --  that it is not redundant.
5224
 
5225
      if Null_Exclusion_Present (Type_Definition (N)) then
5226
         Set_Can_Never_Be_Null (Derived_Type);
5227
 
5228
         if Can_Never_Be_Null (Parent_Type)
5229
           and then False
5230
         then
5231
            Error_Msg_NE
5232
              ("`NOT NULL` not allowed (& already excludes null)",
5233
                N, Parent_Type);
5234
         end if;
5235
 
5236
      elsif Can_Never_Be_Null (Parent_Type) then
5237
         Set_Can_Never_Be_Null (Derived_Type);
5238
      end if;
5239
 
5240
      --  Note: we do not copy the Storage_Size_Variable, since we always go to
5241
      --  the root type for this information.
5242
 
5243
      --  Apply range checks to discriminants for derived record case
5244
      --  ??? THIS CODE SHOULD NOT BE HERE REALLY.
5245
 
5246
      Desig_Type := Designated_Type (Derived_Type);
5247
      if Is_Composite_Type (Desig_Type)
5248
        and then (not Is_Array_Type (Desig_Type))
5249
        and then Has_Discriminants (Desig_Type)
5250
        and then Base_Type (Desig_Type) /= Desig_Type
5251
      then
5252
         Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
5253
         Discr_Con_El := First_Elmt (Discr_Con_Elist);
5254
 
5255
         Discr := First_Discriminant (Base_Type (Desig_Type));
5256
         while Present (Discr_Con_El) loop
5257
            Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
5258
            Next_Elmt (Discr_Con_El);
5259
            Next_Discriminant (Discr);
5260
         end loop;
5261
      end if;
5262
   end Build_Derived_Access_Type;
5263
 
5264
   ------------------------------
5265
   -- Build_Derived_Array_Type --
5266
   ------------------------------
5267
 
5268
   procedure Build_Derived_Array_Type
5269
     (N            : Node_Id;
5270
      Parent_Type  : Entity_Id;
5271
      Derived_Type : Entity_Id)
5272
   is
5273
      Loc           : constant Source_Ptr := Sloc (N);
5274
      Tdef          : constant Node_Id    := Type_Definition (N);
5275
      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
5276
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
5277
      Implicit_Base : Entity_Id;
5278
      New_Indic     : Node_Id;
5279
 
5280
      procedure Make_Implicit_Base;
5281
      --  If the parent subtype is constrained, the derived type is a subtype
5282
      --  of an implicit base type derived from the parent base.
5283
 
5284
      ------------------------
5285
      -- Make_Implicit_Base --
5286
      ------------------------
5287
 
5288
      procedure Make_Implicit_Base is
5289
      begin
5290
         Implicit_Base :=
5291
           Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
5292
 
5293
         Set_Ekind (Implicit_Base, Ekind (Parent_Base));
5294
         Set_Etype (Implicit_Base, Parent_Base);
5295
 
5296
         Copy_Array_Subtype_Attributes   (Implicit_Base, Parent_Base);
5297
         Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
5298
 
5299
         Set_Has_Delayed_Freeze (Implicit_Base, True);
5300
      end Make_Implicit_Base;
5301
 
5302
   --  Start of processing for Build_Derived_Array_Type
5303
 
5304
   begin
5305
      if not Is_Constrained (Parent_Type) then
5306
         if Nkind (Indic) /= N_Subtype_Indication then
5307
            Set_Ekind (Derived_Type, E_Array_Type);
5308
 
5309
            Copy_Array_Subtype_Attributes   (Derived_Type, Parent_Type);
5310
            Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
5311
 
5312
            Set_Has_Delayed_Freeze (Derived_Type, True);
5313
 
5314
         else
5315
            Make_Implicit_Base;
5316
            Set_Etype (Derived_Type, Implicit_Base);
5317
 
5318
            New_Indic :=
5319
              Make_Subtype_Declaration (Loc,
5320
                Defining_Identifier => Derived_Type,
5321
                Subtype_Indication  =>
5322
                  Make_Subtype_Indication (Loc,
5323
                    Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
5324
                    Constraint => Constraint (Indic)));
5325
 
5326
            Rewrite (N, New_Indic);
5327
            Analyze (N);
5328
         end if;
5329
 
5330
      else
5331
         if Nkind (Indic) /= N_Subtype_Indication then
5332
            Make_Implicit_Base;
5333
 
5334
            Set_Ekind             (Derived_Type, Ekind (Parent_Type));
5335
            Set_Etype             (Derived_Type, Implicit_Base);
5336
            Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
5337
 
5338
         else
5339
            Error_Msg_N ("illegal constraint on constrained type", Indic);
5340
         end if;
5341
      end if;
5342
 
5343
      --  If parent type is not a derived type itself, and is declared in
5344
      --  closed scope (e.g. a subprogram), then we must explicitly introduce
5345
      --  the new type's concatenation operator since Derive_Subprograms
5346
      --  will not inherit the parent's operator. If the parent type is
5347
      --  unconstrained, the operator is of the unconstrained base type.
5348
 
5349
      if Number_Dimensions (Parent_Type) = 1
5350
        and then not Is_Limited_Type (Parent_Type)
5351
        and then not Is_Derived_Type (Parent_Type)
5352
        and then not Is_Package_Or_Generic_Package
5353
                       (Scope (Base_Type (Parent_Type)))
5354
      then
5355
         if not Is_Constrained (Parent_Type)
5356
           and then Is_Constrained (Derived_Type)
5357
         then
5358
            New_Concatenation_Op (Implicit_Base);
5359
         else
5360
            New_Concatenation_Op (Derived_Type);
5361
         end if;
5362
      end if;
5363
   end Build_Derived_Array_Type;
5364
 
5365
   -----------------------------------
5366
   -- Build_Derived_Concurrent_Type --
5367
   -----------------------------------
5368
 
5369
   procedure Build_Derived_Concurrent_Type
5370
     (N            : Node_Id;
5371
      Parent_Type  : Entity_Id;
5372
      Derived_Type : Entity_Id)
5373
   is
5374
      Loc : constant Source_Ptr := Sloc (N);
5375
 
5376
      Corr_Record      : constant Entity_Id := Make_Temporary (Loc, 'C');
5377
      Corr_Decl        : Node_Id;
5378
      Corr_Decl_Needed : Boolean;
5379
      --  If the derived type has fewer discriminants than its parent, the
5380
      --  corresponding record is also a derived type, in order to account for
5381
      --  the bound discriminants. We create a full type declaration for it in
5382
      --  this case.
5383
 
5384
      Constraint_Present : constant Boolean :=
5385
                             Nkind (Subtype_Indication (Type_Definition (N))) =
5386
                                                          N_Subtype_Indication;
5387
 
5388
      D_Constraint   : Node_Id;
5389
      New_Constraint : Elist_Id;
5390
      Old_Disc       : Entity_Id;
5391
      New_Disc       : Entity_Id;
5392
      New_N          : Node_Id;
5393
 
5394
   begin
5395
      Set_Stored_Constraint (Derived_Type, No_Elist);
5396
      Corr_Decl_Needed := False;
5397
      Old_Disc := Empty;
5398
 
5399
      if Present (Discriminant_Specifications (N))
5400
        and then Constraint_Present
5401
      then
5402
         Old_Disc := First_Discriminant (Parent_Type);
5403
         New_Disc := First (Discriminant_Specifications (N));
5404
         while Present (New_Disc) and then Present (Old_Disc) loop
5405
            Next_Discriminant (Old_Disc);
5406
            Next (New_Disc);
5407
         end loop;
5408
      end if;
5409
 
5410
      if Present (Old_Disc) and then Expander_Active then
5411
 
5412
         --  The new type has fewer discriminants, so we need to create a new
5413
         --  corresponding record, which is derived from the corresponding
5414
         --  record of the parent, and has a stored constraint that captures
5415
         --  the values of the discriminant constraints. The corresponding
5416
         --  record is needed only if expander is active and code generation is
5417
         --  enabled.
5418
 
5419
         --  The type declaration for the derived corresponding record has the
5420
         --  same discriminant part and constraints as the current declaration.
5421
         --  Copy the unanalyzed tree to build declaration.
5422
 
5423
         Corr_Decl_Needed := True;
5424
         New_N := Copy_Separate_Tree (N);
5425
 
5426
         Corr_Decl :=
5427
           Make_Full_Type_Declaration (Loc,
5428
             Defining_Identifier         => Corr_Record,
5429
             Discriminant_Specifications =>
5430
                Discriminant_Specifications (New_N),
5431
             Type_Definition             =>
5432
               Make_Derived_Type_Definition (Loc,
5433
                 Subtype_Indication =>
5434
                   Make_Subtype_Indication (Loc,
5435
                     Subtype_Mark =>
5436
                        New_Occurrence_Of
5437
                          (Corresponding_Record_Type (Parent_Type), Loc),
5438
                     Constraint   =>
5439
                       Constraint
5440
                         (Subtype_Indication (Type_Definition (New_N))))));
5441
      end if;
5442
 
5443
      --  Copy Storage_Size and Relative_Deadline variables if task case
5444
 
5445
      if Is_Task_Type (Parent_Type) then
5446
         Set_Storage_Size_Variable (Derived_Type,
5447
           Storage_Size_Variable (Parent_Type));
5448
         Set_Relative_Deadline_Variable (Derived_Type,
5449
           Relative_Deadline_Variable (Parent_Type));
5450
      end if;
5451
 
5452
      if Present (Discriminant_Specifications (N)) then
5453
         Push_Scope (Derived_Type);
5454
         Check_Or_Process_Discriminants (N, Derived_Type);
5455
 
5456
         if Constraint_Present then
5457
            New_Constraint :=
5458
              Expand_To_Stored_Constraint
5459
                (Parent_Type,
5460
                 Build_Discriminant_Constraints
5461
                   (Parent_Type,
5462
                    Subtype_Indication (Type_Definition (N)), True));
5463
         end if;
5464
 
5465
         End_Scope;
5466
 
5467
      elsif Constraint_Present then
5468
 
5469
         --  Build constrained subtype and derive from it
5470
 
5471
         declare
5472
            Loc  : constant Source_Ptr := Sloc (N);
5473
            Anon : constant Entity_Id :=
5474
                     Make_Defining_Identifier (Loc,
5475
                       Chars => New_External_Name (Chars (Derived_Type), 'T'));
5476
            Decl : Node_Id;
5477
 
5478
         begin
5479
            Decl :=
5480
              Make_Subtype_Declaration (Loc,
5481
                Defining_Identifier => Anon,
5482
                Subtype_Indication =>
5483
                  Subtype_Indication (Type_Definition (N)));
5484
            Insert_Before (N, Decl);
5485
            Analyze (Decl);
5486
 
5487
            Rewrite (Subtype_Indication (Type_Definition (N)),
5488
              New_Occurrence_Of (Anon, Loc));
5489
            Set_Analyzed (Derived_Type, False);
5490
            Analyze (N);
5491
            return;
5492
         end;
5493
      end if;
5494
 
5495
      --  By default, operations and private data are inherited from parent.
5496
      --  However, in the presence of bound discriminants, a new corresponding
5497
      --  record will be created, see below.
5498
 
5499
      Set_Has_Discriminants
5500
        (Derived_Type, Has_Discriminants         (Parent_Type));
5501
      Set_Corresponding_Record_Type
5502
        (Derived_Type, Corresponding_Record_Type (Parent_Type));
5503
 
5504
      --  Is_Constrained is set according the parent subtype, but is set to
5505
      --  False if the derived type is declared with new discriminants.
5506
 
5507
      Set_Is_Constrained
5508
        (Derived_Type,
5509
         (Is_Constrained (Parent_Type) or else Constraint_Present)
5510
           and then not Present (Discriminant_Specifications (N)));
5511
 
5512
      if Constraint_Present then
5513
         if not Has_Discriminants (Parent_Type) then
5514
            Error_Msg_N ("untagged parent must have discriminants", N);
5515
 
5516
         elsif Present (Discriminant_Specifications (N)) then
5517
 
5518
            --  Verify that new discriminants are used to constrain old ones
5519
 
5520
            D_Constraint :=
5521
              First
5522
                (Constraints
5523
                  (Constraint (Subtype_Indication (Type_Definition (N)))));
5524
 
5525
            Old_Disc := First_Discriminant (Parent_Type);
5526
 
5527
            while Present (D_Constraint) loop
5528
               if Nkind (D_Constraint) /= N_Discriminant_Association then
5529
 
5530
                  --  Positional constraint. If it is a reference to a new
5531
                  --  discriminant, it constrains the corresponding old one.
5532
 
5533
                  if Nkind (D_Constraint) = N_Identifier then
5534
                     New_Disc := First_Discriminant (Derived_Type);
5535
                     while Present (New_Disc) loop
5536
                        exit when Chars (New_Disc) = Chars (D_Constraint);
5537
                        Next_Discriminant (New_Disc);
5538
                     end loop;
5539
 
5540
                     if Present (New_Disc) then
5541
                        Set_Corresponding_Discriminant (New_Disc, Old_Disc);
5542
                     end if;
5543
                  end if;
5544
 
5545
                  Next_Discriminant (Old_Disc);
5546
 
5547
                  --  if this is a named constraint, search by name for the old
5548
                  --  discriminants constrained by the new one.
5549
 
5550
               elsif Nkind (Expression (D_Constraint)) = N_Identifier then
5551
 
5552
                  --  Find new discriminant with that name
5553
 
5554
                  New_Disc := First_Discriminant (Derived_Type);
5555
                  while Present (New_Disc) loop
5556
                     exit when
5557
                       Chars (New_Disc) = Chars (Expression (D_Constraint));
5558
                     Next_Discriminant (New_Disc);
5559
                  end loop;
5560
 
5561
                  if Present (New_Disc) then
5562
 
5563
                     --  Verify that new discriminant renames some discriminant
5564
                     --  of the parent type, and associate the new discriminant
5565
                     --  with one or more old ones that it renames.
5566
 
5567
                     declare
5568
                        Selector : Node_Id;
5569
 
5570
                     begin
5571
                        Selector := First (Selector_Names (D_Constraint));
5572
                        while Present (Selector) loop
5573
                           Old_Disc := First_Discriminant (Parent_Type);
5574
                           while Present (Old_Disc) loop
5575
                              exit when Chars (Old_Disc) = Chars (Selector);
5576
                              Next_Discriminant (Old_Disc);
5577
                           end loop;
5578
 
5579
                           if Present (Old_Disc) then
5580
                              Set_Corresponding_Discriminant
5581
                                (New_Disc, Old_Disc);
5582
                           end if;
5583
 
5584
                           Next (Selector);
5585
                        end loop;
5586
                     end;
5587
                  end if;
5588
               end if;
5589
 
5590
               Next (D_Constraint);
5591
            end loop;
5592
 
5593
            New_Disc := First_Discriminant (Derived_Type);
5594
            while Present (New_Disc) loop
5595
               if No (Corresponding_Discriminant (New_Disc)) then
5596
                  Error_Msg_NE
5597
                    ("new discriminant& must constrain old one", N, New_Disc);
5598
 
5599
               elsif not
5600
                 Subtypes_Statically_Compatible
5601
                   (Etype (New_Disc),
5602
                    Etype (Corresponding_Discriminant (New_Disc)))
5603
               then
5604
                  Error_Msg_NE
5605
                    ("& not statically compatible with parent discriminant",
5606
                      N, New_Disc);
5607
               end if;
5608
 
5609
               Next_Discriminant (New_Disc);
5610
            end loop;
5611
         end if;
5612
 
5613
      elsif Present (Discriminant_Specifications (N)) then
5614
         Error_Msg_N
5615
           ("missing discriminant constraint in untagged derivation", N);
5616
      end if;
5617
 
5618
      --  The entity chain of the derived type includes the new discriminants
5619
      --  but shares operations with the parent.
5620
 
5621
      if Present (Discriminant_Specifications (N)) then
5622
         Old_Disc := First_Discriminant (Parent_Type);
5623
         while Present (Old_Disc) loop
5624
            if No (Next_Entity (Old_Disc))
5625
              or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
5626
            then
5627
               Set_Next_Entity
5628
                 (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
5629
               exit;
5630
            end if;
5631
 
5632
            Next_Discriminant (Old_Disc);
5633
         end loop;
5634
 
5635
      else
5636
         Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
5637
         if Has_Discriminants (Parent_Type) then
5638
            Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
5639
            Set_Discriminant_Constraint (
5640
              Derived_Type, Discriminant_Constraint (Parent_Type));
5641
         end if;
5642
      end if;
5643
 
5644
      Set_Last_Entity  (Derived_Type, Last_Entity  (Parent_Type));
5645
 
5646
      Set_Has_Completion (Derived_Type);
5647
 
5648
      if Corr_Decl_Needed then
5649
         Set_Stored_Constraint (Derived_Type, New_Constraint);
5650
         Insert_After (N, Corr_Decl);
5651
         Analyze (Corr_Decl);
5652
         Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
5653
      end if;
5654
   end Build_Derived_Concurrent_Type;
5655
 
5656
   ------------------------------------
5657
   -- Build_Derived_Enumeration_Type --
5658
   ------------------------------------
5659
 
5660
   procedure Build_Derived_Enumeration_Type
5661
     (N            : Node_Id;
5662
      Parent_Type  : Entity_Id;
5663
      Derived_Type : Entity_Id)
5664
   is
5665
      Loc           : constant Source_Ptr := Sloc (N);
5666
      Def           : constant Node_Id    := Type_Definition (N);
5667
      Indic         : constant Node_Id    := Subtype_Indication (Def);
5668
      Implicit_Base : Entity_Id;
5669
      Literal       : Entity_Id;
5670
      New_Lit       : Entity_Id;
5671
      Literals_List : List_Id;
5672
      Type_Decl     : Node_Id;
5673
      Hi, Lo        : Node_Id;
5674
      Rang_Expr     : Node_Id;
5675
 
5676
   begin
5677
      --  Since types Standard.Character and Standard.[Wide_]Wide_Character do
5678
      --  not have explicit literals lists we need to process types derived
5679
      --  from them specially. This is handled by Derived_Standard_Character.
5680
      --  If the parent type is a generic type, there are no literals either,
5681
      --  and we construct the same skeletal representation as for the generic
5682
      --  parent type.
5683
 
5684
      if Is_Standard_Character_Type (Parent_Type) then
5685
         Derived_Standard_Character (N, Parent_Type, Derived_Type);
5686
 
5687
      elsif Is_Generic_Type (Root_Type (Parent_Type)) then
5688
         declare
5689
            Lo : Node_Id;
5690
            Hi : Node_Id;
5691
 
5692
         begin
5693
            if Nkind (Indic) /= N_Subtype_Indication then
5694
               Lo :=
5695
                  Make_Attribute_Reference (Loc,
5696
                    Attribute_Name => Name_First,
5697
                    Prefix         => New_Reference_To (Derived_Type, Loc));
5698
               Set_Etype (Lo, Derived_Type);
5699
 
5700
               Hi :=
5701
                  Make_Attribute_Reference (Loc,
5702
                    Attribute_Name => Name_Last,
5703
                    Prefix         => New_Reference_To (Derived_Type, Loc));
5704
               Set_Etype (Hi, Derived_Type);
5705
 
5706
               Set_Scalar_Range (Derived_Type,
5707
                  Make_Range (Loc,
5708
                    Low_Bound  => Lo,
5709
                    High_Bound => Hi));
5710
            else
5711
 
5712
               --   Analyze subtype indication and verify compatibility
5713
               --   with parent type.
5714
 
5715
               if Base_Type (Process_Subtype (Indic, N)) /=
5716
                  Base_Type (Parent_Type)
5717
               then
5718
                  Error_Msg_N
5719
                    ("illegal constraint for formal discrete type", N);
5720
               end if;
5721
            end if;
5722
         end;
5723
 
5724
      else
5725
         --  If a constraint is present, analyze the bounds to catch
5726
         --  premature usage of the derived literals.
5727
 
5728
         if Nkind (Indic) = N_Subtype_Indication
5729
           and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
5730
         then
5731
            Analyze (Low_Bound  (Range_Expression (Constraint (Indic))));
5732
            Analyze (High_Bound (Range_Expression (Constraint (Indic))));
5733
         end if;
5734
 
5735
         --  Introduce an implicit base type for the derived type even if there
5736
         --  is no constraint attached to it, since this seems closer to the
5737
         --  Ada semantics. Build a full type declaration tree for the derived
5738
         --  type using the implicit base type as the defining identifier. The
5739
         --  build a subtype declaration tree which applies the constraint (if
5740
         --  any) have it replace the derived type declaration.
5741
 
5742
         Literal := First_Literal (Parent_Type);
5743
         Literals_List := New_List;
5744
         while Present (Literal)
5745
           and then Ekind (Literal) = E_Enumeration_Literal
5746
         loop
5747
            --  Literals of the derived type have the same representation as
5748
            --  those of the parent type, but this representation can be
5749
            --  overridden by an explicit representation clause. Indicate
5750
            --  that there is no explicit representation given yet. These
5751
            --  derived literals are implicit operations of the new type,
5752
            --  and can be overridden by explicit ones.
5753
 
5754
            if Nkind (Literal) = N_Defining_Character_Literal then
5755
               New_Lit :=
5756
                 Make_Defining_Character_Literal (Loc, Chars (Literal));
5757
            else
5758
               New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
5759
            end if;
5760
 
5761
            Set_Ekind                (New_Lit, E_Enumeration_Literal);
5762
            Set_Enumeration_Pos      (New_Lit, Enumeration_Pos (Literal));
5763
            Set_Enumeration_Rep      (New_Lit, Enumeration_Rep (Literal));
5764
            Set_Enumeration_Rep_Expr (New_Lit, Empty);
5765
            Set_Alias                (New_Lit, Literal);
5766
            Set_Is_Known_Valid       (New_Lit, True);
5767
 
5768
            Append (New_Lit, Literals_List);
5769
            Next_Literal (Literal);
5770
         end loop;
5771
 
5772
         Implicit_Base :=
5773
           Make_Defining_Identifier (Sloc (Derived_Type),
5774
             Chars => New_External_Name (Chars (Derived_Type), 'B'));
5775
 
5776
         --  Indicate the proper nature of the derived type. This must be done
5777
         --  before analysis of the literals, to recognize cases when a literal
5778
         --  may be hidden by a previous explicit function definition (cf.
5779
         --  c83031a).
5780
 
5781
         Set_Ekind (Derived_Type, E_Enumeration_Subtype);
5782
         Set_Etype (Derived_Type, Implicit_Base);
5783
 
5784
         Type_Decl :=
5785
           Make_Full_Type_Declaration (Loc,
5786
             Defining_Identifier => Implicit_Base,
5787
             Discriminant_Specifications => No_List,
5788
             Type_Definition =>
5789
               Make_Enumeration_Type_Definition (Loc, Literals_List));
5790
 
5791
         Mark_Rewrite_Insertion (Type_Decl);
5792
         Insert_Before (N, Type_Decl);
5793
         Analyze (Type_Decl);
5794
 
5795
         --  After the implicit base is analyzed its Etype needs to be changed
5796
         --  to reflect the fact that it is derived from the parent type which
5797
         --  was ignored during analysis. We also set the size at this point.
5798
 
5799
         Set_Etype (Implicit_Base, Parent_Type);
5800
 
5801
         Set_Size_Info      (Implicit_Base,                 Parent_Type);
5802
         Set_RM_Size        (Implicit_Base, RM_Size        (Parent_Type));
5803
         Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
5804
 
5805
         --  Copy other flags from parent type
5806
 
5807
         Set_Has_Non_Standard_Rep
5808
                            (Implicit_Base, Has_Non_Standard_Rep
5809
                                                           (Parent_Type));
5810
         Set_Has_Pragma_Ordered
5811
                            (Implicit_Base, Has_Pragma_Ordered
5812
                                                           (Parent_Type));
5813
         Set_Has_Delayed_Freeze (Implicit_Base);
5814
 
5815
         --  Process the subtype indication including a validation check on the
5816
         --  constraint, if any. If a constraint is given, its bounds must be
5817
         --  implicitly converted to the new type.
5818
 
5819
         if Nkind (Indic) = N_Subtype_Indication then
5820
            declare
5821
               R : constant Node_Id :=
5822
                     Range_Expression (Constraint (Indic));
5823
 
5824
            begin
5825
               if Nkind (R) = N_Range then
5826
                  Hi := Build_Scalar_Bound
5827
                          (High_Bound (R), Parent_Type, Implicit_Base);
5828
                  Lo := Build_Scalar_Bound
5829
                          (Low_Bound  (R), Parent_Type, Implicit_Base);
5830
 
5831
               else
5832
                  --  Constraint is a Range attribute. Replace with explicit
5833
                  --  mention of the bounds of the prefix, which must be a
5834
                  --  subtype.
5835
 
5836
                  Analyze (Prefix (R));
5837
                  Hi :=
5838
                    Convert_To (Implicit_Base,
5839
                      Make_Attribute_Reference (Loc,
5840
                        Attribute_Name => Name_Last,
5841
                        Prefix =>
5842
                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
5843
 
5844
                  Lo :=
5845
                    Convert_To (Implicit_Base,
5846
                      Make_Attribute_Reference (Loc,
5847
                        Attribute_Name => Name_First,
5848
                        Prefix =>
5849
                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
5850
               end if;
5851
            end;
5852
 
5853
         else
5854
            Hi :=
5855
              Build_Scalar_Bound
5856
                (Type_High_Bound (Parent_Type),
5857
                 Parent_Type, Implicit_Base);
5858
            Lo :=
5859
               Build_Scalar_Bound
5860
                 (Type_Low_Bound (Parent_Type),
5861
                  Parent_Type, Implicit_Base);
5862
         end if;
5863
 
5864
         Rang_Expr :=
5865
           Make_Range (Loc,
5866
             Low_Bound  => Lo,
5867
             High_Bound => Hi);
5868
 
5869
         --  If we constructed a default range for the case where no range
5870
         --  was given, then the expressions in the range must not freeze
5871
         --  since they do not correspond to expressions in the source.
5872
 
5873
         if Nkind (Indic) /= N_Subtype_Indication then
5874
            Set_Must_Not_Freeze (Lo);
5875
            Set_Must_Not_Freeze (Hi);
5876
            Set_Must_Not_Freeze (Rang_Expr);
5877
         end if;
5878
 
5879
         Rewrite (N,
5880
           Make_Subtype_Declaration (Loc,
5881
             Defining_Identifier => Derived_Type,
5882
             Subtype_Indication =>
5883
               Make_Subtype_Indication (Loc,
5884
                 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
5885
                 Constraint =>
5886
                   Make_Range_Constraint (Loc,
5887
                     Range_Expression => Rang_Expr))));
5888
 
5889
         Analyze (N);
5890
 
5891
         --  If pragma Discard_Names applies on the first subtype of the parent
5892
         --  type, then it must be applied on this subtype as well.
5893
 
5894
         if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
5895
            Set_Discard_Names (Derived_Type);
5896
         end if;
5897
 
5898
         --  Apply a range check. Since this range expression doesn't have an
5899
         --  Etype, we have to specifically pass the Source_Typ parameter. Is
5900
         --  this right???
5901
 
5902
         if Nkind (Indic) = N_Subtype_Indication then
5903
            Apply_Range_Check (Range_Expression (Constraint (Indic)),
5904
                               Parent_Type,
5905
                               Source_Typ => Entity (Subtype_Mark (Indic)));
5906
         end if;
5907
      end if;
5908
   end Build_Derived_Enumeration_Type;
5909
 
5910
   --------------------------------
5911
   -- Build_Derived_Numeric_Type --
5912
   --------------------------------
5913
 
5914
   procedure Build_Derived_Numeric_Type
5915
     (N            : Node_Id;
5916
      Parent_Type  : Entity_Id;
5917
      Derived_Type : Entity_Id)
5918
   is
5919
      Loc           : constant Source_Ptr := Sloc (N);
5920
      Tdef          : constant Node_Id    := Type_Definition (N);
5921
      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
5922
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
5923
      No_Constraint : constant Boolean    := Nkind (Indic) /=
5924
                                                  N_Subtype_Indication;
5925
      Implicit_Base : Entity_Id;
5926
 
5927
      Lo : Node_Id;
5928
      Hi : Node_Id;
5929
 
5930
   begin
5931
      --  Process the subtype indication including a validation check on
5932
      --  the constraint if any.
5933
 
5934
      Discard_Node (Process_Subtype (Indic, N));
5935
 
5936
      --  Introduce an implicit base type for the derived type even if there
5937
      --  is no constraint attached to it, since this seems closer to the Ada
5938
      --  semantics.
5939
 
5940
      Implicit_Base :=
5941
        Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
5942
 
5943
      Set_Etype          (Implicit_Base, Parent_Base);
5944
      Set_Ekind          (Implicit_Base, Ekind          (Parent_Base));
5945
      Set_Size_Info      (Implicit_Base,                 Parent_Base);
5946
      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
5947
      Set_Parent         (Implicit_Base, Parent (Derived_Type));
5948
      Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base));
5949
 
5950
      --  Set RM Size for discrete type or decimal fixed-point type
5951
      --  Ordinary fixed-point is excluded, why???
5952
 
5953
      if Is_Discrete_Type (Parent_Base)
5954
        or else Is_Decimal_Fixed_Point_Type (Parent_Base)
5955
      then
5956
         Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
5957
      end if;
5958
 
5959
      Set_Has_Delayed_Freeze (Implicit_Base);
5960
 
5961
      Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Base));
5962
      Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
5963
 
5964
      Set_Scalar_Range (Implicit_Base,
5965
        Make_Range (Loc,
5966
          Low_Bound  => Lo,
5967
          High_Bound => Hi));
5968
 
5969
      if Has_Infinities (Parent_Base) then
5970
         Set_Includes_Infinities (Scalar_Range (Implicit_Base));
5971
      end if;
5972
 
5973
      --  The Derived_Type, which is the entity of the declaration, is a
5974
      --  subtype of the implicit base. Its Ekind is a subtype, even in the
5975
      --  absence of an explicit constraint.
5976
 
5977
      Set_Etype (Derived_Type, Implicit_Base);
5978
 
5979
      --  If we did not have a constraint, then the Ekind is set from the
5980
      --  parent type (otherwise Process_Subtype has set the bounds)
5981
 
5982
      if No_Constraint then
5983
         Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
5984
      end if;
5985
 
5986
      --  If we did not have a range constraint, then set the range from the
5987
      --  parent type. Otherwise, the Process_Subtype call has set the bounds.
5988
 
5989
      if No_Constraint
5990
        or else not Has_Range_Constraint (Indic)
5991
      then
5992
         Set_Scalar_Range (Derived_Type,
5993
           Make_Range (Loc,
5994
             Low_Bound  => New_Copy_Tree (Type_Low_Bound  (Parent_Type)),
5995
             High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
5996
         Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
5997
 
5998
         if Has_Infinities (Parent_Type) then
5999
            Set_Includes_Infinities (Scalar_Range (Derived_Type));
6000
         end if;
6001
 
6002
         Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type));
6003
      end if;
6004
 
6005
      Set_Is_Descendent_Of_Address (Derived_Type,
6006
        Is_Descendent_Of_Address (Parent_Type));
6007
      Set_Is_Descendent_Of_Address (Implicit_Base,
6008
        Is_Descendent_Of_Address (Parent_Type));
6009
 
6010
      --  Set remaining type-specific fields, depending on numeric type
6011
 
6012
      if Is_Modular_Integer_Type (Parent_Type) then
6013
         Set_Modulus (Implicit_Base, Modulus (Parent_Base));
6014
 
6015
         Set_Non_Binary_Modulus
6016
           (Implicit_Base, Non_Binary_Modulus (Parent_Base));
6017
 
6018
         Set_Is_Known_Valid
6019
           (Implicit_Base, Is_Known_Valid (Parent_Base));
6020
 
6021
      elsif Is_Floating_Point_Type (Parent_Type) then
6022
 
6023
         --  Digits of base type is always copied from the digits value of
6024
         --  the parent base type, but the digits of the derived type will
6025
         --  already have been set if there was a constraint present.
6026
 
6027
         Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
6028
         Set_Float_Rep    (Implicit_Base, Float_Rep    (Parent_Base));
6029
 
6030
         if No_Constraint then
6031
            Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
6032
         end if;
6033
 
6034
      elsif Is_Fixed_Point_Type (Parent_Type) then
6035
 
6036
         --  Small of base type and derived type are always copied from the
6037
         --  parent base type, since smalls never change. The delta of the
6038
         --  base type is also copied from the parent base type. However the
6039
         --  delta of the derived type will have been set already if a
6040
         --  constraint was present.
6041
 
6042
         Set_Small_Value (Derived_Type,  Small_Value (Parent_Base));
6043
         Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
6044
         Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
6045
 
6046
         if No_Constraint then
6047
            Set_Delta_Value (Derived_Type,  Delta_Value (Parent_Type));
6048
         end if;
6049
 
6050
         --  The scale and machine radix in the decimal case are always
6051
         --  copied from the parent base type.
6052
 
6053
         if Is_Decimal_Fixed_Point_Type (Parent_Type) then
6054
            Set_Scale_Value (Derived_Type,  Scale_Value (Parent_Base));
6055
            Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
6056
 
6057
            Set_Machine_Radix_10
6058
              (Derived_Type,  Machine_Radix_10 (Parent_Base));
6059
            Set_Machine_Radix_10
6060
              (Implicit_Base, Machine_Radix_10 (Parent_Base));
6061
 
6062
            Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
6063
 
6064
            if No_Constraint then
6065
               Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
6066
 
6067
            else
6068
               --  the analysis of the subtype_indication sets the
6069
               --  digits value of the derived type.
6070
 
6071
               null;
6072
            end if;
6073
         end if;
6074
      end if;
6075
 
6076
      --  The type of the bounds is that of the parent type, and they
6077
      --  must be converted to the derived type.
6078
 
6079
      Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
6080
 
6081
      --  The implicit_base should be frozen when the derived type is frozen,
6082
      --  but note that it is used in the conversions of the bounds. For fixed
6083
      --  types we delay the determination of the bounds until the proper
6084
      --  freezing point. For other numeric types this is rejected by GCC, for
6085
      --  reasons that are currently unclear (???), so we choose to freeze the
6086
      --  implicit base now. In the case of integers and floating point types
6087
      --  this is harmless because subsequent representation clauses cannot
6088
      --  affect anything, but it is still baffling that we cannot use the
6089
      --  same mechanism for all derived numeric types.
6090
 
6091
      --  There is a further complication: actually *some* representation
6092
      --  clauses can affect the implicit base type. Namely, attribute
6093
      --  definition clauses for stream-oriented attributes need to set the
6094
      --  corresponding TSS entries on the base type, and this normally cannot
6095
      --  be done after the base type is frozen, so the circuitry in
6096
      --  Sem_Ch13.New_Stream_Subprogram must account for this possibility and
6097
      --  not use Set_TSS in this case.
6098
 
6099
      if Is_Fixed_Point_Type (Parent_Type) then
6100
         Conditional_Delay (Implicit_Base, Parent_Type);
6101
      else
6102
         Freeze_Before (N, Implicit_Base);
6103
      end if;
6104
   end Build_Derived_Numeric_Type;
6105
 
6106
   --------------------------------
6107
   -- Build_Derived_Private_Type --
6108
   --------------------------------
6109
 
6110
   procedure Build_Derived_Private_Type
6111
     (N             : Node_Id;
6112
      Parent_Type   : Entity_Id;
6113
      Derived_Type  : Entity_Id;
6114
      Is_Completion : Boolean;
6115
      Derive_Subps  : Boolean := True)
6116
   is
6117
      Loc         : constant Source_Ptr := Sloc (N);
6118
      Der_Base    : Entity_Id;
6119
      Discr       : Entity_Id;
6120
      Full_Decl   : Node_Id := Empty;
6121
      Full_Der    : Entity_Id;
6122
      Full_P      : Entity_Id;
6123
      Last_Discr  : Entity_Id;
6124
      Par_Scope   : constant Entity_Id := Scope (Base_Type (Parent_Type));
6125
      Swapped     : Boolean := False;
6126
 
6127
      procedure Copy_And_Build;
6128
      --  Copy derived type declaration, replace parent with its full view,
6129
      --  and analyze new declaration.
6130
 
6131
      --------------------
6132
      -- Copy_And_Build --
6133
      --------------------
6134
 
6135
      procedure Copy_And_Build is
6136
         Full_N : Node_Id;
6137
 
6138
      begin
6139
         if Ekind (Parent_Type) in Record_Kind
6140
           or else
6141
             (Ekind (Parent_Type) in Enumeration_Kind
6142
               and then not Is_Standard_Character_Type (Parent_Type)
6143
               and then not Is_Generic_Type (Root_Type (Parent_Type)))
6144
         then
6145
            Full_N := New_Copy_Tree (N);
6146
            Insert_After (N, Full_N);
6147
            Build_Derived_Type (
6148
              Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
6149
 
6150
         else
6151
            Build_Derived_Type (
6152
              N, Parent_Type, Full_Der, True, Derive_Subps => False);
6153
         end if;
6154
      end Copy_And_Build;
6155
 
6156
   --  Start of processing for Build_Derived_Private_Type
6157
 
6158
   begin
6159
      if Is_Tagged_Type (Parent_Type) then
6160
         Full_P := Full_View (Parent_Type);
6161
 
6162
         --  A type extension of a type with unknown discriminants is an
6163
         --  indefinite type that the back-end cannot handle directly.
6164
         --  We treat it as a private type, and build a completion that is
6165
         --  derived from the full view of the parent, and hopefully has
6166
         --  known discriminants.
6167
 
6168
         --  If the full view of the parent type has an underlying record view,
6169
         --  use it to generate the underlying record view of this derived type
6170
         --  (required for chains of derivations with unknown discriminants).
6171
 
6172
         --  Minor optimization: we avoid the generation of useless underlying
6173
         --  record view entities if the private type declaration has unknown
6174
         --  discriminants but its corresponding full view has no
6175
         --  discriminants.
6176
 
6177
         if Has_Unknown_Discriminants (Parent_Type)
6178
           and then Present (Full_P)
6179
           and then (Has_Discriminants (Full_P)
6180
                      or else Present (Underlying_Record_View (Full_P)))
6181
           and then not In_Open_Scopes (Par_Scope)
6182
           and then Expander_Active
6183
         then
6184
            declare
6185
               Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T');
6186
               New_Ext  : constant Node_Id :=
6187
                            Copy_Separate_Tree
6188
                              (Record_Extension_Part (Type_Definition (N)));
6189
               Decl     : Node_Id;
6190
 
6191
            begin
6192
               Build_Derived_Record_Type
6193
                 (N, Parent_Type, Derived_Type, Derive_Subps);
6194
 
6195
               --  Build anonymous completion, as a derivation from the full
6196
               --  view of the parent. This is not a completion in the usual
6197
               --  sense, because the current type is not private.
6198
 
6199
               Decl :=
6200
                 Make_Full_Type_Declaration (Loc,
6201
                   Defining_Identifier => Full_Der,
6202
                   Type_Definition     =>
6203
                     Make_Derived_Type_Definition (Loc,
6204
                       Subtype_Indication =>
6205
                         New_Copy_Tree
6206
                           (Subtype_Indication (Type_Definition (N))),
6207
                       Record_Extension_Part => New_Ext));
6208
 
6209
               --  If the parent type has an underlying record view, use it
6210
               --  here to build the new underlying record view.
6211
 
6212
               if Present (Underlying_Record_View (Full_P)) then
6213
                  pragma Assert
6214
                    (Nkind (Subtype_Indication (Type_Definition (Decl)))
6215
                       = N_Identifier);
6216
                  Set_Entity (Subtype_Indication (Type_Definition (Decl)),
6217
                    Underlying_Record_View (Full_P));
6218
               end if;
6219
 
6220
               Install_Private_Declarations (Par_Scope);
6221
               Install_Visible_Declarations (Par_Scope);
6222
               Insert_Before (N, Decl);
6223
 
6224
               --  Mark entity as an underlying record view before analysis,
6225
               --  to avoid generating the list of its primitive operations
6226
               --  (which is not really required for this entity) and thus
6227
               --  prevent spurious errors associated with missing overriding
6228
               --  of abstract primitives (overridden only for Derived_Type).
6229
 
6230
               Set_Ekind (Full_Der, E_Record_Type);
6231
               Set_Is_Underlying_Record_View (Full_Der);
6232
 
6233
               Analyze (Decl);
6234
 
6235
               pragma Assert (Has_Discriminants (Full_Der)
6236
                 and then not Has_Unknown_Discriminants (Full_Der));
6237
 
6238
               Uninstall_Declarations (Par_Scope);
6239
 
6240
               --  Freeze the underlying record view, to prevent generation of
6241
               --  useless dispatching information, which is simply shared with
6242
               --  the real derived type.
6243
 
6244
               Set_Is_Frozen (Full_Der);
6245
 
6246
               --  Set up links between real entity and underlying record view
6247
 
6248
               Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
6249
               Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type);
6250
            end;
6251
 
6252
         --  If discriminants are known, build derived record
6253
 
6254
         else
6255
            Build_Derived_Record_Type
6256
              (N, Parent_Type, Derived_Type, Derive_Subps);
6257
         end if;
6258
 
6259
         return;
6260
 
6261
      elsif Has_Discriminants (Parent_Type) then
6262
         if Present (Full_View (Parent_Type)) then
6263
            if not Is_Completion then
6264
 
6265
               --  Copy declaration for subsequent analysis, to provide a
6266
               --  completion for what is a private declaration. Indicate that
6267
               --  the full type is internally generated.
6268
 
6269
               Full_Decl := New_Copy_Tree (N);
6270
               Full_Der  := New_Copy (Derived_Type);
6271
               Set_Comes_From_Source (Full_Decl, False);
6272
               Set_Comes_From_Source (Full_Der, False);
6273
               Set_Parent (Full_Der, Full_Decl);
6274
 
6275
               Insert_After (N, Full_Decl);
6276
 
6277
            else
6278
               --  If this is a completion, the full view being built is itself
6279
               --  private. We build a subtype of the parent with the same
6280
               --  constraints as this full view, to convey to the back end the
6281
               --  constrained components and the size of this subtype. If the
6282
               --  parent is constrained, its full view can serve as the
6283
               --  underlying full view of the derived type.
6284
 
6285
               if No (Discriminant_Specifications (N)) then
6286
                  if Nkind (Subtype_Indication (Type_Definition (N))) =
6287
                                                        N_Subtype_Indication
6288
                  then
6289
                     Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
6290
 
6291
                  elsif Is_Constrained (Full_View (Parent_Type)) then
6292
                     Set_Underlying_Full_View
6293
                       (Derived_Type, Full_View (Parent_Type));
6294
                  end if;
6295
 
6296
               else
6297
                  --  If there are new discriminants, the parent subtype is
6298
                  --  constrained by them, but it is not clear how to build
6299
                  --  the Underlying_Full_View in this case???
6300
 
6301
                  null;
6302
               end if;
6303
            end if;
6304
         end if;
6305
 
6306
         --  Build partial view of derived type from partial view of parent
6307
 
6308
         Build_Derived_Record_Type
6309
           (N, Parent_Type, Derived_Type, Derive_Subps);
6310
 
6311
         if Present (Full_View (Parent_Type)) and then not Is_Completion then
6312
            if not In_Open_Scopes (Par_Scope)
6313
              or else not In_Same_Source_Unit (N, Parent_Type)
6314
            then
6315
               --  Swap partial and full views temporarily
6316
 
6317
               Install_Private_Declarations (Par_Scope);
6318
               Install_Visible_Declarations (Par_Scope);
6319
               Swapped := True;
6320
            end if;
6321
 
6322
            --  Build full view of derived type from full view of parent which
6323
            --  is now installed. Subprograms have been derived on the partial
6324
            --  view, the completion does not derive them anew.
6325
 
6326
            if not Is_Tagged_Type (Parent_Type) then
6327
 
6328
               --  If the parent is itself derived from another private type,
6329
               --  installing the private declarations has not affected its
6330
               --  privacy status, so use its own full view explicitly.
6331
 
6332
               if Is_Private_Type (Parent_Type) then
6333
                  Build_Derived_Record_Type
6334
                    (Full_Decl, Full_View (Parent_Type), Full_Der, False);
6335
               else
6336
                  Build_Derived_Record_Type
6337
                    (Full_Decl, Parent_Type, Full_Der, False);
6338
               end if;
6339
 
6340
            else
6341
               --  If full view of parent is tagged, the completion inherits
6342
               --  the proper primitive operations.
6343
 
6344
               Set_Defining_Identifier (Full_Decl, Full_Der);
6345
               Build_Derived_Record_Type
6346
                 (Full_Decl, Parent_Type, Full_Der, Derive_Subps);
6347
            end if;
6348
 
6349
            --  The full declaration has been introduced into the tree and
6350
            --  processed in the step above. It should not be analyzed again
6351
            --  (when encountered later in the current list of declarations)
6352
            --  to prevent spurious name conflicts. The full entity remains
6353
            --  invisible.
6354
 
6355
            Set_Analyzed (Full_Decl);
6356
 
6357
            if Swapped then
6358
               Uninstall_Declarations (Par_Scope);
6359
 
6360
               if In_Open_Scopes (Par_Scope) then
6361
                  Install_Visible_Declarations (Par_Scope);
6362
               end if;
6363
            end if;
6364
 
6365
            Der_Base := Base_Type (Derived_Type);
6366
            Set_Full_View (Derived_Type, Full_Der);
6367
            Set_Full_View (Der_Base, Base_Type (Full_Der));
6368
 
6369
            --  Copy the discriminant list from full view to the partial views
6370
            --  (base type and its subtype). Gigi requires that the partial and
6371
            --  full views have the same discriminants.
6372
 
6373
            --  Note that since the partial view is pointing to discriminants
6374
            --  in the full view, their scope will be that of the full view.
6375
            --  This might cause some front end problems and need adjustment???
6376
 
6377
            Discr := First_Discriminant (Base_Type (Full_Der));
6378
            Set_First_Entity (Der_Base, Discr);
6379
 
6380
            loop
6381
               Last_Discr := Discr;
6382
               Next_Discriminant (Discr);
6383
               exit when No (Discr);
6384
            end loop;
6385
 
6386
            Set_Last_Entity (Der_Base, Last_Discr);
6387
 
6388
            Set_First_Entity (Derived_Type, First_Entity (Der_Base));
6389
            Set_Last_Entity  (Derived_Type, Last_Entity  (Der_Base));
6390
            Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
6391
 
6392
         else
6393
            --  If this is a completion, the derived type stays private and
6394
            --  there is no need to create a further full view, except in the
6395
            --  unusual case when the derivation is nested within a child unit,
6396
            --  see below.
6397
 
6398
            null;
6399
         end if;
6400
 
6401
      elsif Present (Full_View (Parent_Type))
6402
        and then  Has_Discriminants (Full_View (Parent_Type))
6403
      then
6404
         if Has_Unknown_Discriminants (Parent_Type)
6405
           and then Nkind (Subtype_Indication (Type_Definition (N))) =
6406
                                                         N_Subtype_Indication
6407
         then
6408
            Error_Msg_N
6409
              ("cannot constrain type with unknown discriminants",
6410
               Subtype_Indication (Type_Definition (N)));
6411
            return;
6412
         end if;
6413
 
6414
         --  If full view of parent is a record type, build full view as a
6415
         --  derivation from the parent's full view. Partial view remains
6416
         --  private. For code generation and linking, the full view must have
6417
         --  the same public status as the partial one. This full view is only
6418
         --  needed if the parent type is in an enclosing scope, so that the
6419
         --  full view may actually become visible, e.g. in a child unit. This
6420
         --  is both more efficient, and avoids order of freezing problems with
6421
         --  the added entities.
6422
 
6423
         if not Is_Private_Type (Full_View (Parent_Type))
6424
           and then (In_Open_Scopes (Scope (Parent_Type)))
6425
         then
6426
            Full_Der :=
6427
              Make_Defining_Identifier
6428
                (Sloc (Derived_Type), Chars (Derived_Type));
6429
            Set_Is_Itype (Full_Der);
6430
            Set_Has_Private_Declaration (Full_Der);
6431
            Set_Has_Private_Declaration (Derived_Type);
6432
            Set_Associated_Node_For_Itype (Full_Der, N);
6433
            Set_Parent (Full_Der, Parent (Derived_Type));
6434
            Set_Full_View (Derived_Type, Full_Der);
6435
            Set_Is_Public (Full_Der, Is_Public (Derived_Type));
6436
            Full_P := Full_View (Parent_Type);
6437
            Exchange_Declarations (Parent_Type);
6438
            Copy_And_Build;
6439
            Exchange_Declarations (Full_P);
6440
 
6441
         else
6442
            Build_Derived_Record_Type
6443
              (N, Full_View (Parent_Type), Derived_Type,
6444
                Derive_Subps => False);
6445
         end if;
6446
 
6447
         --  In any case, the primitive operations are inherited from the
6448
         --  parent type, not from the internal full view.
6449
 
6450
         Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
6451
 
6452
         if Derive_Subps then
6453
            Derive_Subprograms (Parent_Type, Derived_Type);
6454
         end if;
6455
 
6456
      else
6457
         --  Untagged type, No discriminants on either view
6458
 
6459
         if Nkind (Subtype_Indication (Type_Definition (N))) =
6460
                                                   N_Subtype_Indication
6461
         then
6462
            Error_Msg_N
6463
              ("illegal constraint on type without discriminants", N);
6464
         end if;
6465
 
6466
         if Present (Discriminant_Specifications (N))
6467
           and then Present (Full_View (Parent_Type))
6468
           and then not Is_Tagged_Type (Full_View (Parent_Type))
6469
         then
6470
            Error_Msg_N ("cannot add discriminants to untagged type", N);
6471
         end if;
6472
 
6473
         Set_Stored_Constraint (Derived_Type, No_Elist);
6474
         Set_Is_Constrained    (Derived_Type, Is_Constrained (Parent_Type));
6475
         Set_Is_Controlled     (Derived_Type, Is_Controlled  (Parent_Type));
6476
         Set_Has_Controlled_Component
6477
                               (Derived_Type, Has_Controlled_Component
6478
                                                             (Parent_Type));
6479
 
6480
         --  Direct controlled types do not inherit Finalize_Storage_Only flag
6481
 
6482
         if not Is_Controlled  (Parent_Type) then
6483
            Set_Finalize_Storage_Only
6484
              (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
6485
         end if;
6486
 
6487
         --  Construct the implicit full view by deriving from full view of the
6488
         --  parent type. In order to get proper visibility, we install the
6489
         --  parent scope and its declarations.
6490
 
6491
         --  ??? If the parent is untagged private and its completion is
6492
         --  tagged, this mechanism will not work because we cannot derive from
6493
         --  the tagged full view unless we have an extension.
6494
 
6495
         if Present (Full_View (Parent_Type))
6496
           and then not Is_Tagged_Type (Full_View (Parent_Type))
6497
           and then not Is_Completion
6498
         then
6499
            Full_Der :=
6500
              Make_Defining_Identifier
6501
                (Sloc (Derived_Type), Chars (Derived_Type));
6502
            Set_Is_Itype (Full_Der);
6503
            Set_Has_Private_Declaration (Full_Der);
6504
            Set_Has_Private_Declaration (Derived_Type);
6505
            Set_Associated_Node_For_Itype (Full_Der, N);
6506
            Set_Parent (Full_Der, Parent (Derived_Type));
6507
            Set_Full_View (Derived_Type, Full_Der);
6508
 
6509
            if not In_Open_Scopes (Par_Scope) then
6510
               Install_Private_Declarations (Par_Scope);
6511
               Install_Visible_Declarations (Par_Scope);
6512
               Copy_And_Build;
6513
               Uninstall_Declarations (Par_Scope);
6514
 
6515
            --  If parent scope is open and in another unit, and parent has a
6516
            --  completion, then the derivation is taking place in the visible
6517
            --  part of a child unit. In that case retrieve the full view of
6518
            --  the parent momentarily.
6519
 
6520
            elsif not In_Same_Source_Unit (N, Parent_Type) then
6521
               Full_P := Full_View (Parent_Type);
6522
               Exchange_Declarations (Parent_Type);
6523
               Copy_And_Build;
6524
               Exchange_Declarations (Full_P);
6525
 
6526
            --  Otherwise it is a local derivation
6527
 
6528
            else
6529
               Copy_And_Build;
6530
            end if;
6531
 
6532
            Set_Scope                (Full_Der, Current_Scope);
6533
            Set_Is_First_Subtype     (Full_Der,
6534
                                       Is_First_Subtype (Derived_Type));
6535
            Set_Has_Size_Clause      (Full_Der, False);
6536
            Set_Has_Alignment_Clause (Full_Der, False);
6537
            Set_Next_Entity          (Full_Der, Empty);
6538
            Set_Has_Delayed_Freeze   (Full_Der);
6539
            Set_Is_Frozen            (Full_Der, False);
6540
            Set_Freeze_Node          (Full_Der, Empty);
6541
            Set_Depends_On_Private   (Full_Der,
6542
                                       Has_Private_Component (Full_Der));
6543
            Set_Public_Status        (Full_Der);
6544
         end if;
6545
      end if;
6546
 
6547
      Set_Has_Unknown_Discriminants (Derived_Type,
6548
        Has_Unknown_Discriminants (Parent_Type));
6549
 
6550
      if Is_Private_Type (Derived_Type) then
6551
         Set_Private_Dependents (Derived_Type, New_Elmt_List);
6552
      end if;
6553
 
6554
      if Is_Private_Type (Parent_Type)
6555
        and then Base_Type (Parent_Type) = Parent_Type
6556
        and then In_Open_Scopes (Scope (Parent_Type))
6557
      then
6558
         Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
6559
 
6560
         if Is_Child_Unit (Scope (Current_Scope))
6561
           and then Is_Completion
6562
           and then In_Private_Part (Current_Scope)
6563
           and then Scope (Parent_Type) /= Current_Scope
6564
         then
6565
            --  This is the unusual case where a type completed by a private
6566
            --  derivation occurs within a package nested in a child unit, and
6567
            --  the parent is declared in an ancestor. In this case, the full
6568
            --  view of the parent type will become visible in the body of
6569
            --  the enclosing child, and only then will the current type be
6570
            --  possibly non-private. We build a underlying full view that
6571
            --  will be installed when the enclosing child body is compiled.
6572
 
6573
            Full_Der :=
6574
              Make_Defining_Identifier
6575
                (Sloc (Derived_Type), Chars (Derived_Type));
6576
            Set_Is_Itype (Full_Der);
6577
            Build_Itype_Reference (Full_Der, N);
6578
 
6579
            --  The full view will be used to swap entities on entry/exit to
6580
            --  the body, and must appear in the entity list for the package.
6581
 
6582
            Append_Entity (Full_Der, Scope (Derived_Type));
6583
            Set_Has_Private_Declaration (Full_Der);
6584
            Set_Has_Private_Declaration (Derived_Type);
6585
            Set_Associated_Node_For_Itype (Full_Der, N);
6586
            Set_Parent (Full_Der, Parent (Derived_Type));
6587
            Full_P := Full_View (Parent_Type);
6588
            Exchange_Declarations (Parent_Type);
6589
            Copy_And_Build;
6590
            Exchange_Declarations (Full_P);
6591
            Set_Underlying_Full_View (Derived_Type, Full_Der);
6592
         end if;
6593
      end if;
6594
   end Build_Derived_Private_Type;
6595
 
6596
   -------------------------------
6597
   -- Build_Derived_Record_Type --
6598
   -------------------------------
6599
 
6600
   --  1. INTRODUCTION
6601
 
6602
   --  Ideally we would like to use the same model of type derivation for
6603
   --  tagged and untagged record types. Unfortunately this is not quite
6604
   --  possible because the semantics of representation clauses is different
6605
   --  for tagged and untagged records under inheritance. Consider the
6606
   --  following:
6607
 
6608
   --     type R (...) is [tagged] record ... end record;
6609
   --     type T (...) is new R (...) [with ...];
6610
 
6611
   --  The representation clauses for T can specify a completely different
6612
   --  record layout from R's. Hence the same component can be placed in two
6613
   --  very different positions in objects of type T and R. If R and T are
6614
   --  tagged types, representation clauses for T can only specify the layout
6615
   --  of non inherited components, thus components that are common in R and T
6616
   --  have the same position in objects of type R and T.
6617
 
6618
   --  This has two implications. The first is that the entire tree for R's
6619
   --  declaration needs to be copied for T in the untagged case, so that T
6620
   --  can be viewed as a record type of its own with its own representation
6621
   --  clauses. The second implication is the way we handle discriminants.
6622
   --  Specifically, in the untagged case we need a way to communicate to Gigi
6623
   --  what are the real discriminants in the record, while for the semantics
6624
   --  we need to consider those introduced by the user to rename the
6625
   --  discriminants in the parent type. This is handled by introducing the
6626
   --  notion of stored discriminants. See below for more.
6627
 
6628
   --  Fortunately the way regular components are inherited can be handled in
6629
   --  the same way in tagged and untagged types.
6630
 
6631
   --  To complicate things a bit more the private view of a private extension
6632
   --  cannot be handled in the same way as the full view (for one thing the
6633
   --  semantic rules are somewhat different). We will explain what differs
6634
   --  below.
6635
 
6636
   --  2. DISCRIMINANTS UNDER INHERITANCE
6637
 
6638
   --  The semantic rules governing the discriminants of derived types are
6639
   --  quite subtle.
6640
 
6641
   --   type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
6642
   --      [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
6643
 
6644
   --  If parent type has discriminants, then the discriminants that are
6645
   --  declared in the derived type are [3.4 (11)]:
6646
 
6647
   --  o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
6648
   --    there is one;
6649
 
6650
   --  o Otherwise, each discriminant of the parent type (implicitly declared
6651
   --    in the same order with the same specifications). In this case, the
6652
   --    discriminants are said to be "inherited", or if unknown in the parent
6653
   --    are also unknown in the derived type.
6654
 
6655
   --  Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
6656
 
6657
   --  o The parent subtype shall be constrained;
6658
 
6659
   --  o If the parent type is not a tagged type, then each discriminant of
6660
   --    the derived type shall be used in the constraint defining a parent
6661
   --    subtype. [Implementation note: This ensures that the new discriminant
6662
   --    can share storage with an existing discriminant.]
6663
 
6664
   --  For the derived type each discriminant of the parent type is either
6665
   --  inherited, constrained to equal some new discriminant of the derived
6666
   --  type, or constrained to the value of an expression.
6667
 
6668
   --  When inherited or constrained to equal some new discriminant, the
6669
   --  parent discriminant and the discriminant of the derived type are said
6670
   --  to "correspond".
6671
 
6672
   --  If a discriminant of the parent type is constrained to a specific value
6673
   --  in the derived type definition, then the discriminant is said to be
6674
   --  "specified" by that derived type definition.
6675
 
6676
   --  3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
6677
 
6678
   --  We have spoken about stored discriminants in point 1 (introduction)
6679
   --  above. There are two sort of stored discriminants: implicit and
6680
   --  explicit. As long as the derived type inherits the same discriminants as
6681
   --  the root record type, stored discriminants are the same as regular
6682
   --  discriminants, and are said to be implicit. However, if any discriminant
6683
   --  in the root type was renamed in the derived type, then the derived
6684
   --  type will contain explicit stored discriminants. Explicit stored
6685
   --  discriminants are discriminants in addition to the semantically visible
6686
   --  discriminants defined for the derived type. Stored discriminants are
6687
   --  used by Gigi to figure out what are the physical discriminants in
6688
   --  objects of the derived type (see precise definition in einfo.ads).
6689
   --  As an example, consider the following:
6690
 
6691
   --           type R  (D1, D2, D3 : Int) is record ... end record;
6692
   --           type T1 is new R;
6693
   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
6694
   --           type T3 is new T2;
6695
   --           type T4 (Y : Int) is new T3 (Y, 99);
6696
 
6697
   --  The following table summarizes the discriminants and stored
6698
   --  discriminants in R and T1 through T4.
6699
 
6700
   --   Type      Discrim     Stored Discrim  Comment
6701
   --    R      (D1, D2, D3)   (D1, D2, D3)   Girder discrims implicit in R
6702
   --    T1     (D1, D2, D3)   (D1, D2, D3)   Girder discrims implicit in T1
6703
   --    T2     (X1, X2)       (D1, D2, D3)   Girder discrims EXPLICIT in T2
6704
   --    T3     (X1, X2)       (D1, D2, D3)   Girder discrims EXPLICIT in T3
6705
   --    T4     (Y)            (D1, D2, D3)   Girder discrims EXPLICIT in T4
6706
 
6707
   --  Field Corresponding_Discriminant (abbreviated CD below) allows us to
6708
   --  find the corresponding discriminant in the parent type, while
6709
   --  Original_Record_Component (abbreviated ORC below), the actual physical
6710
   --  component that is renamed. Finally the field Is_Completely_Hidden
6711
   --  (abbreviated ICH below) is set for all explicit stored discriminants
6712
   --  (see einfo.ads for more info). For the above example this gives:
6713
 
6714
   --                 Discrim     CD        ORC     ICH
6715
   --                 ^^^^^^^     ^^        ^^^     ^^^
6716
   --                 D1 in R    empty     itself    no
6717
   --                 D2 in R    empty     itself    no
6718
   --                 D3 in R    empty     itself    no
6719
 
6720
   --                 D1 in T1  D1 in R    itself    no
6721
   --                 D2 in T1  D2 in R    itself    no
6722
   --                 D3 in T1  D3 in R    itself    no
6723
 
6724
   --                 X1 in T2  D3 in T1  D3 in T2   no
6725
   --                 X2 in T2  D1 in T1  D1 in T2   no
6726
   --                 D1 in T2   empty    itself    yes
6727
   --                 D2 in T2   empty    itself    yes
6728
   --                 D3 in T2   empty    itself    yes
6729
 
6730
   --                 X1 in T3  X1 in T2  D3 in T3   no
6731
   --                 X2 in T3  X2 in T2  D1 in T3   no
6732
   --                 D1 in T3   empty    itself    yes
6733
   --                 D2 in T3   empty    itself    yes
6734
   --                 D3 in T3   empty    itself    yes
6735
 
6736
   --                 Y  in T4  X1 in T3  D3 in T3   no
6737
   --                 D1 in T3   empty    itself    yes
6738
   --                 D2 in T3   empty    itself    yes
6739
   --                 D3 in T3   empty    itself    yes
6740
 
6741
   --  4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
6742
 
6743
   --  Type derivation for tagged types is fairly straightforward. If no
6744
   --  discriminants are specified by the derived type, these are inherited
6745
   --  from the parent. No explicit stored discriminants are ever necessary.
6746
   --  The only manipulation that is done to the tree is that of adding a
6747
   --  _parent field with parent type and constrained to the same constraint
6748
   --  specified for the parent in the derived type definition. For instance:
6749
 
6750
   --           type R  (D1, D2, D3 : Int) is tagged record ... end record;
6751
   --           type T1 is new R with null record;
6752
   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
6753
 
6754
   --  are changed into:
6755
 
6756
   --           type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
6757
   --              _parent : R (D1, D2, D3);
6758
   --           end record;
6759
 
6760
   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
6761
   --              _parent : T1 (X2, 88, X1);
6762
   --           end record;
6763
 
6764
   --  The discriminants actually present in R, T1 and T2 as well as their CD,
6765
   --  ORC and ICH fields are:
6766
 
6767
   --                 Discrim     CD        ORC     ICH
6768
   --                 ^^^^^^^     ^^        ^^^     ^^^
6769
   --                 D1 in R    empty     itself    no
6770
   --                 D2 in R    empty     itself    no
6771
   --                 D3 in R    empty     itself    no
6772
 
6773
   --                 D1 in T1  D1 in R    D1 in R   no
6774
   --                 D2 in T1  D2 in R    D2 in R   no
6775
   --                 D3 in T1  D3 in R    D3 in R   no
6776
 
6777
   --                 X1 in T2  D3 in T1   D3 in R   no
6778
   --                 X2 in T2  D1 in T1   D1 in R   no
6779
 
6780
   --  5. FIRST TRANSFORMATION FOR DERIVED RECORDS
6781
   --
6782
   --  Regardless of whether we dealing with a tagged or untagged type
6783
   --  we will transform all derived type declarations of the form
6784
   --
6785
   --               type T is new R (...) [with ...];
6786
   --  or
6787
   --               subtype S is R (...);
6788
   --               type T is new S [with ...];
6789
   --  into
6790
   --               type BT is new R [with ...];
6791
   --               subtype T is BT (...);
6792
   --
6793
   --  That is, the base derived type is constrained only if it has no
6794
   --  discriminants. The reason for doing this is that GNAT's semantic model
6795
   --  assumes that a base type with discriminants is unconstrained.
6796
   --
6797
   --  Note that, strictly speaking, the above transformation is not always
6798
   --  correct. Consider for instance the following excerpt from ACVC b34011a:
6799
   --
6800
   --       procedure B34011A is
6801
   --          type REC (D : integer := 0) is record
6802
   --             I : Integer;
6803
   --          end record;
6804
 
6805
   --          package P is
6806
   --             type T6 is new Rec;
6807
   --             function F return T6;
6808
   --          end P;
6809
 
6810
   --          use P;
6811
   --          package Q6 is
6812
   --             type U is new T6 (Q6.F.I);                   -- ERROR: Q6.F.
6813
   --          end Q6;
6814
   --
6815
   --  The definition of Q6.U is illegal. However transforming Q6.U into
6816
 
6817
   --             type BaseU is new T6;
6818
   --             subtype U is BaseU (Q6.F.I)
6819
 
6820
   --  turns U into a legal subtype, which is incorrect. To avoid this problem
6821
   --  we always analyze the constraint (in this case (Q6.F.I)) before applying
6822
   --  the transformation described above.
6823
 
6824
   --  There is another instance where the above transformation is incorrect.
6825
   --  Consider:
6826
 
6827
   --          package Pack is
6828
   --             type Base (D : Integer) is tagged null record;
6829
   --             procedure P (X : Base);
6830
 
6831
   --             type Der is new Base (2) with null record;
6832
   --             procedure P (X : Der);
6833
   --          end Pack;
6834
 
6835
   --  Then the above transformation turns this into
6836
 
6837
   --             type Der_Base is new Base with null record;
6838
   --             --  procedure P (X : Base) is implicitly inherited here
6839
   --             --  as procedure P (X : Der_Base).
6840
 
6841
   --             subtype Der is Der_Base (2);
6842
   --             procedure P (X : Der);
6843
   --             --  The overriding of P (X : Der_Base) is illegal since we
6844
   --             --  have a parameter conformance problem.
6845
 
6846
   --  To get around this problem, after having semantically processed Der_Base
6847
   --  and the rewritten subtype declaration for Der, we copy Der_Base field
6848
   --  Discriminant_Constraint from Der so that when parameter conformance is
6849
   --  checked when P is overridden, no semantic errors are flagged.
6850
 
6851
   --  6. SECOND TRANSFORMATION FOR DERIVED RECORDS
6852
 
6853
   --  Regardless of whether we are dealing with a tagged or untagged type
6854
   --  we will transform all derived type declarations of the form
6855
 
6856
   --               type R (D1, .., Dn : ...) is [tagged] record ...;
6857
   --               type T is new R [with ...];
6858
   --  into
6859
   --               type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
6860
 
6861
   --  The reason for such transformation is that it allows us to implement a
6862
   --  very clean form of component inheritance as explained below.
6863
 
6864
   --  Note that this transformation is not achieved by direct tree rewriting
6865
   --  and manipulation, but rather by redoing the semantic actions that the
6866
   --  above transformation will entail. This is done directly in routine
6867
   --  Inherit_Components.
6868
 
6869
   --  7. TYPE DERIVATION AND COMPONENT INHERITANCE
6870
 
6871
   --  In both tagged and untagged derived types, regular non discriminant
6872
   --  components are inherited in the derived type from the parent type. In
6873
   --  the absence of discriminants component, inheritance is straightforward
6874
   --  as components can simply be copied from the parent.
6875
 
6876
   --  If the parent has discriminants, inheriting components constrained with
6877
   --  these discriminants requires caution. Consider the following example:
6878
 
6879
   --      type R  (D1, D2 : Positive) is [tagged] record
6880
   --         S : String (D1 .. D2);
6881
   --      end record;
6882
 
6883
   --      type T1                is new R        [with null record];
6884
   --      type T2 (X : positive) is new R (1, X) [with null record];
6885
 
6886
   --  As explained in 6. above, T1 is rewritten as
6887
   --      type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
6888
   --  which makes the treatment for T1 and T2 identical.
6889
 
6890
   --  What we want when inheriting S, is that references to D1 and D2 in R are
6891
   --  replaced with references to their correct constraints, i.e. D1 and D2 in
6892
   --  T1 and 1 and X in T2. So all R's discriminant references are replaced
6893
   --  with either discriminant references in the derived type or expressions.
6894
   --  This replacement is achieved as follows: before inheriting R's
6895
   --  components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
6896
   --  created in the scope of T1 (resp. scope of T2) so that discriminants D1
6897
   --  and D2 of T1 are visible (resp. discriminant X of T2 is visible).
6898
   --  For T2, for instance, this has the effect of replacing String (D1 .. D2)
6899
   --  by String (1 .. X).
6900
 
6901
   --  8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
6902
 
6903
   --  We explain here the rules governing private type extensions relevant to
6904
   --  type derivation. These rules are explained on the following example:
6905
 
6906
   --      type D [(...)] is new A [(...)] with private;      <-- partial view
6907
   --      type D [(...)] is new P [(...)] with null record;  <-- full view
6908
 
6909
   --  Type A is called the ancestor subtype of the private extension.
6910
   --  Type P is the parent type of the full view of the private extension. It
6911
   --  must be A or a type derived from A.
6912
 
6913
   --  The rules concerning the discriminants of private type extensions are
6914
   --  [7.3(10-13)]:
6915
 
6916
   --  o If a private extension inherits known discriminants from the ancestor
6917
   --    subtype, then the full view shall also inherit its discriminants from
6918
   --    the ancestor subtype and the parent subtype of the full view shall be
6919
   --    constrained if and only if the ancestor subtype is constrained.
6920
 
6921
   --  o If a partial view has unknown discriminants, then the full view may
6922
   --    define a definite or an indefinite subtype, with or without
6923
   --    discriminants.
6924
 
6925
   --  o If a partial view has neither known nor unknown discriminants, then
6926
   --    the full view shall define a definite subtype.
6927
 
6928
   --  o If the ancestor subtype of a private extension has constrained
6929
   --    discriminants, then the parent subtype of the full view shall impose a
6930
   --    statically matching constraint on those discriminants.
6931
 
6932
   --  This means that only the following forms of private extensions are
6933
   --  allowed:
6934
 
6935
   --      type D is new A with private;      <-- partial view
6936
   --      type D is new P with null record;  <-- full view
6937
 
6938
   --  If A has no discriminants than P has no discriminants, otherwise P must
6939
   --  inherit A's discriminants.
6940
 
6941
   --      type D is new A (...) with private;      <-- partial view
6942
   --      type D is new P (:::) with null record;  <-- full view
6943
 
6944
   --  P must inherit A's discriminants and (...) and (:::) must statically
6945
   --  match.
6946
 
6947
   --      subtype A is R (...);
6948
   --      type D is new A with private;      <-- partial view
6949
   --      type D is new P with null record;  <-- full view
6950
 
6951
   --  P must have inherited R's discriminants and must be derived from A or
6952
   --  any of its subtypes.
6953
 
6954
   --      type D (..) is new A with private;              <-- partial view
6955
   --      type D (..) is new P [(:::)] with null record;  <-- full view
6956
 
6957
   --  No specific constraints on P's discriminants or constraint (:::).
6958
   --  Note that A can be unconstrained, but the parent subtype P must either
6959
   --  be constrained or (:::) must be present.
6960
 
6961
   --      type D (..) is new A [(...)] with private;      <-- partial view
6962
   --      type D (..) is new P [(:::)] with null record;  <-- full view
6963
 
6964
   --  P's constraints on A's discriminants must statically match those
6965
   --  imposed by (...).
6966
 
6967
   --  9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
6968
 
6969
   --  The full view of a private extension is handled exactly as described
6970
   --  above. The model chose for the private view of a private extension is
6971
   --  the same for what concerns discriminants (i.e. they receive the same
6972
   --  treatment as in the tagged case). However, the private view of the
6973
   --  private extension always inherits the components of the parent base,
6974
   --  without replacing any discriminant reference. Strictly speaking this is
6975
   --  incorrect. However, Gigi never uses this view to generate code so this
6976
   --  is a purely semantic issue. In theory, a set of transformations similar
6977
   --  to those given in 5. and 6. above could be applied to private views of
6978
   --  private extensions to have the same model of component inheritance as
6979
   --  for non private extensions. However, this is not done because it would
6980
   --  further complicate private type processing. Semantically speaking, this
6981
   --  leaves us in an uncomfortable situation. As an example consider:
6982
 
6983
   --          package Pack is
6984
   --             type R (D : integer) is tagged record
6985
   --                S : String (1 .. D);
6986
   --             end record;
6987
   --             procedure P (X : R);
6988
   --             type T is new R (1) with private;
6989
   --          private
6990
   --             type T is new R (1) with null record;
6991
   --          end;
6992
 
6993
   --  This is transformed into:
6994
 
6995
   --          package Pack is
6996
   --             type R (D : integer) is tagged record
6997
   --                S : String (1 .. D);
6998
   --             end record;
6999
   --             procedure P (X : R);
7000
   --             type T is new R (1) with private;
7001
   --          private
7002
   --             type BaseT is new R with null record;
7003
   --             subtype  T is BaseT (1);
7004
   --          end;
7005
 
7006
   --  (strictly speaking the above is incorrect Ada)
7007
 
7008
   --  From the semantic standpoint the private view of private extension T
7009
   --  should be flagged as constrained since one can clearly have
7010
   --
7011
   --             Obj : T;
7012
   --
7013
   --  in a unit withing Pack. However, when deriving subprograms for the
7014
   --  private view of private extension T, T must be seen as unconstrained
7015
   --  since T has discriminants (this is a constraint of the current
7016
   --  subprogram derivation model). Thus, when processing the private view of
7017
   --  a private extension such as T, we first mark T as unconstrained, we
7018
   --  process it, we perform program derivation and just before returning from
7019
   --  Build_Derived_Record_Type we mark T as constrained.
7020
 
7021
   --  ??? Are there are other uncomfortable cases that we will have to
7022
   --      deal with.
7023
 
7024
   --  10. RECORD_TYPE_WITH_PRIVATE complications
7025
 
7026
   --  Types that are derived from a visible record type and have a private
7027
   --  extension present other peculiarities. They behave mostly like private
7028
   --  types, but if they have primitive operations defined, these will not
7029
   --  have the proper signatures for further inheritance, because other
7030
   --  primitive operations will use the implicit base that we define for
7031
   --  private derivations below. This affect subprogram inheritance (see
7032
   --  Derive_Subprograms for details). We also derive the implicit base from
7033
   --  the base type of the full view, so that the implicit base is a record
7034
   --  type and not another private type, This avoids infinite loops.
7035
 
7036
   procedure Build_Derived_Record_Type
7037
     (N            : Node_Id;
7038
      Parent_Type  : Entity_Id;
7039
      Derived_Type : Entity_Id;
7040
      Derive_Subps : Boolean := True)
7041
   is
7042
      Discriminant_Specs : constant Boolean :=
7043
                             Present (Discriminant_Specifications (N));
7044
      Is_Tagged          : constant Boolean := Is_Tagged_Type (Parent_Type);
7045
      Loc                : constant Source_Ptr := Sloc (N);
7046
      Private_Extension  : constant Boolean :=
7047
                             Nkind (N) = N_Private_Extension_Declaration;
7048
      Assoc_List         : Elist_Id;
7049
      Constraint_Present : Boolean;
7050
      Constrs            : Elist_Id;
7051
      Discrim            : Entity_Id;
7052
      Indic              : Node_Id;
7053
      Inherit_Discrims   : Boolean := False;
7054
      Last_Discrim       : Entity_Id;
7055
      New_Base           : Entity_Id;
7056
      New_Decl           : Node_Id;
7057
      New_Discrs         : Elist_Id;
7058
      New_Indic          : Node_Id;
7059
      Parent_Base        : Entity_Id;
7060
      Save_Etype         : Entity_Id;
7061
      Save_Discr_Constr  : Elist_Id;
7062
      Save_Next_Entity   : Entity_Id;
7063
      Type_Def           : Node_Id;
7064
 
7065
      Discs : Elist_Id := New_Elmt_List;
7066
      --  An empty Discs list means that there were no constraints in the
7067
      --  subtype indication or that there was an error processing it.
7068
 
7069
   begin
7070
      if Ekind (Parent_Type) = E_Record_Type_With_Private
7071
        and then Present (Full_View (Parent_Type))
7072
        and then Has_Discriminants (Parent_Type)
7073
      then
7074
         Parent_Base := Base_Type (Full_View (Parent_Type));
7075
      else
7076
         Parent_Base := Base_Type (Parent_Type);
7077
      end if;
7078
 
7079
      --  AI05-0115 : if this is a derivation from a private type in some
7080
      --  other scope that may lead to invisible components for the derived
7081
      --  type, mark it accordingly.
7082
 
7083
      if Is_Private_Type (Parent_Type) then
7084
         if Scope (Parent_Type) = Scope (Derived_Type) then
7085
            null;
7086
 
7087
         elsif In_Open_Scopes (Scope (Parent_Type))
7088
           and then In_Private_Part (Scope (Parent_Type))
7089
         then
7090
            null;
7091
 
7092
         else
7093
            Set_Has_Private_Ancestor (Derived_Type);
7094
         end if;
7095
 
7096
      else
7097
         Set_Has_Private_Ancestor
7098
           (Derived_Type, Has_Private_Ancestor (Parent_Type));
7099
      end if;
7100
 
7101
      --  Before we start the previously documented transformations, here is
7102
      --  little fix for size and alignment of tagged types. Normally when we
7103
      --  derive type D from type P, we copy the size and alignment of P as the
7104
      --  default for D, and in the absence of explicit representation clauses
7105
      --  for D, the size and alignment are indeed the same as the parent.
7106
 
7107
      --  But this is wrong for tagged types, since fields may be added, and
7108
      --  the default size may need to be larger, and the default alignment may
7109
      --  need to be larger.
7110
 
7111
      --  We therefore reset the size and alignment fields in the tagged case.
7112
      --  Note that the size and alignment will in any case be at least as
7113
      --  large as the parent type (since the derived type has a copy of the
7114
      --  parent type in the _parent field)
7115
 
7116
      --  The type is also marked as being tagged here, which is needed when
7117
      --  processing components with a self-referential anonymous access type
7118
      --  in the call to Check_Anonymous_Access_Components below. Note that
7119
      --  this flag is also set later on for completeness.
7120
 
7121
      if Is_Tagged then
7122
         Set_Is_Tagged_Type (Derived_Type);
7123
         Init_Size_Align    (Derived_Type);
7124
      end if;
7125
 
7126
      --  STEP 0a: figure out what kind of derived type declaration we have
7127
 
7128
      if Private_Extension then
7129
         Type_Def := N;
7130
         Set_Ekind (Derived_Type, E_Record_Type_With_Private);
7131
 
7132
      else
7133
         Type_Def := Type_Definition (N);
7134
 
7135
         --  Ekind (Parent_Base) is not necessarily E_Record_Type since
7136
         --  Parent_Base can be a private type or private extension. However,
7137
         --  for tagged types with an extension the newly added fields are
7138
         --  visible and hence the Derived_Type is always an E_Record_Type.
7139
         --  (except that the parent may have its own private fields).
7140
         --  For untagged types we preserve the Ekind of the Parent_Base.
7141
 
7142
         if Present (Record_Extension_Part (Type_Def)) then
7143
            Set_Ekind (Derived_Type, E_Record_Type);
7144
 
7145
            --  Create internal access types for components with anonymous
7146
            --  access types.
7147
 
7148
            if Ada_Version >= Ada_2005 then
7149
               Check_Anonymous_Access_Components
7150
                 (N, Derived_Type, Derived_Type,
7151
                   Component_List (Record_Extension_Part (Type_Def)));
7152
            end if;
7153
 
7154
         else
7155
            Set_Ekind (Derived_Type, Ekind (Parent_Base));
7156
         end if;
7157
      end if;
7158
 
7159
      --  Indic can either be an N_Identifier if the subtype indication
7160
      --  contains no constraint or an N_Subtype_Indication if the subtype
7161
      --  indication has a constraint.
7162
 
7163
      Indic := Subtype_Indication (Type_Def);
7164
      Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
7165
 
7166
      --  Check that the type has visible discriminants. The type may be
7167
      --  a private type with unknown discriminants whose full view has
7168
      --  discriminants which are invisible.
7169
 
7170
      if Constraint_Present then
7171
         if not Has_Discriminants (Parent_Base)
7172
           or else
7173
             (Has_Unknown_Discriminants (Parent_Base)
7174
                and then Is_Private_Type (Parent_Base))
7175
         then
7176
            Error_Msg_N
7177
              ("invalid constraint: type has no discriminant",
7178
                 Constraint (Indic));
7179
 
7180
            Constraint_Present := False;
7181
            Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
7182
 
7183
         elsif Is_Constrained (Parent_Type) then
7184
            Error_Msg_N
7185
               ("invalid constraint: parent type is already constrained",
7186
                  Constraint (Indic));
7187
 
7188
            Constraint_Present := False;
7189
            Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
7190
         end if;
7191
      end if;
7192
 
7193
      --  STEP 0b: If needed, apply transformation given in point 5. above
7194
 
7195
      if not Private_Extension
7196
        and then Has_Discriminants (Parent_Type)
7197
        and then not Discriminant_Specs
7198
        and then (Is_Constrained (Parent_Type) or else Constraint_Present)
7199
      then
7200
         --  First, we must analyze the constraint (see comment in point 5.)
7201
 
7202
         if Constraint_Present then
7203
            New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
7204
 
7205
            if Has_Discriminants (Derived_Type)
7206
              and then Has_Private_Declaration (Derived_Type)
7207
              and then Present (Discriminant_Constraint (Derived_Type))
7208
            then
7209
               --  Verify that constraints of the full view statically match
7210
               --  those given in the partial view.
7211
 
7212
               declare
7213
                  C1, C2 : Elmt_Id;
7214
 
7215
               begin
7216
                  C1 := First_Elmt (New_Discrs);
7217
                  C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
7218
                  while Present (C1) and then Present (C2) loop
7219
                     if Fully_Conformant_Expressions (Node (C1), Node (C2))
7220
                       or else
7221
                         (Is_OK_Static_Expression (Node (C1))
7222
                            and then
7223
                          Is_OK_Static_Expression (Node (C2))
7224
                            and then
7225
                          Expr_Value (Node (C1)) = Expr_Value (Node (C2)))
7226
                     then
7227
                        null;
7228
 
7229
                     else
7230
                        Error_Msg_N (
7231
                          "constraint not conformant to previous declaration",
7232
                             Node (C1));
7233
                     end if;
7234
 
7235
                     Next_Elmt (C1);
7236
                     Next_Elmt (C2);
7237
                  end loop;
7238
               end;
7239
            end if;
7240
         end if;
7241
 
7242
         --  Insert and analyze the declaration for the unconstrained base type
7243
 
7244
         New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
7245
 
7246
         New_Decl :=
7247
           Make_Full_Type_Declaration (Loc,
7248
              Defining_Identifier => New_Base,
7249
              Type_Definition     =>
7250
                Make_Derived_Type_Definition (Loc,
7251
                  Abstract_Present      => Abstract_Present (Type_Def),
7252
                  Limited_Present       => Limited_Present (Type_Def),
7253
                  Subtype_Indication    =>
7254
                    New_Occurrence_Of (Parent_Base, Loc),
7255
                  Record_Extension_Part =>
7256
                    Relocate_Node (Record_Extension_Part (Type_Def)),
7257
                  Interface_List        => Interface_List (Type_Def)));
7258
 
7259
         Set_Parent (New_Decl, Parent (N));
7260
         Mark_Rewrite_Insertion (New_Decl);
7261
         Insert_Before (N, New_Decl);
7262
 
7263
         --  In the extension case, make sure ancestor is frozen appropriately
7264
         --  (see also non-discriminated case below).
7265
 
7266
         if Present (Record_Extension_Part (Type_Def))
7267
           or else Is_Interface (Parent_Base)
7268
         then
7269
            Freeze_Before (New_Decl, Parent_Type);
7270
         end if;
7271
 
7272
         --  Note that this call passes False for the Derive_Subps parameter
7273
         --  because subprogram derivation is deferred until after creating
7274
         --  the subtype (see below).
7275
 
7276
         Build_Derived_Type
7277
           (New_Decl, Parent_Base, New_Base,
7278
            Is_Completion => True, Derive_Subps => False);
7279
 
7280
         --  ??? This needs re-examination to determine whether the
7281
         --  above call can simply be replaced by a call to Analyze.
7282
 
7283
         Set_Analyzed (New_Decl);
7284
 
7285
         --  Insert and analyze the declaration for the constrained subtype
7286
 
7287
         if Constraint_Present then
7288
            New_Indic :=
7289
              Make_Subtype_Indication (Loc,
7290
                Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
7291
                Constraint   => Relocate_Node (Constraint (Indic)));
7292
 
7293
         else
7294
            declare
7295
               Constr_List : constant List_Id := New_List;
7296
               C           : Elmt_Id;
7297
               Expr        : Node_Id;
7298
 
7299
            begin
7300
               C := First_Elmt (Discriminant_Constraint (Parent_Type));
7301
               while Present (C) loop
7302
                  Expr := Node (C);
7303
 
7304
                  --  It is safe here to call New_Copy_Tree since
7305
                  --  Force_Evaluation was called on each constraint in
7306
                  --  Build_Discriminant_Constraints.
7307
 
7308
                  Append (New_Copy_Tree (Expr), To => Constr_List);
7309
 
7310
                  Next_Elmt (C);
7311
               end loop;
7312
 
7313
               New_Indic :=
7314
                 Make_Subtype_Indication (Loc,
7315
                   Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
7316
                   Constraint   =>
7317
                     Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
7318
            end;
7319
         end if;
7320
 
7321
         Rewrite (N,
7322
           Make_Subtype_Declaration (Loc,
7323
             Defining_Identifier => Derived_Type,
7324
             Subtype_Indication  => New_Indic));
7325
 
7326
         Analyze (N);
7327
 
7328
         --  Derivation of subprograms must be delayed until the full subtype
7329
         --  has been established, to ensure proper overriding of subprograms
7330
         --  inherited by full types. If the derivations occurred as part of
7331
         --  the call to Build_Derived_Type above, then the check for type
7332
         --  conformance would fail because earlier primitive subprograms
7333
         --  could still refer to the full type prior the change to the new
7334
         --  subtype and hence would not match the new base type created here.
7335
         --  Subprograms are not derived, however, when Derive_Subps is False
7336
         --  (since otherwise there could be redundant derivations).
7337
 
7338
         if Derive_Subps then
7339
            Derive_Subprograms (Parent_Type, Derived_Type);
7340
         end if;
7341
 
7342
         --  For tagged types the Discriminant_Constraint of the new base itype
7343
         --  is inherited from the first subtype so that no subtype conformance
7344
         --  problem arise when the first subtype overrides primitive
7345
         --  operations inherited by the implicit base type.
7346
 
7347
         if Is_Tagged then
7348
            Set_Discriminant_Constraint
7349
              (New_Base, Discriminant_Constraint (Derived_Type));
7350
         end if;
7351
 
7352
         return;
7353
      end if;
7354
 
7355
      --  If we get here Derived_Type will have no discriminants or it will be
7356
      --  a discriminated unconstrained base type.
7357
 
7358
      --  STEP 1a: perform preliminary actions/checks for derived tagged types
7359
 
7360
      if Is_Tagged then
7361
 
7362
         --  The parent type is frozen for non-private extensions (RM 13.14(7))
7363
         --  The declaration of a specific descendant of an interface type
7364
         --  freezes the interface type (RM 13.14).
7365
 
7366
         if not Private_Extension or else Is_Interface (Parent_Base) then
7367
            Freeze_Before (N, Parent_Type);
7368
         end if;
7369
 
7370
         --  In Ada 2005 (AI-344), the restriction that a derived tagged type
7371
         --  cannot be declared at a deeper level than its parent type is
7372
         --  removed. The check on derivation within a generic body is also
7373
         --  relaxed, but there's a restriction that a derived tagged type
7374
         --  cannot be declared in a generic body if it's derived directly
7375
         --  or indirectly from a formal type of that generic.
7376
 
7377
         if Ada_Version >= Ada_2005 then
7378
            if Present (Enclosing_Generic_Body (Derived_Type)) then
7379
               declare
7380
                  Ancestor_Type : Entity_Id;
7381
 
7382
               begin
7383
                  --  Check to see if any ancestor of the derived type is a
7384
                  --  formal type.
7385
 
7386
                  Ancestor_Type := Parent_Type;
7387
                  while not Is_Generic_Type (Ancestor_Type)
7388
                    and then Etype (Ancestor_Type) /= Ancestor_Type
7389
                  loop
7390
                     Ancestor_Type := Etype (Ancestor_Type);
7391
                  end loop;
7392
 
7393
                  --  If the derived type does have a formal type as an
7394
                  --  ancestor, then it's an error if the derived type is
7395
                  --  declared within the body of the generic unit that
7396
                  --  declares the formal type in its generic formal part. It's
7397
                  --  sufficient to check whether the ancestor type is declared
7398
                  --  inside the same generic body as the derived type (such as
7399
                  --  within a nested generic spec), in which case the
7400
                  --  derivation is legal. If the formal type is declared
7401
                  --  outside of that generic body, then it's guaranteed that
7402
                  --  the derived type is declared within the generic body of
7403
                  --  the generic unit declaring the formal type.
7404
 
7405
                  if Is_Generic_Type (Ancestor_Type)
7406
                    and then Enclosing_Generic_Body (Ancestor_Type) /=
7407
                               Enclosing_Generic_Body (Derived_Type)
7408
                  then
7409
                     Error_Msg_NE
7410
                       ("parent type of& must not be descendant of formal type"
7411
                          & " of an enclosing generic body",
7412
                            Indic, Derived_Type);
7413
                  end if;
7414
               end;
7415
            end if;
7416
 
7417
         elsif Type_Access_Level (Derived_Type) /=
7418
                 Type_Access_Level (Parent_Type)
7419
           and then not Is_Generic_Type (Derived_Type)
7420
         then
7421
            if Is_Controlled (Parent_Type) then
7422
               Error_Msg_N
7423
                 ("controlled type must be declared at the library level",
7424
                  Indic);
7425
            else
7426
               Error_Msg_N
7427
                 ("type extension at deeper accessibility level than parent",
7428
                  Indic);
7429
            end if;
7430
 
7431
         else
7432
            declare
7433
               GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
7434
 
7435
            begin
7436
               if Present (GB)
7437
                 and then GB /= Enclosing_Generic_Body (Parent_Base)
7438
               then
7439
                  Error_Msg_NE
7440
                    ("parent type of& must not be outside generic body"
7441
                       & " (RM 3.9.1(4))",
7442
                         Indic, Derived_Type);
7443
               end if;
7444
            end;
7445
         end if;
7446
      end if;
7447
 
7448
      --  Ada 2005 (AI-251)
7449
 
7450
      if Ada_Version >= Ada_2005 and then Is_Tagged then
7451
 
7452
         --  "The declaration of a specific descendant of an interface type
7453
         --  freezes the interface type" (RM 13.14).
7454
 
7455
         declare
7456
            Iface : Node_Id;
7457
         begin
7458
            if Is_Non_Empty_List (Interface_List (Type_Def)) then
7459
               Iface := First (Interface_List (Type_Def));
7460
               while Present (Iface) loop
7461
                  Freeze_Before (N, Etype (Iface));
7462
                  Next (Iface);
7463
               end loop;
7464
            end if;
7465
         end;
7466
      end if;
7467
 
7468
      --  STEP 1b : preliminary cleanup of the full view of private types
7469
 
7470
      --  If the type is already marked as having discriminants, then it's the
7471
      --  completion of a private type or private extension and we need to
7472
      --  retain the discriminants from the partial view if the current
7473
      --  declaration has Discriminant_Specifications so that we can verify
7474
      --  conformance. However, we must remove any existing components that
7475
      --  were inherited from the parent (and attached in Copy_And_Swap)
7476
      --  because the full type inherits all appropriate components anyway, and
7477
      --  we do not want the partial view's components interfering.
7478
 
7479
      if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
7480
         Discrim := First_Discriminant (Derived_Type);
7481
         loop
7482
            Last_Discrim := Discrim;
7483
            Next_Discriminant (Discrim);
7484
            exit when No (Discrim);
7485
         end loop;
7486
 
7487
         Set_Last_Entity (Derived_Type, Last_Discrim);
7488
 
7489
      --  In all other cases wipe out the list of inherited components (even
7490
      --  inherited discriminants), it will be properly rebuilt here.
7491
 
7492
      else
7493
         Set_First_Entity (Derived_Type, Empty);
7494
         Set_Last_Entity  (Derived_Type, Empty);
7495
      end if;
7496
 
7497
      --  STEP 1c: Initialize some flags for the Derived_Type
7498
 
7499
      --  The following flags must be initialized here so that
7500
      --  Process_Discriminants can check that discriminants of tagged types do
7501
      --  not have a default initial value and that access discriminants are
7502
      --  only specified for limited records. For completeness, these flags are
7503
      --  also initialized along with all the other flags below.
7504
 
7505
      --  AI-419: Limitedness is not inherited from an interface parent, so to
7506
      --  be limited in that case the type must be explicitly declared as
7507
      --  limited. However, task and protected interfaces are always limited.
7508
 
7509
      if Limited_Present (Type_Def) then
7510
         Set_Is_Limited_Record (Derived_Type);
7511
 
7512
      elsif Is_Limited_Record (Parent_Type)
7513
        or else (Present (Full_View (Parent_Type))
7514
                   and then Is_Limited_Record (Full_View (Parent_Type)))
7515
      then
7516
         if not Is_Interface (Parent_Type)
7517
           or else Is_Synchronized_Interface (Parent_Type)
7518
           or else Is_Protected_Interface (Parent_Type)
7519
           or else Is_Task_Interface (Parent_Type)
7520
         then
7521
            Set_Is_Limited_Record (Derived_Type);
7522
         end if;
7523
      end if;
7524
 
7525
      --  STEP 2a: process discriminants of derived type if any
7526
 
7527
      Push_Scope (Derived_Type);
7528
 
7529
      if Discriminant_Specs then
7530
         Set_Has_Unknown_Discriminants (Derived_Type, False);
7531
 
7532
         --  The following call initializes fields Has_Discriminants and
7533
         --  Discriminant_Constraint, unless we are processing the completion
7534
         --  of a private type declaration.
7535
 
7536
         Check_Or_Process_Discriminants (N, Derived_Type);
7537
 
7538
         --  For untagged types, the constraint on the Parent_Type must be
7539
         --  present and is used to rename the discriminants.
7540
 
7541
         if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
7542
            Error_Msg_N ("untagged parent must have discriminants", Indic);
7543
 
7544
         elsif not Is_Tagged and then not Constraint_Present then
7545
            Error_Msg_N
7546
              ("discriminant constraint needed for derived untagged records",
7547
               Indic);
7548
 
7549
         --  Otherwise the parent subtype must be constrained unless we have a
7550
         --  private extension.
7551
 
7552
         elsif not Constraint_Present
7553
           and then not Private_Extension
7554
           and then not Is_Constrained (Parent_Type)
7555
         then
7556
            Error_Msg_N
7557
              ("unconstrained type not allowed in this context", Indic);
7558
 
7559
         elsif Constraint_Present then
7560
            --  The following call sets the field Corresponding_Discriminant
7561
            --  for the discriminants in the Derived_Type.
7562
 
7563
            Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
7564
 
7565
            --  For untagged types all new discriminants must rename
7566
            --  discriminants in the parent. For private extensions new
7567
            --  discriminants cannot rename old ones (implied by [7.3(13)]).
7568
 
7569
            Discrim := First_Discriminant (Derived_Type);
7570
            while Present (Discrim) loop
7571
               if not Is_Tagged
7572
                 and then No (Corresponding_Discriminant (Discrim))
7573
               then
7574
                  Error_Msg_N
7575
                    ("new discriminants must constrain old ones", Discrim);
7576
 
7577
               elsif Private_Extension
7578
                 and then Present (Corresponding_Discriminant (Discrim))
7579
               then
7580
                  Error_Msg_N
7581
                    ("only static constraints allowed for parent"
7582
                     & " discriminants in the partial view", Indic);
7583
                  exit;
7584
               end if;
7585
 
7586
               --  If a new discriminant is used in the constraint, then its
7587
               --  subtype must be statically compatible with the parent
7588
               --  discriminant's subtype (3.7(15)).
7589
 
7590
               if Present (Corresponding_Discriminant (Discrim))
7591
                 and then
7592
                   not Subtypes_Statically_Compatible
7593
                         (Etype (Discrim),
7594
                          Etype (Corresponding_Discriminant (Discrim)))
7595
               then
7596
                  Error_Msg_N
7597
                    ("subtype must be compatible with parent discriminant",
7598
                     Discrim);
7599
               end if;
7600
 
7601
               Next_Discriminant (Discrim);
7602
            end loop;
7603
 
7604
            --  Check whether the constraints of the full view statically
7605
            --  match those imposed by the parent subtype [7.3(13)].
7606
 
7607
            if Present (Stored_Constraint (Derived_Type)) then
7608
               declare
7609
                  C1, C2 : Elmt_Id;
7610
 
7611
               begin
7612
                  C1 := First_Elmt (Discs);
7613
                  C2 := First_Elmt (Stored_Constraint (Derived_Type));
7614
                  while Present (C1) and then Present (C2) loop
7615
                     if not
7616
                       Fully_Conformant_Expressions (Node (C1), Node (C2))
7617
                     then
7618
                        Error_Msg_N
7619
                          ("not conformant with previous declaration",
7620
                           Node (C1));
7621
                     end if;
7622
 
7623
                     Next_Elmt (C1);
7624
                     Next_Elmt (C2);
7625
                  end loop;
7626
               end;
7627
            end if;
7628
         end if;
7629
 
7630
      --  STEP 2b: No new discriminants, inherit discriminants if any
7631
 
7632
      else
7633
         if Private_Extension then
7634
            Set_Has_Unknown_Discriminants
7635
              (Derived_Type,
7636
               Has_Unknown_Discriminants (Parent_Type)
7637
                 or else Unknown_Discriminants_Present (N));
7638
 
7639
         --  The partial view of the parent may have unknown discriminants,
7640
         --  but if the full view has discriminants and the parent type is
7641
         --  in scope they must be inherited.
7642
 
7643
         elsif Has_Unknown_Discriminants (Parent_Type)
7644
           and then
7645
            (not Has_Discriminants (Parent_Type)
7646
              or else not In_Open_Scopes (Scope (Parent_Type)))
7647
         then
7648
            Set_Has_Unknown_Discriminants (Derived_Type);
7649
         end if;
7650
 
7651
         if not Has_Unknown_Discriminants (Derived_Type)
7652
           and then not Has_Unknown_Discriminants (Parent_Base)
7653
           and then Has_Discriminants (Parent_Type)
7654
         then
7655
            Inherit_Discrims := True;
7656
            Set_Has_Discriminants
7657
              (Derived_Type, True);
7658
            Set_Discriminant_Constraint
7659
              (Derived_Type, Discriminant_Constraint (Parent_Base));
7660
         end if;
7661
 
7662
         --  The following test is true for private types (remember
7663
         --  transformation 5. is not applied to those) and in an error
7664
         --  situation.
7665
 
7666
         if Constraint_Present then
7667
            Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
7668
         end if;
7669
 
7670
         --  For now mark a new derived type as constrained only if it has no
7671
         --  discriminants. At the end of Build_Derived_Record_Type we properly
7672
         --  set this flag in the case of private extensions. See comments in
7673
         --  point 9. just before body of Build_Derived_Record_Type.
7674
 
7675
         Set_Is_Constrained
7676
           (Derived_Type,
7677
            not (Inherit_Discrims
7678
                   or else Has_Unknown_Discriminants (Derived_Type)));
7679
      end if;
7680
 
7681
      --  STEP 3: initialize fields of derived type
7682
 
7683
      Set_Is_Tagged_Type    (Derived_Type, Is_Tagged);
7684
      Set_Stored_Constraint (Derived_Type, No_Elist);
7685
 
7686
      --  Ada 2005 (AI-251): Private type-declarations can implement interfaces
7687
      --  but cannot be interfaces
7688
 
7689
      if not Private_Extension
7690
         and then Ekind (Derived_Type) /= E_Private_Type
7691
         and then Ekind (Derived_Type) /= E_Limited_Private_Type
7692
      then
7693
         if Interface_Present (Type_Def) then
7694
            Analyze_Interface_Declaration (Derived_Type, Type_Def);
7695
         end if;
7696
 
7697
         Set_Interfaces (Derived_Type, No_Elist);
7698
      end if;
7699
 
7700
      --  Fields inherited from the Parent_Type
7701
 
7702
      Set_Discard_Names
7703
        (Derived_Type, Einfo.Discard_Names  (Parent_Type));
7704
      Set_Has_Specified_Layout
7705
        (Derived_Type, Has_Specified_Layout (Parent_Type));
7706
      Set_Is_Limited_Composite
7707
        (Derived_Type, Is_Limited_Composite (Parent_Type));
7708
      Set_Is_Private_Composite
7709
        (Derived_Type, Is_Private_Composite (Parent_Type));
7710
 
7711
      --  Fields inherited from the Parent_Base
7712
 
7713
      Set_Has_Controlled_Component
7714
        (Derived_Type, Has_Controlled_Component (Parent_Base));
7715
      Set_Has_Non_Standard_Rep
7716
        (Derived_Type, Has_Non_Standard_Rep     (Parent_Base));
7717
      Set_Has_Primitive_Operations
7718
        (Derived_Type, Has_Primitive_Operations (Parent_Base));
7719
 
7720
      --  Fields inherited from the Parent_Base in the non-private case
7721
 
7722
      if Ekind (Derived_Type) = E_Record_Type then
7723
         Set_Has_Complex_Representation
7724
           (Derived_Type, Has_Complex_Representation (Parent_Base));
7725
      end if;
7726
 
7727
      --  Fields inherited from the Parent_Base for record types
7728
 
7729
      if Is_Record_Type (Derived_Type) then
7730
 
7731
         --  Ekind (Parent_Base) is not necessarily E_Record_Type since
7732
         --  Parent_Base can be a private type or private extension.
7733
 
7734
         if Present (Full_View (Parent_Base)) then
7735
            Set_OK_To_Reorder_Components
7736
              (Derived_Type,
7737
               OK_To_Reorder_Components (Full_View (Parent_Base)));
7738
            Set_Reverse_Bit_Order
7739
              (Derived_Type, Reverse_Bit_Order (Full_View (Parent_Base)));
7740
         else
7741
            Set_OK_To_Reorder_Components
7742
              (Derived_Type, OK_To_Reorder_Components (Parent_Base));
7743
            Set_Reverse_Bit_Order
7744
              (Derived_Type, Reverse_Bit_Order (Parent_Base));
7745
         end if;
7746
      end if;
7747
 
7748
      --  Direct controlled types do not inherit Finalize_Storage_Only flag
7749
 
7750
      if not Is_Controlled (Parent_Type) then
7751
         Set_Finalize_Storage_Only
7752
           (Derived_Type, Finalize_Storage_Only (Parent_Type));
7753
      end if;
7754
 
7755
      --  Set fields for private derived types
7756
 
7757
      if Is_Private_Type (Derived_Type) then
7758
         Set_Depends_On_Private (Derived_Type, True);
7759
         Set_Private_Dependents (Derived_Type, New_Elmt_List);
7760
 
7761
      --  Inherit fields from non private record types. If this is the
7762
      --  completion of a derivation from a private type, the parent itself
7763
      --  is private, and the attributes come from its full view, which must
7764
      --  be present.
7765
 
7766
      else
7767
         if Is_Private_Type (Parent_Base)
7768
           and then not Is_Record_Type (Parent_Base)
7769
         then
7770
            Set_Component_Alignment
7771
              (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
7772
            Set_C_Pass_By_Copy
7773
              (Derived_Type, C_Pass_By_Copy      (Full_View (Parent_Base)));
7774
         else
7775
            Set_Component_Alignment
7776
              (Derived_Type, Component_Alignment (Parent_Base));
7777
            Set_C_Pass_By_Copy
7778
              (Derived_Type, C_Pass_By_Copy      (Parent_Base));
7779
         end if;
7780
      end if;
7781
 
7782
      --  Set fields for tagged types
7783
 
7784
      if Is_Tagged then
7785
         Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
7786
 
7787
         --  All tagged types defined in Ada.Finalization are controlled
7788
 
7789
         if Chars (Scope (Derived_Type)) = Name_Finalization
7790
           and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
7791
           and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
7792
         then
7793
            Set_Is_Controlled (Derived_Type);
7794
         else
7795
            Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
7796
         end if;
7797
 
7798
         --  Minor optimization: there is no need to generate the class-wide
7799
         --  entity associated with an underlying record view.
7800
 
7801
         if not Is_Underlying_Record_View (Derived_Type) then
7802
            Make_Class_Wide_Type (Derived_Type);
7803
         end if;
7804
 
7805
         Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
7806
 
7807
         if Has_Discriminants (Derived_Type)
7808
           and then Constraint_Present
7809
         then
7810
            Set_Stored_Constraint
7811
              (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
7812
         end if;
7813
 
7814
         if Ada_Version >= Ada_2005 then
7815
            declare
7816
               Ifaces_List : Elist_Id;
7817
 
7818
            begin
7819
               --  Checks rules 3.9.4 (13/2 and 14/2)
7820
 
7821
               if Comes_From_Source (Derived_Type)
7822
                 and then not Is_Private_Type (Derived_Type)
7823
                 and then Is_Interface (Parent_Type)
7824
                 and then not Is_Interface (Derived_Type)
7825
               then
7826
                  if Is_Task_Interface (Parent_Type) then
7827
                     Error_Msg_N
7828
                       ("(Ada 2005) task type required (RM 3.9.4 (13.2))",
7829
                        Derived_Type);
7830
 
7831
                  elsif Is_Protected_Interface (Parent_Type) then
7832
                     Error_Msg_N
7833
                       ("(Ada 2005) protected type required (RM 3.9.4 (14.2))",
7834
                        Derived_Type);
7835
                  end if;
7836
               end if;
7837
 
7838
               --  Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
7839
 
7840
               Check_Interfaces (N, Type_Def);
7841
 
7842
               --  Ada 2005 (AI-251): Collect the list of progenitors that are
7843
               --  not already in the parents.
7844
 
7845
               Collect_Interfaces
7846
                 (T               => Derived_Type,
7847
                  Ifaces_List     => Ifaces_List,
7848
                  Exclude_Parents => True);
7849
 
7850
               Set_Interfaces (Derived_Type, Ifaces_List);
7851
 
7852
               --  If the derived type is the anonymous type created for
7853
               --  a declaration whose parent has a constraint, propagate
7854
               --  the interface list to the source type. This must be done
7855
               --  prior to the completion of the analysis of the source type
7856
               --  because the components in the extension may contain current
7857
               --  instances whose legality depends on some ancestor.
7858
 
7859
               if Is_Itype (Derived_Type) then
7860
                  declare
7861
                     Def : constant Node_Id :=
7862
                       Associated_Node_For_Itype (Derived_Type);
7863
                  begin
7864
                     if Present (Def)
7865
                       and then Nkind (Def) = N_Full_Type_Declaration
7866
                     then
7867
                        Set_Interfaces
7868
                          (Defining_Identifier (Def), Ifaces_List);
7869
                     end if;
7870
                  end;
7871
               end if;
7872
            end;
7873
         end if;
7874
 
7875
      else
7876
         Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
7877
         Set_Has_Non_Standard_Rep
7878
                       (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
7879
      end if;
7880
 
7881
      --  STEP 4: Inherit components from the parent base and constrain them.
7882
      --          Apply the second transformation described in point 6. above.
7883
 
7884
      if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
7885
        or else not Has_Discriminants (Parent_Type)
7886
        or else not Is_Constrained (Parent_Type)
7887
      then
7888
         Constrs := Discs;
7889
      else
7890
         Constrs := Discriminant_Constraint (Parent_Type);
7891
      end if;
7892
 
7893
      Assoc_List :=
7894
        Inherit_Components
7895
          (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
7896
 
7897
      --  STEP 5a: Copy the parent record declaration for untagged types
7898
 
7899
      if not Is_Tagged then
7900
 
7901
         --  Discriminant_Constraint (Derived_Type) has been properly
7902
         --  constructed. Save it and temporarily set it to Empty because we
7903
         --  do not want the call to New_Copy_Tree below to mess this list.
7904
 
7905
         if Has_Discriminants (Derived_Type) then
7906
            Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
7907
            Set_Discriminant_Constraint (Derived_Type, No_Elist);
7908
         else
7909
            Save_Discr_Constr := No_Elist;
7910
         end if;
7911
 
7912
         --  Save the Etype field of Derived_Type. It is correctly set now,
7913
         --  but the call to New_Copy tree may remap it to point to itself,
7914
         --  which is not what we want. Ditto for the Next_Entity field.
7915
 
7916
         Save_Etype       := Etype (Derived_Type);
7917
         Save_Next_Entity := Next_Entity (Derived_Type);
7918
 
7919
         --  Assoc_List maps all stored discriminants in the Parent_Base to
7920
         --  stored discriminants in the Derived_Type. It is fundamental that
7921
         --  no types or itypes with discriminants other than the stored
7922
         --  discriminants appear in the entities declared inside
7923
         --  Derived_Type, since the back end cannot deal with it.
7924
 
7925
         New_Decl :=
7926
           New_Copy_Tree
7927
             (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
7928
 
7929
         --  Restore the fields saved prior to the New_Copy_Tree call
7930
         --  and compute the stored constraint.
7931
 
7932
         Set_Etype       (Derived_Type, Save_Etype);
7933
         Set_Next_Entity (Derived_Type, Save_Next_Entity);
7934
 
7935
         if Has_Discriminants (Derived_Type) then
7936
            Set_Discriminant_Constraint
7937
              (Derived_Type, Save_Discr_Constr);
7938
            Set_Stored_Constraint
7939
              (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
7940
            Replace_Components (Derived_Type, New_Decl);
7941
            Set_Has_Implicit_Dereference
7942
              (Derived_Type, Has_Implicit_Dereference (Parent_Type));
7943
         end if;
7944
 
7945
         --  Insert the new derived type declaration
7946
 
7947
         Rewrite (N, New_Decl);
7948
 
7949
      --  STEP 5b: Complete the processing for record extensions in generics
7950
 
7951
      --  There is no completion for record extensions declared in the
7952
      --  parameter part of a generic, so we need to complete processing for
7953
      --  these generic record extensions here. The Record_Type_Definition call
7954
      --  will change the Ekind of the components from E_Void to E_Component.
7955
 
7956
      elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
7957
         Record_Type_Definition (Empty, Derived_Type);
7958
 
7959
      --  STEP 5c: Process the record extension for non private tagged types
7960
 
7961
      elsif not Private_Extension then
7962
 
7963
         --  Add the _parent field in the derived type
7964
 
7965
         Expand_Record_Extension (Derived_Type, Type_Def);
7966
 
7967
         --  Ada 2005 (AI-251): Addition of the Tag corresponding to all the
7968
         --  implemented interfaces if we are in expansion mode
7969
 
7970
         if Expander_Active
7971
           and then Has_Interfaces (Derived_Type)
7972
         then
7973
            Add_Interface_Tag_Components (N, Derived_Type);
7974
         end if;
7975
 
7976
         --  Analyze the record extension
7977
 
7978
         Record_Type_Definition
7979
           (Record_Extension_Part (Type_Def), Derived_Type);
7980
      end if;
7981
 
7982
      End_Scope;
7983
 
7984
      --  Nothing else to do if there is an error in the derivation.
7985
      --  An unusual case: the full view may be derived from a type in an
7986
      --  instance, when the partial view was used illegally as an actual
7987
      --  in that instance, leading to a circular definition.
7988
 
7989
      if Etype (Derived_Type) = Any_Type
7990
        or else Etype (Parent_Type) = Derived_Type
7991
      then
7992
         return;
7993
      end if;
7994
 
7995
      --  Set delayed freeze and then derive subprograms, we need to do
7996
      --  this in this order so that derived subprograms inherit the
7997
      --  derived freeze if necessary.
7998
 
7999
      Set_Has_Delayed_Freeze (Derived_Type);
8000
 
8001
      if Derive_Subps then
8002
         Derive_Subprograms (Parent_Type, Derived_Type);
8003
      end if;
8004
 
8005
      --  If we have a private extension which defines a constrained derived
8006
      --  type mark as constrained here after we have derived subprograms. See
8007
      --  comment on point 9. just above the body of Build_Derived_Record_Type.
8008
 
8009
      if Private_Extension and then Inherit_Discrims then
8010
         if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
8011
            Set_Is_Constrained          (Derived_Type, True);
8012
            Set_Discriminant_Constraint (Derived_Type, Discs);
8013
 
8014
         elsif Is_Constrained (Parent_Type) then
8015
            Set_Is_Constrained
8016
              (Derived_Type, True);
8017
            Set_Discriminant_Constraint
8018
              (Derived_Type, Discriminant_Constraint (Parent_Type));
8019
         end if;
8020
      end if;
8021
 
8022
      --  Update the class-wide type, which shares the now-completed entity
8023
      --  list with its specific type. In case of underlying record views,
8024
      --  we do not generate the corresponding class wide entity.
8025
 
8026
      if Is_Tagged
8027
        and then not Is_Underlying_Record_View (Derived_Type)
8028
      then
8029
         Set_First_Entity
8030
           (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
8031
         Set_Last_Entity
8032
           (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
8033
      end if;
8034
   end Build_Derived_Record_Type;
8035
 
8036
   ------------------------
8037
   -- Build_Derived_Type --
8038
   ------------------------
8039
 
8040
   procedure Build_Derived_Type
8041
     (N             : Node_Id;
8042
      Parent_Type   : Entity_Id;
8043
      Derived_Type  : Entity_Id;
8044
      Is_Completion : Boolean;
8045
      Derive_Subps  : Boolean := True)
8046
   is
8047
      Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
8048
 
8049
   begin
8050
      --  Set common attributes
8051
 
8052
      Set_Scope          (Derived_Type, Current_Scope);
8053
 
8054
      Set_Ekind          (Derived_Type, Ekind    (Parent_Base));
8055
      Set_Etype          (Derived_Type,           Parent_Base);
8056
      Set_Has_Task       (Derived_Type, Has_Task (Parent_Base));
8057
 
8058
      Set_Size_Info      (Derived_Type,                 Parent_Type);
8059
      Set_RM_Size        (Derived_Type, RM_Size        (Parent_Type));
8060
      Set_Is_Controlled  (Derived_Type, Is_Controlled  (Parent_Type));
8061
      Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
8062
 
8063
      --  If the parent type is a private subtype, the convention on the base
8064
      --  type may be set in the private part, and not propagated to the
8065
      --  subtype until later, so we obtain the convention from the base type.
8066
 
8067
      Set_Convention     (Derived_Type, Convention     (Parent_Base));
8068
 
8069
      --  Propagate invariant information. The new type has invariants if
8070
      --  they are inherited from the parent type, and these invariants can
8071
      --  be further inherited, so both flags are set.
8072
 
8073
      if Has_Inheritable_Invariants (Parent_Type) then
8074
         Set_Has_Inheritable_Invariants (Derived_Type);
8075
         Set_Has_Invariants (Derived_Type);
8076
      end if;
8077
 
8078
      --  We similarly inherit predicates
8079
 
8080
      if Has_Predicates (Parent_Type) then
8081
         Set_Has_Predicates (Derived_Type);
8082
      end if;
8083
 
8084
      --  The derived type inherits the representation clauses of the parent.
8085
      --  However, for a private type that is completed by a derivation, there
8086
      --  may be operation attributes that have been specified already (stream
8087
      --  attributes and External_Tag) and those must be provided. Finally,
8088
      --  if the partial view is a private extension, the representation items
8089
      --  of the parent have been inherited already, and should not be chained
8090
      --  twice to the derived type.
8091
 
8092
      if Is_Tagged_Type (Parent_Type)
8093
        and then Present (First_Rep_Item (Derived_Type))
8094
      then
8095
         --  The existing items are either operational items or items inherited
8096
         --  from a private extension declaration.
8097
 
8098
         declare
8099
            Rep : Node_Id;
8100
            --  Used to iterate over representation items of the derived type
8101
 
8102
            Last_Rep : Node_Id;
8103
            --  Last representation item of the (non-empty) representation
8104
            --  item list of the derived type.
8105
 
8106
            Found : Boolean := False;
8107
 
8108
         begin
8109
            Rep      := First_Rep_Item (Derived_Type);
8110
            Last_Rep := Rep;
8111
            while Present (Rep) loop
8112
               if Rep = First_Rep_Item (Parent_Type) then
8113
                  Found := True;
8114
                  exit;
8115
 
8116
               else
8117
                  Rep := Next_Rep_Item (Rep);
8118
 
8119
                  if Present (Rep) then
8120
                     Last_Rep := Rep;
8121
                  end if;
8122
               end if;
8123
            end loop;
8124
 
8125
            --  Here if we either encountered the parent type's first rep
8126
            --  item on the derived type's rep item list (in which case
8127
            --  Found is True, and we have nothing else to do), or if we
8128
            --  reached the last rep item of the derived type, which is
8129
            --  Last_Rep, in which case we further chain the parent type's
8130
            --  rep items to those of the derived type.
8131
 
8132
            if not Found then
8133
               Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type));
8134
            end if;
8135
         end;
8136
 
8137
      else
8138
         Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
8139
      end if;
8140
 
8141
      case Ekind (Parent_Type) is
8142
         when Numeric_Kind =>
8143
            Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
8144
 
8145
         when Array_Kind =>
8146
            Build_Derived_Array_Type (N, Parent_Type,  Derived_Type);
8147
 
8148
         when E_Record_Type
8149
            | E_Record_Subtype
8150
            | Class_Wide_Kind  =>
8151
            Build_Derived_Record_Type
8152
              (N, Parent_Type, Derived_Type, Derive_Subps);
8153
            return;
8154
 
8155
         when Enumeration_Kind =>
8156
            Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
8157
 
8158
         when Access_Kind =>
8159
            Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
8160
 
8161
         when Incomplete_Or_Private_Kind =>
8162
            Build_Derived_Private_Type
8163
              (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
8164
 
8165
            --  For discriminated types, the derivation includes deriving
8166
            --  primitive operations. For others it is done below.
8167
 
8168
            if Is_Tagged_Type (Parent_Type)
8169
              or else Has_Discriminants (Parent_Type)
8170
              or else (Present (Full_View (Parent_Type))
8171
                        and then Has_Discriminants (Full_View (Parent_Type)))
8172
            then
8173
               return;
8174
            end if;
8175
 
8176
         when Concurrent_Kind =>
8177
            Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
8178
 
8179
         when others =>
8180
            raise Program_Error;
8181
      end case;
8182
 
8183
      if Etype (Derived_Type) = Any_Type then
8184
         return;
8185
      end if;
8186
 
8187
      --  Set delayed freeze and then derive subprograms, we need to do this
8188
      --  in this order so that derived subprograms inherit the derived freeze
8189
      --  if necessary.
8190
 
8191
      Set_Has_Delayed_Freeze (Derived_Type);
8192
      if Derive_Subps then
8193
         Derive_Subprograms (Parent_Type, Derived_Type);
8194
      end if;
8195
 
8196
      Set_Has_Primitive_Operations
8197
        (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
8198
   end Build_Derived_Type;
8199
 
8200
   -----------------------
8201
   -- Build_Discriminal --
8202
   -----------------------
8203
 
8204
   procedure Build_Discriminal (Discrim : Entity_Id) is
8205
      D_Minal : Entity_Id;
8206
      CR_Disc : Entity_Id;
8207
 
8208
   begin
8209
      --  A discriminal has the same name as the discriminant
8210
 
8211
      D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
8212
 
8213
      Set_Ekind     (D_Minal, E_In_Parameter);
8214
      Set_Mechanism (D_Minal, Default_Mechanism);
8215
      Set_Etype     (D_Minal, Etype (Discrim));
8216
      Set_Scope     (D_Minal, Current_Scope);
8217
 
8218
      Set_Discriminal (Discrim, D_Minal);
8219
      Set_Discriminal_Link (D_Minal, Discrim);
8220
 
8221
      --  For task types, build at once the discriminants of the corresponding
8222
      --  record, which are needed if discriminants are used in entry defaults
8223
      --  and in family bounds.
8224
 
8225
      if Is_Concurrent_Type (Current_Scope)
8226
        or else Is_Limited_Type (Current_Scope)
8227
      then
8228
         CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
8229
 
8230
         Set_Ekind            (CR_Disc, E_In_Parameter);
8231
         Set_Mechanism        (CR_Disc, Default_Mechanism);
8232
         Set_Etype            (CR_Disc, Etype (Discrim));
8233
         Set_Scope            (CR_Disc, Current_Scope);
8234
         Set_Discriminal_Link (CR_Disc, Discrim);
8235
         Set_CR_Discriminant  (Discrim, CR_Disc);
8236
      end if;
8237
   end Build_Discriminal;
8238
 
8239
   ------------------------------------
8240
   -- Build_Discriminant_Constraints --
8241
   ------------------------------------
8242
 
8243
   function Build_Discriminant_Constraints
8244
     (T           : Entity_Id;
8245
      Def         : Node_Id;
8246
      Derived_Def : Boolean := False) return Elist_Id
8247
   is
8248
      C        : constant Node_Id := Constraint (Def);
8249
      Nb_Discr : constant Nat     := Number_Discriminants (T);
8250
 
8251
      Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
8252
      --  Saves the expression corresponding to a given discriminant in T
8253
 
8254
      function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
8255
      --  Return the Position number within array Discr_Expr of a discriminant
8256
      --  D within the discriminant list of the discriminated type T.
8257
 
8258
      ------------------
8259
      -- Pos_Of_Discr --
8260
      ------------------
8261
 
8262
      function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
8263
         Disc : Entity_Id;
8264
 
8265
      begin
8266
         Disc := First_Discriminant (T);
8267
         for J in Discr_Expr'Range loop
8268
            if Disc = D then
8269
               return J;
8270
            end if;
8271
 
8272
            Next_Discriminant (Disc);
8273
         end loop;
8274
 
8275
         --  Note: Since this function is called on discriminants that are
8276
         --  known to belong to the discriminated type, falling through the
8277
         --  loop with no match signals an internal compiler error.
8278
 
8279
         raise Program_Error;
8280
      end Pos_Of_Discr;
8281
 
8282
      --  Declarations local to Build_Discriminant_Constraints
8283
 
8284
      Discr : Entity_Id;
8285
      E     : Entity_Id;
8286
      Elist : constant Elist_Id := New_Elmt_List;
8287
 
8288
      Constr   : Node_Id;
8289
      Expr     : Node_Id;
8290
      Id       : Node_Id;
8291
      Position : Nat;
8292
      Found    : Boolean;
8293
 
8294
      Discrim_Present : Boolean := False;
8295
 
8296
   --  Start of processing for Build_Discriminant_Constraints
8297
 
8298
   begin
8299
      --  The following loop will process positional associations only.
8300
      --  For a positional association, the (single) discriminant is
8301
      --  implicitly specified by position, in textual order (RM 3.7.2).
8302
 
8303
      Discr  := First_Discriminant (T);
8304
      Constr := First (Constraints (C));
8305
      for D in Discr_Expr'Range loop
8306
         exit when Nkind (Constr) = N_Discriminant_Association;
8307
 
8308
         if No (Constr) then
8309
            Error_Msg_N ("too few discriminants given in constraint", C);
8310
            return New_Elmt_List;
8311
 
8312
         elsif Nkind (Constr) = N_Range
8313
           or else (Nkind (Constr) = N_Attribute_Reference
8314
                     and then
8315
                    Attribute_Name (Constr) = Name_Range)
8316
         then
8317
            Error_Msg_N
8318
              ("a range is not a valid discriminant constraint", Constr);
8319
            Discr_Expr (D) := Error;
8320
 
8321
         else
8322
            Analyze_And_Resolve (Constr, Base_Type (Etype (Discr)));
8323
            Discr_Expr (D) := Constr;
8324
         end if;
8325
 
8326
         Next_Discriminant (Discr);
8327
         Next (Constr);
8328
      end loop;
8329
 
8330
      if No (Discr) and then Present (Constr) then
8331
         Error_Msg_N ("too many discriminants given in constraint", Constr);
8332
         return New_Elmt_List;
8333
      end if;
8334
 
8335
      --  Named associations can be given in any order, but if both positional
8336
      --  and named associations are used in the same discriminant constraint,
8337
      --  then positional associations must occur first, at their normal
8338
      --  position. Hence once a named association is used, the rest of the
8339
      --  discriminant constraint must use only named associations.
8340
 
8341
      while Present (Constr) loop
8342
 
8343
         --  Positional association forbidden after a named association
8344
 
8345
         if Nkind (Constr) /= N_Discriminant_Association then
8346
            Error_Msg_N ("positional association follows named one", Constr);
8347
            return New_Elmt_List;
8348
 
8349
         --  Otherwise it is a named association
8350
 
8351
         else
8352
            --  E records the type of the discriminants in the named
8353
            --  association. All the discriminants specified in the same name
8354
            --  association must have the same type.
8355
 
8356
            E := Empty;
8357
 
8358
            --  Search the list of discriminants in T to see if the simple name
8359
            --  given in the constraint matches any of them.
8360
 
8361
            Id := First (Selector_Names (Constr));
8362
            while Present (Id) loop
8363
               Found := False;
8364
 
8365
               --  If Original_Discriminant is present, we are processing a
8366
               --  generic instantiation and this is an instance node. We need
8367
               --  to find the name of the corresponding discriminant in the
8368
               --  actual record type T and not the name of the discriminant in
8369
               --  the generic formal. Example:
8370
 
8371
               --    generic
8372
               --       type G (D : int) is private;
8373
               --    package P is
8374
               --       subtype W is G (D => 1);
8375
               --    end package;
8376
               --    type Rec (X : int) is record ... end record;
8377
               --    package Q is new P (G => Rec);
8378
 
8379
               --  At the point of the instantiation, formal type G is Rec
8380
               --  and therefore when reanalyzing "subtype W is G (D => 1);"
8381
               --  which really looks like "subtype W is Rec (D => 1);" at
8382
               --  the point of instantiation, we want to find the discriminant
8383
               --  that corresponds to D in Rec, i.e. X.
8384
 
8385
               if Present (Original_Discriminant (Id))
8386
                 and then In_Instance
8387
               then
8388
                  Discr := Find_Corresponding_Discriminant (Id, T);
8389
                  Found := True;
8390
 
8391
               else
8392
                  Discr := First_Discriminant (T);
8393
                  while Present (Discr) loop
8394
                     if Chars (Discr) = Chars (Id) then
8395
                        Found := True;
8396
                        exit;
8397
                     end if;
8398
 
8399
                     Next_Discriminant (Discr);
8400
                  end loop;
8401
 
8402
                  if not Found then
8403
                     Error_Msg_N ("& does not match any discriminant", Id);
8404
                     return New_Elmt_List;
8405
 
8406
                  --  If the parent type is a generic formal, preserve the
8407
                  --  name of the discriminant for subsequent instances.
8408
                  --  see comment at the beginning of this if statement.
8409
 
8410
                  elsif Is_Generic_Type (Root_Type (T)) then
8411
                     Set_Original_Discriminant (Id, Discr);
8412
                  end if;
8413
               end if;
8414
 
8415
               Position := Pos_Of_Discr (T, Discr);
8416
 
8417
               if Present (Discr_Expr (Position)) then
8418
                  Error_Msg_N ("duplicate constraint for discriminant&", Id);
8419
 
8420
               else
8421
                  --  Each discriminant specified in the same named association
8422
                  --  must be associated with a separate copy of the
8423
                  --  corresponding expression.
8424
 
8425
                  if Present (Next (Id)) then
8426
                     Expr := New_Copy_Tree (Expression (Constr));
8427
                     Set_Parent (Expr, Parent (Expression (Constr)));
8428
                  else
8429
                     Expr := Expression (Constr);
8430
                  end if;
8431
 
8432
                  Discr_Expr (Position) := Expr;
8433
                  Analyze_And_Resolve (Expr, Base_Type (Etype (Discr)));
8434
               end if;
8435
 
8436
               --  A discriminant association with more than one discriminant
8437
               --  name is only allowed if the named discriminants are all of
8438
               --  the same type (RM 3.7.1(8)).
8439
 
8440
               if E = Empty then
8441
                  E := Base_Type (Etype (Discr));
8442
 
8443
               elsif Base_Type (Etype (Discr)) /= E then
8444
                  Error_Msg_N
8445
                    ("all discriminants in an association " &
8446
                     "must have the same type", Id);
8447
               end if;
8448
 
8449
               Next (Id);
8450
            end loop;
8451
         end if;
8452
 
8453
         Next (Constr);
8454
      end loop;
8455
 
8456
      --  A discriminant constraint must provide exactly one value for each
8457
      --  discriminant of the type (RM 3.7.1(8)).
8458
 
8459
      for J in Discr_Expr'Range loop
8460
         if No (Discr_Expr (J)) then
8461
            Error_Msg_N ("too few discriminants given in constraint", C);
8462
            return New_Elmt_List;
8463
         end if;
8464
      end loop;
8465
 
8466
      --  Determine if there are discriminant expressions in the constraint
8467
 
8468
      for J in Discr_Expr'Range loop
8469
         if Denotes_Discriminant
8470
              (Discr_Expr (J), Check_Concurrent => True)
8471
         then
8472
            Discrim_Present := True;
8473
         end if;
8474
      end loop;
8475
 
8476
      --  Build an element list consisting of the expressions given in the
8477
      --  discriminant constraint and apply the appropriate checks. The list
8478
      --  is constructed after resolving any named discriminant associations
8479
      --  and therefore the expressions appear in the textual order of the
8480
      --  discriminants.
8481
 
8482
      Discr := First_Discriminant (T);
8483
      for J in Discr_Expr'Range loop
8484
         if Discr_Expr (J) /= Error then
8485
            Append_Elmt (Discr_Expr (J), Elist);
8486
 
8487
            --  If any of the discriminant constraints is given by a
8488
            --  discriminant and we are in a derived type declaration we
8489
            --  have a discriminant renaming. Establish link between new
8490
            --  and old discriminant.
8491
 
8492
            if Denotes_Discriminant (Discr_Expr (J)) then
8493
               if Derived_Def then
8494
                  Set_Corresponding_Discriminant
8495
                    (Entity (Discr_Expr (J)), Discr);
8496
               end if;
8497
 
8498
            --  Force the evaluation of non-discriminant expressions.
8499
            --  If we have found a discriminant in the constraint 3.4(26)
8500
            --  and 3.8(18) demand that no range checks are performed are
8501
            --  after evaluation. If the constraint is for a component
8502
            --  definition that has a per-object constraint, expressions are
8503
            --  evaluated but not checked either. In all other cases perform
8504
            --  a range check.
8505
 
8506
            else
8507
               if Discrim_Present then
8508
                  null;
8509
 
8510
               elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
8511
                 and then
8512
                   Has_Per_Object_Constraint
8513
                     (Defining_Identifier (Parent (Parent (Def))))
8514
               then
8515
                  null;
8516
 
8517
               elsif Is_Access_Type (Etype (Discr)) then
8518
                  Apply_Constraint_Check (Discr_Expr (J), Etype (Discr));
8519
 
8520
               else
8521
                  Apply_Range_Check (Discr_Expr (J), Etype (Discr));
8522
               end if;
8523
 
8524
               Force_Evaluation (Discr_Expr (J));
8525
            end if;
8526
 
8527
            --  Check that the designated type of an access discriminant's
8528
            --  expression is not a class-wide type unless the discriminant's
8529
            --  designated type is also class-wide.
8530
 
8531
            if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
8532
              and then not Is_Class_Wide_Type
8533
                         (Designated_Type (Etype (Discr)))
8534
              and then Etype (Discr_Expr (J)) /= Any_Type
8535
              and then Is_Class_Wide_Type
8536
                         (Designated_Type (Etype (Discr_Expr (J))))
8537
            then
8538
               Wrong_Type (Discr_Expr (J), Etype (Discr));
8539
 
8540
            elsif Is_Access_Type (Etype (Discr))
8541
              and then not Is_Access_Constant (Etype (Discr))
8542
              and then Is_Access_Type (Etype (Discr_Expr (J)))
8543
              and then Is_Access_Constant (Etype (Discr_Expr (J)))
8544
            then
8545
               Error_Msg_NE
8546
                 ("constraint for discriminant& must be access to variable",
8547
                    Def, Discr);
8548
            end if;
8549
         end if;
8550
 
8551
         Next_Discriminant (Discr);
8552
      end loop;
8553
 
8554
      return Elist;
8555
   end Build_Discriminant_Constraints;
8556
 
8557
   ---------------------------------
8558
   -- Build_Discriminated_Subtype --
8559
   ---------------------------------
8560
 
8561
   procedure Build_Discriminated_Subtype
8562
     (T           : Entity_Id;
8563
      Def_Id      : Entity_Id;
8564
      Elist       : Elist_Id;
8565
      Related_Nod : Node_Id;
8566
      For_Access  : Boolean := False)
8567
   is
8568
      Has_Discrs  : constant Boolean := Has_Discriminants (T);
8569
      Constrained : constant Boolean :=
8570
                      (Has_Discrs
8571
                         and then not Is_Empty_Elmt_List (Elist)
8572
                         and then not Is_Class_Wide_Type (T))
8573
                        or else Is_Constrained (T);
8574
 
8575
   begin
8576
      if Ekind (T) = E_Record_Type then
8577
         if For_Access then
8578
            Set_Ekind (Def_Id, E_Private_Subtype);
8579
            Set_Is_For_Access_Subtype (Def_Id, True);
8580
         else
8581
            Set_Ekind (Def_Id, E_Record_Subtype);
8582
         end if;
8583
 
8584
         --  Inherit preelaboration flag from base, for types for which it
8585
         --  may have been set: records, private types, protected types.
8586
 
8587
         Set_Known_To_Have_Preelab_Init
8588
           (Def_Id, Known_To_Have_Preelab_Init (T));
8589
 
8590
      elsif Ekind (T) = E_Task_Type then
8591
         Set_Ekind (Def_Id, E_Task_Subtype);
8592
 
8593
      elsif Ekind (T) = E_Protected_Type then
8594
         Set_Ekind (Def_Id, E_Protected_Subtype);
8595
         Set_Known_To_Have_Preelab_Init
8596
           (Def_Id, Known_To_Have_Preelab_Init (T));
8597
 
8598
      elsif Is_Private_Type (T) then
8599
         Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
8600
         Set_Known_To_Have_Preelab_Init
8601
           (Def_Id, Known_To_Have_Preelab_Init (T));
8602
 
8603
      elsif Is_Class_Wide_Type (T) then
8604
         Set_Ekind (Def_Id, E_Class_Wide_Subtype);
8605
 
8606
      else
8607
         --  Incomplete type. Attach subtype to list of dependents, to be
8608
         --  completed with full view of parent type,  unless is it the
8609
         --  designated subtype of a record component within an init_proc.
8610
         --  This last case arises for a component of an access type whose
8611
         --  designated type is incomplete (e.g. a Taft Amendment type).
8612
         --  The designated subtype is within an inner scope, and needs no
8613
         --  elaboration, because only the access type is needed in the
8614
         --  initialization procedure.
8615
 
8616
         Set_Ekind (Def_Id, Ekind (T));
8617
 
8618
         if For_Access and then Within_Init_Proc then
8619
            null;
8620
         else
8621
            Append_Elmt (Def_Id, Private_Dependents (T));
8622
         end if;
8623
      end if;
8624
 
8625
      Set_Etype             (Def_Id, T);
8626
      Init_Size_Align       (Def_Id);
8627
      Set_Has_Discriminants (Def_Id, Has_Discrs);
8628
      Set_Is_Constrained    (Def_Id, Constrained);
8629
 
8630
      Set_First_Entity      (Def_Id, First_Entity   (T));
8631
      Set_Last_Entity       (Def_Id, Last_Entity    (T));
8632
      Set_Has_Implicit_Dereference
8633
                            (Def_Id, Has_Implicit_Dereference (T));
8634
 
8635
      --  If the subtype is the completion of a private declaration, there may
8636
      --  have been representation clauses for the partial view, and they must
8637
      --  be preserved. Build_Derived_Type chains the inherited clauses with
8638
      --  the ones appearing on the extension. If this comes from a subtype
8639
      --  declaration, all clauses are inherited.
8640
 
8641
      if No (First_Rep_Item (Def_Id)) then
8642
         Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
8643
      end if;
8644
 
8645
      if Is_Tagged_Type (T) then
8646
         Set_Is_Tagged_Type (Def_Id);
8647
         Make_Class_Wide_Type (Def_Id);
8648
      end if;
8649
 
8650
      Set_Stored_Constraint (Def_Id, No_Elist);
8651
 
8652
      if Has_Discrs then
8653
         Set_Discriminant_Constraint (Def_Id, Elist);
8654
         Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id);
8655
      end if;
8656
 
8657
      if Is_Tagged_Type (T) then
8658
 
8659
         --  Ada 2005 (AI-251): In case of concurrent types we inherit the
8660
         --  concurrent record type (which has the list of primitive
8661
         --  operations).
8662
 
8663
         if Ada_Version >= Ada_2005
8664
           and then Is_Concurrent_Type (T)
8665
         then
8666
            Set_Corresponding_Record_Type (Def_Id,
8667
               Corresponding_Record_Type (T));
8668
         else
8669
            Set_Direct_Primitive_Operations (Def_Id,
8670
              Direct_Primitive_Operations (T));
8671
         end if;
8672
 
8673
         Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
8674
      end if;
8675
 
8676
      --  Subtypes introduced by component declarations do not need to be
8677
      --  marked as delayed, and do not get freeze nodes, because the semantics
8678
      --  verifies that the parents of the subtypes are frozen before the
8679
      --  enclosing record is frozen.
8680
 
8681
      if not Is_Type (Scope (Def_Id)) then
8682
         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
8683
 
8684
         if Is_Private_Type (T)
8685
           and then Present (Full_View (T))
8686
         then
8687
            Conditional_Delay (Def_Id, Full_View (T));
8688
         else
8689
            Conditional_Delay (Def_Id, T);
8690
         end if;
8691
      end if;
8692
 
8693
      if Is_Record_Type (T) then
8694
         Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
8695
 
8696
         if Has_Discrs
8697
            and then not Is_Empty_Elmt_List (Elist)
8698
            and then not For_Access
8699
         then
8700
            Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
8701
         elsif not For_Access then
8702
            Set_Cloned_Subtype (Def_Id, T);
8703
         end if;
8704
      end if;
8705
   end Build_Discriminated_Subtype;
8706
 
8707
   ---------------------------
8708
   -- Build_Itype_Reference --
8709
   ---------------------------
8710
 
8711
   procedure Build_Itype_Reference
8712
     (Ityp : Entity_Id;
8713
      Nod  : Node_Id)
8714
   is
8715
      IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod));
8716
   begin
8717
 
8718
      --  Itype references are only created for use by the back-end
8719
 
8720
      if Inside_A_Generic then
8721
         return;
8722
      else
8723
         Set_Itype (IR, Ityp);
8724
         Insert_After (Nod, IR);
8725
      end if;
8726
   end Build_Itype_Reference;
8727
 
8728
   ------------------------
8729
   -- Build_Scalar_Bound --
8730
   ------------------------
8731
 
8732
   function Build_Scalar_Bound
8733
     (Bound : Node_Id;
8734
      Par_T : Entity_Id;
8735
      Der_T : Entity_Id) return Node_Id
8736
   is
8737
      New_Bound : Entity_Id;
8738
 
8739
   begin
8740
      --  Note: not clear why this is needed, how can the original bound
8741
      --  be unanalyzed at this point? and if it is, what business do we
8742
      --  have messing around with it? and why is the base type of the
8743
      --  parent type the right type for the resolution. It probably is
8744
      --  not! It is OK for the new bound we are creating, but not for
8745
      --  the old one??? Still if it never happens, no problem!
8746
 
8747
      Analyze_And_Resolve (Bound, Base_Type (Par_T));
8748
 
8749
      if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then
8750
         New_Bound := New_Copy (Bound);
8751
         Set_Etype (New_Bound, Der_T);
8752
         Set_Analyzed (New_Bound);
8753
 
8754
      elsif Is_Entity_Name (Bound) then
8755
         New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
8756
 
8757
      --  The following is almost certainly wrong. What business do we have
8758
      --  relocating a node (Bound) that is presumably still attached to
8759
      --  the tree elsewhere???
8760
 
8761
      else
8762
         New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
8763
      end if;
8764
 
8765
      Set_Etype (New_Bound, Der_T);
8766
      return New_Bound;
8767
   end Build_Scalar_Bound;
8768
 
8769
   --------------------------------
8770
   -- Build_Underlying_Full_View --
8771
   --------------------------------
8772
 
8773
   procedure Build_Underlying_Full_View
8774
     (N   : Node_Id;
8775
      Typ : Entity_Id;
8776
      Par : Entity_Id)
8777
   is
8778
      Loc  : constant Source_Ptr := Sloc (N);
8779
      Subt : constant Entity_Id :=
8780
               Make_Defining_Identifier
8781
                 (Loc, New_External_Name (Chars (Typ), 'S'));
8782
 
8783
      Constr : Node_Id;
8784
      Indic  : Node_Id;
8785
      C      : Node_Id;
8786
      Id     : Node_Id;
8787
 
8788
      procedure Set_Discriminant_Name (Id : Node_Id);
8789
      --  If the derived type has discriminants, they may rename discriminants
8790
      --  of the parent. When building the full view of the parent, we need to
8791
      --  recover the names of the original discriminants if the constraint is
8792
      --  given by named associations.
8793
 
8794
      ---------------------------
8795
      -- Set_Discriminant_Name --
8796
      ---------------------------
8797
 
8798
      procedure Set_Discriminant_Name (Id : Node_Id) is
8799
         Disc : Entity_Id;
8800
 
8801
      begin
8802
         Set_Original_Discriminant (Id, Empty);
8803
 
8804
         if Has_Discriminants (Typ) then
8805
            Disc := First_Discriminant (Typ);
8806
            while Present (Disc) loop
8807
               if Chars (Disc) = Chars (Id)
8808
                 and then Present (Corresponding_Discriminant (Disc))
8809
               then
8810
                  Set_Chars (Id, Chars (Corresponding_Discriminant (Disc)));
8811
               end if;
8812
               Next_Discriminant (Disc);
8813
            end loop;
8814
         end if;
8815
      end Set_Discriminant_Name;
8816
 
8817
   --  Start of processing for Build_Underlying_Full_View
8818
 
8819
   begin
8820
      if Nkind (N) = N_Full_Type_Declaration then
8821
         Constr := Constraint (Subtype_Indication (Type_Definition (N)));
8822
 
8823
      elsif Nkind (N) = N_Subtype_Declaration then
8824
         Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
8825
 
8826
      elsif Nkind (N) = N_Component_Declaration then
8827
         Constr :=
8828
           New_Copy_Tree
8829
             (Constraint (Subtype_Indication (Component_Definition (N))));
8830
 
8831
      else
8832
         raise Program_Error;
8833
      end if;
8834
 
8835
      C := First (Constraints (Constr));
8836
      while Present (C) loop
8837
         if Nkind (C) = N_Discriminant_Association then
8838
            Id := First (Selector_Names (C));
8839
            while Present (Id) loop
8840
               Set_Discriminant_Name (Id);
8841
               Next (Id);
8842
            end loop;
8843
         end if;
8844
 
8845
         Next (C);
8846
      end loop;
8847
 
8848
      Indic :=
8849
        Make_Subtype_Declaration (Loc,
8850
          Defining_Identifier => Subt,
8851
          Subtype_Indication  =>
8852
            Make_Subtype_Indication (Loc,
8853
              Subtype_Mark => New_Reference_To (Par, Loc),
8854
              Constraint   => New_Copy_Tree (Constr)));
8855
 
8856
      --  If this is a component subtype for an outer itype, it is not
8857
      --  a list member, so simply set the parent link for analysis: if
8858
      --  the enclosing type does not need to be in a declarative list,
8859
      --  neither do the components.
8860
 
8861
      if Is_List_Member (N)
8862
        and then Nkind (N) /= N_Component_Declaration
8863
      then
8864
         Insert_Before (N, Indic);
8865
      else
8866
         Set_Parent (Indic, Parent (N));
8867
      end if;
8868
 
8869
      Analyze (Indic);
8870
      Set_Underlying_Full_View (Typ, Full_View (Subt));
8871
   end Build_Underlying_Full_View;
8872
 
8873
   -------------------------------
8874
   -- Check_Abstract_Overriding --
8875
   -------------------------------
8876
 
8877
   procedure Check_Abstract_Overriding (T : Entity_Id) is
8878
      Alias_Subp : Entity_Id;
8879
      Elmt       : Elmt_Id;
8880
      Op_List    : Elist_Id;
8881
      Subp       : Entity_Id;
8882
      Type_Def   : Node_Id;
8883
 
8884
      procedure Check_Pragma_Implemented (Subp : Entity_Id);
8885
      --  Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine
8886
      --  which has pragma Implemented already set. Check whether Subp's entity
8887
      --  kind conforms to the implementation kind of the overridden routine.
8888
 
8889
      procedure Check_Pragma_Implemented
8890
        (Subp       : Entity_Id;
8891
         Iface_Subp : Entity_Id);
8892
      --  Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine
8893
      --  Iface_Subp and both entities have pragma Implemented already set on
8894
      --  them. Check whether the two implementation kinds are conforming.
8895
 
8896
      procedure Inherit_Pragma_Implemented
8897
        (Subp       : Entity_Id;
8898
         Iface_Subp : Entity_Id);
8899
      --  Ada 2012 (AI05-0030): Interface primitive Subp overrides interface
8900
      --  subprogram Iface_Subp which has been marked by pragma Implemented.
8901
      --  Propagate the implementation kind of Iface_Subp to Subp.
8902
 
8903
      ------------------------------
8904
      -- Check_Pragma_Implemented --
8905
      ------------------------------
8906
 
8907
      procedure Check_Pragma_Implemented (Subp : Entity_Id) is
8908
         Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
8909
         Impl_Kind   : constant Name_Id   := Implementation_Kind (Iface_Alias);
8910
         Subp_Alias  : constant Entity_Id := Alias (Subp);
8911
         Contr_Typ   : Entity_Id;
8912
         Impl_Subp   : Entity_Id;
8913
 
8914
      begin
8915
         --  Subp must have an alias since it is a hidden entity used to link
8916
         --  an interface subprogram to its overriding counterpart.
8917
 
8918
         pragma Assert (Present (Subp_Alias));
8919
 
8920
         --  Handle aliases to synchronized wrappers
8921
 
8922
         Impl_Subp := Subp_Alias;
8923
 
8924
         if Is_Primitive_Wrapper (Impl_Subp) then
8925
            Impl_Subp := Wrapped_Entity (Impl_Subp);
8926
         end if;
8927
 
8928
         --  Extract the type of the controlling formal
8929
 
8930
         Contr_Typ := Etype (First_Formal (Subp_Alias));
8931
 
8932
         if Is_Concurrent_Record_Type (Contr_Typ) then
8933
            Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
8934
         end if;
8935
 
8936
         --  An interface subprogram whose implementation kind is By_Entry must
8937
         --  be implemented by an entry.
8938
 
8939
         if Impl_Kind = Name_By_Entry
8940
           and then Ekind (Impl_Subp) /= E_Entry
8941
         then
8942
            Error_Msg_Node_2 := Iface_Alias;
8943
            Error_Msg_NE
8944
              ("type & must implement abstract subprogram & with an entry",
8945
               Subp_Alias, Contr_Typ);
8946
 
8947
         elsif Impl_Kind = Name_By_Protected_Procedure then
8948
 
8949
            --  An interface subprogram whose implementation kind is By_
8950
            --  Protected_Procedure cannot be implemented by a primitive
8951
            --  procedure of a task type.
8952
 
8953
            if Ekind (Contr_Typ) /= E_Protected_Type then
8954
               Error_Msg_Node_2 := Contr_Typ;
8955
               Error_Msg_NE
8956
                 ("interface subprogram & cannot be implemented by a " &
8957
                  "primitive procedure of task type &", Subp_Alias,
8958
                  Iface_Alias);
8959
 
8960
            --  An interface subprogram whose implementation kind is By_
8961
            --  Protected_Procedure must be implemented by a procedure.
8962
 
8963
            elsif Ekind (Impl_Subp) /= E_Procedure then
8964
               Error_Msg_Node_2 := Iface_Alias;
8965
               Error_Msg_NE
8966
                 ("type & must implement abstract subprogram & with a " &
8967
                  "procedure", Subp_Alias, Contr_Typ);
8968
            end if;
8969
         end if;
8970
      end Check_Pragma_Implemented;
8971
 
8972
      ------------------------------
8973
      -- Check_Pragma_Implemented --
8974
      ------------------------------
8975
 
8976
      procedure Check_Pragma_Implemented
8977
        (Subp       : Entity_Id;
8978
         Iface_Subp : Entity_Id)
8979
      is
8980
         Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp);
8981
         Subp_Kind  : constant Name_Id := Implementation_Kind (Subp);
8982
 
8983
      begin
8984
         --  Ada 2012 (AI05-0030): The implementation kinds of an overridden
8985
         --  and overriding subprogram are different. In general this is an
8986
         --  error except when the implementation kind of the overridden
8987
         --  subprograms is By_Any or Optional.
8988
 
8989
         if Iface_Kind /= Subp_Kind
8990
           and then Iface_Kind /= Name_By_Any
8991
           and then Iface_Kind /= Name_Optional
8992
         then
8993
            if Iface_Kind = Name_By_Entry then
8994
               Error_Msg_N
8995
                 ("incompatible implementation kind, overridden subprogram " &
8996
                  "is marked By_Entry", Subp);
8997
            else
8998
               Error_Msg_N
8999
                 ("incompatible implementation kind, overridden subprogram " &
9000
                  "is marked By_Protected_Procedure", Subp);
9001
            end if;
9002
         end if;
9003
      end Check_Pragma_Implemented;
9004
 
9005
      --------------------------------
9006
      -- Inherit_Pragma_Implemented --
9007
      --------------------------------
9008
 
9009
      procedure Inherit_Pragma_Implemented
9010
        (Subp       : Entity_Id;
9011
         Iface_Subp : Entity_Id)
9012
      is
9013
         Iface_Kind : constant Name_Id    := Implementation_Kind (Iface_Subp);
9014
         Loc        : constant Source_Ptr := Sloc (Subp);
9015
         Impl_Prag  : Node_Id;
9016
 
9017
      begin
9018
         --  Since the implementation kind is stored as a representation item
9019
         --  rather than a flag, create a pragma node.
9020
 
9021
         Impl_Prag :=
9022
           Make_Pragma (Loc,
9023
             Chars => Name_Implemented,
9024
             Pragma_Argument_Associations => New_List (
9025
               Make_Pragma_Argument_Association (Loc,
9026
                 Expression =>
9027
                   New_Reference_To (Subp, Loc)),
9028
 
9029
               Make_Pragma_Argument_Association (Loc,
9030
                 Expression => Make_Identifier (Loc, Iface_Kind))));
9031
 
9032
         --  The pragma doesn't need to be analyzed because it is internally
9033
         --  build. It is safe to directly register it as a rep item since we
9034
         --  are only interested in the characters of the implementation kind.
9035
 
9036
         Record_Rep_Item (Subp, Impl_Prag);
9037
      end Inherit_Pragma_Implemented;
9038
 
9039
   --  Start of processing for Check_Abstract_Overriding
9040
 
9041
   begin
9042
      Op_List := Primitive_Operations (T);
9043
 
9044
      --  Loop to check primitive operations
9045
 
9046
      Elmt := First_Elmt (Op_List);
9047
      while Present (Elmt) loop
9048
         Subp := Node (Elmt);
9049
         Alias_Subp := Alias (Subp);
9050
 
9051
         --  Inherited subprograms are identified by the fact that they do not
9052
         --  come from source, and the associated source location is the
9053
         --  location of the first subtype of the derived type.
9054
 
9055
         --  Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for
9056
         --  subprograms that "require overriding".
9057
 
9058
         --  Special exception, do not complain about failure to override the
9059
         --  stream routines _Input and _Output, as well as the primitive
9060
         --  operations used in dispatching selects since we always provide
9061
         --  automatic overridings for these subprograms.
9062
 
9063
         --  Also ignore this rule for convention CIL since .NET libraries
9064
         --  do bizarre things with interfaces???
9065
 
9066
         --  The partial view of T may have been a private extension, for
9067
         --  which inherited functions dispatching on result are abstract.
9068
         --  If the full view is a null extension, there is no need for
9069
         --  overriding in Ada 2005, but wrappers need to be built for them
9070
         --  (see exp_ch3, Build_Controlling_Function_Wrappers).
9071
 
9072
         if Is_Null_Extension (T)
9073
           and then Has_Controlling_Result (Subp)
9074
           and then Ada_Version >= Ada_2005
9075
           and then Present (Alias_Subp)
9076
           and then not Comes_From_Source (Subp)
9077
           and then not Is_Abstract_Subprogram (Alias_Subp)
9078
           and then not Is_Access_Type (Etype (Subp))
9079
         then
9080
            null;
9081
 
9082
         --  Ada 2005 (AI-251): Internal entities of interfaces need no
9083
         --  processing because this check is done with the aliased
9084
         --  entity
9085
 
9086
         elsif Present (Interface_Alias (Subp)) then
9087
            null;
9088
 
9089
         elsif (Is_Abstract_Subprogram (Subp)
9090
                 or else Requires_Overriding (Subp)
9091
                 or else
9092
                   (Has_Controlling_Result (Subp)
9093
                     and then Present (Alias_Subp)
9094
                     and then not Comes_From_Source (Subp)
9095
                     and then Sloc (Subp) = Sloc (First_Subtype (T))))
9096
           and then not Is_TSS (Subp, TSS_Stream_Input)
9097
           and then not Is_TSS (Subp, TSS_Stream_Output)
9098
           and then not Is_Abstract_Type (T)
9099
           and then Convention (T) /= Convention_CIL
9100
           and then not Is_Predefined_Interface_Primitive (Subp)
9101
 
9102
            --  Ada 2005 (AI-251): Do not consider hidden entities associated
9103
            --  with abstract interface types because the check will be done
9104
            --  with the aliased entity (otherwise we generate a duplicated
9105
            --  error message).
9106
 
9107
           and then not Present (Interface_Alias (Subp))
9108
         then
9109
            if Present (Alias_Subp) then
9110
 
9111
               --  Only perform the check for a derived subprogram when the
9112
               --  type has an explicit record extension. This avoids incorrect
9113
               --  flagging of abstract subprograms for the case of a type
9114
               --  without an extension that is derived from a formal type
9115
               --  with a tagged actual (can occur within a private part).
9116
 
9117
               --  Ada 2005 (AI-391): In the case of an inherited function with
9118
               --  a controlling result of the type, the rule does not apply if
9119
               --  the type is a null extension (unless the parent function
9120
               --  itself is abstract, in which case the function must still be
9121
               --  be overridden). The expander will generate an overriding
9122
               --  wrapper function calling the parent subprogram (see
9123
               --  Exp_Ch3.Make_Controlling_Wrapper_Functions).
9124
 
9125
               Type_Def := Type_Definition (Parent (T));
9126
 
9127
               if Nkind (Type_Def) = N_Derived_Type_Definition
9128
                 and then Present (Record_Extension_Part (Type_Def))
9129
                 and then
9130
                   (Ada_Version < Ada_2005
9131
                      or else not Is_Null_Extension (T)
9132
                      or else Ekind (Subp) = E_Procedure
9133
                      or else not Has_Controlling_Result (Subp)
9134
                      or else Is_Abstract_Subprogram (Alias_Subp)
9135
                      or else Requires_Overriding (Subp)
9136
                      or else Is_Access_Type (Etype (Subp)))
9137
               then
9138
                  --  Avoid reporting error in case of abstract predefined
9139
                  --  primitive inherited from interface type because the
9140
                  --  body of internally generated predefined primitives
9141
                  --  of tagged types are generated later by Freeze_Type
9142
 
9143
                  if Is_Interface (Root_Type (T))
9144
                    and then Is_Abstract_Subprogram (Subp)
9145
                    and then Is_Predefined_Dispatching_Operation (Subp)
9146
                    and then not Comes_From_Source (Ultimate_Alias (Subp))
9147
                  then
9148
                     null;
9149
 
9150
                  else
9151
                     Error_Msg_NE
9152
                       ("type must be declared abstract or & overridden",
9153
                        T, Subp);
9154
 
9155
                     --  Traverse the whole chain of aliased subprograms to
9156
                     --  complete the error notification. This is especially
9157
                     --  useful for traceability of the chain of entities when
9158
                     --  the subprogram corresponds with an interface
9159
                     --  subprogram (which may be defined in another package).
9160
 
9161
                     if Present (Alias_Subp) then
9162
                        declare
9163
                           E : Entity_Id;
9164
 
9165
                        begin
9166
                           E := Subp;
9167
                           while Present (Alias (E)) loop
9168
 
9169
                              --  Avoid reporting redundant errors on entities
9170
                              --  inherited from interfaces
9171
 
9172
                              if Sloc (E) /= Sloc (T) then
9173
                                 Error_Msg_Sloc := Sloc (E);
9174
                                 Error_Msg_NE
9175
                                   ("\& has been inherited #", T, Subp);
9176
                              end if;
9177
 
9178
                              E := Alias (E);
9179
                           end loop;
9180
 
9181
                           Error_Msg_Sloc := Sloc (E);
9182
 
9183
                           --  AI05-0068: report if there is an overriding
9184
                           --  non-abstract subprogram that is invisible.
9185
 
9186
                           if Is_Hidden (E)
9187
                             and then not Is_Abstract_Subprogram (E)
9188
                           then
9189
                              Error_Msg_NE
9190
                                ("\& subprogram# is not visible",
9191
                                 T, Subp);
9192
 
9193
                           else
9194
                              Error_Msg_NE
9195
                                ("\& has been inherited from subprogram #",
9196
                                 T, Subp);
9197
                           end if;
9198
                        end;
9199
                     end if;
9200
                  end if;
9201
 
9202
               --  Ada 2005 (AI-345): Protected or task type implementing
9203
               --  abstract interfaces.
9204
 
9205
               elsif Is_Concurrent_Record_Type (T)
9206
                 and then Present (Interfaces (T))
9207
               then
9208
                  --  The controlling formal of Subp must be of mode "out",
9209
                  --  "in out" or an access-to-variable to be overridden.
9210
 
9211
                  if Ekind (First_Formal (Subp)) = E_In_Parameter
9212
                    and then Ekind (Subp) /= E_Function
9213
                  then
9214
                     if not Is_Predefined_Dispatching_Operation (Subp)
9215
                       and then Is_Protected_Type
9216
                                  (Corresponding_Concurrent_Type (T))
9217
                     then
9218
                        Error_Msg_PT (T, Subp);
9219
                     end if;
9220
 
9221
                  --  Some other kind of overriding failure
9222
 
9223
                  else
9224
                     Error_Msg_NE
9225
                       ("interface subprogram & must be overridden",
9226
                        T, Subp);
9227
 
9228
                     --  Examine primitive operations of synchronized type,
9229
                     --  to find homonyms that have the wrong profile.
9230
 
9231
                     declare
9232
                        Prim : Entity_Id;
9233
 
9234
                     begin
9235
                        Prim :=
9236
                          First_Entity (Corresponding_Concurrent_Type (T));
9237
                        while Present (Prim) loop
9238
                           if Chars (Prim) = Chars (Subp) then
9239
                              Error_Msg_NE
9240
                                ("profile is not type conformant with "
9241
                                   & "prefixed view profile of "
9242
                                   & "inherited operation&", Prim, Subp);
9243
                           end if;
9244
 
9245
                           Next_Entity (Prim);
9246
                        end loop;
9247
                     end;
9248
                  end if;
9249
               end if;
9250
 
9251
            else
9252
               Error_Msg_Node_2 := T;
9253
               Error_Msg_N
9254
                 ("abstract subprogram& not allowed for type&", Subp);
9255
 
9256
               --  Also post unconditional warning on the type (unconditional
9257
               --  so that if there are more than one of these cases, we get
9258
               --  them all, and not just the first one).
9259
 
9260
               Error_Msg_Node_2 := Subp;
9261
               Error_Msg_N ("nonabstract type& has abstract subprogram&!", T);
9262
            end if;
9263
         end if;
9264
 
9265
         --  Ada 2012 (AI05-0030): Perform some checks related to pragma
9266
         --  Implemented
9267
 
9268
         --  Subp is an expander-generated procedure which maps an interface
9269
         --  alias to a protected wrapper. The interface alias is flagged by
9270
         --  pragma Implemented. Ensure that Subp is a procedure when the
9271
         --  implementation kind is By_Protected_Procedure or an entry when
9272
         --  By_Entry.
9273
 
9274
         if Ada_Version >= Ada_2012
9275
           and then Is_Hidden (Subp)
9276
           and then Present (Interface_Alias (Subp))
9277
           and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented)
9278
         then
9279
            Check_Pragma_Implemented (Subp);
9280
         end if;
9281
 
9282
         --  Subp is an interface primitive which overrides another interface
9283
         --  primitive marked with pragma Implemented.
9284
 
9285
         if Ada_Version >= Ada_2012
9286
           and then Present (Overridden_Operation (Subp))
9287
           and then Has_Rep_Pragma
9288
                      (Overridden_Operation (Subp), Name_Implemented)
9289
         then
9290
            --  If the overriding routine is also marked by Implemented, check
9291
            --  that the two implementation kinds are conforming.
9292
 
9293
            if Has_Rep_Pragma (Subp, Name_Implemented) then
9294
               Check_Pragma_Implemented
9295
                 (Subp       => Subp,
9296
                  Iface_Subp => Overridden_Operation (Subp));
9297
 
9298
            --  Otherwise the overriding routine inherits the implementation
9299
            --  kind from the overridden subprogram.
9300
 
9301
            else
9302
               Inherit_Pragma_Implemented
9303
                 (Subp       => Subp,
9304
                  Iface_Subp => Overridden_Operation (Subp));
9305
            end if;
9306
         end if;
9307
 
9308
         Next_Elmt (Elmt);
9309
      end loop;
9310
   end Check_Abstract_Overriding;
9311
 
9312
   ------------------------------------------------
9313
   -- Check_Access_Discriminant_Requires_Limited --
9314
   ------------------------------------------------
9315
 
9316
   procedure Check_Access_Discriminant_Requires_Limited
9317
     (D   : Node_Id;
9318
      Loc : Node_Id)
9319
   is
9320
   begin
9321
      --  A discriminant_specification for an access discriminant shall appear
9322
      --  only in the declaration for a task or protected type, or for a type
9323
      --  with the reserved word 'limited' in its definition or in one of its
9324
      --  ancestors (RM 3.7(10)).
9325
 
9326
      --  AI-0063: The proper condition is that type must be immutably limited,
9327
      --  or else be a partial view.
9328
 
9329
      if Nkind (Discriminant_Type (D)) = N_Access_Definition then
9330
         if Is_Immutably_Limited_Type (Current_Scope)
9331
           or else
9332
             (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration
9333
               and then Limited_Present (Parent (Current_Scope)))
9334
         then
9335
            null;
9336
 
9337
         else
9338
            Error_Msg_N
9339
              ("access discriminants allowed only for limited types", Loc);
9340
         end if;
9341
      end if;
9342
   end Check_Access_Discriminant_Requires_Limited;
9343
 
9344
   -----------------------------------
9345
   -- Check_Aliased_Component_Types --
9346
   -----------------------------------
9347
 
9348
   procedure Check_Aliased_Component_Types (T : Entity_Id) is
9349
      C : Entity_Id;
9350
 
9351
   begin
9352
      --  ??? Also need to check components of record extensions, but not
9353
      --  components of protected types (which are always limited).
9354
 
9355
      --  Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
9356
      --  types to be unconstrained. This is safe because it is illegal to
9357
      --  create access subtypes to such types with explicit discriminant
9358
      --  constraints.
9359
 
9360
      if not Is_Limited_Type (T) then
9361
         if Ekind (T) = E_Record_Type then
9362
            C := First_Component (T);
9363
            while Present (C) loop
9364
               if Is_Aliased (C)
9365
                 and then Has_Discriminants (Etype (C))
9366
                 and then not Is_Constrained (Etype (C))
9367
                 and then not In_Instance_Body
9368
                 and then Ada_Version < Ada_2005
9369
               then
9370
                  Error_Msg_N
9371
                    ("aliased component must be constrained (RM 3.6(11))",
9372
                      C);
9373
               end if;
9374
 
9375
               Next_Component (C);
9376
            end loop;
9377
 
9378
         elsif Ekind (T) = E_Array_Type then
9379
            if Has_Aliased_Components (T)
9380
              and then Has_Discriminants (Component_Type (T))
9381
              and then not Is_Constrained (Component_Type (T))
9382
              and then not In_Instance_Body
9383
              and then Ada_Version < Ada_2005
9384
            then
9385
               Error_Msg_N
9386
                 ("aliased component type must be constrained (RM 3.6(11))",
9387
                    T);
9388
            end if;
9389
         end if;
9390
      end if;
9391
   end Check_Aliased_Component_Types;
9392
 
9393
   ----------------------
9394
   -- Check_Completion --
9395
   ----------------------
9396
 
9397
   procedure Check_Completion (Body_Id : Node_Id := Empty) is
9398
      E : Entity_Id;
9399
 
9400
      procedure Post_Error;
9401
      --  Post error message for lack of completion for entity E
9402
 
9403
      ----------------
9404
      -- Post_Error --
9405
      ----------------
9406
 
9407
      procedure Post_Error is
9408
 
9409
         procedure Missing_Body;
9410
         --  Output missing body message
9411
 
9412
         ------------------
9413
         -- Missing_Body --
9414
         ------------------
9415
 
9416
         procedure Missing_Body is
9417
         begin
9418
            --  Spec is in same unit, so we can post on spec
9419
 
9420
            if In_Same_Source_Unit (Body_Id, E) then
9421
               Error_Msg_N ("missing body for &", E);
9422
 
9423
            --  Spec is in a separate unit, so we have to post on the body
9424
 
9425
            else
9426
               Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
9427
            end if;
9428
         end Missing_Body;
9429
 
9430
      --  Start of processing for Post_Error
9431
 
9432
      begin
9433
         if not Comes_From_Source (E) then
9434
 
9435
            if Ekind_In (E, E_Task_Type, E_Protected_Type) then
9436
               --  It may be an anonymous protected type created for a
9437
               --  single variable. Post error on variable, if present.
9438
 
9439
               declare
9440
                  Var : Entity_Id;
9441
 
9442
               begin
9443
                  Var := First_Entity (Current_Scope);
9444
                  while Present (Var) loop
9445
                     exit when Etype (Var) = E
9446
                       and then Comes_From_Source (Var);
9447
 
9448
                     Next_Entity (Var);
9449
                  end loop;
9450
 
9451
                  if Present (Var) then
9452
                     E := Var;
9453
                  end if;
9454
               end;
9455
            end if;
9456
         end if;
9457
 
9458
         --  If a generated entity has no completion, then either previous
9459
         --  semantic errors have disabled the expansion phase, or else we had
9460
         --  missing subunits, or else we are compiling without expansion,
9461
         --  or else something is very wrong.
9462
 
9463
         if not Comes_From_Source (E) then
9464
            pragma Assert
9465
              (Serious_Errors_Detected > 0
9466
                or else Configurable_Run_Time_Violations > 0
9467
                or else Subunits_Missing
9468
                or else not Expander_Active);
9469
            return;
9470
 
9471
         --  Here for source entity
9472
 
9473
         else
9474
            --  Here if no body to post the error message, so we post the error
9475
            --  on the declaration that has no completion. This is not really
9476
            --  the right place to post it, think about this later ???
9477
 
9478
            if No (Body_Id) then
9479
               if Is_Type (E) then
9480
                  Error_Msg_NE
9481
                    ("missing full declaration for }", Parent (E), E);
9482
               else
9483
                  Error_Msg_NE ("missing body for &", Parent (E), E);
9484
               end if;
9485
 
9486
            --  Package body has no completion for a declaration that appears
9487
            --  in the corresponding spec. Post error on the body, with a
9488
            --  reference to the non-completed declaration.
9489
 
9490
            else
9491
               Error_Msg_Sloc := Sloc (E);
9492
 
9493
               if Is_Type (E) then
9494
                  Error_Msg_NE ("missing full declaration for }!", Body_Id, E);
9495
 
9496
               elsif Is_Overloadable (E)
9497
                 and then Current_Entity_In_Scope (E) /= E
9498
               then
9499
                  --  It may be that the completion is mistyped and appears as
9500
                  --  a distinct overloading of the entity.
9501
 
9502
                  declare
9503
                     Candidate : constant Entity_Id :=
9504
                                   Current_Entity_In_Scope (E);
9505
                     Decl      : constant Node_Id :=
9506
                                   Unit_Declaration_Node (Candidate);
9507
 
9508
                  begin
9509
                     if Is_Overloadable (Candidate)
9510
                       and then Ekind (Candidate) = Ekind (E)
9511
                       and then Nkind (Decl) = N_Subprogram_Body
9512
                       and then Acts_As_Spec (Decl)
9513
                     then
9514
                        Check_Type_Conformant (Candidate, E);
9515
 
9516
                     else
9517
                        Missing_Body;
9518
                     end if;
9519
                  end;
9520
 
9521
               else
9522
                  Missing_Body;
9523
               end if;
9524
            end if;
9525
         end if;
9526
      end Post_Error;
9527
 
9528
   --  Start of processing for Check_Completion
9529
 
9530
   begin
9531
      E := First_Entity (Current_Scope);
9532
      while Present (E) loop
9533
         if Is_Intrinsic_Subprogram (E) then
9534
            null;
9535
 
9536
         --  The following situation requires special handling: a child unit
9537
         --  that appears in the context clause of the body of its parent:
9538
 
9539
         --    procedure Parent.Child (...);
9540
 
9541
         --    with Parent.Child;
9542
         --    package body Parent is
9543
 
9544
         --  Here Parent.Child appears as a local entity, but should not be
9545
         --  flagged as requiring completion, because it is a compilation
9546
         --  unit.
9547
 
9548
         --  Ignore missing completion for a subprogram that does not come from
9549
         --  source (including the _Call primitive operation of RAS types,
9550
         --  which has to have the flag Comes_From_Source for other purposes):
9551
         --  we assume that the expander will provide the missing completion.
9552
         --  In case of previous errors, other expansion actions that provide
9553
         --  bodies for null procedures with not be invoked, so inhibit message
9554
         --  in those cases.
9555
 
9556
         --  Note that E_Operator is not in the list that follows, because
9557
         --  this kind is reserved for predefined operators, that are
9558
         --  intrinsic and do not need completion.
9559
 
9560
         elsif     Ekind (E) = E_Function
9561
           or else Ekind (E) = E_Procedure
9562
           or else Ekind (E) = E_Generic_Function
9563
           or else Ekind (E) = E_Generic_Procedure
9564
         then
9565
            if Has_Completion (E) then
9566
               null;
9567
 
9568
            elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
9569
               null;
9570
 
9571
            elsif Is_Subprogram (E)
9572
              and then (not Comes_From_Source (E)
9573
                          or else Chars (E) = Name_uCall)
9574
            then
9575
               null;
9576
 
9577
            elsif
9578
               Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
9579
            then
9580
               null;
9581
 
9582
            elsif Nkind (Parent (E)) = N_Procedure_Specification
9583
              and then Null_Present (Parent (E))
9584
              and then Serious_Errors_Detected > 0
9585
            then
9586
               null;
9587
 
9588
            else
9589
               Post_Error;
9590
            end if;
9591
 
9592
         elsif Is_Entry (E) then
9593
            if not Has_Completion (E) and then
9594
              (Ekind (Scope (E)) = E_Protected_Object
9595
                or else Ekind (Scope (E)) = E_Protected_Type)
9596
            then
9597
               Post_Error;
9598
            end if;
9599
 
9600
         elsif Is_Package_Or_Generic_Package (E) then
9601
            if Unit_Requires_Body (E) then
9602
               if not Has_Completion (E)
9603
                 and then Nkind (Parent (Unit_Declaration_Node (E))) /=
9604
                                                       N_Compilation_Unit
9605
               then
9606
                  Post_Error;
9607
               end if;
9608
 
9609
            elsif not Is_Child_Unit (E) then
9610
               May_Need_Implicit_Body (E);
9611
            end if;
9612
 
9613
         --  A formal incomplete type (Ada 2012) does not require a completion;
9614
         --  other incomplete type declarations do.
9615
 
9616
         elsif Ekind (E) = E_Incomplete_Type
9617
           and then No (Underlying_Type (E))
9618
           and then not Is_Generic_Type (E)
9619
         then
9620
            Post_Error;
9621
 
9622
         elsif (Ekind (E) = E_Task_Type or else
9623
                Ekind (E) = E_Protected_Type)
9624
           and then not Has_Completion (E)
9625
         then
9626
            Post_Error;
9627
 
9628
         --  A single task declared in the current scope is a constant, verify
9629
         --  that the body of its anonymous type is in the same scope. If the
9630
         --  task is defined elsewhere, this may be a renaming declaration for
9631
         --  which no completion is needed.
9632
 
9633
         elsif Ekind (E) = E_Constant
9634
           and then Ekind (Etype (E)) = E_Task_Type
9635
           and then not Has_Completion (Etype (E))
9636
           and then Scope (Etype (E)) = Current_Scope
9637
         then
9638
            Post_Error;
9639
 
9640
         elsif Ekind (E) = E_Protected_Object
9641
           and then not Has_Completion (Etype (E))
9642
         then
9643
            Post_Error;
9644
 
9645
         elsif Ekind (E) = E_Record_Type then
9646
            if Is_Tagged_Type (E) then
9647
               Check_Abstract_Overriding (E);
9648
               Check_Conventions (E);
9649
            end if;
9650
 
9651
            Check_Aliased_Component_Types (E);
9652
 
9653
         elsif Ekind (E) = E_Array_Type then
9654
            Check_Aliased_Component_Types (E);
9655
 
9656
         end if;
9657
 
9658
         Next_Entity (E);
9659
      end loop;
9660
   end Check_Completion;
9661
 
9662
   ------------------------------------
9663
   -- Check_CPP_Type_Has_No_Defaults --
9664
   ------------------------------------
9665
 
9666
   procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
9667
      Tdef  : constant Node_Id := Type_Definition (Declaration_Node (T));
9668
      Clist : Node_Id;
9669
      Comp  : Node_Id;
9670
 
9671
   begin
9672
      --  Obtain the component list
9673
 
9674
      if Nkind (Tdef) = N_Record_Definition then
9675
         Clist := Component_List (Tdef);
9676
      else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
9677
         Clist := Component_List (Record_Extension_Part (Tdef));
9678
      end if;
9679
 
9680
      --  Check all components to ensure no default expressions
9681
 
9682
      if Present (Clist) then
9683
         Comp := First (Component_Items (Clist));
9684
         while Present (Comp) loop
9685
            if Present (Expression (Comp)) then
9686
               Error_Msg_N
9687
                 ("component of imported 'C'P'P type cannot have "
9688
                  & "default expression", Expression (Comp));
9689
            end if;
9690
 
9691
            Next (Comp);
9692
         end loop;
9693
      end if;
9694
   end Check_CPP_Type_Has_No_Defaults;
9695
 
9696
   ----------------------------
9697
   -- Check_Delta_Expression --
9698
   ----------------------------
9699
 
9700
   procedure Check_Delta_Expression (E : Node_Id) is
9701
   begin
9702
      if not (Is_Real_Type (Etype (E))) then
9703
         Wrong_Type (E, Any_Real);
9704
 
9705
      elsif not Is_OK_Static_Expression (E) then
9706
         Flag_Non_Static_Expr
9707
           ("non-static expression used for delta value!", E);
9708
 
9709
      elsif not UR_Is_Positive (Expr_Value_R (E)) then
9710
         Error_Msg_N ("delta expression must be positive", E);
9711
 
9712
      else
9713
         return;
9714
      end if;
9715
 
9716
      --  If any of above errors occurred, then replace the incorrect
9717
      --  expression by the real 0.1, which should prevent further errors.
9718
 
9719
      Rewrite (E,
9720
        Make_Real_Literal (Sloc (E), Ureal_Tenth));
9721
      Analyze_And_Resolve (E, Standard_Float);
9722
   end Check_Delta_Expression;
9723
 
9724
   -----------------------------
9725
   -- Check_Digits_Expression --
9726
   -----------------------------
9727
 
9728
   procedure Check_Digits_Expression (E : Node_Id) is
9729
   begin
9730
      if not (Is_Integer_Type (Etype (E))) then
9731
         Wrong_Type (E, Any_Integer);
9732
 
9733
      elsif not Is_OK_Static_Expression (E) then
9734
         Flag_Non_Static_Expr
9735
           ("non-static expression used for digits value!", E);
9736
 
9737
      elsif Expr_Value (E) <= 0 then
9738
         Error_Msg_N ("digits value must be greater than zero", E);
9739
 
9740
      else
9741
         return;
9742
      end if;
9743
 
9744
      --  If any of above errors occurred, then replace the incorrect
9745
      --  expression by the integer 1, which should prevent further errors.
9746
 
9747
      Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
9748
      Analyze_And_Resolve (E, Standard_Integer);
9749
 
9750
   end Check_Digits_Expression;
9751
 
9752
   --------------------------
9753
   -- Check_Initialization --
9754
   --------------------------
9755
 
9756
   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
9757
   begin
9758
      if Is_Limited_Type (T)
9759
        and then not In_Instance
9760
        and then not In_Inlined_Body
9761
      then
9762
         if not OK_For_Limited_Init (T, Exp) then
9763
 
9764
            --  In GNAT mode, this is just a warning, to allow it to be evilly
9765
            --  turned off. Otherwise it is a real error.
9766
 
9767
            if GNAT_Mode then
9768
               Error_Msg_N
9769
                 ("?cannot initialize entities of limited type!", Exp);
9770
 
9771
            elsif Ada_Version < Ada_2005 then
9772
 
9773
               --  The side effect removal machinery may generate illegal Ada
9774
               --  code to avoid the usage of access types and 'reference in
9775
               --  Alfa mode. Since this is legal code with respect to theorem
9776
               --  proving, do not emit the error.
9777
 
9778
               if Alfa_Mode
9779
                 and then Nkind (Exp) = N_Function_Call
9780
                 and then Nkind (Parent (Exp)) = N_Object_Declaration
9781
                 and then not Comes_From_Source
9782
                                (Defining_Identifier (Parent (Exp)))
9783
               then
9784
                  null;
9785
 
9786
               else
9787
                  Error_Msg_N
9788
                    ("cannot initialize entities of limited type", Exp);
9789
                  Explain_Limited_Type (T, Exp);
9790
               end if;
9791
 
9792
            else
9793
               --  Specialize error message according to kind of illegal
9794
               --  initial expression.
9795
 
9796
               if Nkind (Exp) = N_Type_Conversion
9797
                 and then Nkind (Expression (Exp)) = N_Function_Call
9798
               then
9799
                  Error_Msg_N
9800
                    ("illegal context for call"
9801
                      & " to function with limited result", Exp);
9802
 
9803
               else
9804
                  Error_Msg_N
9805
                    ("initialization of limited object requires aggregate "
9806
                      & "or function call",  Exp);
9807
               end if;
9808
            end if;
9809
         end if;
9810
      end if;
9811
   end Check_Initialization;
9812
 
9813
   ----------------------
9814
   -- Check_Interfaces --
9815
   ----------------------
9816
 
9817
   procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
9818
      Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
9819
 
9820
      Iface       : Node_Id;
9821
      Iface_Def   : Node_Id;
9822
      Iface_Typ   : Entity_Id;
9823
      Parent_Node : Node_Id;
9824
 
9825
      Is_Task : Boolean := False;
9826
      --  Set True if parent type or any progenitor is a task interface
9827
 
9828
      Is_Protected : Boolean := False;
9829
      --  Set True if parent type or any progenitor is a protected interface
9830
 
9831
      procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
9832
      --  Check that a progenitor is compatible with declaration.
9833
      --  Error is posted on Error_Node.
9834
 
9835
      ------------------
9836
      -- Check_Ifaces --
9837
      ------------------
9838
 
9839
      procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
9840
         Iface_Id : constant Entity_Id :=
9841
                      Defining_Identifier (Parent (Iface_Def));
9842
         Type_Def : Node_Id;
9843
 
9844
      begin
9845
         if Nkind (N) = N_Private_Extension_Declaration then
9846
            Type_Def := N;
9847
         else
9848
            Type_Def := Type_Definition (N);
9849
         end if;
9850
 
9851
         if Is_Task_Interface (Iface_Id) then
9852
            Is_Task := True;
9853
 
9854
         elsif Is_Protected_Interface (Iface_Id) then
9855
            Is_Protected := True;
9856
         end if;
9857
 
9858
         if Is_Synchronized_Interface (Iface_Id) then
9859
 
9860
            --  A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
9861
            --  extension derived from a synchronized interface must explicitly
9862
            --  be declared synchronized, because the full view will be a
9863
            --  synchronized type.
9864
 
9865
            if Nkind (N) = N_Private_Extension_Declaration then
9866
               if not Synchronized_Present (N) then
9867
                  Error_Msg_NE
9868
                    ("private extension of& must be explicitly synchronized",
9869
                      N, Iface_Id);
9870
               end if;
9871
 
9872
            --  However, by 3.9.4(16/2), a full type that is a record extension
9873
            --  is never allowed to derive from a synchronized interface (note
9874
            --  that interfaces must be excluded from this check, because those
9875
            --  are represented by derived type definitions in some cases).
9876
 
9877
            elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
9878
              and then not Interface_Present (Type_Definition (N))
9879
            then
9880
               Error_Msg_N ("record extension cannot derive from synchronized"
9881
                             & " interface", Error_Node);
9882
            end if;
9883
         end if;
9884
 
9885
         --  Check that the characteristics of the progenitor are compatible
9886
         --  with the explicit qualifier in the declaration.
9887
         --  The check only applies to qualifiers that come from source.
9888
         --  Limited_Present also appears in the declaration of corresponding
9889
         --  records, and the check does not apply to them.
9890
 
9891
         if Limited_Present (Type_Def)
9892
           and then not
9893
             Is_Concurrent_Record_Type (Defining_Identifier (N))
9894
         then
9895
            if Is_Limited_Interface (Parent_Type)
9896
              and then not Is_Limited_Interface (Iface_Id)
9897
            then
9898
               Error_Msg_NE
9899
                 ("progenitor& must be limited interface",
9900
                   Error_Node, Iface_Id);
9901
 
9902
            elsif
9903
              (Task_Present (Iface_Def)
9904
                or else Protected_Present (Iface_Def)
9905
                or else Synchronized_Present (Iface_Def))
9906
              and then Nkind (N) /= N_Private_Extension_Declaration
9907
              and then not Error_Posted (N)
9908
            then
9909
               Error_Msg_NE
9910
                 ("progenitor& must be limited interface",
9911
                   Error_Node, Iface_Id);
9912
            end if;
9913
 
9914
         --  Protected interfaces can only inherit from limited, synchronized
9915
         --  or protected interfaces.
9916
 
9917
         elsif Nkind (N) = N_Full_Type_Declaration
9918
           and then  Protected_Present (Type_Def)
9919
         then
9920
            if Limited_Present (Iface_Def)
9921
              or else Synchronized_Present (Iface_Def)
9922
              or else Protected_Present (Iface_Def)
9923
            then
9924
               null;
9925
 
9926
            elsif Task_Present (Iface_Def) then
9927
               Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
9928
                            & " from task interface", Error_Node);
9929
 
9930
            else
9931
               Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
9932
                            & " from non-limited interface", Error_Node);
9933
            end if;
9934
 
9935
         --  Ada 2005 (AI-345): Synchronized interfaces can only inherit from
9936
         --  limited and synchronized.
9937
 
9938
         elsif Synchronized_Present (Type_Def) then
9939
            if Limited_Present (Iface_Def)
9940
              or else Synchronized_Present (Iface_Def)
9941
            then
9942
               null;
9943
 
9944
            elsif Protected_Present (Iface_Def)
9945
              and then Nkind (N) /= N_Private_Extension_Declaration
9946
            then
9947
               Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
9948
                            & " from protected interface", Error_Node);
9949
 
9950
            elsif Task_Present (Iface_Def)
9951
              and then Nkind (N) /= N_Private_Extension_Declaration
9952
            then
9953
               Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
9954
                            & " from task interface", Error_Node);
9955
 
9956
            elsif not Is_Limited_Interface (Iface_Id) then
9957
               Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
9958
                            & " from non-limited interface", Error_Node);
9959
            end if;
9960
 
9961
         --  Ada 2005 (AI-345): Task interfaces can only inherit from limited,
9962
         --  synchronized or task interfaces.
9963
 
9964
         elsif Nkind (N) = N_Full_Type_Declaration
9965
           and then Task_Present (Type_Def)
9966
         then
9967
            if Limited_Present (Iface_Def)
9968
              or else Synchronized_Present (Iface_Def)
9969
              or else Task_Present (Iface_Def)
9970
            then
9971
               null;
9972
 
9973
            elsif Protected_Present (Iface_Def) then
9974
               Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
9975
                            & " protected interface", Error_Node);
9976
 
9977
            else
9978
               Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
9979
                            & " non-limited interface", Error_Node);
9980
            end if;
9981
         end if;
9982
      end Check_Ifaces;
9983
 
9984
   --  Start of processing for Check_Interfaces
9985
 
9986
   begin
9987
      if Is_Interface (Parent_Type) then
9988
         if Is_Task_Interface (Parent_Type) then
9989
            Is_Task := True;
9990
 
9991
         elsif Is_Protected_Interface (Parent_Type) then
9992
            Is_Protected := True;
9993
         end if;
9994
      end if;
9995
 
9996
      if Nkind (N) = N_Private_Extension_Declaration then
9997
 
9998
         --  Check that progenitors are compatible with declaration
9999
 
10000
         Iface := First (Interface_List (Def));
10001
         while Present (Iface) loop
10002
            Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
10003
 
10004
            Parent_Node := Parent (Base_Type (Iface_Typ));
10005
            Iface_Def   := Type_Definition (Parent_Node);
10006
 
10007
            if not Is_Interface (Iface_Typ) then
10008
               Diagnose_Interface (Iface, Iface_Typ);
10009
 
10010
            else
10011
               Check_Ifaces (Iface_Def, Iface);
10012
            end if;
10013
 
10014
            Next (Iface);
10015
         end loop;
10016
 
10017
         if Is_Task and Is_Protected then
10018
            Error_Msg_N
10019
              ("type cannot derive from task and protected interface", N);
10020
         end if;
10021
 
10022
         return;
10023
      end if;
10024
 
10025
      --  Full type declaration of derived type.
10026
      --  Check compatibility with parent if it is interface type
10027
 
10028
      if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
10029
        and then Is_Interface (Parent_Type)
10030
      then
10031
         Parent_Node := Parent (Parent_Type);
10032
 
10033
         --  More detailed checks for interface varieties
10034
 
10035
         Check_Ifaces
10036
           (Iface_Def  => Type_Definition (Parent_Node),
10037
            Error_Node => Subtype_Indication (Type_Definition (N)));
10038
      end if;
10039
 
10040
      Iface := First (Interface_List (Def));
10041
      while Present (Iface) loop
10042
         Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
10043
 
10044
         Parent_Node := Parent (Base_Type (Iface_Typ));
10045
         Iface_Def   := Type_Definition (Parent_Node);
10046
 
10047
         if not Is_Interface (Iface_Typ) then
10048
            Diagnose_Interface (Iface, Iface_Typ);
10049
 
10050
         else
10051
            --  "The declaration of a specific descendant of an interface
10052
            --   type freezes the interface type" RM 13.14
10053
 
10054
            Freeze_Before (N, Iface_Typ);
10055
            Check_Ifaces (Iface_Def, Error_Node => Iface);
10056
         end if;
10057
 
10058
         Next (Iface);
10059
      end loop;
10060
 
10061
      if Is_Task and Is_Protected then
10062
         Error_Msg_N
10063
           ("type cannot derive from task and protected interface", N);
10064
      end if;
10065
   end Check_Interfaces;
10066
 
10067
   ------------------------------------
10068
   -- Check_Or_Process_Discriminants --
10069
   ------------------------------------
10070
 
10071
   --  If an incomplete or private type declaration was already given for the
10072
   --  type, the discriminants may have already been processed if they were
10073
   --  present on the incomplete declaration. In this case a full conformance
10074
   --  check has been performed in Find_Type_Name, and we then recheck here
10075
   --  some properties that can't be checked on the partial view alone.
10076
   --  Otherwise we call Process_Discriminants.
10077
 
10078
   procedure Check_Or_Process_Discriminants
10079
     (N    : Node_Id;
10080
      T    : Entity_Id;
10081
      Prev : Entity_Id := Empty)
10082
   is
10083
   begin
10084
      if Has_Discriminants (T) then
10085
 
10086
         --  Discriminants are already set on T if they were already present
10087
         --  on the partial view. Make them visible to component declarations.
10088
 
10089
         declare
10090
            D : Entity_Id;
10091
            --  Discriminant on T (full view) referencing expr on partial view
10092
 
10093
            Prev_D : Entity_Id;
10094
            --  Entity of corresponding discriminant on partial view
10095
 
10096
            New_D : Node_Id;
10097
            --  Discriminant specification for full view, expression is the
10098
            --  syntactic copy on full view (which has been checked for
10099
            --  conformance with partial view), only used here to post error
10100
            --  message.
10101
 
10102
         begin
10103
            D     := First_Discriminant (T);
10104
            New_D := First (Discriminant_Specifications (N));
10105
            while Present (D) loop
10106
               Prev_D := Current_Entity (D);
10107
               Set_Current_Entity (D);
10108
               Set_Is_Immediately_Visible (D);
10109
               Set_Homonym (D, Prev_D);
10110
 
10111
               --  Handle the case where there is an untagged partial view and
10112
               --  the full view is tagged: must disallow discriminants with
10113
               --  defaults, unless compiling for Ada 2012, which allows a
10114
               --  limited tagged type to have defaulted discriminants (see
10115
               --  AI05-0214). However, suppress the error here if it was
10116
               --  already reported on the default expression of the partial
10117
               --  view.
10118
 
10119
               if Is_Tagged_Type (T)
10120
                    and then Present (Expression (Parent (D)))
10121
                    and then (not Is_Limited_Type (Current_Scope)
10122
                               or else Ada_Version < Ada_2012)
10123
                    and then not Error_Posted (Expression (Parent (D)))
10124
               then
10125
                  if Ada_Version >= Ada_2012 then
10126
                     Error_Msg_N
10127
                       ("discriminants of nonlimited tagged type cannot have"
10128
                          & " defaults",
10129
                        Expression (New_D));
10130
                  else
10131
                     Error_Msg_N
10132
                       ("discriminants of tagged type cannot have defaults",
10133
                        Expression (New_D));
10134
                  end if;
10135
               end if;
10136
 
10137
               --  Ada 2005 (AI-230): Access discriminant allowed in
10138
               --  non-limited record types.
10139
 
10140
               if Ada_Version < Ada_2005 then
10141
 
10142
                  --  This restriction gets applied to the full type here. It
10143
                  --  has already been applied earlier to the partial view.
10144
 
10145
                  Check_Access_Discriminant_Requires_Limited (Parent (D), N);
10146
               end if;
10147
 
10148
               Next_Discriminant (D);
10149
               Next (New_D);
10150
            end loop;
10151
         end;
10152
 
10153
      elsif Present (Discriminant_Specifications (N)) then
10154
         Process_Discriminants (N, Prev);
10155
      end if;
10156
   end Check_Or_Process_Discriminants;
10157
 
10158
   ----------------------
10159
   -- Check_Real_Bound --
10160
   ----------------------
10161
 
10162
   procedure Check_Real_Bound (Bound : Node_Id) is
10163
   begin
10164
      if not Is_Real_Type (Etype (Bound)) then
10165
         Error_Msg_N
10166
           ("bound in real type definition must be of real type", Bound);
10167
 
10168
      elsif not Is_OK_Static_Expression (Bound) then
10169
         Flag_Non_Static_Expr
10170
           ("non-static expression used for real type bound!", Bound);
10171
 
10172
      else
10173
         return;
10174
      end if;
10175
 
10176
      Rewrite
10177
        (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
10178
      Analyze (Bound);
10179
      Resolve (Bound, Standard_Float);
10180
   end Check_Real_Bound;
10181
 
10182
   ------------------------------
10183
   -- Complete_Private_Subtype --
10184
   ------------------------------
10185
 
10186
   procedure Complete_Private_Subtype
10187
     (Priv        : Entity_Id;
10188
      Full        : Entity_Id;
10189
      Full_Base   : Entity_Id;
10190
      Related_Nod : Node_Id)
10191
   is
10192
      Save_Next_Entity : Entity_Id;
10193
      Save_Homonym     : Entity_Id;
10194
 
10195
   begin
10196
      --  Set semantic attributes for (implicit) private subtype completion.
10197
      --  If the full type has no discriminants, then it is a copy of the full
10198
      --  view of the base. Otherwise, it is a subtype of the base with a
10199
      --  possible discriminant constraint. Save and restore the original
10200
      --  Next_Entity field of full to ensure that the calls to Copy_Node
10201
      --  do not corrupt the entity chain.
10202
 
10203
      --  Note that the type of the full view is the same entity as the type of
10204
      --  the partial view. In this fashion, the subtype has access to the
10205
      --  correct view of the parent.
10206
 
10207
      Save_Next_Entity := Next_Entity (Full);
10208
      Save_Homonym     := Homonym (Priv);
10209
 
10210
      case Ekind (Full_Base) is
10211
         when E_Record_Type    |
10212
              E_Record_Subtype |
10213
              Class_Wide_Kind  |
10214
              Private_Kind     |
10215
              Task_Kind        |
10216
              Protected_Kind   =>
10217
            Copy_Node (Priv, Full);
10218
 
10219
            Set_Has_Discriminants  (Full, Has_Discriminants (Full_Base));
10220
            Set_First_Entity       (Full, First_Entity (Full_Base));
10221
            Set_Last_Entity        (Full, Last_Entity (Full_Base));
10222
 
10223
         when others =>
10224
            Copy_Node (Full_Base, Full);
10225
            Set_Chars          (Full, Chars (Priv));
10226
            Conditional_Delay  (Full, Priv);
10227
            Set_Sloc           (Full, Sloc (Priv));
10228
      end case;
10229
 
10230
      Set_Next_Entity (Full, Save_Next_Entity);
10231
      Set_Homonym     (Full, Save_Homonym);
10232
      Set_Associated_Node_For_Itype (Full, Related_Nod);
10233
 
10234
      --  Set common attributes for all subtypes: kind, convention, etc.
10235
 
10236
      Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
10237
      Set_Convention (Full, Convention (Full_Base));
10238
 
10239
      --  The Etype of the full view is inconsistent. Gigi needs to see the
10240
      --  structural full view,  which is what the current scheme gives:
10241
      --  the Etype of the full view is the etype of the full base. However,
10242
      --  if the full base is a derived type, the full view then looks like
10243
      --  a subtype of the parent, not a subtype of the full base. If instead
10244
      --  we write:
10245
 
10246
      --       Set_Etype (Full, Full_Base);
10247
 
10248
      --  then we get inconsistencies in the front-end (confusion between
10249
      --  views). Several outstanding bugs are related to this ???
10250
 
10251
      Set_Is_First_Subtype (Full, False);
10252
      Set_Scope            (Full, Scope (Priv));
10253
      Set_Size_Info        (Full, Full_Base);
10254
      Set_RM_Size          (Full, RM_Size (Full_Base));
10255
      Set_Is_Itype         (Full);
10256
 
10257
      --  A subtype of a private-type-without-discriminants, whose full-view
10258
      --  has discriminants with default expressions, is not constrained!
10259
 
10260
      if not Has_Discriminants (Priv) then
10261
         Set_Is_Constrained (Full, Is_Constrained (Full_Base));
10262
 
10263
         if Has_Discriminants (Full_Base) then
10264
            Set_Discriminant_Constraint
10265
              (Full, Discriminant_Constraint (Full_Base));
10266
 
10267
            --  The partial view may have been indefinite, the full view
10268
            --  might not be.
10269
 
10270
            Set_Has_Unknown_Discriminants
10271
              (Full, Has_Unknown_Discriminants (Full_Base));
10272
         end if;
10273
      end if;
10274
 
10275
      Set_First_Rep_Item     (Full, First_Rep_Item (Full_Base));
10276
      Set_Depends_On_Private (Full, Has_Private_Component (Full));
10277
 
10278
      --  Freeze the private subtype entity if its parent is delayed, and not
10279
      --  already frozen. We skip this processing if the type is an anonymous
10280
      --  subtype of a record component, or is the corresponding record of a
10281
      --  protected type, since ???
10282
 
10283
      if not Is_Type (Scope (Full)) then
10284
         Set_Has_Delayed_Freeze (Full,
10285
           Has_Delayed_Freeze (Full_Base)
10286
             and then (not Is_Frozen (Full_Base)));
10287
      end if;
10288
 
10289
      Set_Freeze_Node (Full, Empty);
10290
      Set_Is_Frozen (Full, False);
10291
      Set_Full_View (Priv, Full);
10292
 
10293
      if Has_Discriminants (Full) then
10294
         Set_Stored_Constraint_From_Discriminant_Constraint (Full);
10295
         Set_Stored_Constraint (Priv, Stored_Constraint (Full));
10296
 
10297
         if Has_Unknown_Discriminants (Full) then
10298
            Set_Discriminant_Constraint (Full, No_Elist);
10299
         end if;
10300
      end if;
10301
 
10302
      if Ekind (Full_Base) = E_Record_Type
10303
        and then Has_Discriminants (Full_Base)
10304
        and then Has_Discriminants (Priv) -- might not, if errors
10305
        and then not Has_Unknown_Discriminants (Priv)
10306
        and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
10307
      then
10308
         Create_Constrained_Components
10309
           (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
10310
 
10311
      --  If the full base is itself derived from private, build a congruent
10312
      --  subtype of its underlying type, for use by the back end. For a
10313
      --  constrained record component, the declaration cannot be placed on
10314
      --  the component list, but it must nevertheless be built an analyzed, to
10315
      --  supply enough information for Gigi to compute the size of component.
10316
 
10317
      elsif Ekind (Full_Base) in Private_Kind
10318
        and then Is_Derived_Type (Full_Base)
10319
        and then Has_Discriminants (Full_Base)
10320
        and then (Ekind (Current_Scope) /= E_Record_Subtype)
10321
      then
10322
         if not Is_Itype (Priv)
10323
           and then
10324
             Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
10325
         then
10326
            Build_Underlying_Full_View
10327
              (Parent (Priv), Full, Etype (Full_Base));
10328
 
10329
         elsif Nkind (Related_Nod) = N_Component_Declaration then
10330
            Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
10331
         end if;
10332
 
10333
      elsif Is_Record_Type (Full_Base) then
10334
 
10335
         --  Show Full is simply a renaming of Full_Base
10336
 
10337
         Set_Cloned_Subtype (Full, Full_Base);
10338
      end if;
10339
 
10340
      --  It is unsafe to share to bounds of a scalar type, because the Itype
10341
      --  is elaborated on demand, and if a bound is non-static then different
10342
      --  orders of elaboration in different units will lead to different
10343
      --  external symbols.
10344
 
10345
      if Is_Scalar_Type (Full_Base) then
10346
         Set_Scalar_Range (Full,
10347
           Make_Range (Sloc (Related_Nod),
10348
             Low_Bound  =>
10349
               Duplicate_Subexpr_No_Checks (Type_Low_Bound  (Full_Base)),
10350
             High_Bound =>
10351
               Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
10352
 
10353
         --  This completion inherits the bounds of the full parent, but if
10354
         --  the parent is an unconstrained floating point type, so is the
10355
         --  completion.
10356
 
10357
         if Is_Floating_Point_Type (Full_Base) then
10358
            Set_Includes_Infinities
10359
             (Scalar_Range (Full), Has_Infinities (Full_Base));
10360
         end if;
10361
      end if;
10362
 
10363
      --  ??? It seems that a lot of fields are missing that should be copied
10364
      --  from Full_Base to Full. Here are some that are introduced in a
10365
      --  non-disruptive way but a cleanup is necessary.
10366
 
10367
      if Is_Tagged_Type (Full_Base) then
10368
         Set_Is_Tagged_Type (Full);
10369
         Set_Direct_Primitive_Operations (Full,
10370
           Direct_Primitive_Operations (Full_Base));
10371
 
10372
         --  Inherit class_wide type of full_base in case the partial view was
10373
         --  not tagged. Otherwise it has already been created when the private
10374
         --  subtype was analyzed.
10375
 
10376
         if No (Class_Wide_Type (Full)) then
10377
            Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
10378
         end if;
10379
 
10380
      --  If this is a subtype of a protected or task type, constrain its
10381
      --  corresponding record, unless this is a subtype without constraints,
10382
      --  i.e. a simple renaming as with an actual subtype in an instance.
10383
 
10384
      elsif Is_Concurrent_Type (Full_Base) then
10385
         if Has_Discriminants (Full)
10386
           and then Present (Corresponding_Record_Type (Full_Base))
10387
           and then
10388
             not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
10389
         then
10390
            Set_Corresponding_Record_Type (Full,
10391
              Constrain_Corresponding_Record
10392
                (Full, Corresponding_Record_Type (Full_Base),
10393
                  Related_Nod, Full_Base));
10394
 
10395
         else
10396
            Set_Corresponding_Record_Type (Full,
10397
              Corresponding_Record_Type (Full_Base));
10398
         end if;
10399
      end if;
10400
 
10401
      --  Link rep item chain, and also setting of Has_Predicates from private
10402
      --  subtype to full subtype, since we will need these on the full subtype
10403
      --  to create the predicate function. Note that the full subtype may
10404
      --  already have rep items, inherited from the full view of the base
10405
      --  type, so we must be sure not to overwrite these entries.
10406
 
10407
      declare
10408
         Append    : Boolean;
10409
         Item      : Node_Id;
10410
         Next_Item : Node_Id;
10411
 
10412
      begin
10413
         Item := First_Rep_Item (Full);
10414
 
10415
         --  If no existing rep items on full type, we can just link directly
10416
         --  to the list of items on the private type.
10417
 
10418
         if No (Item) then
10419
            Set_First_Rep_Item (Full, First_Rep_Item (Priv));
10420
 
10421
         --  Otherwise, search to the end of items currently linked to the full
10422
         --  subtype and append the private items to the end. However, if Priv
10423
         --  and Full already have the same list of rep items, then the append
10424
         --  is not done, as that would create a circularity.
10425
 
10426
         elsif Item /= First_Rep_Item (Priv) then
10427
            Append := True;
10428
 
10429
            loop
10430
               Next_Item := Next_Rep_Item (Item);
10431
               exit when No (Next_Item);
10432
               Item := Next_Item;
10433
 
10434
               --  If the private view has aspect specifications, the full view
10435
               --  inherits them. Since these aspects may already have been
10436
               --  attached to the full view during derivation, do not append
10437
               --  them if already present.
10438
 
10439
               if Item = First_Rep_Item (Priv) then
10440
                  Append := False;
10441
                  exit;
10442
               end if;
10443
            end loop;
10444
 
10445
            --  And link the private type items at the end of the chain
10446
 
10447
            if Append then
10448
               Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
10449
            end if;
10450
         end if;
10451
      end;
10452
 
10453
      --  Make sure Has_Predicates is set on full type if it is set on the
10454
      --  private type. Note that it may already be set on the full type and
10455
      --  if so, we don't want to unset it.
10456
 
10457
      if Has_Predicates (Priv) then
10458
         Set_Has_Predicates (Full);
10459
      end if;
10460
   end Complete_Private_Subtype;
10461
 
10462
   ----------------------------
10463
   -- Constant_Redeclaration --
10464
   ----------------------------
10465
 
10466
   procedure Constant_Redeclaration
10467
     (Id : Entity_Id;
10468
      N  : Node_Id;
10469
      T  : out Entity_Id)
10470
   is
10471
      Prev    : constant Entity_Id := Current_Entity_In_Scope (Id);
10472
      Obj_Def : constant Node_Id := Object_Definition (N);
10473
      New_T   : Entity_Id;
10474
 
10475
      procedure Check_Possible_Deferred_Completion
10476
        (Prev_Id      : Entity_Id;
10477
         Prev_Obj_Def : Node_Id;
10478
         Curr_Obj_Def : Node_Id);
10479
      --  Determine whether the two object definitions describe the partial
10480
      --  and the full view of a constrained deferred constant. Generate
10481
      --  a subtype for the full view and verify that it statically matches
10482
      --  the subtype of the partial view.
10483
 
10484
      procedure Check_Recursive_Declaration (Typ : Entity_Id);
10485
      --  If deferred constant is an access type initialized with an allocator,
10486
      --  check whether there is an illegal recursion in the definition,
10487
      --  through a default value of some record subcomponent. This is normally
10488
      --  detected when generating init procs, but requires this additional
10489
      --  mechanism when expansion is disabled.
10490
 
10491
      ----------------------------------------
10492
      -- Check_Possible_Deferred_Completion --
10493
      ----------------------------------------
10494
 
10495
      procedure Check_Possible_Deferred_Completion
10496
        (Prev_Id      : Entity_Id;
10497
         Prev_Obj_Def : Node_Id;
10498
         Curr_Obj_Def : Node_Id)
10499
      is
10500
      begin
10501
         if Nkind (Prev_Obj_Def) = N_Subtype_Indication
10502
           and then Present (Constraint (Prev_Obj_Def))
10503
           and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
10504
           and then Present (Constraint (Curr_Obj_Def))
10505
         then
10506
            declare
10507
               Loc    : constant Source_Ptr := Sloc (N);
10508
               Def_Id : constant Entity_Id  := Make_Temporary (Loc, 'S');
10509
               Decl   : constant Node_Id    :=
10510
                          Make_Subtype_Declaration (Loc,
10511
                            Defining_Identifier => Def_Id,
10512
                            Subtype_Indication  =>
10513
                              Relocate_Node (Curr_Obj_Def));
10514
 
10515
            begin
10516
               Insert_Before_And_Analyze (N, Decl);
10517
               Set_Etype (Id, Def_Id);
10518
 
10519
               if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
10520
                  Error_Msg_Sloc := Sloc (Prev_Id);
10521
                  Error_Msg_N ("subtype does not statically match deferred " &
10522
                               "declaration#", N);
10523
               end if;
10524
            end;
10525
         end if;
10526
      end Check_Possible_Deferred_Completion;
10527
 
10528
      ---------------------------------
10529
      -- Check_Recursive_Declaration --
10530
      ---------------------------------
10531
 
10532
      procedure Check_Recursive_Declaration (Typ : Entity_Id) is
10533
         Comp : Entity_Id;
10534
 
10535
      begin
10536
         if Is_Record_Type (Typ) then
10537
            Comp := First_Component (Typ);
10538
            while Present (Comp) loop
10539
               if Comes_From_Source (Comp) then
10540
                  if Present (Expression (Parent (Comp)))
10541
                    and then Is_Entity_Name (Expression (Parent (Comp)))
10542
                    and then Entity (Expression (Parent (Comp))) = Prev
10543
                  then
10544
                     Error_Msg_Sloc := Sloc (Parent (Comp));
10545
                     Error_Msg_NE
10546
                       ("illegal circularity with declaration for&#",
10547
                         N, Comp);
10548
                     return;
10549
 
10550
                  elsif Is_Record_Type (Etype (Comp)) then
10551
                     Check_Recursive_Declaration (Etype (Comp));
10552
                  end if;
10553
               end if;
10554
 
10555
               Next_Component (Comp);
10556
            end loop;
10557
         end if;
10558
      end Check_Recursive_Declaration;
10559
 
10560
   --  Start of processing for Constant_Redeclaration
10561
 
10562
   begin
10563
      if Nkind (Parent (Prev)) = N_Object_Declaration then
10564
         if Nkind (Object_Definition
10565
                     (Parent (Prev))) = N_Subtype_Indication
10566
         then
10567
            --  Find type of new declaration. The constraints of the two
10568
            --  views must match statically, but there is no point in
10569
            --  creating an itype for the full view.
10570
 
10571
            if Nkind (Obj_Def) = N_Subtype_Indication then
10572
               Find_Type (Subtype_Mark (Obj_Def));
10573
               New_T := Entity (Subtype_Mark (Obj_Def));
10574
 
10575
            else
10576
               Find_Type (Obj_Def);
10577
               New_T := Entity (Obj_Def);
10578
            end if;
10579
 
10580
            T := Etype (Prev);
10581
 
10582
         else
10583
            --  The full view may impose a constraint, even if the partial
10584
            --  view does not, so construct the subtype.
10585
 
10586
            New_T := Find_Type_Of_Object (Obj_Def, N);
10587
            T     := New_T;
10588
         end if;
10589
 
10590
      else
10591
         --  Current declaration is illegal, diagnosed below in Enter_Name
10592
 
10593
         T := Empty;
10594
         New_T := Any_Type;
10595
      end if;
10596
 
10597
      --  If previous full declaration or a renaming declaration exists, or if
10598
      --  a homograph is present, let Enter_Name handle it, either with an
10599
      --  error or with the removal of an overridden implicit subprogram.
10600
 
10601
      if Ekind (Prev) /= E_Constant
10602
        or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
10603
        or else Present (Expression (Parent (Prev)))
10604
        or else Present (Full_View (Prev))
10605
      then
10606
         Enter_Name (Id);
10607
 
10608
      --  Verify that types of both declarations match, or else that both types
10609
      --  are anonymous access types whose designated subtypes statically match
10610
      --  (as allowed in Ada 2005 by AI-385).
10611
 
10612
      elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
10613
        and then
10614
          (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
10615
             or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
10616
             or else Is_Access_Constant (Etype (New_T)) /=
10617
                     Is_Access_Constant (Etype (Prev))
10618
             or else Can_Never_Be_Null (Etype (New_T)) /=
10619
                     Can_Never_Be_Null (Etype (Prev))
10620
             or else Null_Exclusion_Present (Parent (Prev)) /=
10621
                     Null_Exclusion_Present (Parent (Id))
10622
             or else not Subtypes_Statically_Match
10623
                           (Designated_Type (Etype (Prev)),
10624
                            Designated_Type (Etype (New_T))))
10625
      then
10626
         Error_Msg_Sloc := Sloc (Prev);
10627
         Error_Msg_N ("type does not match declaration#", N);
10628
         Set_Full_View (Prev, Id);
10629
         Set_Etype (Id, Any_Type);
10630
 
10631
      elsif
10632
        Null_Exclusion_Present (Parent (Prev))
10633
          and then not Null_Exclusion_Present (N)
10634
      then
10635
         Error_Msg_Sloc := Sloc (Prev);
10636
         Error_Msg_N ("null-exclusion does not match declaration#", N);
10637
         Set_Full_View (Prev, Id);
10638
         Set_Etype (Id, Any_Type);
10639
 
10640
      --  If so, process the full constant declaration
10641
 
10642
      else
10643
         --  RM 7.4 (6): If the subtype defined by the subtype_indication in
10644
         --  the deferred declaration is constrained, then the subtype defined
10645
         --  by the subtype_indication in the full declaration shall match it
10646
         --  statically.
10647
 
10648
         Check_Possible_Deferred_Completion
10649
           (Prev_Id      => Prev,
10650
            Prev_Obj_Def => Object_Definition (Parent (Prev)),
10651
            Curr_Obj_Def => Obj_Def);
10652
 
10653
         Set_Full_View (Prev, Id);
10654
         Set_Is_Public (Id, Is_Public (Prev));
10655
         Set_Is_Internal (Id);
10656
         Append_Entity (Id, Current_Scope);
10657
 
10658
         --  Check ALIASED present if present before (RM 7.4(7))
10659
 
10660
         if Is_Aliased (Prev)
10661
           and then not Aliased_Present (N)
10662
         then
10663
            Error_Msg_Sloc := Sloc (Prev);
10664
            Error_Msg_N ("ALIASED required (see declaration#)", N);
10665
         end if;
10666
 
10667
         --  Check that placement is in private part and that the incomplete
10668
         --  declaration appeared in the visible part.
10669
 
10670
         if Ekind (Current_Scope) = E_Package
10671
           and then not In_Private_Part (Current_Scope)
10672
         then
10673
            Error_Msg_Sloc := Sloc (Prev);
10674
            Error_Msg_N
10675
              ("full constant for declaration#"
10676
               & " must be in private part", N);
10677
 
10678
         elsif Ekind (Current_Scope) = E_Package
10679
           and then
10680
             List_Containing (Parent (Prev)) /=
10681
               Visible_Declarations
10682
                 (Specification (Unit_Declaration_Node (Current_Scope)))
10683
         then
10684
            Error_Msg_N
10685
              ("deferred constant must be declared in visible part",
10686
                 Parent (Prev));
10687
         end if;
10688
 
10689
         if Is_Access_Type (T)
10690
           and then Nkind (Expression (N)) = N_Allocator
10691
         then
10692
            Check_Recursive_Declaration (Designated_Type (T));
10693
         end if;
10694
      end if;
10695
   end Constant_Redeclaration;
10696
 
10697
   ----------------------
10698
   -- Constrain_Access --
10699
   ----------------------
10700
 
10701
   procedure Constrain_Access
10702
     (Def_Id      : in out Entity_Id;
10703
      S           : Node_Id;
10704
      Related_Nod : Node_Id)
10705
   is
10706
      T             : constant Entity_Id := Entity (Subtype_Mark (S));
10707
      Desig_Type    : constant Entity_Id := Designated_Type (T);
10708
      Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
10709
      Constraint_OK : Boolean := True;
10710
 
10711
      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean;
10712
      --  Simple predicate to test for defaulted discriminants
10713
      --  Shouldn't this be in sem_util???
10714
 
10715
      ---------------------------------
10716
      -- Has_Defaulted_Discriminants --
10717
      ---------------------------------
10718
 
10719
      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
10720
      begin
10721
         return Has_Discriminants (Typ)
10722
          and then Present (First_Discriminant (Typ))
10723
          and then Present
10724
            (Discriminant_Default_Value (First_Discriminant (Typ)));
10725
      end Has_Defaulted_Discriminants;
10726
 
10727
   --  Start of processing for Constrain_Access
10728
 
10729
   begin
10730
      if Is_Array_Type (Desig_Type) then
10731
         Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
10732
 
10733
      elsif (Is_Record_Type (Desig_Type)
10734
              or else Is_Incomplete_Or_Private_Type (Desig_Type))
10735
        and then not Is_Constrained (Desig_Type)
10736
      then
10737
         --  ??? The following code is a temporary kludge to ignore a
10738
         --  discriminant constraint on access type if it is constraining
10739
         --  the current record. Avoid creating the implicit subtype of the
10740
         --  record we are currently compiling since right now, we cannot
10741
         --  handle these. For now, just return the access type itself.
10742
 
10743
         if Desig_Type = Current_Scope
10744
           and then No (Def_Id)
10745
         then
10746
            Set_Ekind (Desig_Subtype, E_Record_Subtype);
10747
            Def_Id := Entity (Subtype_Mark (S));
10748
 
10749
            --  This call added to ensure that the constraint is analyzed
10750
            --  (needed for a B test). Note that we still return early from
10751
            --  this procedure to avoid recursive processing. ???
10752
 
10753
            Constrain_Discriminated_Type
10754
              (Desig_Subtype, S, Related_Nod, For_Access => True);
10755
            return;
10756
         end if;
10757
 
10758
         --  Enforce rule that the constraint is illegal if there is an
10759
         --  unconstrained view of the designated type. This means that the
10760
         --  partial view (either a private type declaration or a derivation
10761
         --  from a private type) has no discriminants. (Defect Report
10762
         --  8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
10763
 
10764
         --  Rule updated for Ada 2005: the private type is said to have
10765
         --  a constrained partial view, given that objects of the type
10766
         --  can be declared. Furthermore, the rule applies to all access
10767
         --  types, unlike the rule concerning default discriminants (see
10768
         --  RM 3.7.1(7/3))
10769
 
10770
         if (Ekind (T) = E_General_Access_Type
10771
              or else Ada_Version >= Ada_2005)
10772
           and then Has_Private_Declaration (Desig_Type)
10773
           and then In_Open_Scopes (Scope (Desig_Type))
10774
           and then Has_Discriminants (Desig_Type)
10775
         then
10776
            declare
10777
               Pack  : constant Node_Id :=
10778
                         Unit_Declaration_Node (Scope (Desig_Type));
10779
               Decls : List_Id;
10780
               Decl  : Node_Id;
10781
 
10782
            begin
10783
               if Nkind (Pack) = N_Package_Declaration then
10784
                  Decls := Visible_Declarations (Specification (Pack));
10785
                  Decl := First (Decls);
10786
                  while Present (Decl) loop
10787
                     if (Nkind (Decl) = N_Private_Type_Declaration
10788
                          and then
10789
                            Chars (Defining_Identifier (Decl)) =
10790
                                                     Chars (Desig_Type))
10791
 
10792
                       or else
10793
                        (Nkind (Decl) = N_Full_Type_Declaration
10794
                          and then
10795
                            Chars (Defining_Identifier (Decl)) =
10796
                                                     Chars (Desig_Type)
10797
                          and then Is_Derived_Type (Desig_Type)
10798
                          and then
10799
                            Has_Private_Declaration (Etype (Desig_Type)))
10800
                     then
10801
                        if No (Discriminant_Specifications (Decl)) then
10802
                           Error_Msg_N
10803
                            ("cannot constrain access type if designated " &
10804
                               "type has constrained partial view", S);
10805
                        end if;
10806
 
10807
                        exit;
10808
                     end if;
10809
 
10810
                     Next (Decl);
10811
                  end loop;
10812
               end if;
10813
            end;
10814
         end if;
10815
 
10816
         Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
10817
           For_Access => True);
10818
 
10819
      elsif (Is_Task_Type (Desig_Type)
10820
              or else Is_Protected_Type (Desig_Type))
10821
        and then not Is_Constrained (Desig_Type)
10822
      then
10823
         Constrain_Concurrent
10824
           (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
10825
 
10826
      else
10827
         Error_Msg_N ("invalid constraint on access type", S);
10828
         Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
10829
         Constraint_OK := False;
10830
      end if;
10831
 
10832
      if No (Def_Id) then
10833
         Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
10834
      else
10835
         Set_Ekind (Def_Id, E_Access_Subtype);
10836
      end if;
10837
 
10838
      if Constraint_OK then
10839
         Set_Etype (Def_Id, Base_Type (T));
10840
 
10841
         if Is_Private_Type (Desig_Type) then
10842
            Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
10843
         end if;
10844
      else
10845
         Set_Etype (Def_Id, Any_Type);
10846
      end if;
10847
 
10848
      Set_Size_Info                (Def_Id, T);
10849
      Set_Is_Constrained           (Def_Id, Constraint_OK);
10850
      Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
10851
      Set_Depends_On_Private       (Def_Id, Has_Private_Component (Def_Id));
10852
      Set_Is_Access_Constant       (Def_Id, Is_Access_Constant (T));
10853
 
10854
      Conditional_Delay (Def_Id, T);
10855
 
10856
      --  AI-363 : Subtypes of general access types whose designated types have
10857
      --  default discriminants are disallowed. In instances, the rule has to
10858
      --  be checked against the actual, of which T is the subtype. In a
10859
      --  generic body, the rule is checked assuming that the actual type has
10860
      --  defaulted discriminants.
10861
 
10862
      if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then
10863
         if Ekind (Base_Type (T)) = E_General_Access_Type
10864
           and then Has_Defaulted_Discriminants (Desig_Type)
10865
         then
10866
            if Ada_Version < Ada_2005 then
10867
               Error_Msg_N
10868
                 ("access subtype of general access type would not " &
10869
                  "be allowed in Ada 2005?", S);
10870
            else
10871
               Error_Msg_N
10872
                 ("access subtype of general access type not allowed", S);
10873
            end if;
10874
 
10875
            Error_Msg_N ("\discriminants have defaults", S);
10876
 
10877
         elsif Is_Access_Type (T)
10878
           and then Is_Generic_Type (Desig_Type)
10879
           and then Has_Discriminants (Desig_Type)
10880
           and then In_Package_Body (Current_Scope)
10881
         then
10882
            if Ada_Version < Ada_2005 then
10883
               Error_Msg_N
10884
                 ("access subtype would not be allowed in generic body " &
10885
                  "in Ada 2005?", S);
10886
            else
10887
               Error_Msg_N
10888
                 ("access subtype not allowed in generic body", S);
10889
            end if;
10890
 
10891
            Error_Msg_N
10892
              ("\designated type is a discriminated formal", S);
10893
         end if;
10894
      end if;
10895
   end Constrain_Access;
10896
 
10897
   ---------------------
10898
   -- Constrain_Array --
10899
   ---------------------
10900
 
10901
   procedure Constrain_Array
10902
     (Def_Id      : in out Entity_Id;
10903
      SI          : Node_Id;
10904
      Related_Nod : Node_Id;
10905
      Related_Id  : Entity_Id;
10906
      Suffix      : Character)
10907
   is
10908
      C                     : constant Node_Id := Constraint (SI);
10909
      Number_Of_Constraints : Nat := 0;
10910
      Index                 : Node_Id;
10911
      S, T                  : Entity_Id;
10912
      Constraint_OK         : Boolean := True;
10913
 
10914
   begin
10915
      T := Entity (Subtype_Mark (SI));
10916
 
10917
      if Ekind (T) in Access_Kind then
10918
         T := Designated_Type (T);
10919
      end if;
10920
 
10921
      --  If an index constraint follows a subtype mark in a subtype indication
10922
      --  then the type or subtype denoted by the subtype mark must not already
10923
      --  impose an index constraint. The subtype mark must denote either an
10924
      --  unconstrained array type or an access type whose designated type
10925
      --  is such an array type... (RM 3.6.1)
10926
 
10927
      if Is_Constrained (T) then
10928
         Error_Msg_N ("array type is already constrained", Subtype_Mark (SI));
10929
         Constraint_OK := False;
10930
 
10931
      else
10932
         S := First (Constraints (C));
10933
         while Present (S) loop
10934
            Number_Of_Constraints := Number_Of_Constraints + 1;
10935
            Next (S);
10936
         end loop;
10937
 
10938
         --  In either case, the index constraint must provide a discrete
10939
         --  range for each index of the array type and the type of each
10940
         --  discrete range must be the same as that of the corresponding
10941
         --  index. (RM 3.6.1)
10942
 
10943
         if Number_Of_Constraints /= Number_Dimensions (T) then
10944
            Error_Msg_NE ("incorrect number of index constraints for }", C, T);
10945
            Constraint_OK := False;
10946
 
10947
         else
10948
            S := First (Constraints (C));
10949
            Index := First_Index (T);
10950
            Analyze (Index);
10951
 
10952
            --  Apply constraints to each index type
10953
 
10954
            for J in 1 .. Number_Of_Constraints loop
10955
               Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
10956
               Next (Index);
10957
               Next (S);
10958
            end loop;
10959
 
10960
         end if;
10961
      end if;
10962
 
10963
      if No (Def_Id) then
10964
         Def_Id :=
10965
           Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
10966
         Set_Parent (Def_Id, Related_Nod);
10967
 
10968
      else
10969
         Set_Ekind (Def_Id, E_Array_Subtype);
10970
      end if;
10971
 
10972
      Set_Size_Info      (Def_Id,                (T));
10973
      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
10974
      Set_Etype          (Def_Id, Base_Type      (T));
10975
 
10976
      if Constraint_OK then
10977
         Set_First_Index (Def_Id, First (Constraints (C)));
10978
      else
10979
         Set_First_Index (Def_Id, First_Index (T));
10980
      end if;
10981
 
10982
      Set_Is_Constrained     (Def_Id, True);
10983
      Set_Is_Aliased         (Def_Id, Is_Aliased (T));
10984
      Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
10985
 
10986
      Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
10987
      Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
10988
 
10989
      --  A subtype does not inherit the packed_array_type of is parent. We
10990
      --  need to initialize the attribute because if Def_Id is previously
10991
      --  analyzed through a limited_with clause, it will have the attributes
10992
      --  of an incomplete type, one of which is an Elist that overlaps the
10993
      --  Packed_Array_Type field.
10994
 
10995
      Set_Packed_Array_Type (Def_Id, Empty);
10996
 
10997
      --  Build a freeze node if parent still needs one. Also make sure that
10998
      --  the Depends_On_Private status is set because the subtype will need
10999
      --  reprocessing at the time the base type does, and also we must set a
11000
      --  conditional delay.
11001
 
11002
      Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
11003
      Conditional_Delay (Def_Id, T);
11004
   end Constrain_Array;
11005
 
11006
   ------------------------------
11007
   -- Constrain_Component_Type --
11008
   ------------------------------
11009
 
11010
   function Constrain_Component_Type
11011
     (Comp            : Entity_Id;
11012
      Constrained_Typ : Entity_Id;
11013
      Related_Node    : Node_Id;
11014
      Typ             : Entity_Id;
11015
      Constraints     : Elist_Id) return Entity_Id
11016
   is
11017
      Loc         : constant Source_Ptr := Sloc (Constrained_Typ);
11018
      Compon_Type : constant Entity_Id := Etype (Comp);
11019
 
11020
      function Build_Constrained_Array_Type
11021
        (Old_Type : Entity_Id) return Entity_Id;
11022
      --  If Old_Type is an array type, one of whose indexes is constrained
11023
      --  by a discriminant, build an Itype whose constraint replaces the
11024
      --  discriminant with its value in the constraint.
11025
 
11026
      function Build_Constrained_Discriminated_Type
11027
        (Old_Type : Entity_Id) return Entity_Id;
11028
      --  Ditto for record components
11029
 
11030
      function Build_Constrained_Access_Type
11031
        (Old_Type : Entity_Id) return Entity_Id;
11032
      --  Ditto for access types. Makes use of previous two functions, to
11033
      --  constrain designated type.
11034
 
11035
      function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
11036
      --  T is an array or discriminated type, C is a list of constraints
11037
      --  that apply to T. This routine builds the constrained subtype.
11038
 
11039
      function Is_Discriminant (Expr : Node_Id) return Boolean;
11040
      --  Returns True if Expr is a discriminant
11041
 
11042
      function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
11043
      --  Find the value of discriminant Discrim in Constraint
11044
 
11045
      -----------------------------------
11046
      -- Build_Constrained_Access_Type --
11047
      -----------------------------------
11048
 
11049
      function Build_Constrained_Access_Type
11050
        (Old_Type : Entity_Id) return Entity_Id
11051
      is
11052
         Desig_Type    : constant Entity_Id := Designated_Type (Old_Type);
11053
         Itype         : Entity_Id;
11054
         Desig_Subtype : Entity_Id;
11055
         Scop          : Entity_Id;
11056
 
11057
      begin
11058
         --  if the original access type was not embedded in the enclosing
11059
         --  type definition, there is no need to produce a new access
11060
         --  subtype. In fact every access type with an explicit constraint
11061
         --  generates an itype whose scope is the enclosing record.
11062
 
11063
         if not Is_Type (Scope (Old_Type)) then
11064
            return Old_Type;
11065
 
11066
         elsif Is_Array_Type (Desig_Type) then
11067
            Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
11068
 
11069
         elsif Has_Discriminants (Desig_Type) then
11070
 
11071
            --  This may be an access type to an enclosing record type for
11072
            --  which we are constructing the constrained components. Return
11073
            --  the enclosing record subtype. This is not always correct,
11074
            --  but avoids infinite recursion. ???
11075
 
11076
            Desig_Subtype := Any_Type;
11077
 
11078
            for J in reverse 0 .. Scope_Stack.Last loop
11079
               Scop := Scope_Stack.Table (J).Entity;
11080
 
11081
               if Is_Type (Scop)
11082
                 and then Base_Type (Scop) = Base_Type (Desig_Type)
11083
               then
11084
                  Desig_Subtype := Scop;
11085
               end if;
11086
 
11087
               exit when not Is_Type (Scop);
11088
            end loop;
11089
 
11090
            if Desig_Subtype = Any_Type then
11091
               Desig_Subtype :=
11092
                 Build_Constrained_Discriminated_Type (Desig_Type);
11093
            end if;
11094
 
11095
         else
11096
            return Old_Type;
11097
         end if;
11098
 
11099
         if Desig_Subtype /= Desig_Type then
11100
 
11101
            --  The Related_Node better be here or else we won't be able
11102
            --  to attach new itypes to a node in the tree.
11103
 
11104
            pragma Assert (Present (Related_Node));
11105
 
11106
            Itype := Create_Itype (E_Access_Subtype, Related_Node);
11107
 
11108
            Set_Etype                    (Itype, Base_Type      (Old_Type));
11109
            Set_Size_Info                (Itype,                (Old_Type));
11110
            Set_Directly_Designated_Type (Itype, Desig_Subtype);
11111
            Set_Depends_On_Private       (Itype, Has_Private_Component
11112
                                                                (Old_Type));
11113
            Set_Is_Access_Constant       (Itype, Is_Access_Constant
11114
                                                                (Old_Type));
11115
 
11116
            --  The new itype needs freezing when it depends on a not frozen
11117
            --  type and the enclosing subtype needs freezing.
11118
 
11119
            if Has_Delayed_Freeze (Constrained_Typ)
11120
              and then not Is_Frozen (Constrained_Typ)
11121
            then
11122
               Conditional_Delay (Itype, Base_Type (Old_Type));
11123
            end if;
11124
 
11125
            return Itype;
11126
 
11127
         else
11128
            return Old_Type;
11129
         end if;
11130
      end Build_Constrained_Access_Type;
11131
 
11132
      ----------------------------------
11133
      -- Build_Constrained_Array_Type --
11134
      ----------------------------------
11135
 
11136
      function Build_Constrained_Array_Type
11137
        (Old_Type : Entity_Id) return Entity_Id
11138
      is
11139
         Lo_Expr     : Node_Id;
11140
         Hi_Expr     : Node_Id;
11141
         Old_Index   : Node_Id;
11142
         Range_Node  : Node_Id;
11143
         Constr_List : List_Id;
11144
 
11145
         Need_To_Create_Itype : Boolean := False;
11146
 
11147
      begin
11148
         Old_Index := First_Index (Old_Type);
11149
         while Present (Old_Index) loop
11150
            Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
11151
 
11152
            if Is_Discriminant (Lo_Expr)
11153
              or else Is_Discriminant (Hi_Expr)
11154
            then
11155
               Need_To_Create_Itype := True;
11156
            end if;
11157
 
11158
            Next_Index (Old_Index);
11159
         end loop;
11160
 
11161
         if Need_To_Create_Itype then
11162
            Constr_List := New_List;
11163
 
11164
            Old_Index := First_Index (Old_Type);
11165
            while Present (Old_Index) loop
11166
               Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
11167
 
11168
               if Is_Discriminant (Lo_Expr) then
11169
                  Lo_Expr := Get_Discr_Value (Lo_Expr);
11170
               end if;
11171
 
11172
               if Is_Discriminant (Hi_Expr) then
11173
                  Hi_Expr := Get_Discr_Value (Hi_Expr);
11174
               end if;
11175
 
11176
               Range_Node :=
11177
                 Make_Range
11178
                   (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
11179
 
11180
               Append (Range_Node, To => Constr_List);
11181
 
11182
               Next_Index (Old_Index);
11183
            end loop;
11184
 
11185
            return Build_Subtype (Old_Type, Constr_List);
11186
 
11187
         else
11188
            return Old_Type;
11189
         end if;
11190
      end Build_Constrained_Array_Type;
11191
 
11192
      ------------------------------------------
11193
      -- Build_Constrained_Discriminated_Type --
11194
      ------------------------------------------
11195
 
11196
      function Build_Constrained_Discriminated_Type
11197
        (Old_Type : Entity_Id) return Entity_Id
11198
      is
11199
         Expr           : Node_Id;
11200
         Constr_List    : List_Id;
11201
         Old_Constraint : Elmt_Id;
11202
 
11203
         Need_To_Create_Itype : Boolean := False;
11204
 
11205
      begin
11206
         Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
11207
         while Present (Old_Constraint) loop
11208
            Expr := Node (Old_Constraint);
11209
 
11210
            if Is_Discriminant (Expr) then
11211
               Need_To_Create_Itype := True;
11212
            end if;
11213
 
11214
            Next_Elmt (Old_Constraint);
11215
         end loop;
11216
 
11217
         if Need_To_Create_Itype then
11218
            Constr_List := New_List;
11219
 
11220
            Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
11221
            while Present (Old_Constraint) loop
11222
               Expr := Node (Old_Constraint);
11223
 
11224
               if Is_Discriminant (Expr) then
11225
                  Expr := Get_Discr_Value (Expr);
11226
               end if;
11227
 
11228
               Append (New_Copy_Tree (Expr), To => Constr_List);
11229
 
11230
               Next_Elmt (Old_Constraint);
11231
            end loop;
11232
 
11233
            return Build_Subtype (Old_Type, Constr_List);
11234
 
11235
         else
11236
            return Old_Type;
11237
         end if;
11238
      end Build_Constrained_Discriminated_Type;
11239
 
11240
      -------------------
11241
      -- Build_Subtype --
11242
      -------------------
11243
 
11244
      function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
11245
         Indic       : Node_Id;
11246
         Subtyp_Decl : Node_Id;
11247
         Def_Id      : Entity_Id;
11248
         Btyp        : Entity_Id := Base_Type (T);
11249
 
11250
      begin
11251
         --  The Related_Node better be here or else we won't be able to
11252
         --  attach new itypes to a node in the tree.
11253
 
11254
         pragma Assert (Present (Related_Node));
11255
 
11256
         --  If the view of the component's type is incomplete or private
11257
         --  with unknown discriminants, then the constraint must be applied
11258
         --  to the full type.
11259
 
11260
         if Has_Unknown_Discriminants (Btyp)
11261
           and then Present (Underlying_Type (Btyp))
11262
         then
11263
            Btyp := Underlying_Type (Btyp);
11264
         end if;
11265
 
11266
         Indic :=
11267
           Make_Subtype_Indication (Loc,
11268
             Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
11269
             Constraint   => Make_Index_Or_Discriminant_Constraint (Loc, C));
11270
 
11271
         Def_Id := Create_Itype (Ekind (T), Related_Node);
11272
 
11273
         Subtyp_Decl :=
11274
           Make_Subtype_Declaration (Loc,
11275
             Defining_Identifier => Def_Id,
11276
             Subtype_Indication  => Indic);
11277
 
11278
         Set_Parent (Subtyp_Decl, Parent (Related_Node));
11279
 
11280
         --  Itypes must be analyzed with checks off (see package Itypes)
11281
 
11282
         Analyze (Subtyp_Decl, Suppress => All_Checks);
11283
 
11284
         return Def_Id;
11285
      end Build_Subtype;
11286
 
11287
      ---------------------
11288
      -- Get_Discr_Value --
11289
      ---------------------
11290
 
11291
      function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
11292
         D : Entity_Id;
11293
         E : Elmt_Id;
11294
 
11295
      begin
11296
         --  The discriminant may be declared for the type, in which case we
11297
         --  find it by iterating over the list of discriminants. If the
11298
         --  discriminant is inherited from a parent type, it appears as the
11299
         --  corresponding discriminant of the current type. This will be the
11300
         --  case when constraining an inherited component whose constraint is
11301
         --  given by a discriminant of the parent.
11302
 
11303
         D := First_Discriminant (Typ);
11304
         E := First_Elmt (Constraints);
11305
 
11306
         while Present (D) loop
11307
            if D = Entity (Discrim)
11308
              or else D = CR_Discriminant (Entity (Discrim))
11309
              or else Corresponding_Discriminant (D) = Entity (Discrim)
11310
            then
11311
               return Node (E);
11312
            end if;
11313
 
11314
            Next_Discriminant (D);
11315
            Next_Elmt (E);
11316
         end loop;
11317
 
11318
         --  The Corresponding_Discriminant mechanism is incomplete, because
11319
         --  the correspondence between new and old discriminants is not one
11320
         --  to one: one new discriminant can constrain several old ones. In
11321
         --  that case, scan sequentially the stored_constraint, the list of
11322
         --  discriminants of the parents, and the constraints.
11323
         --  Previous code checked for the present of the Stored_Constraint
11324
         --  list for the derived type, but did not use it at all. Should it
11325
         --  be present when the component is a discriminated task type?
11326
 
11327
         if Is_Derived_Type (Typ)
11328
           and then Scope (Entity (Discrim)) = Etype (Typ)
11329
         then
11330
            D := First_Discriminant (Etype (Typ));
11331
            E := First_Elmt (Constraints);
11332
            while Present (D) loop
11333
               if D = Entity (Discrim) then
11334
                  return Node (E);
11335
               end if;
11336
 
11337
               Next_Discriminant (D);
11338
               Next_Elmt (E);
11339
            end loop;
11340
         end if;
11341
 
11342
         --  Something is wrong if we did not find the value
11343
 
11344
         raise Program_Error;
11345
      end Get_Discr_Value;
11346
 
11347
      ---------------------
11348
      -- Is_Discriminant --
11349
      ---------------------
11350
 
11351
      function Is_Discriminant (Expr : Node_Id) return Boolean is
11352
         Discrim_Scope : Entity_Id;
11353
 
11354
      begin
11355
         if Denotes_Discriminant (Expr) then
11356
            Discrim_Scope := Scope (Entity (Expr));
11357
 
11358
            --  Either we have a reference to one of Typ's discriminants,
11359
 
11360
            pragma Assert (Discrim_Scope = Typ
11361
 
11362
               --  or to the discriminants of the parent type, in the case
11363
               --  of a derivation of a tagged type with variants.
11364
 
11365
               or else Discrim_Scope = Etype (Typ)
11366
               or else Full_View (Discrim_Scope) = Etype (Typ)
11367
 
11368
               --  or same as above for the case where the discriminants
11369
               --  were declared in Typ's private view.
11370
 
11371
               or else (Is_Private_Type (Discrim_Scope)
11372
                        and then Chars (Discrim_Scope) = Chars (Typ))
11373
 
11374
               --  or else we are deriving from the full view and the
11375
               --  discriminant is declared in the private entity.
11376
 
11377
               or else (Is_Private_Type (Typ)
11378
                         and then Chars (Discrim_Scope) = Chars (Typ))
11379
 
11380
               --  Or we are constrained the corresponding record of a
11381
               --  synchronized type that completes a private declaration.
11382
 
11383
               or else (Is_Concurrent_Record_Type (Typ)
11384
                         and then
11385
                           Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
11386
 
11387
               --  or we have a class-wide type, in which case make sure the
11388
               --  discriminant found belongs to the root type.
11389
 
11390
               or else (Is_Class_Wide_Type (Typ)
11391
                         and then Etype (Typ) = Discrim_Scope));
11392
 
11393
            return True;
11394
         end if;
11395
 
11396
         --  In all other cases we have something wrong
11397
 
11398
         return False;
11399
      end Is_Discriminant;
11400
 
11401
   --  Start of processing for Constrain_Component_Type
11402
 
11403
   begin
11404
      if Nkind (Parent (Comp)) = N_Component_Declaration
11405
        and then Comes_From_Source (Parent (Comp))
11406
        and then Comes_From_Source
11407
          (Subtype_Indication (Component_Definition (Parent (Comp))))
11408
        and then
11409
          Is_Entity_Name
11410
            (Subtype_Indication (Component_Definition (Parent (Comp))))
11411
      then
11412
         return Compon_Type;
11413
 
11414
      elsif Is_Array_Type (Compon_Type) then
11415
         return Build_Constrained_Array_Type (Compon_Type);
11416
 
11417
      elsif Has_Discriminants (Compon_Type) then
11418
         return Build_Constrained_Discriminated_Type (Compon_Type);
11419
 
11420
      elsif Is_Access_Type (Compon_Type) then
11421
         return Build_Constrained_Access_Type (Compon_Type);
11422
 
11423
      else
11424
         return Compon_Type;
11425
      end if;
11426
   end Constrain_Component_Type;
11427
 
11428
   --------------------------
11429
   -- Constrain_Concurrent --
11430
   --------------------------
11431
 
11432
   --  For concurrent types, the associated record value type carries the same
11433
   --  discriminants, so when we constrain a concurrent type, we must constrain
11434
   --  the corresponding record type as well.
11435
 
11436
   procedure Constrain_Concurrent
11437
     (Def_Id      : in out Entity_Id;
11438
      SI          : Node_Id;
11439
      Related_Nod : Node_Id;
11440
      Related_Id  : Entity_Id;
11441
      Suffix      : Character)
11442
   is
11443
      --  Retrieve Base_Type to ensure getting to the concurrent type in the
11444
      --  case of a private subtype (needed when only doing semantic analysis).
11445
 
11446
      T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
11447
      T_Val : Entity_Id;
11448
 
11449
   begin
11450
      if Ekind (T_Ent) in Access_Kind then
11451
         T_Ent := Designated_Type (T_Ent);
11452
      end if;
11453
 
11454
      T_Val := Corresponding_Record_Type (T_Ent);
11455
 
11456
      if Present (T_Val) then
11457
 
11458
         if No (Def_Id) then
11459
            Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
11460
         end if;
11461
 
11462
         Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
11463
 
11464
         Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
11465
         Set_Corresponding_Record_Type (Def_Id,
11466
           Constrain_Corresponding_Record
11467
             (Def_Id, T_Val, Related_Nod, Related_Id));
11468
 
11469
      else
11470
         --  If there is no associated record, expansion is disabled and this
11471
         --  is a generic context. Create a subtype in any case, so that
11472
         --  semantic analysis can proceed.
11473
 
11474
         if No (Def_Id) then
11475
            Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
11476
         end if;
11477
 
11478
         Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
11479
      end if;
11480
   end Constrain_Concurrent;
11481
 
11482
   ------------------------------------
11483
   -- Constrain_Corresponding_Record --
11484
   ------------------------------------
11485
 
11486
   function Constrain_Corresponding_Record
11487
     (Prot_Subt   : Entity_Id;
11488
      Corr_Rec    : Entity_Id;
11489
      Related_Nod : Node_Id;
11490
      Related_Id  : Entity_Id) return Entity_Id
11491
   is
11492
      T_Sub : constant Entity_Id :=
11493
                Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
11494
 
11495
   begin
11496
      Set_Etype             (T_Sub, Corr_Rec);
11497
      Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
11498
      Set_Is_Constrained    (T_Sub, True);
11499
      Set_First_Entity      (T_Sub, First_Entity (Corr_Rec));
11500
      Set_Last_Entity       (T_Sub, Last_Entity  (Corr_Rec));
11501
 
11502
      --  As elsewhere, we do not want to create a freeze node for this itype
11503
      --  if it is created for a constrained component of an enclosing record
11504
      --  because references to outer discriminants will appear out of scope.
11505
 
11506
      if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
11507
         Conditional_Delay (T_Sub, Corr_Rec);
11508
      else
11509
         Set_Is_Frozen (T_Sub);
11510
      end if;
11511
 
11512
      if Has_Discriminants (Prot_Subt) then -- False only if errors.
11513
         Set_Discriminant_Constraint
11514
           (T_Sub, Discriminant_Constraint (Prot_Subt));
11515
         Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
11516
         Create_Constrained_Components
11517
           (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
11518
      end if;
11519
 
11520
      Set_Depends_On_Private      (T_Sub, Has_Private_Component (T_Sub));
11521
 
11522
      return T_Sub;
11523
   end Constrain_Corresponding_Record;
11524
 
11525
   -----------------------
11526
   -- Constrain_Decimal --
11527
   -----------------------
11528
 
11529
   procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is
11530
      T           : constant Entity_Id  := Entity (Subtype_Mark (S));
11531
      C           : constant Node_Id    := Constraint (S);
11532
      Loc         : constant Source_Ptr := Sloc (C);
11533
      Range_Expr  : Node_Id;
11534
      Digits_Expr : Node_Id;
11535
      Digits_Val  : Uint;
11536
      Bound_Val   : Ureal;
11537
 
11538
   begin
11539
      Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
11540
 
11541
      if Nkind (C) = N_Range_Constraint then
11542
         Range_Expr := Range_Expression (C);
11543
         Digits_Val := Digits_Value (T);
11544
 
11545
      else
11546
         pragma Assert (Nkind (C) = N_Digits_Constraint);
11547
 
11548
         Check_SPARK_Restriction ("digits constraint is not allowed", S);
11549
 
11550
         Digits_Expr := Digits_Expression (C);
11551
         Analyze_And_Resolve (Digits_Expr, Any_Integer);
11552
 
11553
         Check_Digits_Expression (Digits_Expr);
11554
         Digits_Val := Expr_Value (Digits_Expr);
11555
 
11556
         if Digits_Val > Digits_Value (T) then
11557
            Error_Msg_N
11558
               ("digits expression is incompatible with subtype", C);
11559
            Digits_Val := Digits_Value (T);
11560
         end if;
11561
 
11562
         if Present (Range_Constraint (C)) then
11563
            Range_Expr := Range_Expression (Range_Constraint (C));
11564
         else
11565
            Range_Expr := Empty;
11566
         end if;
11567
      end if;
11568
 
11569
      Set_Etype            (Def_Id, Base_Type        (T));
11570
      Set_Size_Info        (Def_Id,                  (T));
11571
      Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
11572
      Set_Delta_Value      (Def_Id, Delta_Value      (T));
11573
      Set_Scale_Value      (Def_Id, Scale_Value      (T));
11574
      Set_Small_Value      (Def_Id, Small_Value      (T));
11575
      Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
11576
      Set_Digits_Value     (Def_Id, Digits_Val);
11577
 
11578
      --  Manufacture range from given digits value if no range present
11579
 
11580
      if No (Range_Expr) then
11581
         Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
11582
         Range_Expr :=
11583
           Make_Range (Loc,
11584
             Low_Bound =>
11585
               Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
11586
             High_Bound =>
11587
               Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
11588
      end if;
11589
 
11590
      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
11591
      Set_Discrete_RM_Size (Def_Id);
11592
 
11593
      --  Unconditionally delay the freeze, since we cannot set size
11594
      --  information in all cases correctly until the freeze point.
11595
 
11596
      Set_Has_Delayed_Freeze (Def_Id);
11597
   end Constrain_Decimal;
11598
 
11599
   ----------------------------------
11600
   -- Constrain_Discriminated_Type --
11601
   ----------------------------------
11602
 
11603
   procedure Constrain_Discriminated_Type
11604
     (Def_Id      : Entity_Id;
11605
      S           : Node_Id;
11606
      Related_Nod : Node_Id;
11607
      For_Access  : Boolean := False)
11608
   is
11609
      E     : constant Entity_Id := Entity (Subtype_Mark (S));
11610
      T     : Entity_Id;
11611
      C     : Node_Id;
11612
      Elist : Elist_Id := New_Elmt_List;
11613
 
11614
      procedure Fixup_Bad_Constraint;
11615
      --  This is called after finding a bad constraint, and after having
11616
      --  posted an appropriate error message. The mission is to leave the
11617
      --  entity T in as reasonable state as possible!
11618
 
11619
      --------------------------
11620
      -- Fixup_Bad_Constraint --
11621
      --------------------------
11622
 
11623
      procedure Fixup_Bad_Constraint is
11624
      begin
11625
         --  Set a reasonable Ekind for the entity. For an incomplete type,
11626
         --  we can't do much, but for other types, we can set the proper
11627
         --  corresponding subtype kind.
11628
 
11629
         if Ekind (T) = E_Incomplete_Type then
11630
            Set_Ekind (Def_Id, Ekind (T));
11631
         else
11632
            Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
11633
         end if;
11634
 
11635
         --  Set Etype to the known type, to reduce chances of cascaded errors
11636
 
11637
         Set_Etype (Def_Id, E);
11638
         Set_Error_Posted (Def_Id);
11639
      end Fixup_Bad_Constraint;
11640
 
11641
   --  Start of processing for Constrain_Discriminated_Type
11642
 
11643
   begin
11644
      C := Constraint (S);
11645
 
11646
      --  A discriminant constraint is only allowed in a subtype indication,
11647
      --  after a subtype mark. This subtype mark must denote either a type
11648
      --  with discriminants, or an access type whose designated type is a
11649
      --  type with discriminants. A discriminant constraint specifies the
11650
      --  values of these discriminants (RM 3.7.2(5)).
11651
 
11652
      T := Base_Type (Entity (Subtype_Mark (S)));
11653
 
11654
      if Ekind (T) in Access_Kind then
11655
         T := Designated_Type (T);
11656
      end if;
11657
 
11658
      --  Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
11659
      --  Avoid generating an error for access-to-incomplete subtypes.
11660
 
11661
      if Ada_Version >= Ada_2005
11662
        and then Ekind (T) = E_Incomplete_Type
11663
        and then Nkind (Parent (S)) = N_Subtype_Declaration
11664
        and then not Is_Itype (Def_Id)
11665
      then
11666
         --  A little sanity check, emit an error message if the type
11667
         --  has discriminants to begin with. Type T may be a regular
11668
         --  incomplete type or imported via a limited with clause.
11669
 
11670
         if Has_Discriminants (T)
11671
           or else
11672
             (From_With_Type (T)
11673
                and then Present (Non_Limited_View (T))
11674
                and then Nkind (Parent (Non_Limited_View (T))) =
11675
                           N_Full_Type_Declaration
11676
                and then Present (Discriminant_Specifications
11677
                          (Parent (Non_Limited_View (T)))))
11678
         then
11679
            Error_Msg_N
11680
              ("(Ada 2005) incomplete subtype may not be constrained", C);
11681
         else
11682
            Error_Msg_N ("invalid constraint: type has no discriminant", C);
11683
         end if;
11684
 
11685
         Fixup_Bad_Constraint;
11686
         return;
11687
 
11688
      --  Check that the type has visible discriminants. The type may be
11689
      --  a private type with unknown discriminants whose full view has
11690
      --  discriminants which are invisible.
11691
 
11692
      elsif not Has_Discriminants (T)
11693
        or else
11694
          (Has_Unknown_Discriminants (T)
11695
             and then Is_Private_Type (T))
11696
      then
11697
         Error_Msg_N ("invalid constraint: type has no discriminant", C);
11698
         Fixup_Bad_Constraint;
11699
         return;
11700
 
11701
      elsif Is_Constrained (E)
11702
        or else (Ekind (E) = E_Class_Wide_Subtype
11703
                  and then Present (Discriminant_Constraint (E)))
11704
      then
11705
         Error_Msg_N ("type is already constrained", Subtype_Mark (S));
11706
         Fixup_Bad_Constraint;
11707
         return;
11708
      end if;
11709
 
11710
      --  T may be an unconstrained subtype (e.g. a generic actual).
11711
      --  Constraint applies to the base type.
11712
 
11713
      T := Base_Type (T);
11714
 
11715
      Elist := Build_Discriminant_Constraints (T, S);
11716
 
11717
      --  If the list returned was empty we had an error in building the
11718
      --  discriminant constraint. We have also already signalled an error
11719
      --  in the incomplete type case
11720
 
11721
      if Is_Empty_Elmt_List (Elist) then
11722
         Fixup_Bad_Constraint;
11723
         return;
11724
      end if;
11725
 
11726
      Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
11727
   end Constrain_Discriminated_Type;
11728
 
11729
   ---------------------------
11730
   -- Constrain_Enumeration --
11731
   ---------------------------
11732
 
11733
   procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is
11734
      T : constant Entity_Id := Entity (Subtype_Mark (S));
11735
      C : constant Node_Id   := Constraint (S);
11736
 
11737
   begin
11738
      Set_Ekind (Def_Id, E_Enumeration_Subtype);
11739
 
11740
      Set_First_Literal     (Def_Id, First_Literal (Base_Type (T)));
11741
 
11742
      Set_Etype             (Def_Id, Base_Type         (T));
11743
      Set_Size_Info         (Def_Id,                   (T));
11744
      Set_First_Rep_Item    (Def_Id, First_Rep_Item    (T));
11745
      Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
11746
 
11747
      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
11748
 
11749
      Set_Discrete_RM_Size (Def_Id);
11750
   end Constrain_Enumeration;
11751
 
11752
   ----------------------
11753
   -- Constrain_Float --
11754
   ----------------------
11755
 
11756
   procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is
11757
      T    : constant Entity_Id := Entity (Subtype_Mark (S));
11758
      C    : Node_Id;
11759
      D    : Node_Id;
11760
      Rais : Node_Id;
11761
 
11762
   begin
11763
      Set_Ekind (Def_Id, E_Floating_Point_Subtype);
11764
 
11765
      Set_Etype          (Def_Id, Base_Type      (T));
11766
      Set_Size_Info      (Def_Id,                (T));
11767
      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
11768
 
11769
      --  Process the constraint
11770
 
11771
      C := Constraint (S);
11772
 
11773
      --  Digits constraint present
11774
 
11775
      if Nkind (C) = N_Digits_Constraint then
11776
 
11777
         Check_SPARK_Restriction ("digits constraint is not allowed", S);
11778
         Check_Restriction (No_Obsolescent_Features, C);
11779
 
11780
         if Warn_On_Obsolescent_Feature then
11781
            Error_Msg_N
11782
              ("subtype digits constraint is an " &
11783
               "obsolescent feature (RM J.3(8))?", C);
11784
         end if;
11785
 
11786
         D := Digits_Expression (C);
11787
         Analyze_And_Resolve (D, Any_Integer);
11788
         Check_Digits_Expression (D);
11789
         Set_Digits_Value (Def_Id, Expr_Value (D));
11790
 
11791
         --  Check that digits value is in range. Obviously we can do this
11792
         --  at compile time, but it is strictly a runtime check, and of
11793
         --  course there is an ACVC test that checks this!
11794
 
11795
         if Digits_Value (Def_Id) > Digits_Value (T) then
11796
            Error_Msg_Uint_1 := Digits_Value (T);
11797
            Error_Msg_N ("?digits value is too large, maximum is ^", D);
11798
            Rais :=
11799
              Make_Raise_Constraint_Error (Sloc (D),
11800
                Reason => CE_Range_Check_Failed);
11801
            Insert_Action (Declaration_Node (Def_Id), Rais);
11802
         end if;
11803
 
11804
         C := Range_Constraint (C);
11805
 
11806
      --  No digits constraint present
11807
 
11808
      else
11809
         Set_Digits_Value (Def_Id, Digits_Value (T));
11810
      end if;
11811
 
11812
      --  Range constraint present
11813
 
11814
      if Nkind (C) = N_Range_Constraint then
11815
         Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
11816
 
11817
      --  No range constraint present
11818
 
11819
      else
11820
         pragma Assert (No (C));
11821
         Set_Scalar_Range (Def_Id, Scalar_Range (T));
11822
      end if;
11823
 
11824
      Set_Is_Constrained (Def_Id);
11825
   end Constrain_Float;
11826
 
11827
   ---------------------
11828
   -- Constrain_Index --
11829
   ---------------------
11830
 
11831
   procedure Constrain_Index
11832
     (Index        : Node_Id;
11833
      S            : Node_Id;
11834
      Related_Nod  : Node_Id;
11835
      Related_Id   : Entity_Id;
11836
      Suffix       : Character;
11837
      Suffix_Index : Nat)
11838
   is
11839
      Def_Id : Entity_Id;
11840
      R      : Node_Id := Empty;
11841
      T      : constant Entity_Id := Etype (Index);
11842
 
11843
   begin
11844
      if Nkind (S) = N_Range
11845
        or else
11846
          (Nkind (S) = N_Attribute_Reference
11847
            and then Attribute_Name (S) = Name_Range)
11848
      then
11849
         --  A Range attribute will be transformed into N_Range by Resolve
11850
 
11851
         Analyze (S);
11852
         Set_Etype (S, T);
11853
         R := S;
11854
 
11855
         Process_Range_Expr_In_Decl (R, T, Empty_List);
11856
 
11857
         if not Error_Posted (S)
11858
           and then
11859
             (Nkind (S) /= N_Range
11860
               or else not Covers (T, (Etype (Low_Bound (S))))
11861
               or else not Covers (T, (Etype (High_Bound (S)))))
11862
         then
11863
            if Base_Type (T) /= Any_Type
11864
              and then Etype (Low_Bound (S)) /= Any_Type
11865
              and then Etype (High_Bound (S)) /= Any_Type
11866
            then
11867
               Error_Msg_N ("range expected", S);
11868
            end if;
11869
         end if;
11870
 
11871
      elsif Nkind (S) = N_Subtype_Indication then
11872
 
11873
         --  The parser has verified that this is a discrete indication
11874
 
11875
         Resolve_Discrete_Subtype_Indication (S, T);
11876
         R := Range_Expression (Constraint (S));
11877
 
11878
         --  Capture values of bounds and generate temporaries for them if
11879
         --  needed, since checks may cause duplication of the expressions
11880
         --  which must not be reevaluated.
11881
 
11882
         --  The forced evaluation removes side effects from expressions,
11883
         --  which should occur also in Alfa mode. Otherwise, we end up with
11884
         --  unexpected insertions of actions at places where this is not
11885
         --  supposed to occur, e.g. on default parameters of a call.
11886
 
11887
         if Expander_Active then
11888
            Force_Evaluation (Low_Bound (R));
11889
            Force_Evaluation (High_Bound (R));
11890
         end if;
11891
 
11892
      elsif Nkind (S) = N_Discriminant_Association then
11893
 
11894
         --  Syntactically valid in subtype indication
11895
 
11896
         Error_Msg_N ("invalid index constraint", S);
11897
         Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
11898
         return;
11899
 
11900
      --  Subtype_Mark case, no anonymous subtypes to construct
11901
 
11902
      else
11903
         Analyze (S);
11904
 
11905
         if Is_Entity_Name (S) then
11906
            if not Is_Type (Entity (S)) then
11907
               Error_Msg_N ("expect subtype mark for index constraint", S);
11908
 
11909
            elsif Base_Type (Entity (S)) /= Base_Type (T) then
11910
               Wrong_Type (S, Base_Type (T));
11911
 
11912
            --  Check error of subtype with predicate in index constraint
11913
 
11914
            else
11915
               Bad_Predicated_Subtype_Use
11916
                 ("subtype& has predicate, not allowed in index constraint",
11917
                  S, Entity (S));
11918
            end if;
11919
 
11920
            return;
11921
 
11922
         else
11923
            Error_Msg_N ("invalid index constraint", S);
11924
            Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
11925
            return;
11926
         end if;
11927
      end if;
11928
 
11929
      Def_Id :=
11930
        Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
11931
 
11932
      Set_Etype (Def_Id, Base_Type (T));
11933
 
11934
      if Is_Modular_Integer_Type (T) then
11935
         Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
11936
 
11937
      elsif Is_Integer_Type (T) then
11938
         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
11939
 
11940
      else
11941
         Set_Ekind (Def_Id, E_Enumeration_Subtype);
11942
         Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
11943
         Set_First_Literal     (Def_Id, First_Literal (T));
11944
      end if;
11945
 
11946
      Set_Size_Info      (Def_Id,                (T));
11947
      Set_RM_Size        (Def_Id, RM_Size        (T));
11948
      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
11949
 
11950
      Set_Scalar_Range   (Def_Id, R);
11951
 
11952
      Set_Etype (S, Def_Id);
11953
      Set_Discrete_RM_Size (Def_Id);
11954
   end Constrain_Index;
11955
 
11956
   -----------------------
11957
   -- Constrain_Integer --
11958
   -----------------------
11959
 
11960
   procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is
11961
      T : constant Entity_Id := Entity (Subtype_Mark (S));
11962
      C : constant Node_Id   := Constraint (S);
11963
 
11964
   begin
11965
      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
11966
 
11967
      if Is_Modular_Integer_Type (T) then
11968
         Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
11969
      else
11970
         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
11971
      end if;
11972
 
11973
      Set_Etype            (Def_Id, Base_Type        (T));
11974
      Set_Size_Info        (Def_Id,                  (T));
11975
      Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
11976
      Set_Discrete_RM_Size (Def_Id);
11977
   end Constrain_Integer;
11978
 
11979
   ------------------------------
11980
   -- Constrain_Ordinary_Fixed --
11981
   ------------------------------
11982
 
11983
   procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is
11984
      T    : constant Entity_Id := Entity (Subtype_Mark (S));
11985
      C    : Node_Id;
11986
      D    : Node_Id;
11987
      Rais : Node_Id;
11988
 
11989
   begin
11990
      Set_Ekind          (Def_Id, E_Ordinary_Fixed_Point_Subtype);
11991
      Set_Etype          (Def_Id, Base_Type        (T));
11992
      Set_Size_Info      (Def_Id,                  (T));
11993
      Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
11994
      Set_Small_Value    (Def_Id, Small_Value      (T));
11995
 
11996
      --  Process the constraint
11997
 
11998
      C := Constraint (S);
11999
 
12000
      --  Delta constraint present
12001
 
12002
      if Nkind (C) = N_Delta_Constraint then
12003
 
12004
         Check_SPARK_Restriction ("delta constraint is not allowed", S);
12005
         Check_Restriction (No_Obsolescent_Features, C);
12006
 
12007
         if Warn_On_Obsolescent_Feature then
12008
            Error_Msg_S
12009
              ("subtype delta constraint is an " &
12010
               "obsolescent feature (RM J.3(7))?");
12011
         end if;
12012
 
12013
         D := Delta_Expression (C);
12014
         Analyze_And_Resolve (D, Any_Real);
12015
         Check_Delta_Expression (D);
12016
         Set_Delta_Value (Def_Id, Expr_Value_R (D));
12017
 
12018
         --  Check that delta value is in range. Obviously we can do this
12019
         --  at compile time, but it is strictly a runtime check, and of
12020
         --  course there is an ACVC test that checks this!
12021
 
12022
         if Delta_Value (Def_Id) < Delta_Value (T) then
12023
            Error_Msg_N ("?delta value is too small", D);
12024
            Rais :=
12025
              Make_Raise_Constraint_Error (Sloc (D),
12026
                Reason => CE_Range_Check_Failed);
12027
            Insert_Action (Declaration_Node (Def_Id), Rais);
12028
         end if;
12029
 
12030
         C := Range_Constraint (C);
12031
 
12032
      --  No delta constraint present
12033
 
12034
      else
12035
         Set_Delta_Value (Def_Id, Delta_Value (T));
12036
      end if;
12037
 
12038
      --  Range constraint present
12039
 
12040
      if Nkind (C) = N_Range_Constraint then
12041
         Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
12042
 
12043
      --  No range constraint present
12044
 
12045
      else
12046
         pragma Assert (No (C));
12047
         Set_Scalar_Range (Def_Id, Scalar_Range (T));
12048
 
12049
      end if;
12050
 
12051
      Set_Discrete_RM_Size (Def_Id);
12052
 
12053
      --  Unconditionally delay the freeze, since we cannot set size
12054
      --  information in all cases correctly until the freeze point.
12055
 
12056
      Set_Has_Delayed_Freeze (Def_Id);
12057
   end Constrain_Ordinary_Fixed;
12058
 
12059
   -----------------------
12060
   -- Contain_Interface --
12061
   -----------------------
12062
 
12063
   function Contain_Interface
12064
     (Iface  : Entity_Id;
12065
      Ifaces : Elist_Id) return Boolean
12066
   is
12067
      Iface_Elmt : Elmt_Id;
12068
 
12069
   begin
12070
      if Present (Ifaces) then
12071
         Iface_Elmt := First_Elmt (Ifaces);
12072
         while Present (Iface_Elmt) loop
12073
            if Node (Iface_Elmt) = Iface then
12074
               return True;
12075
            end if;
12076
 
12077
            Next_Elmt (Iface_Elmt);
12078
         end loop;
12079
      end if;
12080
 
12081
      return False;
12082
   end Contain_Interface;
12083
 
12084
   ---------------------------
12085
   -- Convert_Scalar_Bounds --
12086
   ---------------------------
12087
 
12088
   procedure Convert_Scalar_Bounds
12089
     (N            : Node_Id;
12090
      Parent_Type  : Entity_Id;
12091
      Derived_Type : Entity_Id;
12092
      Loc          : Source_Ptr)
12093
   is
12094
      Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
12095
 
12096
      Lo  : Node_Id;
12097
      Hi  : Node_Id;
12098
      Rng : Node_Id;
12099
 
12100
   begin
12101
      --  Defend against previous errors
12102
 
12103
      if No (Scalar_Range (Derived_Type)) then
12104
         return;
12105
      end if;
12106
 
12107
      Lo := Build_Scalar_Bound
12108
              (Type_Low_Bound (Derived_Type),
12109
               Parent_Type, Implicit_Base);
12110
 
12111
      Hi := Build_Scalar_Bound
12112
              (Type_High_Bound (Derived_Type),
12113
               Parent_Type, Implicit_Base);
12114
 
12115
      Rng :=
12116
        Make_Range (Loc,
12117
          Low_Bound  => Lo,
12118
          High_Bound => Hi);
12119
 
12120
      Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
12121
 
12122
      Set_Parent (Rng, N);
12123
      Set_Scalar_Range (Derived_Type, Rng);
12124
 
12125
      --  Analyze the bounds
12126
 
12127
      Analyze_And_Resolve (Lo, Implicit_Base);
12128
      Analyze_And_Resolve (Hi, Implicit_Base);
12129
 
12130
      --  Analyze the range itself, except that we do not analyze it if
12131
      --  the bounds are real literals, and we have a fixed-point type.
12132
      --  The reason for this is that we delay setting the bounds in this
12133
      --  case till we know the final Small and Size values (see circuit
12134
      --  in Freeze.Freeze_Fixed_Point_Type for further details).
12135
 
12136
      if Is_Fixed_Point_Type (Parent_Type)
12137
        and then Nkind (Lo) = N_Real_Literal
12138
        and then Nkind (Hi) = N_Real_Literal
12139
      then
12140
         return;
12141
 
12142
      --  Here we do the analysis of the range
12143
 
12144
      --  Note: we do this manually, since if we do a normal Analyze and
12145
      --  Resolve call, there are problems with the conversions used for
12146
      --  the derived type range.
12147
 
12148
      else
12149
         Set_Etype    (Rng, Implicit_Base);
12150
         Set_Analyzed (Rng, True);
12151
      end if;
12152
   end Convert_Scalar_Bounds;
12153
 
12154
   -------------------
12155
   -- Copy_And_Swap --
12156
   -------------------
12157
 
12158
   procedure Copy_And_Swap (Priv, Full : Entity_Id) is
12159
   begin
12160
      --  Initialize new full declaration entity by copying the pertinent
12161
      --  fields of the corresponding private declaration entity.
12162
 
12163
      --  We temporarily set Ekind to a value appropriate for a type to
12164
      --  avoid assert failures in Einfo from checking for setting type
12165
      --  attributes on something that is not a type. Ekind (Priv) is an
12166
      --  appropriate choice, since it allowed the attributes to be set
12167
      --  in the first place. This Ekind value will be modified later.
12168
 
12169
      Set_Ekind (Full, Ekind (Priv));
12170
 
12171
      --  Also set Etype temporarily to Any_Type, again, in the absence
12172
      --  of errors, it will be properly reset, and if there are errors,
12173
      --  then we want a value of Any_Type to remain.
12174
 
12175
      Set_Etype (Full, Any_Type);
12176
 
12177
      --  Now start copying attributes
12178
 
12179
      Set_Has_Discriminants          (Full, Has_Discriminants       (Priv));
12180
 
12181
      if Has_Discriminants (Full) then
12182
         Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
12183
         Set_Stored_Constraint       (Full, Stored_Constraint       (Priv));
12184
      end if;
12185
 
12186
      Set_First_Rep_Item             (Full, First_Rep_Item          (Priv));
12187
      Set_Homonym                    (Full, Homonym                 (Priv));
12188
      Set_Is_Immediately_Visible     (Full, Is_Immediately_Visible  (Priv));
12189
      Set_Is_Public                  (Full, Is_Public               (Priv));
12190
      Set_Is_Pure                    (Full, Is_Pure                 (Priv));
12191
      Set_Is_Tagged_Type             (Full, Is_Tagged_Type          (Priv));
12192
      Set_Has_Pragma_Unmodified      (Full, Has_Pragma_Unmodified   (Priv));
12193
      Set_Has_Pragma_Unreferenced    (Full, Has_Pragma_Unreferenced (Priv));
12194
      Set_Has_Pragma_Unreferenced_Objects
12195
                                     (Full, Has_Pragma_Unreferenced_Objects
12196
                                                                    (Priv));
12197
 
12198
      Conditional_Delay              (Full,                          Priv);
12199
 
12200
      if Is_Tagged_Type (Full) then
12201
         Set_Direct_Primitive_Operations (Full,
12202
           Direct_Primitive_Operations (Priv));
12203
 
12204
         if Is_Base_Type (Priv) then
12205
            Set_Class_Wide_Type      (Full, Class_Wide_Type         (Priv));
12206
         end if;
12207
      end if;
12208
 
12209
      Set_Is_Volatile                (Full, Is_Volatile             (Priv));
12210
      Set_Treat_As_Volatile          (Full, Treat_As_Volatile       (Priv));
12211
      Set_Scope                      (Full, Scope                   (Priv));
12212
      Set_Next_Entity                (Full, Next_Entity             (Priv));
12213
      Set_First_Entity               (Full, First_Entity            (Priv));
12214
      Set_Last_Entity                (Full, Last_Entity             (Priv));
12215
 
12216
      --  If access types have been recorded for later handling, keep them in
12217
      --  the full view so that they get handled when the full view freeze
12218
      --  node is expanded.
12219
 
12220
      if Present (Freeze_Node (Priv))
12221
        and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
12222
      then
12223
         Ensure_Freeze_Node (Full);
12224
         Set_Access_Types_To_Process
12225
           (Freeze_Node (Full),
12226
            Access_Types_To_Process (Freeze_Node (Priv)));
12227
      end if;
12228
 
12229
      --  Swap the two entities. Now Private is the full type entity and Full
12230
      --  is the private one. They will be swapped back at the end of the
12231
      --  private part. This swapping ensures that the entity that is visible
12232
      --  in the private part is the full declaration.
12233
 
12234
      Exchange_Entities (Priv, Full);
12235
      Append_Entity (Full, Scope (Full));
12236
   end Copy_And_Swap;
12237
 
12238
   -------------------------------------
12239
   -- Copy_Array_Base_Type_Attributes --
12240
   -------------------------------------
12241
 
12242
   procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
12243
   begin
12244
      Set_Component_Alignment      (T1, Component_Alignment      (T2));
12245
      Set_Component_Type           (T1, Component_Type           (T2));
12246
      Set_Component_Size           (T1, Component_Size           (T2));
12247
      Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
12248
      Set_Finalize_Storage_Only    (T1, Finalize_Storage_Only    (T2));
12249
      Set_Has_Non_Standard_Rep     (T1, Has_Non_Standard_Rep     (T2));
12250
      Set_Has_Task                 (T1, Has_Task                 (T2));
12251
      Set_Is_Packed                (T1, Is_Packed                (T2));
12252
      Set_Has_Aliased_Components   (T1, Has_Aliased_Components   (T2));
12253
      Set_Has_Atomic_Components    (T1, Has_Atomic_Components    (T2));
12254
      Set_Has_Volatile_Components  (T1, Has_Volatile_Components  (T2));
12255
   end Copy_Array_Base_Type_Attributes;
12256
 
12257
   -----------------------------------
12258
   -- Copy_Array_Subtype_Attributes --
12259
   -----------------------------------
12260
 
12261
   procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
12262
   begin
12263
      Set_Size_Info (T1, T2);
12264
 
12265
      Set_First_Index          (T1, First_Index           (T2));
12266
      Set_Is_Aliased           (T1, Is_Aliased            (T2));
12267
      Set_Is_Atomic            (T1, Is_Atomic             (T2));
12268
      Set_Is_Volatile          (T1, Is_Volatile           (T2));
12269
      Set_Treat_As_Volatile    (T1, Treat_As_Volatile     (T2));
12270
      Set_Is_Constrained       (T1, Is_Constrained        (T2));
12271
      Set_Depends_On_Private   (T1, Has_Private_Component (T2));
12272
      Set_First_Rep_Item       (T1, First_Rep_Item        (T2));
12273
      Set_Convention           (T1, Convention            (T2));
12274
      Set_Is_Limited_Composite (T1, Is_Limited_Composite  (T2));
12275
      Set_Is_Private_Composite (T1, Is_Private_Composite  (T2));
12276
      Set_Packed_Array_Type    (T1, Packed_Array_Type     (T2));
12277
   end Copy_Array_Subtype_Attributes;
12278
 
12279
   -----------------------------------
12280
   -- Create_Constrained_Components --
12281
   -----------------------------------
12282
 
12283
   procedure Create_Constrained_Components
12284
     (Subt        : Entity_Id;
12285
      Decl_Node   : Node_Id;
12286
      Typ         : Entity_Id;
12287
      Constraints : Elist_Id)
12288
   is
12289
      Loc         : constant Source_Ptr := Sloc (Subt);
12290
      Comp_List   : constant Elist_Id   := New_Elmt_List;
12291
      Parent_Type : constant Entity_Id  := Etype (Typ);
12292
      Assoc_List  : constant List_Id    := New_List;
12293
      Discr_Val   : Elmt_Id;
12294
      Errors      : Boolean;
12295
      New_C       : Entity_Id;
12296
      Old_C       : Entity_Id;
12297
      Is_Static   : Boolean := True;
12298
 
12299
      procedure Collect_Fixed_Components (Typ : Entity_Id);
12300
      --  Collect parent type components that do not appear in a variant part
12301
 
12302
      procedure Create_All_Components;
12303
      --  Iterate over Comp_List to create the components of the subtype
12304
 
12305
      function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
12306
      --  Creates a new component from Old_Compon, copying all the fields from
12307
      --  it, including its Etype, inserts the new component in the Subt entity
12308
      --  chain and returns the new component.
12309
 
12310
      function Is_Variant_Record (T : Entity_Id) return Boolean;
12311
      --  If true, and discriminants are static, collect only components from
12312
      --  variants selected by discriminant values.
12313
 
12314
      ------------------------------
12315
      -- Collect_Fixed_Components --
12316
      ------------------------------
12317
 
12318
      procedure Collect_Fixed_Components (Typ : Entity_Id) is
12319
      begin
12320
      --  Build association list for discriminants, and find components of the
12321
      --  variant part selected by the values of the discriminants.
12322
 
12323
         Old_C := First_Discriminant (Typ);
12324
         Discr_Val := First_Elmt (Constraints);
12325
         while Present (Old_C) loop
12326
            Append_To (Assoc_List,
12327
              Make_Component_Association (Loc,
12328
                 Choices    => New_List (New_Occurrence_Of (Old_C, Loc)),
12329
                 Expression => New_Copy (Node (Discr_Val))));
12330
 
12331
            Next_Elmt (Discr_Val);
12332
            Next_Discriminant (Old_C);
12333
         end loop;
12334
 
12335
         --  The tag and the possible parent component are unconditionally in
12336
         --  the subtype.
12337
 
12338
         if Is_Tagged_Type (Typ)
12339
           or else Has_Controlled_Component (Typ)
12340
         then
12341
            Old_C := First_Component (Typ);
12342
            while Present (Old_C) loop
12343
               if Chars ((Old_C)) = Name_uTag
12344
                 or else Chars ((Old_C)) = Name_uParent
12345
               then
12346
                  Append_Elmt (Old_C, Comp_List);
12347
               end if;
12348
 
12349
               Next_Component (Old_C);
12350
            end loop;
12351
         end if;
12352
      end Collect_Fixed_Components;
12353
 
12354
      ---------------------------
12355
      -- Create_All_Components --
12356
      ---------------------------
12357
 
12358
      procedure Create_All_Components is
12359
         Comp : Elmt_Id;
12360
 
12361
      begin
12362
         Comp := First_Elmt (Comp_List);
12363
         while Present (Comp) loop
12364
            Old_C := Node (Comp);
12365
            New_C := Create_Component (Old_C);
12366
 
12367
            Set_Etype
12368
              (New_C,
12369
               Constrain_Component_Type
12370
                 (Old_C, Subt, Decl_Node, Typ, Constraints));
12371
            Set_Is_Public (New_C, Is_Public (Subt));
12372
 
12373
            Next_Elmt (Comp);
12374
         end loop;
12375
      end Create_All_Components;
12376
 
12377
      ----------------------
12378
      -- Create_Component --
12379
      ----------------------
12380
 
12381
      function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
12382
         New_Compon : constant Entity_Id := New_Copy (Old_Compon);
12383
 
12384
      begin
12385
         if Ekind (Old_Compon) = E_Discriminant
12386
           and then Is_Completely_Hidden (Old_Compon)
12387
         then
12388
            --  This is a shadow discriminant created for a discriminant of
12389
            --  the parent type, which needs to be present in the subtype.
12390
            --  Give the shadow discriminant an internal name that cannot
12391
            --  conflict with that of visible components.
12392
 
12393
            Set_Chars (New_Compon, New_Internal_Name ('C'));
12394
         end if;
12395
 
12396
         --  Set the parent so we have a proper link for freezing etc. This is
12397
         --  not a real parent pointer, since of course our parent does not own
12398
         --  up to us and reference us, we are an illegitimate child of the
12399
         --  original parent!
12400
 
12401
         Set_Parent (New_Compon, Parent (Old_Compon));
12402
 
12403
         --  If the old component's Esize was already determined and is a
12404
         --  static value, then the new component simply inherits it. Otherwise
12405
         --  the old component's size may require run-time determination, but
12406
         --  the new component's size still might be statically determinable
12407
         --  (if, for example it has a static constraint). In that case we want
12408
         --  Layout_Type to recompute the component's size, so we reset its
12409
         --  size and positional fields.
12410
 
12411
         if Frontend_Layout_On_Target
12412
           and then not Known_Static_Esize (Old_Compon)
12413
         then
12414
            Set_Esize (New_Compon, Uint_0);
12415
            Init_Normalized_First_Bit    (New_Compon);
12416
            Init_Normalized_Position     (New_Compon);
12417
            Init_Normalized_Position_Max (New_Compon);
12418
         end if;
12419
 
12420
         --  We do not want this node marked as Comes_From_Source, since
12421
         --  otherwise it would get first class status and a separate cross-
12422
         --  reference line would be generated. Illegitimate children do not
12423
         --  rate such recognition.
12424
 
12425
         Set_Comes_From_Source (New_Compon, False);
12426
 
12427
         --  But it is a real entity, and a birth certificate must be properly
12428
         --  registered by entering it into the entity list.
12429
 
12430
         Enter_Name (New_Compon);
12431
 
12432
         return New_Compon;
12433
      end Create_Component;
12434
 
12435
      -----------------------
12436
      -- Is_Variant_Record --
12437
      -----------------------
12438
 
12439
      function Is_Variant_Record (T : Entity_Id) return Boolean is
12440
      begin
12441
         return Nkind (Parent (T)) = N_Full_Type_Declaration
12442
           and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
12443
           and then Present (Component_List (Type_Definition (Parent (T))))
12444
           and then
12445
             Present
12446
               (Variant_Part (Component_List (Type_Definition (Parent (T)))));
12447
      end Is_Variant_Record;
12448
 
12449
   --  Start of processing for Create_Constrained_Components
12450
 
12451
   begin
12452
      pragma Assert (Subt /= Base_Type (Subt));
12453
      pragma Assert (Typ = Base_Type (Typ));
12454
 
12455
      Set_First_Entity (Subt, Empty);
12456
      Set_Last_Entity  (Subt, Empty);
12457
 
12458
      --  Check whether constraint is fully static, in which case we can
12459
      --  optimize the list of components.
12460
 
12461
      Discr_Val := First_Elmt (Constraints);
12462
      while Present (Discr_Val) loop
12463
         if not Is_OK_Static_Expression (Node (Discr_Val)) then
12464
            Is_Static := False;
12465
            exit;
12466
         end if;
12467
 
12468
         Next_Elmt (Discr_Val);
12469
      end loop;
12470
 
12471
      Set_Has_Static_Discriminants (Subt, Is_Static);
12472
 
12473
      Push_Scope (Subt);
12474
 
12475
      --  Inherit the discriminants of the parent type
12476
 
12477
      Add_Discriminants : declare
12478
         Num_Disc : Int;
12479
         Num_Gird : Int;
12480
 
12481
      begin
12482
         Num_Disc := 0;
12483
         Old_C := First_Discriminant (Typ);
12484
 
12485
         while Present (Old_C) loop
12486
            Num_Disc := Num_Disc + 1;
12487
            New_C := Create_Component (Old_C);
12488
            Set_Is_Public (New_C, Is_Public (Subt));
12489
            Next_Discriminant (Old_C);
12490
         end loop;
12491
 
12492
         --  For an untagged derived subtype, the number of discriminants may
12493
         --  be smaller than the number of inherited discriminants, because
12494
         --  several of them may be renamed by a single new discriminant or
12495
         --  constrained. In this case, add the hidden discriminants back into
12496
         --  the subtype, because they need to be present if the optimizer of
12497
         --  the GCC 4.x back-end decides to break apart assignments between
12498
         --  objects using the parent view into member-wise assignments.
12499
 
12500
         Num_Gird := 0;
12501
 
12502
         if Is_Derived_Type (Typ)
12503
           and then not Is_Tagged_Type (Typ)
12504
         then
12505
            Old_C := First_Stored_Discriminant (Typ);
12506
 
12507
            while Present (Old_C) loop
12508
               Num_Gird := Num_Gird + 1;
12509
               Next_Stored_Discriminant (Old_C);
12510
            end loop;
12511
         end if;
12512
 
12513
         if Num_Gird > Num_Disc then
12514
 
12515
            --  Find out multiple uses of new discriminants, and add hidden
12516
            --  components for the extra renamed discriminants. We recognize
12517
            --  multiple uses through the Corresponding_Discriminant of a
12518
            --  new discriminant: if it constrains several old discriminants,
12519
            --  this field points to the last one in the parent type. The
12520
            --  stored discriminants of the derived type have the same name
12521
            --  as those of the parent.
12522
 
12523
            declare
12524
               Constr    : Elmt_Id;
12525
               New_Discr : Entity_Id;
12526
               Old_Discr : Entity_Id;
12527
 
12528
            begin
12529
               Constr    := First_Elmt (Stored_Constraint (Typ));
12530
               Old_Discr := First_Stored_Discriminant (Typ);
12531
               while Present (Constr) loop
12532
                  if Is_Entity_Name (Node (Constr))
12533
                    and then Ekind (Entity (Node (Constr))) = E_Discriminant
12534
                  then
12535
                     New_Discr := Entity (Node (Constr));
12536
 
12537
                     if Chars (Corresponding_Discriminant (New_Discr)) /=
12538
                        Chars (Old_Discr)
12539
                     then
12540
                        --  The new discriminant has been used to rename a
12541
                        --  subsequent old discriminant. Introduce a shadow
12542
                        --  component for the current old discriminant.
12543
 
12544
                        New_C := Create_Component (Old_Discr);
12545
                        Set_Original_Record_Component (New_C, Old_Discr);
12546
                     end if;
12547
 
12548
                  else
12549
                     --  The constraint has eliminated the old discriminant.
12550
                     --  Introduce a shadow component.
12551
 
12552
                     New_C := Create_Component (Old_Discr);
12553
                     Set_Original_Record_Component (New_C, Old_Discr);
12554
                  end if;
12555
 
12556
                  Next_Elmt (Constr);
12557
                  Next_Stored_Discriminant (Old_Discr);
12558
               end loop;
12559
            end;
12560
         end if;
12561
      end Add_Discriminants;
12562
 
12563
      if Is_Static
12564
        and then Is_Variant_Record (Typ)
12565
      then
12566
         Collect_Fixed_Components (Typ);
12567
 
12568
         Gather_Components (
12569
           Typ,
12570
           Component_List (Type_Definition (Parent (Typ))),
12571
           Governed_By   => Assoc_List,
12572
           Into          => Comp_List,
12573
           Report_Errors => Errors);
12574
         pragma Assert (not Errors);
12575
 
12576
         Create_All_Components;
12577
 
12578
      --  If the subtype declaration is created for a tagged type derivation
12579
      --  with constraints, we retrieve the record definition of the parent
12580
      --  type to select the components of the proper variant.
12581
 
12582
      elsif Is_Static
12583
        and then Is_Tagged_Type (Typ)
12584
        and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
12585
        and then
12586
          Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
12587
        and then Is_Variant_Record (Parent_Type)
12588
      then
12589
         Collect_Fixed_Components (Typ);
12590
 
12591
         Gather_Components (
12592
           Typ,
12593
           Component_List (Type_Definition (Parent (Parent_Type))),
12594
           Governed_By   => Assoc_List,
12595
           Into          => Comp_List,
12596
           Report_Errors => Errors);
12597
         pragma Assert (not Errors);
12598
 
12599
         --  If the tagged derivation has a type extension, collect all the
12600
         --  new components therein.
12601
 
12602
         if Present
12603
              (Record_Extension_Part (Type_Definition (Parent (Typ))))
12604
         then
12605
            Old_C := First_Component (Typ);
12606
            while Present (Old_C) loop
12607
               if Original_Record_Component (Old_C) = Old_C
12608
                and then Chars (Old_C) /= Name_uTag
12609
                and then Chars (Old_C) /= Name_uParent
12610
               then
12611
                  Append_Elmt (Old_C, Comp_List);
12612
               end if;
12613
 
12614
               Next_Component (Old_C);
12615
            end loop;
12616
         end if;
12617
 
12618
         Create_All_Components;
12619
 
12620
      else
12621
         --  If discriminants are not static, or if this is a multi-level type
12622
         --  extension, we have to include all components of the parent type.
12623
 
12624
         Old_C := First_Component (Typ);
12625
         while Present (Old_C) loop
12626
            New_C := Create_Component (Old_C);
12627
 
12628
            Set_Etype
12629
              (New_C,
12630
               Constrain_Component_Type
12631
                 (Old_C, Subt, Decl_Node, Typ, Constraints));
12632
            Set_Is_Public (New_C, Is_Public (Subt));
12633
 
12634
            Next_Component (Old_C);
12635
         end loop;
12636
      end if;
12637
 
12638
      End_Scope;
12639
   end Create_Constrained_Components;
12640
 
12641
   ------------------------------------------
12642
   -- Decimal_Fixed_Point_Type_Declaration --
12643
   ------------------------------------------
12644
 
12645
   procedure Decimal_Fixed_Point_Type_Declaration
12646
     (T   : Entity_Id;
12647
      Def : Node_Id)
12648
   is
12649
      Loc           : constant Source_Ptr := Sloc (Def);
12650
      Digs_Expr     : constant Node_Id    := Digits_Expression (Def);
12651
      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
12652
      Implicit_Base : Entity_Id;
12653
      Digs_Val      : Uint;
12654
      Delta_Val     : Ureal;
12655
      Scale_Val     : Uint;
12656
      Bound_Val     : Ureal;
12657
 
12658
   begin
12659
      Check_SPARK_Restriction
12660
        ("decimal fixed point type is not allowed", Def);
12661
      Check_Restriction (No_Fixed_Point, Def);
12662
 
12663
      --  Create implicit base type
12664
 
12665
      Implicit_Base :=
12666
        Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
12667
      Set_Etype (Implicit_Base, Implicit_Base);
12668
 
12669
      --  Analyze and process delta expression
12670
 
12671
      Analyze_And_Resolve (Delta_Expr, Universal_Real);
12672
 
12673
      Check_Delta_Expression (Delta_Expr);
12674
      Delta_Val := Expr_Value_R (Delta_Expr);
12675
 
12676
      --  Check delta is power of 10, and determine scale value from it
12677
 
12678
      declare
12679
         Val : Ureal;
12680
 
12681
      begin
12682
         Scale_Val := Uint_0;
12683
         Val := Delta_Val;
12684
 
12685
         if Val < Ureal_1 then
12686
            while Val < Ureal_1 loop
12687
               Val := Val * Ureal_10;
12688
               Scale_Val := Scale_Val + 1;
12689
            end loop;
12690
 
12691
            if Scale_Val > 18 then
12692
               Error_Msg_N ("scale exceeds maximum value of 18", Def);
12693
               Scale_Val := UI_From_Int (+18);
12694
            end if;
12695
 
12696
         else
12697
            while Val > Ureal_1 loop
12698
               Val := Val / Ureal_10;
12699
               Scale_Val := Scale_Val - 1;
12700
            end loop;
12701
 
12702
            if Scale_Val < -18 then
12703
               Error_Msg_N ("scale is less than minimum value of -18", Def);
12704
               Scale_Val := UI_From_Int (-18);
12705
            end if;
12706
         end if;
12707
 
12708
         if Val /= Ureal_1 then
12709
            Error_Msg_N ("delta expression must be a power of 10", Def);
12710
            Delta_Val := Ureal_10 ** (-Scale_Val);
12711
         end if;
12712
      end;
12713
 
12714
      --  Set delta, scale and small (small = delta for decimal type)
12715
 
12716
      Set_Delta_Value (Implicit_Base, Delta_Val);
12717
      Set_Scale_Value (Implicit_Base, Scale_Val);
12718
      Set_Small_Value (Implicit_Base, Delta_Val);
12719
 
12720
      --  Analyze and process digits expression
12721
 
12722
      Analyze_And_Resolve (Digs_Expr, Any_Integer);
12723
      Check_Digits_Expression (Digs_Expr);
12724
      Digs_Val := Expr_Value (Digs_Expr);
12725
 
12726
      if Digs_Val > 18 then
12727
         Digs_Val := UI_From_Int (+18);
12728
         Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
12729
      end if;
12730
 
12731
      Set_Digits_Value (Implicit_Base, Digs_Val);
12732
      Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
12733
 
12734
      --  Set range of base type from digits value for now. This will be
12735
      --  expanded to represent the true underlying base range by Freeze.
12736
 
12737
      Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
12738
 
12739
      --  Note: We leave size as zero for now, size will be set at freeze
12740
      --  time. We have to do this for ordinary fixed-point, because the size
12741
      --  depends on the specified small, and we might as well do the same for
12742
      --  decimal fixed-point.
12743
 
12744
      pragma Assert (Esize (Implicit_Base) = Uint_0);
12745
 
12746
      --  If there are bounds given in the declaration use them as the
12747
      --  bounds of the first named subtype.
12748
 
12749
      if Present (Real_Range_Specification (Def)) then
12750
         declare
12751
            RRS      : constant Node_Id := Real_Range_Specification (Def);
12752
            Low      : constant Node_Id := Low_Bound (RRS);
12753
            High     : constant Node_Id := High_Bound (RRS);
12754
            Low_Val  : Ureal;
12755
            High_Val : Ureal;
12756
 
12757
         begin
12758
            Analyze_And_Resolve (Low, Any_Real);
12759
            Analyze_And_Resolve (High, Any_Real);
12760
            Check_Real_Bound (Low);
12761
            Check_Real_Bound (High);
12762
            Low_Val := Expr_Value_R (Low);
12763
            High_Val := Expr_Value_R (High);
12764
 
12765
            if Low_Val < (-Bound_Val) then
12766
               Error_Msg_N
12767
                 ("range low bound too small for digits value", Low);
12768
               Low_Val := -Bound_Val;
12769
            end if;
12770
 
12771
            if High_Val > Bound_Val then
12772
               Error_Msg_N
12773
                 ("range high bound too large for digits value", High);
12774
               High_Val := Bound_Val;
12775
            end if;
12776
 
12777
            Set_Fixed_Range (T, Loc, Low_Val, High_Val);
12778
         end;
12779
 
12780
      --  If no explicit range, use range that corresponds to given
12781
      --  digits value. This will end up as the final range for the
12782
      --  first subtype.
12783
 
12784
      else
12785
         Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
12786
      end if;
12787
 
12788
      --  Complete entity for first subtype
12789
 
12790
      Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
12791
      Set_Etype          (T, Implicit_Base);
12792
      Set_Size_Info      (T, Implicit_Base);
12793
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
12794
      Set_Digits_Value   (T, Digs_Val);
12795
      Set_Delta_Value    (T, Delta_Val);
12796
      Set_Small_Value    (T, Delta_Val);
12797
      Set_Scale_Value    (T, Scale_Val);
12798
      Set_Is_Constrained (T);
12799
   end Decimal_Fixed_Point_Type_Declaration;
12800
 
12801
   -----------------------------------
12802
   -- Derive_Progenitor_Subprograms --
12803
   -----------------------------------
12804
 
12805
   procedure Derive_Progenitor_Subprograms
12806
     (Parent_Type : Entity_Id;
12807
      Tagged_Type : Entity_Id)
12808
   is
12809
      E          : Entity_Id;
12810
      Elmt       : Elmt_Id;
12811
      Iface      : Entity_Id;
12812
      Iface_Elmt : Elmt_Id;
12813
      Iface_Subp : Entity_Id;
12814
      New_Subp   : Entity_Id := Empty;
12815
      Prim_Elmt  : Elmt_Id;
12816
      Subp       : Entity_Id;
12817
      Typ        : Entity_Id;
12818
 
12819
   begin
12820
      pragma Assert (Ada_Version >= Ada_2005
12821
        and then Is_Record_Type (Tagged_Type)
12822
        and then Is_Tagged_Type (Tagged_Type)
12823
        and then Has_Interfaces (Tagged_Type));
12824
 
12825
      --  Step 1: Transfer to the full-view primitives associated with the
12826
      --  partial-view that cover interface primitives. Conceptually this
12827
      --  work should be done later by Process_Full_View; done here to
12828
      --  simplify its implementation at later stages. It can be safely
12829
      --  done here because interfaces must be visible in the partial and
12830
      --  private view (RM 7.3(7.3/2)).
12831
 
12832
      --  Small optimization: This work is only required if the parent is
12833
      --  abstract. If the tagged type is not abstract, it cannot have
12834
      --  abstract primitives (the only entities in the list of primitives of
12835
      --  non-abstract tagged types that can reference abstract primitives
12836
      --  through its Alias attribute are the internal entities that have
12837
      --  attribute Interface_Alias, and these entities are generated later
12838
      --  by Add_Internal_Interface_Entities).
12839
 
12840
      if In_Private_Part (Current_Scope)
12841
        and then Is_Abstract_Type (Parent_Type)
12842
      then
12843
         Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
12844
         while Present (Elmt) loop
12845
            Subp := Node (Elmt);
12846
 
12847
            --  At this stage it is not possible to have entities in the list
12848
            --  of primitives that have attribute Interface_Alias
12849
 
12850
            pragma Assert (No (Interface_Alias (Subp)));
12851
 
12852
            Typ := Find_Dispatching_Type (Ultimate_Alias (Subp));
12853
 
12854
            if Is_Interface (Typ) then
12855
               E := Find_Primitive_Covering_Interface
12856
                      (Tagged_Type => Tagged_Type,
12857
                       Iface_Prim  => Subp);
12858
 
12859
               if Present (E)
12860
                 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ
12861
               then
12862
                  Replace_Elmt (Elmt, E);
12863
                  Remove_Homonym (Subp);
12864
               end if;
12865
            end if;
12866
 
12867
            Next_Elmt (Elmt);
12868
         end loop;
12869
      end if;
12870
 
12871
      --  Step 2: Add primitives of progenitors that are not implemented by
12872
      --  parents of Tagged_Type
12873
 
12874
      if Present (Interfaces (Base_Type (Tagged_Type))) then
12875
         Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
12876
         while Present (Iface_Elmt) loop
12877
            Iface := Node (Iface_Elmt);
12878
 
12879
            Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
12880
            while Present (Prim_Elmt) loop
12881
               Iface_Subp := Node (Prim_Elmt);
12882
 
12883
               --  Exclude derivation of predefined primitives except those
12884
               --  that come from source, or are inherited from one that comes
12885
               --  from source. Required to catch declarations of equality
12886
               --  operators of interfaces. For example:
12887
 
12888
               --     type Iface is interface;
12889
               --     function "=" (Left, Right : Iface) return Boolean;
12890
 
12891
               if not Is_Predefined_Dispatching_Operation (Iface_Subp)
12892
                 or else Comes_From_Source (Ultimate_Alias (Iface_Subp))
12893
               then
12894
                  E := Find_Primitive_Covering_Interface
12895
                         (Tagged_Type => Tagged_Type,
12896
                          Iface_Prim  => Iface_Subp);
12897
 
12898
                  --  If not found we derive a new primitive leaving its alias
12899
                  --  attribute referencing the interface primitive
12900
 
12901
                  if No (E) then
12902
                     Derive_Subprogram
12903
                       (New_Subp, Iface_Subp, Tagged_Type, Iface);
12904
 
12905
                  --  Ada 2012 (AI05-0197): If the covering primitive's name
12906
                  --  differs from the name of the interface primitive then it
12907
                  --  is a private primitive inherited from a parent type. In
12908
                  --  such case, given that Tagged_Type covers the interface,
12909
                  --  the inherited private primitive becomes visible. For such
12910
                  --  purpose we add a new entity that renames the inherited
12911
                  --  private primitive.
12912
 
12913
                  elsif Chars (E) /= Chars (Iface_Subp) then
12914
                     pragma Assert (Has_Suffix (E, 'P'));
12915
                     Derive_Subprogram
12916
                       (New_Subp, Iface_Subp, Tagged_Type, Iface);
12917
                     Set_Alias (New_Subp, E);
12918
                     Set_Is_Abstract_Subprogram (New_Subp,
12919
                       Is_Abstract_Subprogram (E));
12920
 
12921
                  --  Propagate to the full view interface entities associated
12922
                  --  with the partial view
12923
 
12924
                  elsif In_Private_Part (Current_Scope)
12925
                    and then Present (Alias (E))
12926
                    and then Alias (E) = Iface_Subp
12927
                    and then
12928
                      List_Containing (Parent (E)) /=
12929
                        Private_Declarations
12930
                          (Specification
12931
                            (Unit_Declaration_Node (Current_Scope)))
12932
                  then
12933
                     Append_Elmt (E, Primitive_Operations (Tagged_Type));
12934
                  end if;
12935
               end if;
12936
 
12937
               Next_Elmt (Prim_Elmt);
12938
            end loop;
12939
 
12940
            Next_Elmt (Iface_Elmt);
12941
         end loop;
12942
      end if;
12943
   end Derive_Progenitor_Subprograms;
12944
 
12945
   -----------------------
12946
   -- Derive_Subprogram --
12947
   -----------------------
12948
 
12949
   procedure Derive_Subprogram
12950
     (New_Subp     : in out Entity_Id;
12951
      Parent_Subp  : Entity_Id;
12952
      Derived_Type : Entity_Id;
12953
      Parent_Type  : Entity_Id;
12954
      Actual_Subp  : Entity_Id := Empty)
12955
   is
12956
      Formal : Entity_Id;
12957
      --  Formal parameter of parent primitive operation
12958
 
12959
      Formal_Of_Actual : Entity_Id;
12960
      --  Formal parameter of actual operation, when the derivation is to
12961
      --  create a renaming for a primitive operation of an actual in an
12962
      --  instantiation.
12963
 
12964
      New_Formal : Entity_Id;
12965
      --  Formal of inherited operation
12966
 
12967
      Visible_Subp : Entity_Id := Parent_Subp;
12968
 
12969
      function Is_Private_Overriding return Boolean;
12970
      --  If Subp is a private overriding of a visible operation, the inherited
12971
      --  operation derives from the overridden op (even though its body is the
12972
      --  overriding one) and the inherited operation is visible now. See
12973
      --  sem_disp to see the full details of the handling of the overridden
12974
      --  subprogram, which is removed from the list of primitive operations of
12975
      --  the type. The overridden subprogram is saved locally in Visible_Subp,
12976
      --  and used to diagnose abstract operations that need overriding in the
12977
      --  derived type.
12978
 
12979
      procedure Replace_Type (Id, New_Id : Entity_Id);
12980
      --  When the type is an anonymous access type, create a new access type
12981
      --  designating the derived type.
12982
 
12983
      procedure Set_Derived_Name;
12984
      --  This procedure sets the appropriate Chars name for New_Subp. This
12985
      --  is normally just a copy of the parent name. An exception arises for
12986
      --  type support subprograms, where the name is changed to reflect the
12987
      --  name of the derived type, e.g. if type foo is derived from type bar,
12988
      --  then a procedure barDA is derived with a name fooDA.
12989
 
12990
      ---------------------------
12991
      -- Is_Private_Overriding --
12992
      ---------------------------
12993
 
12994
      function Is_Private_Overriding return Boolean is
12995
         Prev : Entity_Id;
12996
 
12997
      begin
12998
         --  If the parent is not a dispatching operation there is no
12999
         --  need to investigate overridings
13000
 
13001
         if not Is_Dispatching_Operation (Parent_Subp) then
13002
            return False;
13003
         end if;
13004
 
13005
         --  The visible operation that is overridden is a homonym of the
13006
         --  parent subprogram. We scan the homonym chain to find the one
13007
         --  whose alias is the subprogram we are deriving.
13008
 
13009
         Prev := Current_Entity (Parent_Subp);
13010
         while Present (Prev) loop
13011
            if Ekind (Prev) = Ekind (Parent_Subp)
13012
              and then Alias (Prev) = Parent_Subp
13013
              and then Scope (Parent_Subp) = Scope (Prev)
13014
              and then not Is_Hidden (Prev)
13015
            then
13016
               Visible_Subp := Prev;
13017
               return True;
13018
            end if;
13019
 
13020
            Prev := Homonym (Prev);
13021
         end loop;
13022
 
13023
         return False;
13024
      end Is_Private_Overriding;
13025
 
13026
      ------------------
13027
      -- Replace_Type --
13028
      ------------------
13029
 
13030
      procedure Replace_Type (Id, New_Id : Entity_Id) is
13031
         Acc_Type : Entity_Id;
13032
         Par      : constant Node_Id := Parent (Derived_Type);
13033
 
13034
      begin
13035
         --  When the type is an anonymous access type, create a new access
13036
         --  type designating the derived type. This itype must be elaborated
13037
         --  at the point of the derivation, not on subsequent calls that may
13038
         --  be out of the proper scope for Gigi, so we insert a reference to
13039
         --  it after the derivation.
13040
 
13041
         if Ekind (Etype (Id)) = E_Anonymous_Access_Type then
13042
            declare
13043
               Desig_Typ : Entity_Id := Designated_Type (Etype (Id));
13044
 
13045
            begin
13046
               if Ekind (Desig_Typ) = E_Record_Type_With_Private
13047
                 and then Present (Full_View (Desig_Typ))
13048
                 and then not Is_Private_Type (Parent_Type)
13049
               then
13050
                  Desig_Typ := Full_View (Desig_Typ);
13051
               end if;
13052
 
13053
               if Base_Type (Desig_Typ) = Base_Type (Parent_Type)
13054
 
13055
                  --  Ada 2005 (AI-251): Handle also derivations of abstract
13056
                  --  interface primitives.
13057
 
13058
                 or else (Is_Interface (Desig_Typ)
13059
                          and then not Is_Class_Wide_Type (Desig_Typ))
13060
               then
13061
                  Acc_Type := New_Copy (Etype (Id));
13062
                  Set_Etype (Acc_Type, Acc_Type);
13063
                  Set_Scope (Acc_Type, New_Subp);
13064
 
13065
                  --  Compute size of anonymous access type
13066
 
13067
                  if Is_Array_Type (Desig_Typ)
13068
                    and then not Is_Constrained (Desig_Typ)
13069
                  then
13070
                     Init_Size (Acc_Type, 2 * System_Address_Size);
13071
                  else
13072
                     Init_Size (Acc_Type, System_Address_Size);
13073
                  end if;
13074
 
13075
                  Init_Alignment (Acc_Type);
13076
                  Set_Directly_Designated_Type (Acc_Type, Derived_Type);
13077
 
13078
                  Set_Etype (New_Id, Acc_Type);
13079
                  Set_Scope (New_Id, New_Subp);
13080
 
13081
                  --  Create a reference to it
13082
                  Build_Itype_Reference (Acc_Type, Parent (Derived_Type));
13083
 
13084
               else
13085
                  Set_Etype (New_Id, Etype (Id));
13086
               end if;
13087
            end;
13088
 
13089
         elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
13090
           or else
13091
             (Ekind (Etype (Id)) = E_Record_Type_With_Private
13092
               and then Present (Full_View (Etype (Id)))
13093
               and then
13094
                 Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type))
13095
         then
13096
            --  Constraint checks on formals are generated during expansion,
13097
            --  based on the signature of the original subprogram. The bounds
13098
            --  of the derived type are not relevant, and thus we can use
13099
            --  the base type for the formals. However, the return type may be
13100
            --  used in a context that requires that the proper static bounds
13101
            --  be used (a case statement, for example)  and for those cases
13102
            --  we must use the derived type (first subtype), not its base.
13103
 
13104
            --  If the derived_type_definition has no constraints, we know that
13105
            --  the derived type has the same constraints as the first subtype
13106
            --  of the parent, and we can also use it rather than its base,
13107
            --  which can lead to more efficient code.
13108
 
13109
            if Etype (Id) = Parent_Type then
13110
               if Is_Scalar_Type (Parent_Type)
13111
                 and then
13112
                   Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
13113
               then
13114
                  Set_Etype (New_Id, Derived_Type);
13115
 
13116
               elsif Nkind (Par) = N_Full_Type_Declaration
13117
                 and then
13118
                   Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
13119
                 and then
13120
                   Is_Entity_Name
13121
                     (Subtype_Indication (Type_Definition (Par)))
13122
               then
13123
                  Set_Etype (New_Id, Derived_Type);
13124
 
13125
               else
13126
                  Set_Etype (New_Id, Base_Type (Derived_Type));
13127
               end if;
13128
 
13129
            else
13130
               Set_Etype (New_Id, Base_Type (Derived_Type));
13131
            end if;
13132
 
13133
         else
13134
            Set_Etype (New_Id, Etype (Id));
13135
         end if;
13136
      end Replace_Type;
13137
 
13138
      ----------------------
13139
      -- Set_Derived_Name --
13140
      ----------------------
13141
 
13142
      procedure Set_Derived_Name is
13143
         Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp);
13144
      begin
13145
         if Nm = TSS_Null then
13146
            Set_Chars (New_Subp, Chars (Parent_Subp));
13147
         else
13148
            Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm));
13149
         end if;
13150
      end Set_Derived_Name;
13151
 
13152
   --  Start of processing for Derive_Subprogram
13153
 
13154
   begin
13155
      New_Subp :=
13156
         New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
13157
      Set_Ekind (New_Subp, Ekind (Parent_Subp));
13158
      Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp)));
13159
 
13160
      --  Check whether the inherited subprogram is a private operation that
13161
      --  should be inherited but not yet made visible. Such subprograms can
13162
      --  become visible at a later point (e.g., the private part of a public
13163
      --  child unit) via Declare_Inherited_Private_Subprograms. If the
13164
      --  following predicate is true, then this is not such a private
13165
      --  operation and the subprogram simply inherits the name of the parent
13166
      --  subprogram. Note the special check for the names of controlled
13167
      --  operations, which are currently exempted from being inherited with
13168
      --  a hidden name because they must be findable for generation of
13169
      --  implicit run-time calls.
13170
 
13171
      if not Is_Hidden (Parent_Subp)
13172
        or else Is_Internal (Parent_Subp)
13173
        or else Is_Private_Overriding
13174
        or else Is_Internal_Name (Chars (Parent_Subp))
13175
        or else Chars (Parent_Subp) = Name_Initialize
13176
        or else Chars (Parent_Subp) = Name_Adjust
13177
        or else Chars (Parent_Subp) = Name_Finalize
13178
      then
13179
         Set_Derived_Name;
13180
 
13181
      --  An inherited dispatching equality will be overridden by an internally
13182
      --  generated one, or by an explicit one, so preserve its name and thus
13183
      --  its entry in the dispatch table. Otherwise, if Parent_Subp is a
13184
      --  private operation it may become invisible if the full view has
13185
      --  progenitors, and the dispatch table will be malformed.
13186
      --  We check that the type is limited to handle the anomalous declaration
13187
      --  of Limited_Controlled, which is derived from a non-limited type, and
13188
      --  which is handled specially elsewhere as well.
13189
 
13190
      elsif Chars (Parent_Subp) = Name_Op_Eq
13191
        and then Is_Dispatching_Operation (Parent_Subp)
13192
        and then Etype (Parent_Subp) = Standard_Boolean
13193
        and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
13194
        and then
13195
          Etype (First_Formal (Parent_Subp)) =
13196
            Etype (Next_Formal (First_Formal (Parent_Subp)))
13197
      then
13198
         Set_Derived_Name;
13199
 
13200
      --  If parent is hidden, this can be a regular derivation if the
13201
      --  parent is immediately visible in a non-instantiating context,
13202
      --  or if we are in the private part of an instance. This test
13203
      --  should still be refined ???
13204
 
13205
      --  The test for In_Instance_Not_Visible avoids inheriting the derived
13206
      --  operation as a non-visible operation in cases where the parent
13207
      --  subprogram might not be visible now, but was visible within the
13208
      --  original generic, so it would be wrong to make the inherited
13209
      --  subprogram non-visible now. (Not clear if this test is fully
13210
      --  correct; are there any cases where we should declare the inherited
13211
      --  operation as not visible to avoid it being overridden, e.g., when
13212
      --  the parent type is a generic actual with private primitives ???)
13213
 
13214
      --  (they should be treated the same as other private inherited
13215
      --  subprograms, but it's not clear how to do this cleanly). ???
13216
 
13217
      elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
13218
              and then Is_Immediately_Visible (Parent_Subp)
13219
              and then not In_Instance)
13220
        or else In_Instance_Not_Visible
13221
      then
13222
         Set_Derived_Name;
13223
 
13224
      --  Ada 2005 (AI-251): Regular derivation if the parent subprogram
13225
      --  overrides an interface primitive because interface primitives
13226
      --  must be visible in the partial view of the parent (RM 7.3 (7.3/2))
13227
 
13228
      elsif Ada_Version >= Ada_2005
13229
         and then Is_Dispatching_Operation (Parent_Subp)
13230
         and then Covers_Some_Interface (Parent_Subp)
13231
      then
13232
         Set_Derived_Name;
13233
 
13234
      --  Otherwise, the type is inheriting a private operation, so enter
13235
      --  it with a special name so it can't be overridden.
13236
 
13237
      else
13238
         Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
13239
      end if;
13240
 
13241
      Set_Parent (New_Subp, Parent (Derived_Type));
13242
 
13243
      if Present (Actual_Subp) then
13244
         Replace_Type (Actual_Subp, New_Subp);
13245
      else
13246
         Replace_Type (Parent_Subp, New_Subp);
13247
      end if;
13248
 
13249
      Conditional_Delay (New_Subp, Parent_Subp);
13250
 
13251
      --  If we are creating a renaming for a primitive operation of an
13252
      --  actual of a generic derived type, we must examine the signature
13253
      --  of the actual primitive, not that of the generic formal, which for
13254
      --  example may be an interface. However the name and initial value
13255
      --  of the inherited operation are those of the formal primitive.
13256
 
13257
      Formal := First_Formal (Parent_Subp);
13258
 
13259
      if Present (Actual_Subp) then
13260
         Formal_Of_Actual := First_Formal (Actual_Subp);
13261
      else
13262
         Formal_Of_Actual := Empty;
13263
      end if;
13264
 
13265
      while Present (Formal) loop
13266
         New_Formal := New_Copy (Formal);
13267
 
13268
         --  Normally we do not go copying parents, but in the case of
13269
         --  formals, we need to link up to the declaration (which is the
13270
         --  parameter specification), and it is fine to link up to the
13271
         --  original formal's parameter specification in this case.
13272
 
13273
         Set_Parent (New_Formal, Parent (Formal));
13274
         Append_Entity (New_Formal, New_Subp);
13275
 
13276
         if Present (Formal_Of_Actual) then
13277
            Replace_Type (Formal_Of_Actual, New_Formal);
13278
            Next_Formal (Formal_Of_Actual);
13279
         else
13280
            Replace_Type (Formal, New_Formal);
13281
         end if;
13282
 
13283
         Next_Formal (Formal);
13284
      end loop;
13285
 
13286
      --  If this derivation corresponds to a tagged generic actual, then
13287
      --  primitive operations rename those of the actual. Otherwise the
13288
      --  primitive operations rename those of the parent type, If the parent
13289
      --  renames an intrinsic operator, so does the new subprogram. We except
13290
      --  concatenation, which is always properly typed, and does not get
13291
      --  expanded as other intrinsic operations.
13292
 
13293
      if No (Actual_Subp) then
13294
         if Is_Intrinsic_Subprogram (Parent_Subp) then
13295
            Set_Is_Intrinsic_Subprogram (New_Subp);
13296
 
13297
            if Present (Alias (Parent_Subp))
13298
              and then Chars (Parent_Subp) /= Name_Op_Concat
13299
            then
13300
               Set_Alias (New_Subp, Alias (Parent_Subp));
13301
            else
13302
               Set_Alias (New_Subp, Parent_Subp);
13303
            end if;
13304
 
13305
         else
13306
            Set_Alias (New_Subp, Parent_Subp);
13307
         end if;
13308
 
13309
      else
13310
         Set_Alias (New_Subp, Actual_Subp);
13311
      end if;
13312
 
13313
      --  Derived subprograms of a tagged type must inherit the convention
13314
      --  of the parent subprogram (a requirement of AI-117). Derived
13315
      --  subprograms of untagged types simply get convention Ada by default.
13316
 
13317
      if Is_Tagged_Type (Derived_Type) then
13318
         Set_Convention (New_Subp, Convention (Parent_Subp));
13319
      end if;
13320
 
13321
      --  Predefined controlled operations retain their name even if the parent
13322
      --  is hidden (see above), but they are not primitive operations if the
13323
      --  ancestor is not visible, for example if the parent is a private
13324
      --  extension completed with a controlled extension. Note that a full
13325
      --  type that is controlled can break privacy: the flag Is_Controlled is
13326
      --  set on both views of the type.
13327
 
13328
      if Is_Controlled (Parent_Type)
13329
        and then
13330
          (Chars (Parent_Subp) = Name_Initialize
13331
            or else Chars (Parent_Subp) = Name_Adjust
13332
            or else Chars (Parent_Subp) = Name_Finalize)
13333
        and then Is_Hidden (Parent_Subp)
13334
        and then not Is_Visibly_Controlled (Parent_Type)
13335
      then
13336
         Set_Is_Hidden (New_Subp);
13337
      end if;
13338
 
13339
      Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
13340
      Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
13341
 
13342
      if Ekind (Parent_Subp) = E_Procedure then
13343
         Set_Is_Valued_Procedure
13344
           (New_Subp, Is_Valued_Procedure (Parent_Subp));
13345
      else
13346
         Set_Has_Controlling_Result
13347
           (New_Subp, Has_Controlling_Result (Parent_Subp));
13348
      end if;
13349
 
13350
      --  No_Return must be inherited properly. If this is overridden in the
13351
      --  case of a dispatching operation, then a check is made in Sem_Disp
13352
      --  that the overriding operation is also No_Return (no such check is
13353
      --  required for the case of non-dispatching operation.
13354
 
13355
      Set_No_Return (New_Subp, No_Return (Parent_Subp));
13356
 
13357
      --  A derived function with a controlling result is abstract. If the
13358
      --  Derived_Type is a nonabstract formal generic derived type, then
13359
      --  inherited operations are not abstract: the required check is done at
13360
      --  instantiation time. If the derivation is for a generic actual, the
13361
      --  function is not abstract unless the actual is.
13362
 
13363
      if Is_Generic_Type (Derived_Type)
13364
        and then not Is_Abstract_Type (Derived_Type)
13365
      then
13366
         null;
13367
 
13368
      --  Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
13369
      --  properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
13370
 
13371
      elsif Ada_Version >= Ada_2005
13372
        and then (Is_Abstract_Subprogram (Alias (New_Subp))
13373
                   or else (Is_Tagged_Type (Derived_Type)
13374
                            and then Etype (New_Subp) = Derived_Type
13375
                            and then not Is_Null_Extension (Derived_Type))
13376
                   or else (Is_Tagged_Type (Derived_Type)
13377
                            and then Ekind (Etype (New_Subp)) =
13378
                                                       E_Anonymous_Access_Type
13379
                            and then Designated_Type (Etype (New_Subp)) =
13380
                                                       Derived_Type
13381
                            and then not Is_Null_Extension (Derived_Type)))
13382
        and then No (Actual_Subp)
13383
      then
13384
         if not Is_Tagged_Type (Derived_Type)
13385
           or else Is_Abstract_Type (Derived_Type)
13386
           or else Is_Abstract_Subprogram (Alias (New_Subp))
13387
         then
13388
            Set_Is_Abstract_Subprogram (New_Subp);
13389
         else
13390
            Set_Requires_Overriding (New_Subp);
13391
         end if;
13392
 
13393
      elsif Ada_Version < Ada_2005
13394
        and then (Is_Abstract_Subprogram (Alias (New_Subp))
13395
                   or else (Is_Tagged_Type (Derived_Type)
13396
                             and then Etype (New_Subp) = Derived_Type
13397
                             and then No (Actual_Subp)))
13398
      then
13399
         Set_Is_Abstract_Subprogram (New_Subp);
13400
 
13401
      --  AI05-0097 : an inherited operation that dispatches on result is
13402
      --  abstract if the derived type is abstract, even if the parent type
13403
      --  is concrete and the derived type is a null extension.
13404
 
13405
      elsif Has_Controlling_Result (Alias (New_Subp))
13406
        and then Is_Abstract_Type (Etype (New_Subp))
13407
      then
13408
         Set_Is_Abstract_Subprogram (New_Subp);
13409
 
13410
      --  Finally, if the parent type is abstract we must verify that all
13411
      --  inherited operations are either non-abstract or overridden, or that
13412
      --  the derived type itself is abstract (this check is performed at the
13413
      --  end of a package declaration, in Check_Abstract_Overriding). A
13414
      --  private overriding in the parent type will not be visible in the
13415
      --  derivation if we are not in an inner package or in a child unit of
13416
      --  the parent type, in which case the abstractness of the inherited
13417
      --  operation is carried to the new subprogram.
13418
 
13419
      elsif Is_Abstract_Type (Parent_Type)
13420
        and then not In_Open_Scopes (Scope (Parent_Type))
13421
        and then Is_Private_Overriding
13422
        and then Is_Abstract_Subprogram (Visible_Subp)
13423
      then
13424
         if No (Actual_Subp) then
13425
            Set_Alias (New_Subp, Visible_Subp);
13426
            Set_Is_Abstract_Subprogram (New_Subp, True);
13427
 
13428
         else
13429
            --  If this is a derivation for an instance of a formal derived
13430
            --  type, abstractness comes from the primitive operation of the
13431
            --  actual, not from the operation inherited from the ancestor.
13432
 
13433
            Set_Is_Abstract_Subprogram
13434
              (New_Subp, Is_Abstract_Subprogram (Actual_Subp));
13435
         end if;
13436
      end if;
13437
 
13438
      New_Overloaded_Entity (New_Subp, Derived_Type);
13439
 
13440
      --  Check for case of a derived subprogram for the instantiation of a
13441
      --  formal derived tagged type, if so mark the subprogram as dispatching
13442
      --  and inherit the dispatching attributes of the actual subprogram. The
13443
      --  derived subprogram is effectively renaming of the actual subprogram,
13444
      --  so it needs to have the same attributes as the actual.
13445
 
13446
      if Present (Actual_Subp)
13447
        and then Is_Dispatching_Operation (Actual_Subp)
13448
      then
13449
         Set_Is_Dispatching_Operation (New_Subp);
13450
 
13451
         if Present (DTC_Entity (Actual_Subp)) then
13452
            Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
13453
            Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
13454
         end if;
13455
      end if;
13456
 
13457
      --  Indicate that a derived subprogram does not require a body and that
13458
      --  it does not require processing of default expressions.
13459
 
13460
      Set_Has_Completion (New_Subp);
13461
      Set_Default_Expressions_Processed (New_Subp);
13462
 
13463
      if Ekind (New_Subp) = E_Function then
13464
         Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
13465
      end if;
13466
   end Derive_Subprogram;
13467
 
13468
   ------------------------
13469
   -- Derive_Subprograms --
13470
   ------------------------
13471
 
13472
   procedure Derive_Subprograms
13473
     (Parent_Type    : Entity_Id;
13474
      Derived_Type   : Entity_Id;
13475
      Generic_Actual : Entity_Id := Empty)
13476
   is
13477
      Op_List : constant Elist_Id :=
13478
                  Collect_Primitive_Operations (Parent_Type);
13479
 
13480
      function Check_Derived_Type return Boolean;
13481
      --  Check that all the entities derived from Parent_Type are found in
13482
      --  the list of primitives of Derived_Type exactly in the same order.
13483
 
13484
      procedure Derive_Interface_Subprogram
13485
        (New_Subp    : in out Entity_Id;
13486
         Subp        : Entity_Id;
13487
         Actual_Subp : Entity_Id);
13488
      --  Derive New_Subp from the ultimate alias of the parent subprogram Subp
13489
      --  (which is an interface primitive). If Generic_Actual is present then
13490
      --  Actual_Subp is the actual subprogram corresponding with the generic
13491
      --  subprogram Subp.
13492
 
13493
      function Check_Derived_Type return Boolean is
13494
         E        : Entity_Id;
13495
         Elmt     : Elmt_Id;
13496
         List     : Elist_Id;
13497
         New_Subp : Entity_Id;
13498
         Op_Elmt  : Elmt_Id;
13499
         Subp     : Entity_Id;
13500
 
13501
      begin
13502
         --  Traverse list of entities in the current scope searching for
13503
         --  an incomplete type whose full-view is derived type
13504
 
13505
         E := First_Entity (Scope (Derived_Type));
13506
         while Present (E)
13507
           and then E /= Derived_Type
13508
         loop
13509
            if Ekind (E) = E_Incomplete_Type
13510
              and then Present (Full_View (E))
13511
              and then Full_View (E) = Derived_Type
13512
            then
13513
               --  Disable this test if Derived_Type completes an incomplete
13514
               --  type because in such case more primitives can be added
13515
               --  later to the list of primitives of Derived_Type by routine
13516
               --  Process_Incomplete_Dependents
13517
 
13518
               return True;
13519
            end if;
13520
 
13521
            E := Next_Entity (E);
13522
         end loop;
13523
 
13524
         List := Collect_Primitive_Operations (Derived_Type);
13525
         Elmt := First_Elmt (List);
13526
 
13527
         Op_Elmt := First_Elmt (Op_List);
13528
         while Present (Op_Elmt) loop
13529
            Subp     := Node (Op_Elmt);
13530
            New_Subp := Node (Elmt);
13531
 
13532
            --  At this early stage Derived_Type has no entities with attribute
13533
            --  Interface_Alias. In addition, such primitives are always
13534
            --  located at the end of the list of primitives of Parent_Type.
13535
            --  Therefore, if found we can safely stop processing pending
13536
            --  entities.
13537
 
13538
            exit when Present (Interface_Alias (Subp));
13539
 
13540
            --  Handle hidden entities
13541
 
13542
            if not Is_Predefined_Dispatching_Operation (Subp)
13543
              and then Is_Hidden (Subp)
13544
            then
13545
               if Present (New_Subp)
13546
                 and then Primitive_Names_Match (Subp, New_Subp)
13547
               then
13548
                  Next_Elmt (Elmt);
13549
               end if;
13550
 
13551
            else
13552
               if not Present (New_Subp)
13553
                 or else Ekind (Subp) /= Ekind (New_Subp)
13554
                 or else not Primitive_Names_Match (Subp, New_Subp)
13555
               then
13556
                  return False;
13557
               end if;
13558
 
13559
               Next_Elmt (Elmt);
13560
            end if;
13561
 
13562
            Next_Elmt (Op_Elmt);
13563
         end loop;
13564
 
13565
         return True;
13566
      end Check_Derived_Type;
13567
 
13568
      ---------------------------------
13569
      -- Derive_Interface_Subprogram --
13570
      ---------------------------------
13571
 
13572
      procedure Derive_Interface_Subprogram
13573
        (New_Subp    : in out Entity_Id;
13574
         Subp        : Entity_Id;
13575
         Actual_Subp : Entity_Id)
13576
      is
13577
         Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp);
13578
         Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp);
13579
 
13580
      begin
13581
         pragma Assert (Is_Interface (Iface_Type));
13582
 
13583
         Derive_Subprogram
13584
           (New_Subp     => New_Subp,
13585
            Parent_Subp  => Iface_Subp,
13586
            Derived_Type => Derived_Type,
13587
            Parent_Type  => Iface_Type,
13588
            Actual_Subp  => Actual_Subp);
13589
 
13590
         --  Given that this new interface entity corresponds with a primitive
13591
         --  of the parent that was not overridden we must leave it associated
13592
         --  with its parent primitive to ensure that it will share the same
13593
         --  dispatch table slot when overridden.
13594
 
13595
         if No (Actual_Subp) then
13596
            Set_Alias (New_Subp, Subp);
13597
 
13598
         --  For instantiations this is not needed since the previous call to
13599
         --  Derive_Subprogram leaves the entity well decorated.
13600
 
13601
         else
13602
            pragma Assert (Alias (New_Subp) = Actual_Subp);
13603
            null;
13604
         end if;
13605
      end Derive_Interface_Subprogram;
13606
 
13607
      --  Local variables
13608
 
13609
      Alias_Subp   : Entity_Id;
13610
      Act_List     : Elist_Id;
13611
      Act_Elmt     : Elmt_Id   := No_Elmt;
13612
      Act_Subp     : Entity_Id := Empty;
13613
      Elmt         : Elmt_Id;
13614
      Need_Search  : Boolean   := False;
13615
      New_Subp     : Entity_Id := Empty;
13616
      Parent_Base  : Entity_Id;
13617
      Subp         : Entity_Id;
13618
 
13619
   --  Start of processing for Derive_Subprograms
13620
 
13621
   begin
13622
      if Ekind (Parent_Type) = E_Record_Type_With_Private
13623
        and then Has_Discriminants (Parent_Type)
13624
        and then Present (Full_View (Parent_Type))
13625
      then
13626
         Parent_Base := Full_View (Parent_Type);
13627
      else
13628
         Parent_Base := Parent_Type;
13629
      end if;
13630
 
13631
      if Present (Generic_Actual) then
13632
         Act_List := Collect_Primitive_Operations (Generic_Actual);
13633
         Act_Elmt := First_Elmt (Act_List);
13634
      end if;
13635
 
13636
      --  Derive primitives inherited from the parent. Note that if the generic
13637
      --  actual is present, this is not really a type derivation, it is a
13638
      --  completion within an instance.
13639
 
13640
      --  Case 1: Derived_Type does not implement interfaces
13641
 
13642
      if not Is_Tagged_Type (Derived_Type)
13643
        or else (not Has_Interfaces (Derived_Type)
13644
                  and then not (Present (Generic_Actual)
13645
                                  and then
13646
                                Has_Interfaces (Generic_Actual)))
13647
      then
13648
         Elmt := First_Elmt (Op_List);
13649
         while Present (Elmt) loop
13650
            Subp := Node (Elmt);
13651
 
13652
            --  Literals are derived earlier in the process of building the
13653
            --  derived type, and are skipped here.
13654
 
13655
            if Ekind (Subp) = E_Enumeration_Literal then
13656
               null;
13657
 
13658
            --  The actual is a direct descendant and the common primitive
13659
            --  operations appear in the same order.
13660
 
13661
            --  If the generic parent type is present, the derived type is an
13662
            --  instance of a formal derived type, and within the instance its
13663
            --  operations are those of the actual. We derive from the formal
13664
            --  type but make the inherited operations aliases of the
13665
            --  corresponding operations of the actual.
13666
 
13667
            else
13668
               pragma Assert (No (Node (Act_Elmt))
13669
                 or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
13670
                            and then
13671
                          Type_Conformant (Subp, Node (Act_Elmt),
13672
                                           Skip_Controlling_Formals => True)));
13673
 
13674
               Derive_Subprogram
13675
                 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
13676
 
13677
               if Present (Act_Elmt) then
13678
                  Next_Elmt (Act_Elmt);
13679
               end if;
13680
            end if;
13681
 
13682
            Next_Elmt (Elmt);
13683
         end loop;
13684
 
13685
      --  Case 2: Derived_Type implements interfaces
13686
 
13687
      else
13688
         --  If the parent type has no predefined primitives we remove
13689
         --  predefined primitives from the list of primitives of generic
13690
         --  actual to simplify the complexity of this algorithm.
13691
 
13692
         if Present (Generic_Actual) then
13693
            declare
13694
               Has_Predefined_Primitives : Boolean := False;
13695
 
13696
            begin
13697
               --  Check if the parent type has predefined primitives
13698
 
13699
               Elmt := First_Elmt (Op_List);
13700
               while Present (Elmt) loop
13701
                  Subp := Node (Elmt);
13702
 
13703
                  if Is_Predefined_Dispatching_Operation (Subp)
13704
                    and then not Comes_From_Source (Ultimate_Alias (Subp))
13705
                  then
13706
                     Has_Predefined_Primitives := True;
13707
                     exit;
13708
                  end if;
13709
 
13710
                  Next_Elmt (Elmt);
13711
               end loop;
13712
 
13713
               --  Remove predefined primitives of Generic_Actual. We must use
13714
               --  an auxiliary list because in case of tagged types the value
13715
               --  returned by Collect_Primitive_Operations is the value stored
13716
               --  in its Primitive_Operations attribute (and we don't want to
13717
               --  modify its current contents).
13718
 
13719
               if not Has_Predefined_Primitives then
13720
                  declare
13721
                     Aux_List : constant Elist_Id := New_Elmt_List;
13722
 
13723
                  begin
13724
                     Elmt := First_Elmt (Act_List);
13725
                     while Present (Elmt) loop
13726
                        Subp := Node (Elmt);
13727
 
13728
                        if not Is_Predefined_Dispatching_Operation (Subp)
13729
                          or else Comes_From_Source (Subp)
13730
                        then
13731
                           Append_Elmt (Subp, Aux_List);
13732
                        end if;
13733
 
13734
                        Next_Elmt (Elmt);
13735
                     end loop;
13736
 
13737
                     Act_List := Aux_List;
13738
                  end;
13739
               end if;
13740
 
13741
               Act_Elmt := First_Elmt (Act_List);
13742
               Act_Subp := Node (Act_Elmt);
13743
            end;
13744
         end if;
13745
 
13746
         --  Stage 1: If the generic actual is not present we derive the
13747
         --  primitives inherited from the parent type. If the generic parent
13748
         --  type is present, the derived type is an instance of a formal
13749
         --  derived type, and within the instance its operations are those of
13750
         --  the actual. We derive from the formal type but make the inherited
13751
         --  operations aliases of the corresponding operations of the actual.
13752
 
13753
         Elmt := First_Elmt (Op_List);
13754
         while Present (Elmt) loop
13755
            Subp       := Node (Elmt);
13756
            Alias_Subp := Ultimate_Alias (Subp);
13757
 
13758
            --  Do not derive internal entities of the parent that link
13759
            --  interface primitives with their covering primitive. These
13760
            --  entities will be added to this type when frozen.
13761
 
13762
            if Present (Interface_Alias (Subp)) then
13763
               goto Continue;
13764
            end if;
13765
 
13766
            --  If the generic actual is present find the corresponding
13767
            --  operation in the generic actual. If the parent type is a
13768
            --  direct ancestor of the derived type then, even if it is an
13769
            --  interface, the operations are inherited from the primary
13770
            --  dispatch table and are in the proper order. If we detect here
13771
            --  that primitives are not in the same order we traverse the list
13772
            --  of primitive operations of the actual to find the one that
13773
            --  implements the interface primitive.
13774
 
13775
            if Need_Search
13776
              or else
13777
                (Present (Generic_Actual)
13778
                  and then Present (Act_Subp)
13779
                  and then not
13780
                    (Primitive_Names_Match (Subp, Act_Subp)
13781
                       and then
13782
                     Type_Conformant (Subp, Act_Subp,
13783
                                      Skip_Controlling_Formals => True)))
13784
            then
13785
               pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual,
13786
                                               Use_Full_View => True));
13787
 
13788
               --  Remember that we need searching for all pending primitives
13789
 
13790
               Need_Search := True;
13791
 
13792
               --  Handle entities associated with interface primitives
13793
 
13794
               if Present (Alias_Subp)
13795
                 and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
13796
                 and then not Is_Predefined_Dispatching_Operation (Subp)
13797
               then
13798
                  --  Search for the primitive in the homonym chain
13799
 
13800
                  Act_Subp :=
13801
                    Find_Primitive_Covering_Interface
13802
                      (Tagged_Type => Generic_Actual,
13803
                       Iface_Prim  => Alias_Subp);
13804
 
13805
                  --  Previous search may not locate primitives covering
13806
                  --  interfaces defined in generics units or instantiations.
13807
                  --  (it fails if the covering primitive has formals whose
13808
                  --  type is also defined in generics or instantiations).
13809
                  --  In such case we search in the list of primitives of the
13810
                  --  generic actual for the internal entity that links the
13811
                  --  interface primitive and the covering primitive.
13812
 
13813
                  if No (Act_Subp)
13814
                    and then Is_Generic_Type (Parent_Type)
13815
                  then
13816
                     --  This code has been designed to handle only generic
13817
                     --  formals that implement interfaces that are defined
13818
                     --  in a generic unit or instantiation. If this code is
13819
                     --  needed for other cases we must review it because
13820
                     --  (given that it relies on Original_Location to locate
13821
                     --  the primitive of Generic_Actual that covers the
13822
                     --  interface) it could leave linked through attribute
13823
                     --  Alias entities of unrelated instantiations).
13824
 
13825
                     pragma Assert
13826
                       (Is_Generic_Unit
13827
                          (Scope (Find_Dispatching_Type (Alias_Subp)))
13828
                       or else
13829
                        Instantiation_Depth
13830
                          (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
13831
 
13832
                     declare
13833
                        Iface_Prim_Loc : constant Source_Ptr :=
13834
                                         Original_Location (Sloc (Alias_Subp));
13835
                        Elmt      : Elmt_Id;
13836
                        Prim      : Entity_Id;
13837
                     begin
13838
                        Elmt :=
13839
                          First_Elmt (Primitive_Operations (Generic_Actual));
13840
 
13841
                        Search : while Present (Elmt) loop
13842
                           Prim := Node (Elmt);
13843
 
13844
                           if Present (Interface_Alias (Prim))
13845
                             and then Original_Location
13846
                                        (Sloc (Interface_Alias (Prim)))
13847
                                       = Iface_Prim_Loc
13848
                           then
13849
                              Act_Subp := Alias (Prim);
13850
                              exit Search;
13851
                           end if;
13852
 
13853
                           Next_Elmt (Elmt);
13854
                        end loop Search;
13855
                     end;
13856
                  end if;
13857
 
13858
                  pragma Assert (Present (Act_Subp)
13859
                    or else Is_Abstract_Type (Generic_Actual)
13860
                    or else Serious_Errors_Detected > 0);
13861
 
13862
               --  Handle predefined primitives plus the rest of user-defined
13863
               --  primitives
13864
 
13865
               else
13866
                  Act_Elmt := First_Elmt (Act_List);
13867
                  while Present (Act_Elmt) loop
13868
                     Act_Subp := Node (Act_Elmt);
13869
 
13870
                     exit when Primitive_Names_Match (Subp, Act_Subp)
13871
                       and then Type_Conformant
13872
                                  (Subp, Act_Subp,
13873
                                   Skip_Controlling_Formals => True)
13874
                       and then No (Interface_Alias (Act_Subp));
13875
 
13876
                     Next_Elmt (Act_Elmt);
13877
                  end loop;
13878
 
13879
                  if No (Act_Elmt) then
13880
                     Act_Subp := Empty;
13881
                  end if;
13882
               end if;
13883
            end if;
13884
 
13885
            --   Case 1: If the parent is a limited interface then it has the
13886
            --   predefined primitives of synchronized interfaces. However, the
13887
            --   actual type may be a non-limited type and hence it does not
13888
            --   have such primitives.
13889
 
13890
            if Present (Generic_Actual)
13891
              and then not Present (Act_Subp)
13892
              and then Is_Limited_Interface (Parent_Base)
13893
              and then Is_Predefined_Interface_Primitive (Subp)
13894
            then
13895
               null;
13896
 
13897
            --  Case 2: Inherit entities associated with interfaces that were
13898
            --  not covered by the parent type. We exclude here null interface
13899
            --  primitives because they do not need special management.
13900
 
13901
            --  We also exclude interface operations that are renamings. If the
13902
            --  subprogram is an explicit renaming of an interface primitive,
13903
            --  it is a regular primitive operation, and the presence of its
13904
            --  alias is not relevant: it has to be derived like any other
13905
            --  primitive.
13906
 
13907
            elsif Present (Alias (Subp))
13908
              and then Nkind (Unit_Declaration_Node (Subp)) /=
13909
                                            N_Subprogram_Renaming_Declaration
13910
              and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
13911
              and then not
13912
                (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
13913
                  and then Null_Present (Parent (Alias_Subp)))
13914
            then
13915
               --  If this is an abstract private type then we transfer the
13916
               --  derivation of the interface primitive from the partial view
13917
               --  to the full view. This is safe because all the interfaces
13918
               --  must be visible in the partial view. Done to avoid adding
13919
               --  a new interface derivation to the private part of the
13920
               --  enclosing package; otherwise this new derivation would be
13921
               --  decorated as hidden when the analysis of the enclosing
13922
               --  package completes.
13923
 
13924
               if Is_Abstract_Type (Derived_Type)
13925
                 and then In_Private_Part (Current_Scope)
13926
                 and then Has_Private_Declaration (Derived_Type)
13927
               then
13928
                  declare
13929
                     Partial_View : Entity_Id;
13930
                     Elmt         : Elmt_Id;
13931
                     Ent          : Entity_Id;
13932
 
13933
                  begin
13934
                     Partial_View := First_Entity (Current_Scope);
13935
                     loop
13936
                        exit when No (Partial_View)
13937
                          or else (Has_Private_Declaration (Partial_View)
13938
                                     and then
13939
                                   Full_View (Partial_View) = Derived_Type);
13940
 
13941
                        Next_Entity (Partial_View);
13942
                     end loop;
13943
 
13944
                     --  If the partial view was not found then the source code
13945
                     --  has errors and the derivation is not needed.
13946
 
13947
                     if Present (Partial_View) then
13948
                        Elmt :=
13949
                          First_Elmt (Primitive_Operations (Partial_View));
13950
                        while Present (Elmt) loop
13951
                           Ent := Node (Elmt);
13952
 
13953
                           if Present (Alias (Ent))
13954
                             and then Ultimate_Alias (Ent) = Alias (Subp)
13955
                           then
13956
                              Append_Elmt
13957
                                (Ent, Primitive_Operations (Derived_Type));
13958
                              exit;
13959
                           end if;
13960
 
13961
                           Next_Elmt (Elmt);
13962
                        end loop;
13963
 
13964
                        --  If the interface primitive was not found in the
13965
                        --  partial view then this interface primitive was
13966
                        --  overridden. We add a derivation to activate in
13967
                        --  Derive_Progenitor_Subprograms the machinery to
13968
                        --  search for it.
13969
 
13970
                        if No (Elmt) then
13971
                           Derive_Interface_Subprogram
13972
                             (New_Subp    => New_Subp,
13973
                              Subp        => Subp,
13974
                              Actual_Subp => Act_Subp);
13975
                        end if;
13976
                     end if;
13977
                  end;
13978
               else
13979
                  Derive_Interface_Subprogram
13980
                    (New_Subp     => New_Subp,
13981
                     Subp         => Subp,
13982
                     Actual_Subp  => Act_Subp);
13983
               end if;
13984
 
13985
            --  Case 3: Common derivation
13986
 
13987
            else
13988
               Derive_Subprogram
13989
                 (New_Subp     => New_Subp,
13990
                  Parent_Subp  => Subp,
13991
                  Derived_Type => Derived_Type,
13992
                  Parent_Type  => Parent_Base,
13993
                  Actual_Subp  => Act_Subp);
13994
            end if;
13995
 
13996
            --  No need to update Act_Elm if we must search for the
13997
            --  corresponding operation in the generic actual
13998
 
13999
            if not Need_Search
14000
              and then Present (Act_Elmt)
14001
            then
14002
               Next_Elmt (Act_Elmt);
14003
               Act_Subp := Node (Act_Elmt);
14004
            end if;
14005
 
14006
            <<Continue>>
14007
            Next_Elmt (Elmt);
14008
         end loop;
14009
 
14010
         --  Inherit additional operations from progenitors. If the derived
14011
         --  type is a generic actual, there are not new primitive operations
14012
         --  for the type because it has those of the actual, and therefore
14013
         --  nothing needs to be done. The renamings generated above are not
14014
         --  primitive operations, and their purpose is simply to make the
14015
         --  proper operations visible within an instantiation.
14016
 
14017
         if No (Generic_Actual) then
14018
            Derive_Progenitor_Subprograms (Parent_Base, Derived_Type);
14019
         end if;
14020
      end if;
14021
 
14022
      --  Final check: Direct descendants must have their primitives in the
14023
      --  same order. We exclude from this test untagged types and instances
14024
      --  of formal derived types. We skip this test if we have already
14025
      --  reported serious errors in the sources.
14026
 
14027
      pragma Assert (not Is_Tagged_Type (Derived_Type)
14028
        or else Present (Generic_Actual)
14029
        or else Serious_Errors_Detected > 0
14030
        or else Check_Derived_Type);
14031
   end Derive_Subprograms;
14032
 
14033
   --------------------------------
14034
   -- Derived_Standard_Character --
14035
   --------------------------------
14036
 
14037
   procedure Derived_Standard_Character
14038
     (N            : Node_Id;
14039
      Parent_Type  : Entity_Id;
14040
      Derived_Type : Entity_Id)
14041
   is
14042
      Loc           : constant Source_Ptr := Sloc (N);
14043
      Def           : constant Node_Id    := Type_Definition (N);
14044
      Indic         : constant Node_Id    := Subtype_Indication (Def);
14045
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
14046
      Implicit_Base : constant Entity_Id  :=
14047
                        Create_Itype
14048
                          (E_Enumeration_Type, N, Derived_Type, 'B');
14049
 
14050
      Lo : Node_Id;
14051
      Hi : Node_Id;
14052
 
14053
   begin
14054
      Discard_Node (Process_Subtype (Indic, N));
14055
 
14056
      Set_Etype     (Implicit_Base, Parent_Base);
14057
      Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
14058
      Set_RM_Size   (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
14059
 
14060
      Set_Is_Character_Type  (Implicit_Base, True);
14061
      Set_Has_Delayed_Freeze (Implicit_Base);
14062
 
14063
      --  The bounds of the implicit base are the bounds of the parent base.
14064
      --  Note that their type is the parent base.
14065
 
14066
      Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Base));
14067
      Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
14068
 
14069
      Set_Scalar_Range (Implicit_Base,
14070
        Make_Range (Loc,
14071
          Low_Bound  => Lo,
14072
          High_Bound => Hi));
14073
 
14074
      Conditional_Delay (Derived_Type, Parent_Type);
14075
 
14076
      Set_Ekind (Derived_Type, E_Enumeration_Subtype);
14077
      Set_Etype (Derived_Type, Implicit_Base);
14078
      Set_Size_Info         (Derived_Type, Parent_Type);
14079
 
14080
      if Unknown_RM_Size (Derived_Type) then
14081
         Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
14082
      end if;
14083
 
14084
      Set_Is_Character_Type (Derived_Type, True);
14085
 
14086
      if Nkind (Indic) /= N_Subtype_Indication then
14087
 
14088
         --  If no explicit constraint, the bounds are those
14089
         --  of the parent type.
14090
 
14091
         Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Type));
14092
         Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
14093
         Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi));
14094
      end if;
14095
 
14096
      Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
14097
 
14098
      --  Because the implicit base is used in the conversion of the bounds, we
14099
      --  have to freeze it now. This is similar to what is done for numeric
14100
      --  types, and it equally suspicious, but otherwise a non-static bound
14101
      --  will have a reference to an unfrozen type, which is rejected by Gigi
14102
      --  (???). This requires specific care for definition of stream
14103
      --  attributes. For details, see comments at the end of
14104
      --  Build_Derived_Numeric_Type.
14105
 
14106
      Freeze_Before (N, Implicit_Base);
14107
   end Derived_Standard_Character;
14108
 
14109
   ------------------------------
14110
   -- Derived_Type_Declaration --
14111
   ------------------------------
14112
 
14113
   procedure Derived_Type_Declaration
14114
     (T             : Entity_Id;
14115
      N             : Node_Id;
14116
      Is_Completion : Boolean)
14117
   is
14118
      Parent_Type  : Entity_Id;
14119
 
14120
      function Comes_From_Generic (Typ : Entity_Id) return Boolean;
14121
      --  Check whether the parent type is a generic formal, or derives
14122
      --  directly or indirectly from one.
14123
 
14124
      ------------------------
14125
      -- Comes_From_Generic --
14126
      ------------------------
14127
 
14128
      function Comes_From_Generic (Typ : Entity_Id) return Boolean is
14129
      begin
14130
         if Is_Generic_Type (Typ) then
14131
            return True;
14132
 
14133
         elsif Is_Generic_Type (Root_Type (Parent_Type)) then
14134
            return True;
14135
 
14136
         elsif Is_Private_Type (Typ)
14137
           and then Present (Full_View (Typ))
14138
           and then Is_Generic_Type (Root_Type (Full_View (Typ)))
14139
         then
14140
            return True;
14141
 
14142
         elsif Is_Generic_Actual_Type (Typ) then
14143
            return True;
14144
 
14145
         else
14146
            return False;
14147
         end if;
14148
      end Comes_From_Generic;
14149
 
14150
      --  Local variables
14151
 
14152
      Def          : constant Node_Id := Type_Definition (N);
14153
      Iface_Def    : Node_Id;
14154
      Indic        : constant Node_Id := Subtype_Indication (Def);
14155
      Extension    : constant Node_Id := Record_Extension_Part (Def);
14156
      Parent_Node  : Node_Id;
14157
      Taggd        : Boolean;
14158
 
14159
   --  Start of processing for Derived_Type_Declaration
14160
 
14161
   begin
14162
      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
14163
 
14164
      --  Ada 2005 (AI-251): In case of interface derivation check that the
14165
      --  parent is also an interface.
14166
 
14167
      if Interface_Present (Def) then
14168
         Check_SPARK_Restriction ("interface is not allowed", Def);
14169
 
14170
         if not Is_Interface (Parent_Type) then
14171
            Diagnose_Interface (Indic, Parent_Type);
14172
 
14173
         else
14174
            Parent_Node := Parent (Base_Type (Parent_Type));
14175
            Iface_Def   := Type_Definition (Parent_Node);
14176
 
14177
            --  Ada 2005 (AI-251): Limited interfaces can only inherit from
14178
            --  other limited interfaces.
14179
 
14180
            if Limited_Present (Def) then
14181
               if Limited_Present (Iface_Def) then
14182
                  null;
14183
 
14184
               elsif Protected_Present (Iface_Def) then
14185
                  Error_Msg_NE
14186
                    ("descendant of& must be declared"
14187
                       & " as a protected interface",
14188
                         N, Parent_Type);
14189
 
14190
               elsif Synchronized_Present (Iface_Def) then
14191
                  Error_Msg_NE
14192
                    ("descendant of& must be declared"
14193
                       & " as a synchronized interface",
14194
                         N, Parent_Type);
14195
 
14196
               elsif Task_Present (Iface_Def) then
14197
                  Error_Msg_NE
14198
                    ("descendant of& must be declared as a task interface",
14199
                       N, Parent_Type);
14200
 
14201
               else
14202
                  Error_Msg_N
14203
                    ("(Ada 2005) limited interface cannot "
14204
                     & "inherit from non-limited interface", Indic);
14205
               end if;
14206
 
14207
            --  Ada 2005 (AI-345): Non-limited interfaces can only inherit
14208
            --  from non-limited or limited interfaces.
14209
 
14210
            elsif not Protected_Present (Def)
14211
              and then not Synchronized_Present (Def)
14212
              and then not Task_Present (Def)
14213
            then
14214
               if Limited_Present (Iface_Def) then
14215
                  null;
14216
 
14217
               elsif Protected_Present (Iface_Def) then
14218
                  Error_Msg_NE
14219
                    ("descendant of& must be declared"
14220
                       & " as a protected interface",
14221
                         N, Parent_Type);
14222
 
14223
               elsif Synchronized_Present (Iface_Def) then
14224
                  Error_Msg_NE
14225
                    ("descendant of& must be declared"
14226
                       & " as a synchronized interface",
14227
                         N, Parent_Type);
14228
 
14229
               elsif Task_Present (Iface_Def) then
14230
                  Error_Msg_NE
14231
                    ("descendant of& must be declared as a task interface",
14232
                       N, Parent_Type);
14233
               else
14234
                  null;
14235
               end if;
14236
            end if;
14237
         end if;
14238
      end if;
14239
 
14240
      if Is_Tagged_Type (Parent_Type)
14241
        and then Is_Concurrent_Type (Parent_Type)
14242
        and then not Is_Interface (Parent_Type)
14243
      then
14244
         Error_Msg_N
14245
           ("parent type of a record extension cannot be "
14246
            & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
14247
         Set_Etype (T, Any_Type);
14248
         return;
14249
      end if;
14250
 
14251
      --  Ada 2005 (AI-251): Decorate all the names in the list of ancestor
14252
      --  interfaces
14253
 
14254
      if Is_Tagged_Type (Parent_Type)
14255
        and then Is_Non_Empty_List (Interface_List (Def))
14256
      then
14257
         declare
14258
            Intf : Node_Id;
14259
            T    : Entity_Id;
14260
 
14261
         begin
14262
            Intf := First (Interface_List (Def));
14263
            while Present (Intf) loop
14264
               T := Find_Type_Of_Subtype_Indic (Intf);
14265
 
14266
               if not Is_Interface (T) then
14267
                  Diagnose_Interface (Intf, T);
14268
 
14269
               --  Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow
14270
               --  a limited type from having a nonlimited progenitor.
14271
 
14272
               elsif (Limited_Present (Def)
14273
                       or else (not Is_Interface (Parent_Type)
14274
                                 and then Is_Limited_Type (Parent_Type)))
14275
                 and then not Is_Limited_Interface (T)
14276
               then
14277
                  Error_Msg_NE
14278
                   ("progenitor interface& of limited type must be limited",
14279
                     N, T);
14280
               end if;
14281
 
14282
               Next (Intf);
14283
            end loop;
14284
         end;
14285
      end if;
14286
 
14287
      if Parent_Type = Any_Type
14288
        or else Etype (Parent_Type) = Any_Type
14289
        or else (Is_Class_Wide_Type (Parent_Type)
14290
                   and then Etype (Parent_Type) = T)
14291
      then
14292
         --  If Parent_Type is undefined or illegal, make new type into a
14293
         --  subtype of Any_Type, and set a few attributes to prevent cascaded
14294
         --  errors. If this is a self-definition, emit error now.
14295
 
14296
         if T = Parent_Type
14297
           or else T = Etype (Parent_Type)
14298
         then
14299
            Error_Msg_N ("type cannot be used in its own definition", Indic);
14300
         end if;
14301
 
14302
         Set_Ekind        (T, Ekind (Parent_Type));
14303
         Set_Etype        (T, Any_Type);
14304
         Set_Scalar_Range (T, Scalar_Range (Any_Type));
14305
 
14306
         if Is_Tagged_Type (T)
14307
           and then Is_Record_Type (T)
14308
         then
14309
            Set_Direct_Primitive_Operations (T, New_Elmt_List);
14310
         end if;
14311
 
14312
         return;
14313
      end if;
14314
 
14315
      --  Ada 2005 (AI-251): The case in which the parent of the full-view is
14316
      --  an interface is special because the list of interfaces in the full
14317
      --  view can be given in any order. For example:
14318
 
14319
      --     type A is interface;
14320
      --     type B is interface and A;
14321
      --     type D is new B with private;
14322
      --   private
14323
      --     type D is new A and B with null record; -- 1 --
14324
 
14325
      --  In this case we perform the following transformation of -1-:
14326
 
14327
      --     type D is new B and A with null record;
14328
 
14329
      --  If the parent of the full-view covers the parent of the partial-view
14330
      --  we have two possible cases:
14331
 
14332
      --     1) They have the same parent
14333
      --     2) The parent of the full-view implements some further interfaces
14334
 
14335
      --  In both cases we do not need to perform the transformation. In the
14336
      --  first case the source program is correct and the transformation is
14337
      --  not needed; in the second case the source program does not fulfill
14338
      --  the no-hidden interfaces rule (AI-396) and the error will be reported
14339
      --  later.
14340
 
14341
      --  This transformation not only simplifies the rest of the analysis of
14342
      --  this type declaration but also simplifies the correct generation of
14343
      --  the object layout to the expander.
14344
 
14345
      if In_Private_Part (Current_Scope)
14346
        and then Is_Interface (Parent_Type)
14347
      then
14348
         declare
14349
            Iface               : Node_Id;
14350
            Partial_View        : Entity_Id;
14351
            Partial_View_Parent : Entity_Id;
14352
            New_Iface           : Node_Id;
14353
 
14354
         begin
14355
            --  Look for the associated private type declaration
14356
 
14357
            Partial_View := First_Entity (Current_Scope);
14358
            loop
14359
               exit when No (Partial_View)
14360
                 or else (Has_Private_Declaration (Partial_View)
14361
                           and then Full_View (Partial_View) = T);
14362
 
14363
               Next_Entity (Partial_View);
14364
            end loop;
14365
 
14366
            --  If the partial view was not found then the source code has
14367
            --  errors and the transformation is not needed.
14368
 
14369
            if Present (Partial_View) then
14370
               Partial_View_Parent := Etype (Partial_View);
14371
 
14372
               --  If the parent of the full-view covers the parent of the
14373
               --  partial-view we have nothing else to do.
14374
 
14375
               if Interface_Present_In_Ancestor
14376
                    (Parent_Type, Partial_View_Parent)
14377
               then
14378
                  null;
14379
 
14380
               --  Traverse the list of interfaces of the full-view to look
14381
               --  for the parent of the partial-view and perform the tree
14382
               --  transformation.
14383
 
14384
               else
14385
                  Iface := First (Interface_List (Def));
14386
                  while Present (Iface) loop
14387
                     if Etype (Iface) = Etype (Partial_View) then
14388
                        Rewrite (Subtype_Indication (Def),
14389
                          New_Copy (Subtype_Indication
14390
                                     (Parent (Partial_View))));
14391
 
14392
                        New_Iface :=
14393
                          Make_Identifier (Sloc (N), Chars (Parent_Type));
14394
                        Append (New_Iface, Interface_List (Def));
14395
 
14396
                        --  Analyze the transformed code
14397
 
14398
                        Derived_Type_Declaration (T, N, Is_Completion);
14399
                        return;
14400
                     end if;
14401
 
14402
                     Next (Iface);
14403
                  end loop;
14404
               end if;
14405
            end if;
14406
         end;
14407
      end if;
14408
 
14409
      --  Only composite types other than array types are allowed to have
14410
      --  discriminants. In SPARK, no types are allowed to have discriminants.
14411
 
14412
      if Present (Discriminant_Specifications (N)) then
14413
         if (Is_Elementary_Type (Parent_Type)
14414
              or else Is_Array_Type (Parent_Type))
14415
           and then not Error_Posted (N)
14416
         then
14417
            Error_Msg_N
14418
              ("elementary or array type cannot have discriminants",
14419
               Defining_Identifier (First (Discriminant_Specifications (N))));
14420
            Set_Has_Discriminants (T, False);
14421
         else
14422
            Check_SPARK_Restriction ("discriminant type is not allowed", N);
14423
         end if;
14424
      end if;
14425
 
14426
      --  In Ada 83, a derived type defined in a package specification cannot
14427
      --  be used for further derivation until the end of its visible part.
14428
      --  Note that derivation in the private part of the package is allowed.
14429
 
14430
      if Ada_Version = Ada_83
14431
        and then Is_Derived_Type (Parent_Type)
14432
        and then In_Visible_Part (Scope (Parent_Type))
14433
      then
14434
         if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
14435
            Error_Msg_N
14436
              ("(Ada 83): premature use of type for derivation", Indic);
14437
         end if;
14438
      end if;
14439
 
14440
      --  Check for early use of incomplete or private type
14441
 
14442
      if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
14443
         Error_Msg_N ("premature derivation of incomplete type", Indic);
14444
         return;
14445
 
14446
      elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
14447
              and then not Comes_From_Generic (Parent_Type))
14448
        or else Has_Private_Component (Parent_Type)
14449
      then
14450
         --  The ancestor type of a formal type can be incomplete, in which
14451
         --  case only the operations of the partial view are available in the
14452
         --  generic. Subsequent checks may be required when the full view is
14453
         --  analyzed to verify that a derivation from a tagged type has an
14454
         --  extension.
14455
 
14456
         if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
14457
            null;
14458
 
14459
         elsif No (Underlying_Type (Parent_Type))
14460
           or else Has_Private_Component (Parent_Type)
14461
         then
14462
            Error_Msg_N
14463
              ("premature derivation of derived or private type", Indic);
14464
 
14465
            --  Flag the type itself as being in error, this prevents some
14466
            --  nasty problems with subsequent uses of the malformed type.
14467
 
14468
            Set_Error_Posted (T);
14469
 
14470
         --  Check that within the immediate scope of an untagged partial
14471
         --  view it's illegal to derive from the partial view if the
14472
         --  full view is tagged. (7.3(7))
14473
 
14474
         --  We verify that the Parent_Type is a partial view by checking
14475
         --  that it is not a Full_Type_Declaration (i.e. a private type or
14476
         --  private extension declaration), to distinguish a partial view
14477
         --  from  a derivation from a private type which also appears as
14478
         --  E_Private_Type. If the parent base type is not declared in an
14479
         --  enclosing scope there is no need to check.
14480
 
14481
         elsif Present (Full_View (Parent_Type))
14482
           and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
14483
           and then not Is_Tagged_Type (Parent_Type)
14484
           and then Is_Tagged_Type (Full_View (Parent_Type))
14485
           and then In_Open_Scopes (Scope (Base_Type (Parent_Type)))
14486
         then
14487
            Error_Msg_N
14488
              ("premature derivation from type with tagged full view",
14489
                Indic);
14490
         end if;
14491
      end if;
14492
 
14493
      --  Check that form of derivation is appropriate
14494
 
14495
      Taggd := Is_Tagged_Type (Parent_Type);
14496
 
14497
      --  Perhaps the parent type should be changed to the class-wide type's
14498
      --  specific type in this case to prevent cascading errors ???
14499
 
14500
      if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
14501
         Error_Msg_N ("parent type must not be a class-wide type", Indic);
14502
         return;
14503
      end if;
14504
 
14505
      if Present (Extension) and then not Taggd then
14506
         Error_Msg_N
14507
           ("type derived from untagged type cannot have extension", Indic);
14508
 
14509
      elsif No (Extension) and then Taggd then
14510
 
14511
         --  If this declaration is within a private part (or body) of a
14512
         --  generic instantiation then the derivation is allowed (the parent
14513
         --  type can only appear tagged in this case if it's a generic actual
14514
         --  type, since it would otherwise have been rejected in the analysis
14515
         --  of the generic template).
14516
 
14517
         if not Is_Generic_Actual_Type (Parent_Type)
14518
           or else In_Visible_Part (Scope (Parent_Type))
14519
         then
14520
            if Is_Class_Wide_Type (Parent_Type) then
14521
               Error_Msg_N
14522
                 ("parent type must not be a class-wide type", Indic);
14523
 
14524
               --  Use specific type to prevent cascaded errors.
14525
 
14526
               Parent_Type := Etype (Parent_Type);
14527
 
14528
            else
14529
               Error_Msg_N
14530
                 ("type derived from tagged type must have extension", Indic);
14531
            end if;
14532
         end if;
14533
      end if;
14534
 
14535
      --  AI-443: Synchronized formal derived types require a private
14536
      --  extension. There is no point in checking the ancestor type or
14537
      --  the progenitors since the construct is wrong to begin with.
14538
 
14539
      if Ada_Version >= Ada_2005
14540
        and then Is_Generic_Type (T)
14541
        and then Present (Original_Node (N))
14542
      then
14543
         declare
14544
            Decl : constant Node_Id := Original_Node (N);
14545
 
14546
         begin
14547
            if Nkind (Decl) = N_Formal_Type_Declaration
14548
              and then Nkind (Formal_Type_Definition (Decl)) =
14549
                         N_Formal_Derived_Type_Definition
14550
              and then Synchronized_Present (Formal_Type_Definition (Decl))
14551
              and then No (Extension)
14552
 
14553
               --  Avoid emitting a duplicate error message
14554
 
14555
              and then not Error_Posted (Indic)
14556
            then
14557
               Error_Msg_N
14558
                 ("synchronized derived type must have extension", N);
14559
            end if;
14560
         end;
14561
      end if;
14562
 
14563
      if Null_Exclusion_Present (Def)
14564
        and then not Is_Access_Type (Parent_Type)
14565
      then
14566
         Error_Msg_N ("null exclusion can only apply to an access type", N);
14567
      end if;
14568
 
14569
      --  Avoid deriving parent primitives of underlying record views
14570
 
14571
      Build_Derived_Type (N, Parent_Type, T, Is_Completion,
14572
        Derive_Subps => not Is_Underlying_Record_View (T));
14573
 
14574
      --  AI-419: The parent type of an explicitly limited derived type must
14575
      --  be a limited type or a limited interface.
14576
 
14577
      if Limited_Present (Def) then
14578
         Set_Is_Limited_Record (T);
14579
 
14580
         if Is_Interface (T) then
14581
            Set_Is_Limited_Interface (T);
14582
         end if;
14583
 
14584
         if not Is_Limited_Type (Parent_Type)
14585
           and then
14586
             (not Is_Interface (Parent_Type)
14587
               or else not Is_Limited_Interface (Parent_Type))
14588
         then
14589
            --  AI05-0096: a derivation in the private part of an instance is
14590
            --  legal if the generic formal is untagged limited, and the actual
14591
            --  is non-limited.
14592
 
14593
            if Is_Generic_Actual_Type (Parent_Type)
14594
              and then In_Private_Part (Current_Scope)
14595
              and then
14596
                not Is_Tagged_Type
14597
                      (Generic_Parent_Type (Parent (Parent_Type)))
14598
            then
14599
               null;
14600
 
14601
            else
14602
               Error_Msg_NE
14603
                 ("parent type& of limited type must be limited",
14604
                  N, Parent_Type);
14605
            end if;
14606
         end if;
14607
      end if;
14608
 
14609
      --  In SPARK, there are no derived type definitions other than type
14610
      --  extensions of tagged record types.
14611
 
14612
      if No (Extension) then
14613
         Check_SPARK_Restriction ("derived type is not allowed", N);
14614
      end if;
14615
   end Derived_Type_Declaration;
14616
 
14617
   ------------------------
14618
   -- Diagnose_Interface --
14619
   ------------------------
14620
 
14621
   procedure Diagnose_Interface (N : Node_Id;  E : Entity_Id) is
14622
   begin
14623
      if not Is_Interface (E)
14624
        and then  E /= Any_Type
14625
      then
14626
         Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
14627
      end if;
14628
   end Diagnose_Interface;
14629
 
14630
   ----------------------------------
14631
   -- Enumeration_Type_Declaration --
14632
   ----------------------------------
14633
 
14634
   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
14635
      Ev     : Uint;
14636
      L      : Node_Id;
14637
      R_Node : Node_Id;
14638
      B_Node : Node_Id;
14639
 
14640
   begin
14641
      --  Create identifier node representing lower bound
14642
 
14643
      B_Node := New_Node (N_Identifier, Sloc (Def));
14644
      L := First (Literals (Def));
14645
      Set_Chars (B_Node, Chars (L));
14646
      Set_Entity (B_Node,  L);
14647
      Set_Etype (B_Node, T);
14648
      Set_Is_Static_Expression (B_Node, True);
14649
 
14650
      R_Node := New_Node (N_Range, Sloc (Def));
14651
      Set_Low_Bound  (R_Node, B_Node);
14652
 
14653
      Set_Ekind (T, E_Enumeration_Type);
14654
      Set_First_Literal (T, L);
14655
      Set_Etype (T, T);
14656
      Set_Is_Constrained (T);
14657
 
14658
      Ev := Uint_0;
14659
 
14660
      --  Loop through literals of enumeration type setting pos and rep values
14661
      --  except that if the Ekind is already set, then it means the literal
14662
      --  was already constructed (case of a derived type declaration and we
14663
      --  should not disturb the Pos and Rep values.
14664
 
14665
      while Present (L) loop
14666
         if Ekind (L) /= E_Enumeration_Literal then
14667
            Set_Ekind (L, E_Enumeration_Literal);
14668
            Set_Enumeration_Pos (L, Ev);
14669
            Set_Enumeration_Rep (L, Ev);
14670
            Set_Is_Known_Valid  (L, True);
14671
         end if;
14672
 
14673
         Set_Etype (L, T);
14674
         New_Overloaded_Entity (L);
14675
         Generate_Definition (L);
14676
         Set_Convention (L, Convention_Intrinsic);
14677
 
14678
         --  Case of character literal
14679
 
14680
         if Nkind (L) = N_Defining_Character_Literal then
14681
            Set_Is_Character_Type (T, True);
14682
 
14683
            --  Check violation of No_Wide_Characters
14684
 
14685
            if Restriction_Check_Required (No_Wide_Characters) then
14686
               Get_Name_String (Chars (L));
14687
 
14688
               if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then
14689
                  Check_Restriction (No_Wide_Characters, L);
14690
               end if;
14691
            end if;
14692
         end if;
14693
 
14694
         Ev := Ev + 1;
14695
         Next (L);
14696
      end loop;
14697
 
14698
      --  Now create a node representing upper bound
14699
 
14700
      B_Node := New_Node (N_Identifier, Sloc (Def));
14701
      Set_Chars (B_Node, Chars (Last (Literals (Def))));
14702
      Set_Entity (B_Node,  Last (Literals (Def)));
14703
      Set_Etype (B_Node, T);
14704
      Set_Is_Static_Expression (B_Node, True);
14705
 
14706
      Set_High_Bound (R_Node, B_Node);
14707
 
14708
      --  Initialize various fields of the type. Some of this information
14709
      --  may be overwritten later through rep.clauses.
14710
 
14711
      Set_Scalar_Range    (T, R_Node);
14712
      Set_RM_Size         (T, UI_From_Int (Minimum_Size (T)));
14713
      Set_Enum_Esize      (T);
14714
      Set_Enum_Pos_To_Rep (T, Empty);
14715
 
14716
      --  Set Discard_Names if configuration pragma set, or if there is
14717
      --  a parameterless pragma in the current declarative region
14718
 
14719
      if Global_Discard_Names
14720
        or else Discard_Names (Scope (T))
14721
      then
14722
         Set_Discard_Names (T);
14723
      end if;
14724
 
14725
      --  Process end label if there is one
14726
 
14727
      if Present (Def) then
14728
         Process_End_Label (Def, 'e', T);
14729
      end if;
14730
   end Enumeration_Type_Declaration;
14731
 
14732
   ---------------------------------
14733
   -- Expand_To_Stored_Constraint --
14734
   ---------------------------------
14735
 
14736
   function Expand_To_Stored_Constraint
14737
     (Typ        : Entity_Id;
14738
      Constraint : Elist_Id) return Elist_Id
14739
   is
14740
      Explicitly_Discriminated_Type : Entity_Id;
14741
      Expansion    : Elist_Id;
14742
      Discriminant : Entity_Id;
14743
 
14744
      function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
14745
      --  Find the nearest type that actually specifies discriminants
14746
 
14747
      ---------------------------------
14748
      -- Type_With_Explicit_Discrims --
14749
      ---------------------------------
14750
 
14751
      function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
14752
         Typ : constant E := Base_Type (Id);
14753
 
14754
      begin
14755
         if Ekind (Typ) in Incomplete_Or_Private_Kind then
14756
            if Present (Full_View (Typ)) then
14757
               return Type_With_Explicit_Discrims (Full_View (Typ));
14758
            end if;
14759
 
14760
         else
14761
            if Has_Discriminants (Typ) then
14762
               return Typ;
14763
            end if;
14764
         end if;
14765
 
14766
         if Etype (Typ) = Typ then
14767
            return Empty;
14768
         elsif Has_Discriminants (Typ) then
14769
            return Typ;
14770
         else
14771
            return Type_With_Explicit_Discrims (Etype (Typ));
14772
         end if;
14773
 
14774
      end Type_With_Explicit_Discrims;
14775
 
14776
   --  Start of processing for Expand_To_Stored_Constraint
14777
 
14778
   begin
14779
      if No (Constraint)
14780
        or else Is_Empty_Elmt_List (Constraint)
14781
      then
14782
         return No_Elist;
14783
      end if;
14784
 
14785
      Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
14786
 
14787
      if No (Explicitly_Discriminated_Type) then
14788
         return No_Elist;
14789
      end if;
14790
 
14791
      Expansion := New_Elmt_List;
14792
 
14793
      Discriminant :=
14794
         First_Stored_Discriminant (Explicitly_Discriminated_Type);
14795
      while Present (Discriminant) loop
14796
         Append_Elmt (
14797
           Get_Discriminant_Value (
14798
             Discriminant, Explicitly_Discriminated_Type, Constraint),
14799
           Expansion);
14800
         Next_Stored_Discriminant (Discriminant);
14801
      end loop;
14802
 
14803
      return Expansion;
14804
   end Expand_To_Stored_Constraint;
14805
 
14806
   ---------------------------
14807
   -- Find_Hidden_Interface --
14808
   ---------------------------
14809
 
14810
   function Find_Hidden_Interface
14811
     (Src  : Elist_Id;
14812
      Dest : Elist_Id) return Entity_Id
14813
   is
14814
      Iface      : Entity_Id;
14815
      Iface_Elmt : Elmt_Id;
14816
 
14817
   begin
14818
      if Present (Src) and then Present (Dest) then
14819
         Iface_Elmt := First_Elmt (Src);
14820
         while Present (Iface_Elmt) loop
14821
            Iface := Node (Iface_Elmt);
14822
 
14823
            if Is_Interface (Iface)
14824
              and then not Contain_Interface (Iface, Dest)
14825
            then
14826
               return Iface;
14827
            end if;
14828
 
14829
            Next_Elmt (Iface_Elmt);
14830
         end loop;
14831
      end if;
14832
 
14833
      return Empty;
14834
   end Find_Hidden_Interface;
14835
 
14836
   --------------------
14837
   -- Find_Type_Name --
14838
   --------------------
14839
 
14840
   function Find_Type_Name (N : Node_Id) return Entity_Id is
14841
      Id       : constant Entity_Id := Defining_Identifier (N);
14842
      Prev     : Entity_Id;
14843
      New_Id   : Entity_Id;
14844
      Prev_Par : Node_Id;
14845
 
14846
      procedure Tag_Mismatch;
14847
      --  Diagnose a tagged partial view whose full view is untagged.
14848
      --  We post the message on the full view, with a reference to
14849
      --  the previous partial view. The partial view can be private
14850
      --  or incomplete, and these are handled in a different manner,
14851
      --  so we determine the position of the error message from the
14852
      --  respective slocs of both.
14853
 
14854
      ------------------
14855
      -- Tag_Mismatch --
14856
      ------------------
14857
 
14858
      procedure Tag_Mismatch is
14859
      begin
14860
         if Sloc (Prev) < Sloc (Id) then
14861
            if Ada_Version >= Ada_2012
14862
              and then Nkind (N) = N_Private_Type_Declaration
14863
            then
14864
               Error_Msg_NE
14865
                 ("declaration of private } must be a tagged type ", Id, Prev);
14866
            else
14867
               Error_Msg_NE
14868
                 ("full declaration of } must be a tagged type ", Id, Prev);
14869
            end if;
14870
         else
14871
            if Ada_Version >= Ada_2012
14872
              and then Nkind (N) = N_Private_Type_Declaration
14873
            then
14874
               Error_Msg_NE
14875
                 ("declaration of private } must be a tagged type ", Prev, Id);
14876
            else
14877
               Error_Msg_NE
14878
                 ("full declaration of } must be a tagged type ", Prev, Id);
14879
            end if;
14880
         end if;
14881
      end Tag_Mismatch;
14882
 
14883
   --  Start of processing for Find_Type_Name
14884
 
14885
   begin
14886
      --  Find incomplete declaration, if one was given
14887
 
14888
      Prev := Current_Entity_In_Scope (Id);
14889
 
14890
      --  New type declaration
14891
 
14892
      if No (Prev) then
14893
         Enter_Name (Id);
14894
         return Id;
14895
 
14896
      --  Previous declaration exists
14897
 
14898
      else
14899
         Prev_Par := Parent (Prev);
14900
 
14901
         --  Error if not incomplete/private case except if previous
14902
         --  declaration is implicit, etc. Enter_Name will emit error if
14903
         --  appropriate.
14904
 
14905
         if not Is_Incomplete_Or_Private_Type (Prev) then
14906
            Enter_Name (Id);
14907
            New_Id := Id;
14908
 
14909
         --  Check invalid completion of private or incomplete type
14910
 
14911
         elsif not Nkind_In (N, N_Full_Type_Declaration,
14912
                                N_Task_Type_Declaration,
14913
                                N_Protected_Type_Declaration)
14914
           and then
14915
             (Ada_Version < Ada_2012
14916
                or else not Is_Incomplete_Type (Prev)
14917
                or else not Nkind_In (N, N_Private_Type_Declaration,
14918
                                         N_Private_Extension_Declaration))
14919
         then
14920
            --  Completion must be a full type declarations (RM 7.3(4))
14921
 
14922
            Error_Msg_Sloc := Sloc (Prev);
14923
            Error_Msg_NE ("invalid completion of }", Id, Prev);
14924
 
14925
            --  Set scope of Id to avoid cascaded errors. Entity is never
14926
            --  examined again, except when saving globals in generics.
14927
 
14928
            Set_Scope (Id, Current_Scope);
14929
            New_Id := Id;
14930
 
14931
            --  If this is a repeated incomplete declaration, no further
14932
            --  checks are possible.
14933
 
14934
            if Nkind (N) = N_Incomplete_Type_Declaration then
14935
               return Prev;
14936
            end if;
14937
 
14938
         --  Case of full declaration of incomplete type
14939
 
14940
         elsif Ekind (Prev) = E_Incomplete_Type
14941
           and then (Ada_Version < Ada_2012
14942
                      or else No (Full_View (Prev))
14943
                      or else not Is_Private_Type (Full_View (Prev)))
14944
         then
14945
 
14946
            --  Indicate that the incomplete declaration has a matching full
14947
            --  declaration. The defining occurrence of the incomplete
14948
            --  declaration remains the visible one, and the procedure
14949
            --  Get_Full_View dereferences it whenever the type is used.
14950
 
14951
            if Present (Full_View (Prev)) then
14952
               Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
14953
            end if;
14954
 
14955
            Set_Full_View (Prev, Id);
14956
            Append_Entity (Id, Current_Scope);
14957
            Set_Is_Public (Id, Is_Public (Prev));
14958
            Set_Is_Internal (Id);
14959
            New_Id := Prev;
14960
 
14961
            --  If the incomplete view is tagged, a class_wide type has been
14962
            --  created already. Use it for the private type as well, in order
14963
            --  to prevent multiple incompatible class-wide types that may be
14964
            --  created for self-referential anonymous access components.
14965
 
14966
            if Is_Tagged_Type (Prev)
14967
              and then Present (Class_Wide_Type (Prev))
14968
            then
14969
               Set_Ekind (Id, Ekind (Prev));         --  will be reset later
14970
               Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
14971
 
14972
               --  If the incomplete type is completed by a private declaration
14973
               --  the class-wide type remains associated with the incomplete
14974
               --  type, to prevent order-of-elaboration issues in gigi, else
14975
               --  we associate the class-wide type with the known full view.
14976
 
14977
               if Nkind (N) /= N_Private_Type_Declaration then
14978
                  Set_Etype (Class_Wide_Type (Id), Id);
14979
               end if;
14980
            end if;
14981
 
14982
         --  Case of full declaration of private type
14983
 
14984
         else
14985
            --  If the private type was a completion of an incomplete type then
14986
            --  update Prev to reference the private type
14987
 
14988
            if Ada_Version >= Ada_2012
14989
              and then Ekind (Prev) = E_Incomplete_Type
14990
              and then Present (Full_View (Prev))
14991
              and then Is_Private_Type (Full_View (Prev))
14992
            then
14993
               Prev := Full_View (Prev);
14994
               Prev_Par := Parent (Prev);
14995
            end if;
14996
 
14997
            if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
14998
               if Etype (Prev) /= Prev then
14999
 
15000
                  --  Prev is a private subtype or a derived type, and needs
15001
                  --  no completion.
15002
 
15003
                  Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
15004
                  New_Id := Id;
15005
 
15006
               elsif Ekind (Prev) = E_Private_Type
15007
                 and then Nkind_In (N, N_Task_Type_Declaration,
15008
                                       N_Protected_Type_Declaration)
15009
               then
15010
                  Error_Msg_N
15011
                   ("completion of nonlimited type cannot be limited", N);
15012
 
15013
               elsif Ekind (Prev) = E_Record_Type_With_Private
15014
                 and then Nkind_In (N, N_Task_Type_Declaration,
15015
                                       N_Protected_Type_Declaration)
15016
               then
15017
                  if not Is_Limited_Record (Prev) then
15018
                     Error_Msg_N
15019
                        ("completion of nonlimited type cannot be limited", N);
15020
 
15021
                  elsif No (Interface_List (N)) then
15022
                     Error_Msg_N
15023
                        ("completion of tagged private type must be tagged",
15024
                         N);
15025
                  end if;
15026
 
15027
               elsif Nkind (N) = N_Full_Type_Declaration
15028
                 and then
15029
                   Nkind (Type_Definition (N)) = N_Record_Definition
15030
                 and then Interface_Present (Type_Definition (N))
15031
               then
15032
                  Error_Msg_N
15033
                    ("completion of private type cannot be an interface", N);
15034
               end if;
15035
 
15036
            --  Ada 2005 (AI-251): Private extension declaration of a task
15037
            --  type or a protected type. This case arises when covering
15038
            --  interface types.
15039
 
15040
            elsif Nkind_In (N, N_Task_Type_Declaration,
15041
                               N_Protected_Type_Declaration)
15042
            then
15043
               null;
15044
 
15045
            elsif Nkind (N) /= N_Full_Type_Declaration
15046
              or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
15047
            then
15048
               Error_Msg_N
15049
                 ("full view of private extension must be an extension", N);
15050
 
15051
            elsif not (Abstract_Present (Parent (Prev)))
15052
              and then Abstract_Present (Type_Definition (N))
15053
            then
15054
               Error_Msg_N
15055
                 ("full view of non-abstract extension cannot be abstract", N);
15056
            end if;
15057
 
15058
            if not In_Private_Part (Current_Scope) then
15059
               Error_Msg_N
15060
                 ("declaration of full view must appear in private part", N);
15061
            end if;
15062
 
15063
            Copy_And_Swap (Prev, Id);
15064
            Set_Has_Private_Declaration (Prev);
15065
            Set_Has_Private_Declaration (Id);
15066
 
15067
            --  Preserve aspect and iterator flags that may have been set on
15068
            --  the partial view.
15069
 
15070
            Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
15071
            Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
15072
 
15073
            --  If no error, propagate freeze_node from private to full view.
15074
            --  It may have been generated for an early operational item.
15075
 
15076
            if Present (Freeze_Node (Id))
15077
              and then Serious_Errors_Detected = 0
15078
              and then No (Full_View (Id))
15079
            then
15080
               Set_Freeze_Node (Prev, Freeze_Node (Id));
15081
               Set_Freeze_Node (Id, Empty);
15082
               Set_First_Rep_Item (Prev, First_Rep_Item (Id));
15083
            end if;
15084
 
15085
            Set_Full_View (Id, Prev);
15086
            New_Id := Prev;
15087
         end if;
15088
 
15089
         --  Verify that full declaration conforms to partial one
15090
 
15091
         if Is_Incomplete_Or_Private_Type (Prev)
15092
           and then Present (Discriminant_Specifications (Prev_Par))
15093
         then
15094
            if Present (Discriminant_Specifications (N)) then
15095
               if Ekind (Prev) = E_Incomplete_Type then
15096
                  Check_Discriminant_Conformance (N, Prev, Prev);
15097
               else
15098
                  Check_Discriminant_Conformance (N, Prev, Id);
15099
               end if;
15100
 
15101
            else
15102
               Error_Msg_N
15103
                 ("missing discriminants in full type declaration", N);
15104
 
15105
               --  To avoid cascaded errors on subsequent use, share the
15106
               --  discriminants of the partial view.
15107
 
15108
               Set_Discriminant_Specifications (N,
15109
                 Discriminant_Specifications (Prev_Par));
15110
            end if;
15111
         end if;
15112
 
15113
         --  A prior untagged partial view can have an associated class-wide
15114
         --  type due to use of the class attribute, and in this case the full
15115
         --  type must also be tagged. This Ada 95 usage is deprecated in favor
15116
         --  of incomplete tagged declarations, but we check for it.
15117
 
15118
         if Is_Type (Prev)
15119
           and then (Is_Tagged_Type (Prev)
15120
                       or else Present (Class_Wide_Type (Prev)))
15121
         then
15122
            --  Ada 2012 (AI05-0162): A private type may be the completion of
15123
            --  an incomplete type
15124
 
15125
            if Ada_Version >= Ada_2012
15126
              and then Is_Incomplete_Type (Prev)
15127
              and then Nkind_In (N, N_Private_Type_Declaration,
15128
                                    N_Private_Extension_Declaration)
15129
            then
15130
               --  No need to check private extensions since they are tagged
15131
 
15132
               if Nkind (N) = N_Private_Type_Declaration
15133
                 and then not Tagged_Present (N)
15134
               then
15135
                  Tag_Mismatch;
15136
               end if;
15137
 
15138
            --  The full declaration is either a tagged type (including
15139
            --  a synchronized type that implements interfaces) or a
15140
            --  type extension, otherwise this is an error.
15141
 
15142
            elsif Nkind_In (N, N_Task_Type_Declaration,
15143
                               N_Protected_Type_Declaration)
15144
            then
15145
               if No (Interface_List (N))
15146
                 and then not Error_Posted (N)
15147
               then
15148
                  Tag_Mismatch;
15149
               end if;
15150
 
15151
            elsif Nkind (Type_Definition (N)) = N_Record_Definition then
15152
 
15153
               --  Indicate that the previous declaration (tagged incomplete
15154
               --  or private declaration) requires the same on the full one.
15155
 
15156
               if not Tagged_Present (Type_Definition (N)) then
15157
                  Tag_Mismatch;
15158
                  Set_Is_Tagged_Type (Id);
15159
               end if;
15160
 
15161
            elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
15162
               if No (Record_Extension_Part (Type_Definition (N))) then
15163
                  Error_Msg_NE
15164
                    ("full declaration of } must be a record extension",
15165
                     Prev, Id);
15166
 
15167
                  --  Set some attributes to produce a usable full view
15168
 
15169
                  Set_Is_Tagged_Type (Id);
15170
               end if;
15171
 
15172
            else
15173
               Tag_Mismatch;
15174
            end if;
15175
         end if;
15176
 
15177
         if Present (Prev)
15178
           and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration
15179
           and then Present (Premature_Use (Parent (Prev)))
15180
         then
15181
            Error_Msg_Sloc := Sloc (N);
15182
            Error_Msg_N
15183
              ("\full declaration #", Premature_Use (Parent (Prev)));
15184
         end if;
15185
 
15186
         return New_Id;
15187
      end if;
15188
   end Find_Type_Name;
15189
 
15190
   -------------------------
15191
   -- Find_Type_Of_Object --
15192
   -------------------------
15193
 
15194
   function Find_Type_Of_Object
15195
     (Obj_Def     : Node_Id;
15196
      Related_Nod : Node_Id) return Entity_Id
15197
   is
15198
      Def_Kind : constant Node_Kind := Nkind (Obj_Def);
15199
      P        : Node_Id := Parent (Obj_Def);
15200
      T        : Entity_Id;
15201
      Nam      : Name_Id;
15202
 
15203
   begin
15204
      --  If the parent is a component_definition node we climb to the
15205
      --  component_declaration node
15206
 
15207
      if Nkind (P) = N_Component_Definition then
15208
         P := Parent (P);
15209
      end if;
15210
 
15211
      --  Case of an anonymous array subtype
15212
 
15213
      if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
15214
                             N_Unconstrained_Array_Definition)
15215
      then
15216
         T := Empty;
15217
         Array_Type_Declaration (T, Obj_Def);
15218
 
15219
      --  Create an explicit subtype whenever possible
15220
 
15221
      elsif Nkind (P) /= N_Component_Declaration
15222
        and then Def_Kind = N_Subtype_Indication
15223
      then
15224
         --  Base name of subtype on object name, which will be unique in
15225
         --  the current scope.
15226
 
15227
         --  If this is a duplicate declaration, return base type, to avoid
15228
         --  generating duplicate anonymous types.
15229
 
15230
         if Error_Posted (P) then
15231
            Analyze (Subtype_Mark (Obj_Def));
15232
            return Entity (Subtype_Mark (Obj_Def));
15233
         end if;
15234
 
15235
         Nam :=
15236
            New_External_Name
15237
             (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
15238
 
15239
         T := Make_Defining_Identifier (Sloc (P), Nam);
15240
 
15241
         Insert_Action (Obj_Def,
15242
           Make_Subtype_Declaration (Sloc (P),
15243
             Defining_Identifier => T,
15244
             Subtype_Indication  => Relocate_Node (Obj_Def)));
15245
 
15246
         --  This subtype may need freezing, and this will not be done
15247
         --  automatically if the object declaration is not in declarative
15248
         --  part. Since this is an object declaration, the type cannot always
15249
         --  be frozen here. Deferred constants do not freeze their type
15250
         --  (which often enough will be private).
15251
 
15252
         if Nkind (P) = N_Object_Declaration
15253
           and then Constant_Present (P)
15254
           and then No (Expression (P))
15255
         then
15256
            null;
15257
         else
15258
            Insert_Actions (Obj_Def, Freeze_Entity (T, P));
15259
         end if;
15260
 
15261
      --  Ada 2005 AI-406: the object definition in an object declaration
15262
      --  can be an access definition.
15263
 
15264
      elsif Def_Kind = N_Access_Definition then
15265
         T := Access_Definition (Related_Nod, Obj_Def);
15266
 
15267
         Set_Is_Local_Anonymous_Access
15268
           (T,
15269
            V => (Ada_Version < Ada_2012)
15270
                   or else (Nkind (P) /= N_Object_Declaration)
15271
                   or else Is_Library_Level_Entity (Defining_Identifier (P)));
15272
 
15273
      --  Otherwise, the object definition is just a subtype_mark
15274
 
15275
      else
15276
         T := Process_Subtype (Obj_Def, Related_Nod);
15277
 
15278
         --  If expansion is disabled an object definition that is an aggregate
15279
         --  will not get expanded and may lead to scoping problems in the back
15280
         --  end, if the object is referenced in an inner scope. In that case
15281
         --  create an itype reference for the object definition now. This
15282
         --  may be redundant in some cases, but harmless.
15283
 
15284
         if Is_Itype (T)
15285
           and then Nkind (Related_Nod) = N_Object_Declaration
15286
           and then ASIS_Mode
15287
         then
15288
            Build_Itype_Reference (T, Related_Nod);
15289
         end if;
15290
      end if;
15291
 
15292
      return T;
15293
   end Find_Type_Of_Object;
15294
 
15295
   --------------------------------
15296
   -- Find_Type_Of_Subtype_Indic --
15297
   --------------------------------
15298
 
15299
   function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
15300
      Typ : Entity_Id;
15301
 
15302
   begin
15303
      --  Case of subtype mark with a constraint
15304
 
15305
      if Nkind (S) = N_Subtype_Indication then
15306
         Find_Type (Subtype_Mark (S));
15307
         Typ := Entity (Subtype_Mark (S));
15308
 
15309
         if not
15310
           Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
15311
         then
15312
            Error_Msg_N
15313
              ("incorrect constraint for this kind of type", Constraint (S));
15314
            Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
15315
         end if;
15316
 
15317
      --  Otherwise we have a subtype mark without a constraint
15318
 
15319
      elsif Error_Posted (S) then
15320
         Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
15321
         return Any_Type;
15322
 
15323
      else
15324
         Find_Type (S);
15325
         Typ := Entity (S);
15326
      end if;
15327
 
15328
      --  Check No_Wide_Characters restriction
15329
 
15330
      Check_Wide_Character_Restriction (Typ, S);
15331
 
15332
      return Typ;
15333
   end Find_Type_Of_Subtype_Indic;
15334
 
15335
   -------------------------------------
15336
   -- Floating_Point_Type_Declaration --
15337
   -------------------------------------
15338
 
15339
   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
15340
      Digs          : constant Node_Id := Digits_Expression (Def);
15341
      Max_Digs_Val  : constant Uint := Digits_Value (Standard_Long_Long_Float);
15342
      Digs_Val      : Uint;
15343
      Base_Typ      : Entity_Id;
15344
      Implicit_Base : Entity_Id;
15345
      Bound         : Node_Id;
15346
 
15347
      function Can_Derive_From (E : Entity_Id) return Boolean;
15348
      --  Find if given digits value, and possibly a specified range, allows
15349
      --  derivation from specified type
15350
 
15351
      function Find_Base_Type return Entity_Id;
15352
      --  Find a predefined base type that Def can derive from, or generate
15353
      --  an error and substitute Long_Long_Float if none exists.
15354
 
15355
      ---------------------
15356
      -- Can_Derive_From --
15357
      ---------------------
15358
 
15359
      function Can_Derive_From (E : Entity_Id) return Boolean is
15360
         Spec : constant Entity_Id := Real_Range_Specification (Def);
15361
 
15362
      begin
15363
         --  Check specified "digits" constraint
15364
 
15365
         if Digs_Val > Digits_Value (E) then
15366
            return False;
15367
         end if;
15368
 
15369
         --  Avoid types not matching pragma Float_Representation, if present
15370
 
15371
         if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary)
15372
              or else
15373
            (Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native)
15374
         then
15375
            return False;
15376
         end if;
15377
 
15378
         --  Check for matching range, if specified
15379
 
15380
         if Present (Spec) then
15381
            if Expr_Value_R (Type_Low_Bound (E)) >
15382
               Expr_Value_R (Low_Bound (Spec))
15383
            then
15384
               return False;
15385
            end if;
15386
 
15387
            if Expr_Value_R (Type_High_Bound (E)) <
15388
               Expr_Value_R (High_Bound (Spec))
15389
            then
15390
               return False;
15391
            end if;
15392
         end if;
15393
 
15394
         return True;
15395
      end Can_Derive_From;
15396
 
15397
      --------------------
15398
      -- Find_Base_Type --
15399
      --------------------
15400
 
15401
      function Find_Base_Type return Entity_Id is
15402
         Choice : Elmt_Id := First_Elmt (Predefined_Float_Types);
15403
 
15404
      begin
15405
         --  Iterate over the predefined types in order, returning the first
15406
         --  one that Def can derive from.
15407
 
15408
         while Present (Choice) loop
15409
            if Can_Derive_From (Node (Choice)) then
15410
               return Node (Choice);
15411
            end if;
15412
 
15413
            Next_Elmt (Choice);
15414
         end loop;
15415
 
15416
         --  If we can't derive from any existing type, use Long_Long_Float
15417
         --  and give appropriate message explaining the problem.
15418
 
15419
         if Digs_Val > Max_Digs_Val then
15420
            --  It might be the case that there is a type with the requested
15421
            --  range, just not the combination of digits and range.
15422
 
15423
            Error_Msg_N
15424
              ("no predefined type has requested range and precision",
15425
               Real_Range_Specification (Def));
15426
 
15427
         else
15428
            Error_Msg_N
15429
              ("range too large for any predefined type",
15430
               Real_Range_Specification (Def));
15431
         end if;
15432
 
15433
         return Standard_Long_Long_Float;
15434
      end Find_Base_Type;
15435
 
15436
   --  Start of processing for Floating_Point_Type_Declaration
15437
 
15438
   begin
15439
      Check_Restriction (No_Floating_Point, Def);
15440
 
15441
      --  Create an implicit base type
15442
 
15443
      Implicit_Base :=
15444
        Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
15445
 
15446
      --  Analyze and verify digits value
15447
 
15448
      Analyze_And_Resolve (Digs, Any_Integer);
15449
      Check_Digits_Expression (Digs);
15450
      Digs_Val := Expr_Value (Digs);
15451
 
15452
      --  Process possible range spec and find correct type to derive from
15453
 
15454
      Process_Real_Range_Specification (Def);
15455
 
15456
      --  Check that requested number of digits is not too high.
15457
 
15458
      if Digs_Val > Max_Digs_Val then
15459
         --  The check for Max_Base_Digits may be somewhat expensive, as it
15460
         --  requires reading System, so only do it when necessary.
15461
 
15462
         declare
15463
            Max_Base_Digits : constant Uint :=
15464
                                Expr_Value
15465
                                  (Expression
15466
                                     (Parent (RTE (RE_Max_Base_Digits))));
15467
 
15468
         begin
15469
            if Digs_Val > Max_Base_Digits then
15470
               Error_Msg_Uint_1 := Max_Base_Digits;
15471
               Error_Msg_N ("digits value out of range, maximum is ^", Digs);
15472
 
15473
            elsif No (Real_Range_Specification (Def)) then
15474
               Error_Msg_Uint_1 := Max_Digs_Val;
15475
               Error_Msg_N ("types with more than ^ digits need range spec "
15476
                 & "(RM 3.5.7(6))", Digs);
15477
            end if;
15478
         end;
15479
      end if;
15480
 
15481
      --  Find a suitable type to derive from or complain and use a substitute
15482
 
15483
      Base_Typ := Find_Base_Type;
15484
 
15485
      --  If there are bounds given in the declaration use them as the bounds
15486
      --  of the type, otherwise use the bounds of the predefined base type
15487
      --  that was chosen based on the Digits value.
15488
 
15489
      if Present (Real_Range_Specification (Def)) then
15490
         Set_Scalar_Range (T, Real_Range_Specification (Def));
15491
         Set_Is_Constrained (T);
15492
 
15493
         --  The bounds of this range must be converted to machine numbers
15494
         --  in accordance with RM 4.9(38).
15495
 
15496
         Bound := Type_Low_Bound (T);
15497
 
15498
         if Nkind (Bound) = N_Real_Literal then
15499
            Set_Realval
15500
              (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
15501
            Set_Is_Machine_Number (Bound);
15502
         end if;
15503
 
15504
         Bound := Type_High_Bound (T);
15505
 
15506
         if Nkind (Bound) = N_Real_Literal then
15507
            Set_Realval
15508
              (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
15509
            Set_Is_Machine_Number (Bound);
15510
         end if;
15511
 
15512
      else
15513
         Set_Scalar_Range (T, Scalar_Range (Base_Typ));
15514
      end if;
15515
 
15516
      --  Complete definition of implicit base and declared first subtype
15517
 
15518
      Set_Etype          (Implicit_Base, Base_Typ);
15519
 
15520
      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
15521
      Set_Size_Info      (Implicit_Base,                (Base_Typ));
15522
      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
15523
      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
15524
      Set_Digits_Value   (Implicit_Base, Digits_Value   (Base_Typ));
15525
      Set_Float_Rep      (Implicit_Base, Float_Rep      (Base_Typ));
15526
 
15527
      Set_Ekind          (T, E_Floating_Point_Subtype);
15528
      Set_Etype          (T, Implicit_Base);
15529
 
15530
      Set_Size_Info      (T,                (Implicit_Base));
15531
      Set_RM_Size        (T, RM_Size        (Implicit_Base));
15532
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
15533
      Set_Digits_Value   (T, Digs_Val);
15534
   end Floating_Point_Type_Declaration;
15535
 
15536
   ----------------------------
15537
   -- Get_Discriminant_Value --
15538
   ----------------------------
15539
 
15540
   --  This is the situation:
15541
 
15542
   --  There is a non-derived type
15543
 
15544
   --       type T0 (Dx, Dy, Dz...)
15545
 
15546
   --  There are zero or more levels of derivation, with each derivation
15547
   --  either purely inheriting the discriminants, or defining its own.
15548
 
15549
   --       type Ti      is new Ti-1
15550
   --  or
15551
   --       type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
15552
   --  or
15553
   --       subtype Ti is ...
15554
 
15555
   --  The subtype issue is avoided by the use of Original_Record_Component,
15556
   --  and the fact that derived subtypes also derive the constraints.
15557
 
15558
   --  This chain leads back from
15559
 
15560
   --       Typ_For_Constraint
15561
 
15562
   --  Typ_For_Constraint has discriminants, and the value for each
15563
   --  discriminant is given by its corresponding Elmt of Constraints.
15564
 
15565
   --  Discriminant is some discriminant in this hierarchy
15566
 
15567
   --  We need to return its value
15568
 
15569
   --  We do this by recursively searching each level, and looking for
15570
   --  Discriminant. Once we get to the bottom, we start backing up
15571
   --  returning the value for it which may in turn be a discriminant
15572
   --  further up, so on the backup we continue the substitution.
15573
 
15574
   function Get_Discriminant_Value
15575
     (Discriminant       : Entity_Id;
15576
      Typ_For_Constraint : Entity_Id;
15577
      Constraint         : Elist_Id) return Node_Id
15578
   is
15579
      function Search_Derivation_Levels
15580
        (Ti                    : Entity_Id;
15581
         Discrim_Values        : Elist_Id;
15582
         Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
15583
      --  This is the routine that performs the recursive search of levels
15584
      --  as described above.
15585
 
15586
      ------------------------------
15587
      -- Search_Derivation_Levels --
15588
      ------------------------------
15589
 
15590
      function Search_Derivation_Levels
15591
        (Ti                    : Entity_Id;
15592
         Discrim_Values        : Elist_Id;
15593
         Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
15594
      is
15595
         Assoc          : Elmt_Id;
15596
         Disc           : Entity_Id;
15597
         Result         : Node_Or_Entity_Id;
15598
         Result_Entity  : Node_Id;
15599
 
15600
      begin
15601
         --  If inappropriate type, return Error, this happens only in
15602
         --  cascaded error situations, and we want to avoid a blow up.
15603
 
15604
         if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
15605
            return Error;
15606
         end if;
15607
 
15608
         --  Look deeper if possible. Use Stored_Constraints only for
15609
         --  untagged types. For tagged types use the given constraint.
15610
         --  This asymmetry needs explanation???
15611
 
15612
         if not Stored_Discrim_Values
15613
           and then Present (Stored_Constraint (Ti))
15614
           and then not Is_Tagged_Type (Ti)
15615
         then
15616
            Result :=
15617
              Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
15618
         else
15619
            declare
15620
               Td : constant Entity_Id := Etype (Ti);
15621
 
15622
            begin
15623
               if Td = Ti then
15624
                  Result := Discriminant;
15625
 
15626
               else
15627
                  if Present (Stored_Constraint (Ti)) then
15628
                     Result :=
15629
                        Search_Derivation_Levels
15630
                          (Td, Stored_Constraint (Ti), True);
15631
                  else
15632
                     Result :=
15633
                        Search_Derivation_Levels
15634
                          (Td, Discrim_Values, Stored_Discrim_Values);
15635
                  end if;
15636
               end if;
15637
            end;
15638
         end if;
15639
 
15640
         --  Extra underlying places to search, if not found above. For
15641
         --  concurrent types, the relevant discriminant appears in the
15642
         --  corresponding record. For a type derived from a private type
15643
         --  without discriminant, the full view inherits the discriminants
15644
         --  of the full view of the parent.
15645
 
15646
         if Result = Discriminant then
15647
            if Is_Concurrent_Type (Ti)
15648
              and then Present (Corresponding_Record_Type (Ti))
15649
            then
15650
               Result :=
15651
                 Search_Derivation_Levels (
15652
                   Corresponding_Record_Type (Ti),
15653
                   Discrim_Values,
15654
                   Stored_Discrim_Values);
15655
 
15656
            elsif Is_Private_Type (Ti)
15657
              and then not Has_Discriminants (Ti)
15658
              and then Present (Full_View (Ti))
15659
              and then Etype (Full_View (Ti)) /= Ti
15660
            then
15661
               Result :=
15662
                 Search_Derivation_Levels (
15663
                   Full_View (Ti),
15664
                   Discrim_Values,
15665
                   Stored_Discrim_Values);
15666
            end if;
15667
         end if;
15668
 
15669
         --  If Result is not a (reference to a) discriminant, return it,
15670
         --  otherwise set Result_Entity to the discriminant.
15671
 
15672
         if Nkind (Result) = N_Defining_Identifier then
15673
            pragma Assert (Result = Discriminant);
15674
            Result_Entity := Result;
15675
 
15676
         else
15677
            if not Denotes_Discriminant (Result) then
15678
               return Result;
15679
            end if;
15680
 
15681
            Result_Entity := Entity (Result);
15682
         end if;
15683
 
15684
         --  See if this level of derivation actually has discriminants
15685
         --  because tagged derivations can add them, hence the lower
15686
         --  levels need not have any.
15687
 
15688
         if not Has_Discriminants (Ti) then
15689
            return Result;
15690
         end if;
15691
 
15692
         --  Scan Ti's discriminants for Result_Entity,
15693
         --  and return its corresponding value, if any.
15694
 
15695
         Result_Entity := Original_Record_Component (Result_Entity);
15696
 
15697
         Assoc := First_Elmt (Discrim_Values);
15698
 
15699
         if Stored_Discrim_Values then
15700
            Disc := First_Stored_Discriminant (Ti);
15701
         else
15702
            Disc := First_Discriminant (Ti);
15703
         end if;
15704
 
15705
         while Present (Disc) loop
15706
            pragma Assert (Present (Assoc));
15707
 
15708
            if Original_Record_Component (Disc) = Result_Entity then
15709
               return Node (Assoc);
15710
            end if;
15711
 
15712
            Next_Elmt (Assoc);
15713
 
15714
            if Stored_Discrim_Values then
15715
               Next_Stored_Discriminant (Disc);
15716
            else
15717
               Next_Discriminant (Disc);
15718
            end if;
15719
         end loop;
15720
 
15721
         --  Could not find it
15722
         --
15723
         return Result;
15724
      end Search_Derivation_Levels;
15725
 
15726
      --  Local Variables
15727
 
15728
      Result : Node_Or_Entity_Id;
15729
 
15730
   --  Start of processing for Get_Discriminant_Value
15731
 
15732
   begin
15733
      --  ??? This routine is a gigantic mess and will be deleted. For the
15734
      --  time being just test for the trivial case before calling recurse.
15735
 
15736
      if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
15737
         declare
15738
            D : Entity_Id;
15739
            E : Elmt_Id;
15740
 
15741
         begin
15742
            D := First_Discriminant (Typ_For_Constraint);
15743
            E := First_Elmt (Constraint);
15744
            while Present (D) loop
15745
               if Chars (D) = Chars (Discriminant) then
15746
                  return Node (E);
15747
               end if;
15748
 
15749
               Next_Discriminant (D);
15750
               Next_Elmt (E);
15751
            end loop;
15752
         end;
15753
      end if;
15754
 
15755
      Result := Search_Derivation_Levels
15756
        (Typ_For_Constraint, Constraint, False);
15757
 
15758
      --  ??? hack to disappear when this routine is gone
15759
 
15760
      if  Nkind (Result) = N_Defining_Identifier then
15761
         declare
15762
            D : Entity_Id;
15763
            E : Elmt_Id;
15764
 
15765
         begin
15766
            D := First_Discriminant (Typ_For_Constraint);
15767
            E := First_Elmt (Constraint);
15768
            while Present (D) loop
15769
               if Corresponding_Discriminant (D) = Discriminant then
15770
                  return Node (E);
15771
               end if;
15772
 
15773
               Next_Discriminant (D);
15774
               Next_Elmt (E);
15775
            end loop;
15776
         end;
15777
      end if;
15778
 
15779
      pragma Assert (Nkind (Result) /= N_Defining_Identifier);
15780
      return Result;
15781
   end Get_Discriminant_Value;
15782
 
15783
   --------------------------
15784
   -- Has_Range_Constraint --
15785
   --------------------------
15786
 
15787
   function Has_Range_Constraint (N : Node_Id) return Boolean is
15788
      C : constant Node_Id := Constraint (N);
15789
 
15790
   begin
15791
      if Nkind (C) = N_Range_Constraint then
15792
         return True;
15793
 
15794
      elsif Nkind (C) = N_Digits_Constraint then
15795
         return
15796
            Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
15797
              or else
15798
            Present (Range_Constraint (C));
15799
 
15800
      elsif Nkind (C) = N_Delta_Constraint then
15801
         return Present (Range_Constraint (C));
15802
 
15803
      else
15804
         return False;
15805
      end if;
15806
   end Has_Range_Constraint;
15807
 
15808
   ------------------------
15809
   -- Inherit_Components --
15810
   ------------------------
15811
 
15812
   function Inherit_Components
15813
     (N             : Node_Id;
15814
      Parent_Base   : Entity_Id;
15815
      Derived_Base  : Entity_Id;
15816
      Is_Tagged     : Boolean;
15817
      Inherit_Discr : Boolean;
15818
      Discs         : Elist_Id) return Elist_Id
15819
   is
15820
      Assoc_List : constant Elist_Id := New_Elmt_List;
15821
 
15822
      procedure Inherit_Component
15823
        (Old_C          : Entity_Id;
15824
         Plain_Discrim  : Boolean := False;
15825
         Stored_Discrim : Boolean := False);
15826
      --  Inherits component Old_C from Parent_Base to the Derived_Base. If
15827
      --  Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
15828
      --  True, Old_C is a stored discriminant. If they are both false then
15829
      --  Old_C is a regular component.
15830
 
15831
      -----------------------
15832
      -- Inherit_Component --
15833
      -----------------------
15834
 
15835
      procedure Inherit_Component
15836
        (Old_C          : Entity_Id;
15837
         Plain_Discrim  : Boolean := False;
15838
         Stored_Discrim : Boolean := False)
15839
      is
15840
         procedure Set_Anonymous_Type (Id : Entity_Id);
15841
         --  Id denotes the entity of an access discriminant or anonymous
15842
         --  access component. Set the type of Id to either the same type of
15843
         --  Old_C or create a new one depending on whether the parent and
15844
         --  the child types are in the same scope.
15845
 
15846
         ------------------------
15847
         -- Set_Anonymous_Type --
15848
         ------------------------
15849
 
15850
         procedure Set_Anonymous_Type (Id : Entity_Id) is
15851
            Old_Typ : constant Entity_Id := Etype (Old_C);
15852
 
15853
         begin
15854
            if Scope (Parent_Base) = Scope (Derived_Base) then
15855
               Set_Etype (Id, Old_Typ);
15856
 
15857
            --  The parent and the derived type are in two different scopes.
15858
            --  Reuse the type of the original discriminant / component by
15859
            --  copying it in order to preserve all attributes.
15860
 
15861
            else
15862
               declare
15863
                  Typ : constant Entity_Id := New_Copy (Old_Typ);
15864
 
15865
               begin
15866
                  Set_Etype (Id, Typ);
15867
 
15868
                  --  Since we do not generate component declarations for
15869
                  --  inherited components, associate the itype with the
15870
                  --  derived type.
15871
 
15872
                  Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
15873
                  Set_Scope                     (Typ, Derived_Base);
15874
               end;
15875
            end if;
15876
         end Set_Anonymous_Type;
15877
 
15878
         --  Local variables and constants
15879
 
15880
         New_C : constant Entity_Id := New_Copy (Old_C);
15881
 
15882
         Corr_Discrim : Entity_Id;
15883
         Discrim      : Entity_Id;
15884
 
15885
      --  Start of processing for Inherit_Component
15886
 
15887
      begin
15888
         pragma Assert (not Is_Tagged or else not Stored_Discrim);
15889
 
15890
         Set_Parent (New_C, Parent (Old_C));
15891
 
15892
         --  Regular discriminants and components must be inserted in the scope
15893
         --  of the Derived_Base. Do it here.
15894
 
15895
         if not Stored_Discrim then
15896
            Enter_Name (New_C);
15897
         end if;
15898
 
15899
         --  For tagged types the Original_Record_Component must point to
15900
         --  whatever this field was pointing to in the parent type. This has
15901
         --  already been achieved by the call to New_Copy above.
15902
 
15903
         if not Is_Tagged then
15904
            Set_Original_Record_Component (New_C, New_C);
15905
         end if;
15906
 
15907
         --  Set the proper type of an access discriminant
15908
 
15909
         if Ekind (New_C) = E_Discriminant
15910
           and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
15911
         then
15912
            Set_Anonymous_Type (New_C);
15913
         end if;
15914
 
15915
         --  If we have inherited a component then see if its Etype contains
15916
         --  references to Parent_Base discriminants. In this case, replace
15917
         --  these references with the constraints given in Discs. We do not
15918
         --  do this for the partial view of private types because this is
15919
         --  not needed (only the components of the full view will be used
15920
         --  for code generation) and cause problem. We also avoid this
15921
         --  transformation in some error situations.
15922
 
15923
         if Ekind (New_C) = E_Component then
15924
 
15925
            --  Set the proper type of an anonymous access component
15926
 
15927
            if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
15928
               Set_Anonymous_Type (New_C);
15929
 
15930
            elsif (Is_Private_Type (Derived_Base)
15931
                    and then not Is_Generic_Type (Derived_Base))
15932
              or else (Is_Empty_Elmt_List (Discs)
15933
                         and then not Expander_Active)
15934
            then
15935
               Set_Etype (New_C, Etype (Old_C));
15936
 
15937
            else
15938
               --  The current component introduces a circularity of the
15939
               --  following kind:
15940
 
15941
               --     limited with Pack_2;
15942
               --     package Pack_1 is
15943
               --        type T_1 is tagged record
15944
               --           Comp : access Pack_2.T_2;
15945
               --           ...
15946
               --        end record;
15947
               --     end Pack_1;
15948
 
15949
               --     with Pack_1;
15950
               --     package Pack_2 is
15951
               --        type T_2 is new Pack_1.T_1 with ...;
15952
               --     end Pack_2;
15953
 
15954
               Set_Etype
15955
                 (New_C,
15956
                  Constrain_Component_Type
15957
                    (Old_C, Derived_Base, N, Parent_Base, Discs));
15958
            end if;
15959
         end if;
15960
 
15961
         --  In derived tagged types it is illegal to reference a non
15962
         --  discriminant component in the parent type. To catch this, mark
15963
         --  these components with an Ekind of E_Void. This will be reset in
15964
         --  Record_Type_Definition after processing the record extension of
15965
         --  the derived type.
15966
 
15967
         --  If the declaration is a private extension, there is no further
15968
         --  record extension to process, and the components retain their
15969
         --  current kind, because they are visible at this point.
15970
 
15971
         if Is_Tagged and then Ekind (New_C) = E_Component
15972
           and then Nkind (N) /= N_Private_Extension_Declaration
15973
         then
15974
            Set_Ekind (New_C, E_Void);
15975
         end if;
15976
 
15977
         if Plain_Discrim then
15978
            Set_Corresponding_Discriminant (New_C, Old_C);
15979
            Build_Discriminal (New_C);
15980
 
15981
         --  If we are explicitly inheriting a stored discriminant it will be
15982
         --  completely hidden.
15983
 
15984
         elsif Stored_Discrim then
15985
            Set_Corresponding_Discriminant (New_C, Empty);
15986
            Set_Discriminal (New_C, Empty);
15987
            Set_Is_Completely_Hidden (New_C);
15988
 
15989
            --  Set the Original_Record_Component of each discriminant in the
15990
            --  derived base to point to the corresponding stored that we just
15991
            --  created.
15992
 
15993
            Discrim := First_Discriminant (Derived_Base);
15994
            while Present (Discrim) loop
15995
               Corr_Discrim := Corresponding_Discriminant (Discrim);
15996
 
15997
               --  Corr_Discrim could be missing in an error situation
15998
 
15999
               if Present (Corr_Discrim)
16000
                 and then Original_Record_Component (Corr_Discrim) = Old_C
16001
               then
16002
                  Set_Original_Record_Component (Discrim, New_C);
16003
               end if;
16004
 
16005
               Next_Discriminant (Discrim);
16006
            end loop;
16007
 
16008
            Append_Entity (New_C, Derived_Base);
16009
         end if;
16010
 
16011
         if not Is_Tagged then
16012
            Append_Elmt (Old_C, Assoc_List);
16013
            Append_Elmt (New_C, Assoc_List);
16014
         end if;
16015
      end Inherit_Component;
16016
 
16017
      --  Variables local to Inherit_Component
16018
 
16019
      Loc : constant Source_Ptr := Sloc (N);
16020
 
16021
      Parent_Discrim : Entity_Id;
16022
      Stored_Discrim : Entity_Id;
16023
      D              : Entity_Id;
16024
      Component      : Entity_Id;
16025
 
16026
   --  Start of processing for Inherit_Components
16027
 
16028
   begin
16029
      if not Is_Tagged then
16030
         Append_Elmt (Parent_Base,  Assoc_List);
16031
         Append_Elmt (Derived_Base, Assoc_List);
16032
      end if;
16033
 
16034
      --  Inherit parent discriminants if needed
16035
 
16036
      if Inherit_Discr then
16037
         Parent_Discrim := First_Discriminant (Parent_Base);
16038
         while Present (Parent_Discrim) loop
16039
            Inherit_Component (Parent_Discrim, Plain_Discrim => True);
16040
            Next_Discriminant (Parent_Discrim);
16041
         end loop;
16042
      end if;
16043
 
16044
      --  Create explicit stored discrims for untagged types when necessary
16045
 
16046
      if not Has_Unknown_Discriminants (Derived_Base)
16047
        and then Has_Discriminants (Parent_Base)
16048
        and then not Is_Tagged
16049
        and then
16050
          (not Inherit_Discr
16051
             or else First_Discriminant (Parent_Base) /=
16052
                     First_Stored_Discriminant (Parent_Base))
16053
      then
16054
         Stored_Discrim := First_Stored_Discriminant (Parent_Base);
16055
         while Present (Stored_Discrim) loop
16056
            Inherit_Component (Stored_Discrim, Stored_Discrim => True);
16057
            Next_Stored_Discriminant (Stored_Discrim);
16058
         end loop;
16059
      end if;
16060
 
16061
      --  See if we can apply the second transformation for derived types, as
16062
      --  explained in point 6. in the comments above Build_Derived_Record_Type
16063
      --  This is achieved by appending Derived_Base discriminants into Discs,
16064
      --  which has the side effect of returning a non empty Discs list to the
16065
      --  caller of Inherit_Components, which is what we want. This must be
16066
      --  done for private derived types if there are explicit stored
16067
      --  discriminants, to ensure that we can retrieve the values of the
16068
      --  constraints provided in the ancestors.
16069
 
16070
      if Inherit_Discr
16071
        and then Is_Empty_Elmt_List (Discs)
16072
        and then Present (First_Discriminant (Derived_Base))
16073
        and then
16074
          (not Is_Private_Type (Derived_Base)
16075
             or else Is_Completely_Hidden
16076
               (First_Stored_Discriminant (Derived_Base))
16077
             or else Is_Generic_Type (Derived_Base))
16078
      then
16079
         D := First_Discriminant (Derived_Base);
16080
         while Present (D) loop
16081
            Append_Elmt (New_Reference_To (D, Loc), Discs);
16082
            Next_Discriminant (D);
16083
         end loop;
16084
      end if;
16085
 
16086
      --  Finally, inherit non-discriminant components unless they are not
16087
      --  visible because defined or inherited from the full view of the
16088
      --  parent. Don't inherit the _parent field of the parent type.
16089
 
16090
      Component := First_Entity (Parent_Base);
16091
      while Present (Component) loop
16092
 
16093
         --  Ada 2005 (AI-251): Do not inherit components associated with
16094
         --  secondary tags of the parent.
16095
 
16096
         if Ekind (Component) = E_Component
16097
           and then Present (Related_Type (Component))
16098
         then
16099
            null;
16100
 
16101
         elsif Ekind (Component) /= E_Component
16102
           or else Chars (Component) = Name_uParent
16103
         then
16104
            null;
16105
 
16106
         --  If the derived type is within the parent type's declarative
16107
         --  region, then the components can still be inherited even though
16108
         --  they aren't visible at this point. This can occur for cases
16109
         --  such as within public child units where the components must
16110
         --  become visible upon entering the child unit's private part.
16111
 
16112
         elsif not Is_Visible_Component (Component)
16113
           and then not In_Open_Scopes (Scope (Parent_Base))
16114
         then
16115
            null;
16116
 
16117
         elsif Ekind_In (Derived_Base, E_Private_Type,
16118
                                       E_Limited_Private_Type)
16119
         then
16120
            null;
16121
 
16122
         else
16123
            Inherit_Component (Component);
16124
         end if;
16125
 
16126
         Next_Entity (Component);
16127
      end loop;
16128
 
16129
      --  For tagged derived types, inherited discriminants cannot be used in
16130
      --  component declarations of the record extension part. To achieve this
16131
      --  we mark the inherited discriminants as not visible.
16132
 
16133
      if Is_Tagged and then Inherit_Discr then
16134
         D := First_Discriminant (Derived_Base);
16135
         while Present (D) loop
16136
            Set_Is_Immediately_Visible (D, False);
16137
            Next_Discriminant (D);
16138
         end loop;
16139
      end if;
16140
 
16141
      return Assoc_List;
16142
   end Inherit_Components;
16143
 
16144
   -----------------------
16145
   -- Is_Constant_Bound --
16146
   -----------------------
16147
 
16148
   function Is_Constant_Bound (Exp : Node_Id) return Boolean is
16149
   begin
16150
      if Compile_Time_Known_Value (Exp) then
16151
         return True;
16152
 
16153
      elsif Is_Entity_Name (Exp)
16154
        and then Present (Entity (Exp))
16155
      then
16156
         return Is_Constant_Object (Entity (Exp))
16157
           or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
16158
 
16159
      elsif Nkind (Exp) in N_Binary_Op then
16160
         return Is_Constant_Bound (Left_Opnd (Exp))
16161
           and then Is_Constant_Bound (Right_Opnd (Exp))
16162
           and then Scope (Entity (Exp)) = Standard_Standard;
16163
 
16164
      else
16165
         return False;
16166
      end if;
16167
   end Is_Constant_Bound;
16168
 
16169
   -----------------------
16170
   -- Is_Null_Extension --
16171
   -----------------------
16172
 
16173
   function Is_Null_Extension (T : Entity_Id) return Boolean is
16174
      Type_Decl : constant Node_Id := Parent (Base_Type (T));
16175
      Comp_List : Node_Id;
16176
      Comp      : Node_Id;
16177
 
16178
   begin
16179
      if Nkind (Type_Decl) /= N_Full_Type_Declaration
16180
        or else not Is_Tagged_Type (T)
16181
        or else Nkind (Type_Definition (Type_Decl)) /=
16182
                                              N_Derived_Type_Definition
16183
        or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
16184
      then
16185
         return False;
16186
      end if;
16187
 
16188
      Comp_List :=
16189
        Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
16190
 
16191
      if Present (Discriminant_Specifications (Type_Decl)) then
16192
         return False;
16193
 
16194
      elsif Present (Comp_List)
16195
        and then Is_Non_Empty_List (Component_Items (Comp_List))
16196
      then
16197
         Comp := First (Component_Items (Comp_List));
16198
 
16199
         --  Only user-defined components are relevant. The component list
16200
         --  may also contain a parent component and internal components
16201
         --  corresponding to secondary tags, but these do not determine
16202
         --  whether this is a null extension.
16203
 
16204
         while Present (Comp) loop
16205
            if Comes_From_Source (Comp) then
16206
               return False;
16207
            end if;
16208
 
16209
            Next (Comp);
16210
         end loop;
16211
 
16212
         return True;
16213
      else
16214
         return True;
16215
      end if;
16216
   end Is_Null_Extension;
16217
 
16218
   ------------------------------
16219
   -- Is_Valid_Constraint_Kind --
16220
   ------------------------------
16221
 
16222
   function Is_Valid_Constraint_Kind
16223
     (T_Kind          : Type_Kind;
16224
      Constraint_Kind : Node_Kind) return Boolean
16225
   is
16226
   begin
16227
      case T_Kind is
16228
         when Enumeration_Kind |
16229
              Integer_Kind =>
16230
            return Constraint_Kind = N_Range_Constraint;
16231
 
16232
         when Decimal_Fixed_Point_Kind =>
16233
            return Nkind_In (Constraint_Kind, N_Digits_Constraint,
16234
                                              N_Range_Constraint);
16235
 
16236
         when Ordinary_Fixed_Point_Kind =>
16237
            return Nkind_In (Constraint_Kind, N_Delta_Constraint,
16238
                                              N_Range_Constraint);
16239
 
16240
         when Float_Kind =>
16241
            return Nkind_In (Constraint_Kind, N_Digits_Constraint,
16242
                                              N_Range_Constraint);
16243
 
16244
         when Access_Kind       |
16245
              Array_Kind        |
16246
              E_Record_Type     |
16247
              E_Record_Subtype  |
16248
              Class_Wide_Kind   |
16249
              E_Incomplete_Type |
16250
              Private_Kind      |
16251
              Concurrent_Kind  =>
16252
            return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
16253
 
16254
         when others =>
16255
            return True; -- Error will be detected later
16256
      end case;
16257
   end Is_Valid_Constraint_Kind;
16258
 
16259
   --------------------------
16260
   -- Is_Visible_Component --
16261
   --------------------------
16262
 
16263
   function Is_Visible_Component (C : Entity_Id) return Boolean is
16264
      Original_Comp  : Entity_Id := Empty;
16265
      Original_Scope : Entity_Id;
16266
      Type_Scope     : Entity_Id;
16267
 
16268
      function Is_Local_Type (Typ : Entity_Id) return Boolean;
16269
      --  Check whether parent type of inherited component is declared locally,
16270
      --  possibly within a nested package or instance. The current scope is
16271
      --  the derived record itself.
16272
 
16273
      -------------------
16274
      -- Is_Local_Type --
16275
      -------------------
16276
 
16277
      function Is_Local_Type (Typ : Entity_Id) return Boolean is
16278
         Scop : Entity_Id;
16279
 
16280
      begin
16281
         Scop := Scope (Typ);
16282
         while Present (Scop)
16283
           and then Scop /= Standard_Standard
16284
         loop
16285
            if Scop = Scope (Current_Scope) then
16286
               return True;
16287
            end if;
16288
 
16289
            Scop := Scope (Scop);
16290
         end loop;
16291
 
16292
         return False;
16293
      end Is_Local_Type;
16294
 
16295
   --  Start of processing for Is_Visible_Component
16296
 
16297
   begin
16298
      if Ekind_In (C, E_Component, E_Discriminant) then
16299
         Original_Comp := Original_Record_Component (C);
16300
      end if;
16301
 
16302
      if No (Original_Comp) then
16303
 
16304
         --  Premature usage, or previous error
16305
 
16306
         return False;
16307
 
16308
      else
16309
         Original_Scope := Scope (Original_Comp);
16310
         Type_Scope     := Scope (Base_Type (Scope (C)));
16311
      end if;
16312
 
16313
      --  This test only concerns tagged types
16314
 
16315
      if not Is_Tagged_Type (Original_Scope) then
16316
         return True;
16317
 
16318
      --  If it is _Parent or _Tag, there is no visibility issue
16319
 
16320
      elsif not Comes_From_Source (Original_Comp) then
16321
         return True;
16322
 
16323
      --  Discriminants are always visible
16324
 
16325
      elsif Ekind (Original_Comp) = E_Discriminant
16326
        and then not Has_Unknown_Discriminants (Original_Scope)
16327
      then
16328
         return True;
16329
 
16330
      --  In the body of an instantiation, no need to check for the visibility
16331
      --  of a component.
16332
 
16333
      elsif In_Instance_Body then
16334
         return True;
16335
 
16336
      --  If the component has been declared in an ancestor which is currently
16337
      --  a private type, then it is not visible. The same applies if the
16338
      --  component's containing type is not in an open scope and the original
16339
      --  component's enclosing type is a visible full view of a private type
16340
      --  (which can occur in cases where an attempt is being made to reference
16341
      --  a component in a sibling package that is inherited from a visible
16342
      --  component of a type in an ancestor package; the component in the
16343
      --  sibling package should not be visible even though the component it
16344
      --  inherited from is visible). This does not apply however in the case
16345
      --  where the scope of the type is a private child unit, or when the
16346
      --  parent comes from a local package in which the ancestor is currently
16347
      --  visible. The latter suppression of visibility is needed for cases
16348
      --  that are tested in B730006.
16349
 
16350
      elsif Is_Private_Type (Original_Scope)
16351
        or else
16352
          (not Is_Private_Descendant (Type_Scope)
16353
            and then not In_Open_Scopes (Type_Scope)
16354
            and then Has_Private_Declaration (Original_Scope))
16355
      then
16356
         --  If the type derives from an entity in a formal package, there
16357
         --  are no additional visible components.
16358
 
16359
         if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) =
16360
            N_Formal_Package_Declaration
16361
         then
16362
            return False;
16363
 
16364
         --  if we are not in the private part of the current package, there
16365
         --  are no additional visible components.
16366
 
16367
         elsif Ekind (Scope (Current_Scope)) = E_Package
16368
           and then not In_Private_Part (Scope (Current_Scope))
16369
         then
16370
            return False;
16371
         else
16372
            return
16373
              Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
16374
                and then In_Open_Scopes (Scope (Original_Scope))
16375
                and then Is_Local_Type (Type_Scope);
16376
         end if;
16377
 
16378
      --  There is another weird way in which a component may be invisible
16379
      --  when the private and the full view are not derived from the same
16380
      --  ancestor. Here is an example :
16381
 
16382
      --       type A1 is tagged      record F1 : integer; end record;
16383
      --       type A2 is new A1 with record F2 : integer; end record;
16384
      --       type T is new A1 with private;
16385
      --     private
16386
      --       type T is new A2 with null record;
16387
 
16388
      --  In this case, the full view of T inherits F1 and F2 but the private
16389
      --  view inherits only F1
16390
 
16391
      else
16392
         declare
16393
            Ancestor : Entity_Id := Scope (C);
16394
 
16395
         begin
16396
            loop
16397
               if Ancestor = Original_Scope then
16398
                  return True;
16399
               elsif Ancestor = Etype (Ancestor) then
16400
                  return False;
16401
               end if;
16402
 
16403
               Ancestor := Etype (Ancestor);
16404
            end loop;
16405
         end;
16406
      end if;
16407
   end Is_Visible_Component;
16408
 
16409
   --------------------------
16410
   -- Make_Class_Wide_Type --
16411
   --------------------------
16412
 
16413
   procedure Make_Class_Wide_Type (T : Entity_Id) is
16414
      CW_Type : Entity_Id;
16415
      CW_Name : Name_Id;
16416
      Next_E  : Entity_Id;
16417
 
16418
   begin
16419
      if Present (Class_Wide_Type (T)) then
16420
 
16421
         --  The class-wide type is a partially decorated entity created for a
16422
         --  unanalyzed tagged type referenced through a limited with clause.
16423
         --  When the tagged type is analyzed, its class-wide type needs to be
16424
         --  redecorated. Note that we reuse the entity created by Decorate_
16425
         --  Tagged_Type in order to preserve all links.
16426
 
16427
         if Materialize_Entity (Class_Wide_Type (T)) then
16428
            CW_Type := Class_Wide_Type (T);
16429
            Set_Materialize_Entity (CW_Type, False);
16430
 
16431
         --  The class wide type can have been defined by the partial view, in
16432
         --  which case everything is already done.
16433
 
16434
         else
16435
            return;
16436
         end if;
16437
 
16438
      --  Default case, we need to create a new class-wide type
16439
 
16440
      else
16441
         CW_Type :=
16442
           New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
16443
      end if;
16444
 
16445
      --  Inherit root type characteristics
16446
 
16447
      CW_Name := Chars (CW_Type);
16448
      Next_E  := Next_Entity (CW_Type);
16449
      Copy_Node (T, CW_Type);
16450
      Set_Comes_From_Source (CW_Type, False);
16451
      Set_Chars (CW_Type, CW_Name);
16452
      Set_Parent (CW_Type, Parent (T));
16453
      Set_Next_Entity (CW_Type, Next_E);
16454
 
16455
      --  Ensure we have a new freeze node for the class-wide type. The partial
16456
      --  view may have freeze action of its own, requiring a proper freeze
16457
      --  node, and the same freeze node cannot be shared between the two
16458
      --  types.
16459
 
16460
      Set_Has_Delayed_Freeze (CW_Type);
16461
      Set_Freeze_Node (CW_Type, Empty);
16462
 
16463
      --  Customize the class-wide type: It has no prim. op., it cannot be
16464
      --  abstract and its Etype points back to the specific root type.
16465
 
16466
      Set_Ekind                       (CW_Type, E_Class_Wide_Type);
16467
      Set_Is_Tagged_Type              (CW_Type, True);
16468
      Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
16469
      Set_Is_Abstract_Type            (CW_Type, False);
16470
      Set_Is_Constrained              (CW_Type, False);
16471
      Set_Is_First_Subtype            (CW_Type, Is_First_Subtype (T));
16472
 
16473
      if Ekind (T) = E_Class_Wide_Subtype then
16474
         Set_Etype             (CW_Type, Etype (Base_Type (T)));
16475
      else
16476
         Set_Etype             (CW_Type, T);
16477
      end if;
16478
 
16479
      --  If this is the class_wide type of a constrained subtype, it does
16480
      --  not have discriminants.
16481
 
16482
      Set_Has_Discriminants (CW_Type,
16483
        Has_Discriminants (T) and then not Is_Constrained (T));
16484
 
16485
      Set_Has_Unknown_Discriminants (CW_Type, True);
16486
      Set_Class_Wide_Type (T, CW_Type);
16487
      Set_Equivalent_Type (CW_Type, Empty);
16488
 
16489
      --  The class-wide type of a class-wide type is itself (RM 3.9(14))
16490
 
16491
      Set_Class_Wide_Type (CW_Type, CW_Type);
16492
   end Make_Class_Wide_Type;
16493
 
16494
   ----------------
16495
   -- Make_Index --
16496
   ----------------
16497
 
16498
   procedure Make_Index
16499
     (I            : Node_Id;
16500
      Related_Nod  : Node_Id;
16501
      Related_Id   : Entity_Id := Empty;
16502
      Suffix_Index : Nat := 1;
16503
      In_Iter_Schm : Boolean := False)
16504
   is
16505
      R      : Node_Id;
16506
      T      : Entity_Id;
16507
      Def_Id : Entity_Id := Empty;
16508
      Found  : Boolean := False;
16509
 
16510
   begin
16511
      --  For a discrete range used in a constrained array definition and
16512
      --  defined by a range, an implicit conversion to the predefined type
16513
      --  INTEGER is assumed if each bound is either a numeric literal, a named
16514
      --  number, or an attribute, and the type of both bounds (prior to the
16515
      --  implicit conversion) is the type universal_integer. Otherwise, both
16516
      --  bounds must be of the same discrete type, other than universal
16517
      --  integer; this type must be determinable independently of the
16518
      --  context, but using the fact that the type must be discrete and that
16519
      --  both bounds must have the same type.
16520
 
16521
      --  Character literals also have a universal type in the absence of
16522
      --  of additional context,  and are resolved to Standard_Character.
16523
 
16524
      if Nkind (I) = N_Range then
16525
 
16526
         --  The index is given by a range constraint. The bounds are known
16527
         --  to be of a consistent type.
16528
 
16529
         if not Is_Overloaded (I) then
16530
            T := Etype (I);
16531
 
16532
            --  For universal bounds, choose the specific predefined type
16533
 
16534
            if T = Universal_Integer then
16535
               T := Standard_Integer;
16536
 
16537
            elsif T = Any_Character then
16538
               Ambiguous_Character (Low_Bound (I));
16539
 
16540
               T := Standard_Character;
16541
            end if;
16542
 
16543
         --  The node may be overloaded because some user-defined operators
16544
         --  are available, but if a universal interpretation exists it is
16545
         --  also the selected one.
16546
 
16547
         elsif Universal_Interpretation (I) = Universal_Integer then
16548
            T := Standard_Integer;
16549
 
16550
         else
16551
            T := Any_Type;
16552
 
16553
            declare
16554
               Ind : Interp_Index;
16555
               It  : Interp;
16556
 
16557
            begin
16558
               Get_First_Interp (I, Ind, It);
16559
               while Present (It.Typ) loop
16560
                  if Is_Discrete_Type (It.Typ) then
16561
 
16562
                     if Found
16563
                       and then not Covers (It.Typ, T)
16564
                       and then not Covers (T, It.Typ)
16565
                     then
16566
                        Error_Msg_N ("ambiguous bounds in discrete range", I);
16567
                        exit;
16568
                     else
16569
                        T := It.Typ;
16570
                        Found := True;
16571
                     end if;
16572
                  end if;
16573
 
16574
                  Get_Next_Interp (Ind, It);
16575
               end loop;
16576
 
16577
               if T = Any_Type then
16578
                  Error_Msg_N ("discrete type required for range", I);
16579
                  Set_Etype (I, Any_Type);
16580
                  return;
16581
 
16582
               elsif T = Universal_Integer then
16583
                  T := Standard_Integer;
16584
               end if;
16585
            end;
16586
         end if;
16587
 
16588
         if not Is_Discrete_Type (T) then
16589
            Error_Msg_N ("discrete type required for range", I);
16590
            Set_Etype (I, Any_Type);
16591
            return;
16592
         end if;
16593
 
16594
         if Nkind (Low_Bound (I)) = N_Attribute_Reference
16595
           and then Attribute_Name (Low_Bound (I)) = Name_First
16596
           and then Is_Entity_Name (Prefix (Low_Bound (I)))
16597
           and then Is_Type (Entity (Prefix (Low_Bound (I))))
16598
           and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I))))
16599
         then
16600
            --  The type of the index will be the type of the prefix, as long
16601
            --  as the upper bound is 'Last of the same type.
16602
 
16603
            Def_Id := Entity (Prefix (Low_Bound (I)));
16604
 
16605
            if Nkind (High_Bound (I)) /= N_Attribute_Reference
16606
              or else Attribute_Name (High_Bound (I)) /= Name_Last
16607
              or else not Is_Entity_Name (Prefix (High_Bound (I)))
16608
              or else Entity (Prefix (High_Bound (I))) /= Def_Id
16609
            then
16610
               Def_Id := Empty;
16611
            end if;
16612
         end if;
16613
 
16614
         R := I;
16615
         Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm);
16616
 
16617
      elsif Nkind (I) = N_Subtype_Indication then
16618
 
16619
         --  The index is given by a subtype with a range constraint
16620
 
16621
         T :=  Base_Type (Entity (Subtype_Mark (I)));
16622
 
16623
         if not Is_Discrete_Type (T) then
16624
            Error_Msg_N ("discrete type required for range", I);
16625
            Set_Etype (I, Any_Type);
16626
            return;
16627
         end if;
16628
 
16629
         R := Range_Expression (Constraint (I));
16630
 
16631
         Resolve (R, T);
16632
         Process_Range_Expr_In_Decl
16633
           (R, Entity (Subtype_Mark (I)), In_Iter_Schm => In_Iter_Schm);
16634
 
16635
      elsif Nkind (I) = N_Attribute_Reference then
16636
 
16637
         --  The parser guarantees that the attribute is a RANGE attribute
16638
 
16639
         --  If the node denotes the range of a type mark, that is also the
16640
         --  resulting type, and we do no need to create an Itype for it.
16641
 
16642
         if Is_Entity_Name (Prefix (I))
16643
           and then Comes_From_Source (I)
16644
           and then Is_Type (Entity (Prefix (I)))
16645
           and then Is_Discrete_Type (Entity (Prefix (I)))
16646
         then
16647
            Def_Id := Entity (Prefix (I));
16648
         end if;
16649
 
16650
         Analyze_And_Resolve (I);
16651
         T := Etype (I);
16652
         R := I;
16653
 
16654
      --  If none of the above, must be a subtype. We convert this to a
16655
      --  range attribute reference because in the case of declared first
16656
      --  named subtypes, the types in the range reference can be different
16657
      --  from the type of the entity. A range attribute normalizes the
16658
      --  reference and obtains the correct types for the bounds.
16659
 
16660
      --  This transformation is in the nature of an expansion, is only
16661
      --  done if expansion is active. In particular, it is not done on
16662
      --  formal generic types,  because we need to retain the name of the
16663
      --  original index for instantiation purposes.
16664
 
16665
      else
16666
         if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
16667
            Error_Msg_N ("invalid subtype mark in discrete range ", I);
16668
            Set_Etype (I, Any_Integer);
16669
            return;
16670
 
16671
         else
16672
            --  The type mark may be that of an incomplete type. It is only
16673
            --  now that we can get the full view, previous analysis does
16674
            --  not look specifically for a type mark.
16675
 
16676
            Set_Entity (I, Get_Full_View (Entity (I)));
16677
            Set_Etype  (I, Entity (I));
16678
            Def_Id := Entity (I);
16679
 
16680
            if not Is_Discrete_Type (Def_Id) then
16681
               Error_Msg_N ("discrete type required for index", I);
16682
               Set_Etype (I, Any_Type);
16683
               return;
16684
            end if;
16685
         end if;
16686
 
16687
         if Expander_Active then
16688
            Rewrite (I,
16689
              Make_Attribute_Reference (Sloc (I),
16690
                Attribute_Name => Name_Range,
16691
                Prefix         => Relocate_Node (I)));
16692
 
16693
            --  The original was a subtype mark that does not freeze. This
16694
            --  means that the rewritten version must not freeze either.
16695
 
16696
            Set_Must_Not_Freeze (I);
16697
            Set_Must_Not_Freeze (Prefix (I));
16698
 
16699
            --  Is order critical??? if so, document why, if not
16700
            --  use Analyze_And_Resolve
16701
 
16702
            Analyze_And_Resolve (I);
16703
            T := Etype (I);
16704
            R := I;
16705
 
16706
         --  If expander is inactive, type is legal, nothing else to construct
16707
 
16708
         else
16709
            return;
16710
         end if;
16711
      end if;
16712
 
16713
      if not Is_Discrete_Type (T) then
16714
         Error_Msg_N ("discrete type required for range", I);
16715
         Set_Etype (I, Any_Type);
16716
         return;
16717
 
16718
      elsif T = Any_Type then
16719
         Set_Etype (I, Any_Type);
16720
         return;
16721
      end if;
16722
 
16723
      --  We will now create the appropriate Itype to describe the range, but
16724
      --  first a check. If we originally had a subtype, then we just label
16725
      --  the range with this subtype. Not only is there no need to construct
16726
      --  a new subtype, but it is wrong to do so for two reasons:
16727
 
16728
      --    1. A legality concern, if we have a subtype, it must not freeze,
16729
      --       and the Itype would cause freezing incorrectly
16730
 
16731
      --    2. An efficiency concern, if we created an Itype, it would not be
16732
      --       recognized as the same type for the purposes of eliminating
16733
      --       checks in some circumstances.
16734
 
16735
      --  We signal this case by setting the subtype entity in Def_Id
16736
 
16737
      if No (Def_Id) then
16738
         Def_Id :=
16739
           Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
16740
         Set_Etype (Def_Id, Base_Type (T));
16741
 
16742
         if Is_Signed_Integer_Type (T) then
16743
            Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
16744
 
16745
         elsif Is_Modular_Integer_Type (T) then
16746
            Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
16747
 
16748
         else
16749
            Set_Ekind             (Def_Id, E_Enumeration_Subtype);
16750
            Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
16751
            Set_First_Literal     (Def_Id, First_Literal (T));
16752
         end if;
16753
 
16754
         Set_Size_Info      (Def_Id,                  (T));
16755
         Set_RM_Size        (Def_Id, RM_Size          (T));
16756
         Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
16757
 
16758
         Set_Scalar_Range   (Def_Id, R);
16759
         Conditional_Delay  (Def_Id, T);
16760
 
16761
         --  In the subtype indication case, if the immediate parent of the
16762
         --  new subtype is non-static, then the subtype we create is non-
16763
         --  static, even if its bounds are static.
16764
 
16765
         if Nkind (I) = N_Subtype_Indication
16766
           and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
16767
         then
16768
            Set_Is_Non_Static_Subtype (Def_Id);
16769
         end if;
16770
      end if;
16771
 
16772
      --  Final step is to label the index with this constructed type
16773
 
16774
      Set_Etype (I, Def_Id);
16775
   end Make_Index;
16776
 
16777
   ------------------------------
16778
   -- Modular_Type_Declaration --
16779
   ------------------------------
16780
 
16781
   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
16782
      Mod_Expr : constant Node_Id := Expression (Def);
16783
      M_Val    : Uint;
16784
 
16785
      procedure Set_Modular_Size (Bits : Int);
16786
      --  Sets RM_Size to Bits, and Esize to normal word size above this
16787
 
16788
      ----------------------
16789
      -- Set_Modular_Size --
16790
      ----------------------
16791
 
16792
      procedure Set_Modular_Size (Bits : Int) is
16793
      begin
16794
         Set_RM_Size (T, UI_From_Int (Bits));
16795
 
16796
         if Bits <= 8 then
16797
            Init_Esize (T, 8);
16798
 
16799
         elsif Bits <= 16 then
16800
            Init_Esize (T, 16);
16801
 
16802
         elsif Bits <= 32 then
16803
            Init_Esize (T, 32);
16804
 
16805
         else
16806
            Init_Esize (T, System_Max_Binary_Modulus_Power);
16807
         end if;
16808
 
16809
         if not Non_Binary_Modulus (T)
16810
           and then Esize (T) = RM_Size (T)
16811
         then
16812
            Set_Is_Known_Valid (T);
16813
         end if;
16814
      end Set_Modular_Size;
16815
 
16816
   --  Start of processing for Modular_Type_Declaration
16817
 
16818
   begin
16819
      --  If the mod expression is (exactly) 2 * literal, where literal is
16820
      --  64 or less,then almost certainly the * was meant to be **. Warn!
16821
 
16822
      if Warn_On_Suspicious_Modulus_Value
16823
        and then Nkind (Mod_Expr) = N_Op_Multiply
16824
        and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal
16825
        and then Intval (Left_Opnd (Mod_Expr)) = Uint_2
16826
        and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal
16827
        and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64
16828
      then
16829
         Error_Msg_N ("suspicious MOD value, was '*'* intended'??", Mod_Expr);
16830
      end if;
16831
 
16832
      --  Proceed with analysis of mod expression
16833
 
16834
      Analyze_And_Resolve (Mod_Expr, Any_Integer);
16835
      Set_Etype (T, T);
16836
      Set_Ekind (T, E_Modular_Integer_Type);
16837
      Init_Alignment (T);
16838
      Set_Is_Constrained (T);
16839
 
16840
      if not Is_OK_Static_Expression (Mod_Expr) then
16841
         Flag_Non_Static_Expr
16842
           ("non-static expression used for modular type bound!", Mod_Expr);
16843
         M_Val := 2 ** System_Max_Binary_Modulus_Power;
16844
      else
16845
         M_Val := Expr_Value (Mod_Expr);
16846
      end if;
16847
 
16848
      if M_Val < 1 then
16849
         Error_Msg_N ("modulus value must be positive", Mod_Expr);
16850
         M_Val := 2 ** System_Max_Binary_Modulus_Power;
16851
      end if;
16852
 
16853
      Set_Modulus (T, M_Val);
16854
 
16855
      --   Create bounds for the modular type based on the modulus given in
16856
      --   the type declaration and then analyze and resolve those bounds.
16857
 
16858
      Set_Scalar_Range (T,
16859
        Make_Range (Sloc (Mod_Expr),
16860
          Low_Bound  => Make_Integer_Literal (Sloc (Mod_Expr), 0),
16861
          High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
16862
 
16863
      --  Properly analyze the literals for the range. We do this manually
16864
      --  because we can't go calling Resolve, since we are resolving these
16865
      --  bounds with the type, and this type is certainly not complete yet!
16866
 
16867
      Set_Etype (Low_Bound  (Scalar_Range (T)), T);
16868
      Set_Etype (High_Bound (Scalar_Range (T)), T);
16869
      Set_Is_Static_Expression (Low_Bound  (Scalar_Range (T)));
16870
      Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
16871
 
16872
      --  Loop through powers of two to find number of bits required
16873
 
16874
      for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
16875
 
16876
         --  Binary case
16877
 
16878
         if M_Val = 2 ** Bits then
16879
            Set_Modular_Size (Bits);
16880
            return;
16881
 
16882
         --  Non-binary case
16883
 
16884
         elsif M_Val < 2 ** Bits then
16885
            Check_SPARK_Restriction ("modulus should be a power of 2", T);
16886
            Set_Non_Binary_Modulus (T);
16887
 
16888
            if Bits > System_Max_Nonbinary_Modulus_Power then
16889
               Error_Msg_Uint_1 :=
16890
                 UI_From_Int (System_Max_Nonbinary_Modulus_Power);
16891
               Error_Msg_F
16892
                 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
16893
               Set_Modular_Size (System_Max_Binary_Modulus_Power);
16894
               return;
16895
 
16896
            else
16897
               --  In the non-binary case, set size as per RM 13.3(55)
16898
 
16899
               Set_Modular_Size (Bits);
16900
               return;
16901
            end if;
16902
         end if;
16903
 
16904
      end loop;
16905
 
16906
      --  If we fall through, then the size exceed System.Max_Binary_Modulus
16907
      --  so we just signal an error and set the maximum size.
16908
 
16909
      Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
16910
      Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
16911
 
16912
      Set_Modular_Size (System_Max_Binary_Modulus_Power);
16913
      Init_Alignment (T);
16914
 
16915
   end Modular_Type_Declaration;
16916
 
16917
   --------------------------
16918
   -- New_Concatenation_Op --
16919
   --------------------------
16920
 
16921
   procedure New_Concatenation_Op (Typ : Entity_Id) is
16922
      Loc : constant Source_Ptr := Sloc (Typ);
16923
      Op  : Entity_Id;
16924
 
16925
      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
16926
      --  Create abbreviated declaration for the formal of a predefined
16927
      --  Operator 'Op' of type 'Typ'
16928
 
16929
      --------------------
16930
      -- Make_Op_Formal --
16931
      --------------------
16932
 
16933
      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
16934
         Formal : Entity_Id;
16935
      begin
16936
         Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
16937
         Set_Etype (Formal, Typ);
16938
         Set_Mechanism (Formal, Default_Mechanism);
16939
         return Formal;
16940
      end Make_Op_Formal;
16941
 
16942
   --  Start of processing for New_Concatenation_Op
16943
 
16944
   begin
16945
      Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
16946
 
16947
      Set_Ekind                   (Op, E_Operator);
16948
      Set_Scope                   (Op, Current_Scope);
16949
      Set_Etype                   (Op, Typ);
16950
      Set_Homonym                 (Op, Get_Name_Entity_Id (Name_Op_Concat));
16951
      Set_Is_Immediately_Visible  (Op);
16952
      Set_Is_Intrinsic_Subprogram (Op);
16953
      Set_Has_Completion          (Op);
16954
      Append_Entity               (Op, Current_Scope);
16955
 
16956
      Set_Name_Entity_Id (Name_Op_Concat, Op);
16957
 
16958
      Append_Entity (Make_Op_Formal (Typ, Op), Op);
16959
      Append_Entity (Make_Op_Formal (Typ, Op), Op);
16960
   end New_Concatenation_Op;
16961
 
16962
   -------------------------
16963
   -- OK_For_Limited_Init --
16964
   -------------------------
16965
 
16966
   --  ???Check all calls of this, and compare the conditions under which it's
16967
   --  called.
16968
 
16969
   function OK_For_Limited_Init
16970
     (Typ : Entity_Id;
16971
      Exp : Node_Id) return Boolean
16972
   is
16973
   begin
16974
      return Is_CPP_Constructor_Call (Exp)
16975
        or else (Ada_Version >= Ada_2005
16976
                  and then not Debug_Flag_Dot_L
16977
                  and then OK_For_Limited_Init_In_05 (Typ, Exp));
16978
   end OK_For_Limited_Init;
16979
 
16980
   -------------------------------
16981
   -- OK_For_Limited_Init_In_05 --
16982
   -------------------------------
16983
 
16984
   function OK_For_Limited_Init_In_05
16985
     (Typ : Entity_Id;
16986
      Exp : Node_Id) return Boolean
16987
   is
16988
   begin
16989
      --  An object of a limited interface type can be initialized with any
16990
      --  expression of a nonlimited descendant type.
16991
 
16992
      if Is_Class_Wide_Type (Typ)
16993
        and then Is_Limited_Interface (Typ)
16994
        and then not Is_Limited_Type (Etype (Exp))
16995
      then
16996
         return True;
16997
      end if;
16998
 
16999
      --  Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
17000
      --  case of limited aggregates (including extension aggregates), and
17001
      --  function calls. The function call may have been given in prefixed
17002
      --  notation, in which case the original node is an indexed component.
17003
      --  If the function is parameterless, the original node was an explicit
17004
      --  dereference. The function may also be parameterless, in which case
17005
      --  the source node is just an identifier.
17006
 
17007
      case Nkind (Original_Node (Exp)) is
17008
         when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
17009
            return True;
17010
 
17011
         when N_Identifier =>
17012
            return Present (Entity (Original_Node (Exp)))
17013
              and then Ekind (Entity (Original_Node (Exp))) = E_Function;
17014
 
17015
         when N_Qualified_Expression =>
17016
            return
17017
              OK_For_Limited_Init_In_05
17018
                (Typ, Expression (Original_Node (Exp)));
17019
 
17020
         --  Ada 2005 (AI-251): If a class-wide interface object is initialized
17021
         --  with a function call, the expander has rewritten the call into an
17022
         --  N_Type_Conversion node to force displacement of the pointer to
17023
         --  reference the component containing the secondary dispatch table.
17024
         --  Otherwise a type conversion is not a legal context.
17025
         --  A return statement for a build-in-place function returning a
17026
         --  synchronized type also introduces an unchecked conversion.
17027
 
17028
         when N_Type_Conversion           |
17029
              N_Unchecked_Type_Conversion =>
17030
            return not Comes_From_Source (Exp)
17031
              and then
17032
                OK_For_Limited_Init_In_05
17033
                  (Typ, Expression (Original_Node (Exp)));
17034
 
17035
         when N_Indexed_Component     |
17036
              N_Selected_Component    |
17037
              N_Explicit_Dereference  =>
17038
            return Nkind (Exp) = N_Function_Call;
17039
 
17040
         --  A use of 'Input is a function call, hence allowed. Normally the
17041
         --  attribute will be changed to a call, but the attribute by itself
17042
         --  can occur with -gnatc.
17043
 
17044
         when N_Attribute_Reference =>
17045
            return Attribute_Name (Original_Node (Exp)) = Name_Input;
17046
 
17047
         --  For a conditional expression, all dependent expressions must be
17048
         --  legal constructs.
17049
 
17050
         when N_Conditional_Expression =>
17051
            declare
17052
               Then_Expr : constant Node_Id :=
17053
                             Next (First (Expressions (Original_Node (Exp))));
17054
               Else_Expr : constant Node_Id := Next (Then_Expr);
17055
            begin
17056
               return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
17057
                 and then OK_For_Limited_Init_In_05 (Typ, Else_Expr);
17058
            end;
17059
 
17060
         when N_Case_Expression =>
17061
            declare
17062
               Alt : Node_Id;
17063
 
17064
            begin
17065
               Alt := First (Alternatives (Original_Node (Exp)));
17066
               while Present (Alt) loop
17067
                  if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then
17068
                     return False;
17069
                  end if;
17070
 
17071
                  Next (Alt);
17072
               end loop;
17073
 
17074
               return True;
17075
            end;
17076
 
17077
         when others =>
17078
            return False;
17079
      end case;
17080
   end OK_For_Limited_Init_In_05;
17081
 
17082
   -------------------------------------------
17083
   -- Ordinary_Fixed_Point_Type_Declaration --
17084
   -------------------------------------------
17085
 
17086
   procedure Ordinary_Fixed_Point_Type_Declaration
17087
     (T   : Entity_Id;
17088
      Def : Node_Id)
17089
   is
17090
      Loc           : constant Source_Ptr := Sloc (Def);
17091
      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
17092
      RRS           : constant Node_Id    := Real_Range_Specification (Def);
17093
      Implicit_Base : Entity_Id;
17094
      Delta_Val     : Ureal;
17095
      Small_Val     : Ureal;
17096
      Low_Val       : Ureal;
17097
      High_Val      : Ureal;
17098
 
17099
   begin
17100
      Check_Restriction (No_Fixed_Point, Def);
17101
 
17102
      --  Create implicit base type
17103
 
17104
      Implicit_Base :=
17105
        Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
17106
      Set_Etype (Implicit_Base, Implicit_Base);
17107
 
17108
      --  Analyze and process delta expression
17109
 
17110
      Analyze_And_Resolve (Delta_Expr, Any_Real);
17111
 
17112
      Check_Delta_Expression (Delta_Expr);
17113
      Delta_Val := Expr_Value_R (Delta_Expr);
17114
 
17115
      Set_Delta_Value (Implicit_Base, Delta_Val);
17116
 
17117
      --  Compute default small from given delta, which is the largest power
17118
      --  of two that does not exceed the given delta value.
17119
 
17120
      declare
17121
         Tmp   : Ureal;
17122
         Scale : Int;
17123
 
17124
      begin
17125
         Tmp := Ureal_1;
17126
         Scale := 0;
17127
 
17128
         if Delta_Val < Ureal_1 then
17129
            while Delta_Val < Tmp loop
17130
               Tmp := Tmp / Ureal_2;
17131
               Scale := Scale + 1;
17132
            end loop;
17133
 
17134
         else
17135
            loop
17136
               Tmp := Tmp * Ureal_2;
17137
               exit when Tmp > Delta_Val;
17138
               Scale := Scale - 1;
17139
            end loop;
17140
         end if;
17141
 
17142
         Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
17143
      end;
17144
 
17145
      Set_Small_Value (Implicit_Base, Small_Val);
17146
 
17147
      --  If no range was given, set a dummy range
17148
 
17149
      if RRS <= Empty_Or_Error then
17150
         Low_Val  := -Small_Val;
17151
         High_Val := Small_Val;
17152
 
17153
      --  Otherwise analyze and process given range
17154
 
17155
      else
17156
         declare
17157
            Low  : constant Node_Id := Low_Bound  (RRS);
17158
            High : constant Node_Id := High_Bound (RRS);
17159
 
17160
         begin
17161
            Analyze_And_Resolve (Low, Any_Real);
17162
            Analyze_And_Resolve (High, Any_Real);
17163
            Check_Real_Bound (Low);
17164
            Check_Real_Bound (High);
17165
 
17166
            --  Obtain and set the range
17167
 
17168
            Low_Val  := Expr_Value_R (Low);
17169
            High_Val := Expr_Value_R (High);
17170
 
17171
            if Low_Val > High_Val then
17172
               Error_Msg_NE ("?fixed point type& has null range", Def, T);
17173
            end if;
17174
         end;
17175
      end if;
17176
 
17177
      --  The range for both the implicit base and the declared first subtype
17178
      --  cannot be set yet, so we use the special routine Set_Fixed_Range to
17179
      --  set a temporary range in place. Note that the bounds of the base
17180
      --  type will be widened to be symmetrical and to fill the available
17181
      --  bits when the type is frozen.
17182
 
17183
      --  We could do this with all discrete types, and probably should, but
17184
      --  we absolutely have to do it for fixed-point, since the end-points
17185
      --  of the range and the size are determined by the small value, which
17186
      --  could be reset before the freeze point.
17187
 
17188
      Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
17189
      Set_Fixed_Range (T, Loc, Low_Val, High_Val);
17190
 
17191
      --  Complete definition of first subtype
17192
 
17193
      Set_Ekind          (T, E_Ordinary_Fixed_Point_Subtype);
17194
      Set_Etype          (T, Implicit_Base);
17195
      Init_Size_Align    (T);
17196
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
17197
      Set_Small_Value    (T, Small_Val);
17198
      Set_Delta_Value    (T, Delta_Val);
17199
      Set_Is_Constrained (T);
17200
 
17201
   end Ordinary_Fixed_Point_Type_Declaration;
17202
 
17203
   ----------------------------------------
17204
   -- Prepare_Private_Subtype_Completion --
17205
   ----------------------------------------
17206
 
17207
   procedure Prepare_Private_Subtype_Completion
17208
     (Id          : Entity_Id;
17209
      Related_Nod : Node_Id)
17210
   is
17211
      Id_B   : constant Entity_Id := Base_Type (Id);
17212
      Full_B : constant Entity_Id := Full_View (Id_B);
17213
      Full   : Entity_Id;
17214
 
17215
   begin
17216
      if Present (Full_B) then
17217
 
17218
         --  The Base_Type is already completed, we can complete the subtype
17219
         --  now. We have to create a new entity with the same name, Thus we
17220
         --  can't use Create_Itype.
17221
 
17222
         --  This is messy, should be fixed ???
17223
 
17224
         Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
17225
         Set_Is_Itype (Full);
17226
         Set_Associated_Node_For_Itype (Full, Related_Nod);
17227
         Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
17228
      end if;
17229
 
17230
      --  The parent subtype may be private, but the base might not, in some
17231
      --  nested instances. In that case, the subtype does not need to be
17232
      --  exchanged. It would still be nice to make private subtypes and their
17233
      --  bases consistent at all times ???
17234
 
17235
      if Is_Private_Type (Id_B) then
17236
         Append_Elmt (Id, Private_Dependents (Id_B));
17237
      end if;
17238
 
17239
   end Prepare_Private_Subtype_Completion;
17240
 
17241
   ---------------------------
17242
   -- Process_Discriminants --
17243
   ---------------------------
17244
 
17245
   procedure Process_Discriminants
17246
     (N    : Node_Id;
17247
      Prev : Entity_Id := Empty)
17248
   is
17249
      Elist               : constant Elist_Id := New_Elmt_List;
17250
      Id                  : Node_Id;
17251
      Discr               : Node_Id;
17252
      Discr_Number        : Uint;
17253
      Discr_Type          : Entity_Id;
17254
      Default_Present     : Boolean := False;
17255
      Default_Not_Present : Boolean := False;
17256
 
17257
   begin
17258
      --  A composite type other than an array type can have discriminants.
17259
      --  On entry, the current scope is the composite type.
17260
 
17261
      --  The discriminants are initially entered into the scope of the type
17262
      --  via Enter_Name with the default Ekind of E_Void to prevent premature
17263
      --  use, as explained at the end of this procedure.
17264
 
17265
      Discr := First (Discriminant_Specifications (N));
17266
      while Present (Discr) loop
17267
         Enter_Name (Defining_Identifier (Discr));
17268
 
17269
         --  For navigation purposes we add a reference to the discriminant
17270
         --  in the entity for the type. If the current declaration is a
17271
         --  completion, place references on the partial view. Otherwise the
17272
         --  type is the current scope.
17273
 
17274
         if Present (Prev) then
17275
 
17276
            --  The references go on the partial view, if present. If the
17277
            --  partial view has discriminants, the references have been
17278
            --  generated already.
17279
 
17280
            if not Has_Discriminants (Prev) then
17281
               Generate_Reference (Prev, Defining_Identifier (Discr), 'd');
17282
            end if;
17283
         else
17284
            Generate_Reference
17285
              (Current_Scope, Defining_Identifier (Discr), 'd');
17286
         end if;
17287
 
17288
         if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
17289
            Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
17290
 
17291
            --  Ada 2005 (AI-254)
17292
 
17293
            if Present (Access_To_Subprogram_Definition
17294
                         (Discriminant_Type (Discr)))
17295
              and then Protected_Present (Access_To_Subprogram_Definition
17296
                                           (Discriminant_Type (Discr)))
17297
            then
17298
               Discr_Type :=
17299
                 Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
17300
            end if;
17301
 
17302
         else
17303
            Find_Type (Discriminant_Type (Discr));
17304
            Discr_Type := Etype (Discriminant_Type (Discr));
17305
 
17306
            if Error_Posted (Discriminant_Type (Discr)) then
17307
               Discr_Type := Any_Type;
17308
            end if;
17309
         end if;
17310
 
17311
         if Is_Access_Type (Discr_Type) then
17312
 
17313
            --  Ada 2005 (AI-230): Access discriminant allowed in non-limited
17314
            --  record types
17315
 
17316
            if Ada_Version < Ada_2005 then
17317
               Check_Access_Discriminant_Requires_Limited
17318
                 (Discr, Discriminant_Type (Discr));
17319
            end if;
17320
 
17321
            if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
17322
               Error_Msg_N
17323
                 ("(Ada 83) access discriminant not allowed", Discr);
17324
            end if;
17325
 
17326
         elsif not Is_Discrete_Type (Discr_Type) then
17327
            Error_Msg_N ("discriminants must have a discrete or access type",
17328
              Discriminant_Type (Discr));
17329
         end if;
17330
 
17331
         Set_Etype (Defining_Identifier (Discr), Discr_Type);
17332
 
17333
         --  If a discriminant specification includes the assignment compound
17334
         --  delimiter followed by an expression, the expression is the default
17335
         --  expression of the discriminant; the default expression must be of
17336
         --  the type of the discriminant. (RM 3.7.1) Since this expression is
17337
         --  a default expression, we do the special preanalysis, since this
17338
         --  expression does not freeze (see "Handling of Default and Per-
17339
         --  Object Expressions" in spec of package Sem).
17340
 
17341
         if Present (Expression (Discr)) then
17342
            Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
17343
 
17344
            if Nkind (N) = N_Formal_Type_Declaration then
17345
               Error_Msg_N
17346
                 ("discriminant defaults not allowed for formal type",
17347
                  Expression (Discr));
17348
 
17349
            --  Flag an error for a tagged type with defaulted discriminants,
17350
            --  excluding limited tagged types when compiling for Ada 2012
17351
            --  (see AI05-0214).
17352
 
17353
            elsif Is_Tagged_Type (Current_Scope)
17354
              and then (not Is_Limited_Type (Current_Scope)
17355
                         or else Ada_Version < Ada_2012)
17356
              and then Comes_From_Source (N)
17357
            then
17358
               --  Note: see similar test in Check_Or_Process_Discriminants, to
17359
               --  handle the (illegal) case of the completion of an untagged
17360
               --  view with discriminants with defaults by a tagged full view.
17361
               --  We skip the check if Discr does not come from source, to
17362
               --  account for the case of an untagged derived type providing
17363
               --  defaults for a renamed discriminant from a private untagged
17364
               --  ancestor with a tagged full view (ACATS B460006).
17365
 
17366
               if Ada_Version >= Ada_2012 then
17367
                  Error_Msg_N
17368
                    ("discriminants of nonlimited tagged type cannot have"
17369
                       & " defaults",
17370
                     Expression (Discr));
17371
               else
17372
                  Error_Msg_N
17373
                    ("discriminants of tagged type cannot have defaults",
17374
                     Expression (Discr));
17375
               end if;
17376
 
17377
            else
17378
               Default_Present := True;
17379
               Append_Elmt (Expression (Discr), Elist);
17380
 
17381
               --  Tag the defining identifiers for the discriminants with
17382
               --  their corresponding default expressions from the tree.
17383
 
17384
               Set_Discriminant_Default_Value
17385
                 (Defining_Identifier (Discr), Expression (Discr));
17386
            end if;
17387
 
17388
         else
17389
            Default_Not_Present := True;
17390
         end if;
17391
 
17392
         --  Ada 2005 (AI-231): Create an Itype that is a duplicate of
17393
         --  Discr_Type but with the null-exclusion attribute
17394
 
17395
         if Ada_Version >= Ada_2005 then
17396
 
17397
            --  Ada 2005 (AI-231): Static checks
17398
 
17399
            if Can_Never_Be_Null (Discr_Type) then
17400
               Null_Exclusion_Static_Checks (Discr);
17401
 
17402
            elsif Is_Access_Type (Discr_Type)
17403
              and then Null_Exclusion_Present (Discr)
17404
 
17405
               --  No need to check itypes because in their case this check
17406
               --  was done at their point of creation
17407
 
17408
              and then not Is_Itype (Discr_Type)
17409
            then
17410
               if Can_Never_Be_Null (Discr_Type) then
17411
                  Error_Msg_NE
17412
                    ("`NOT NULL` not allowed (& already excludes null)",
17413
                     Discr,
17414
                     Discr_Type);
17415
               end if;
17416
 
17417
               Set_Etype (Defining_Identifier (Discr),
17418
                 Create_Null_Excluding_Itype
17419
                   (T           => Discr_Type,
17420
                    Related_Nod => Discr));
17421
 
17422
            --  Check for improper null exclusion if the type is otherwise
17423
            --  legal for a discriminant.
17424
 
17425
            elsif Null_Exclusion_Present (Discr)
17426
              and then Is_Discrete_Type (Discr_Type)
17427
            then
17428
               Error_Msg_N
17429
                 ("null exclusion can only apply to an access type", Discr);
17430
            end if;
17431
 
17432
            --  Ada 2005 (AI-402): access discriminants of nonlimited types
17433
            --  can't have defaults. Synchronized types, or types that are
17434
            --  explicitly limited are fine, but special tests apply to derived
17435
            --  types in generics: in a generic body we have to assume the
17436
            --  worst, and therefore defaults are not allowed if the parent is
17437
            --  a generic formal private type (see ACATS B370001).
17438
 
17439
            if Is_Access_Type (Discr_Type) and then Default_Present then
17440
               if Ekind (Discr_Type) /= E_Anonymous_Access_Type
17441
                 or else Is_Limited_Record (Current_Scope)
17442
                 or else Is_Concurrent_Type (Current_Scope)
17443
                 or else Is_Concurrent_Record_Type (Current_Scope)
17444
                 or else Ekind (Current_Scope) = E_Limited_Private_Type
17445
               then
17446
                  if not Is_Derived_Type (Current_Scope)
17447
                    or else not Is_Generic_Type (Etype (Current_Scope))
17448
                    or else not In_Package_Body (Scope (Etype (Current_Scope)))
17449
                    or else Limited_Present
17450
                              (Type_Definition (Parent (Current_Scope)))
17451
                  then
17452
                     null;
17453
 
17454
                  else
17455
                     Error_Msg_N ("access discriminants of nonlimited types",
17456
                         Expression (Discr));
17457
                     Error_Msg_N ("\cannot have defaults", Expression (Discr));
17458
                  end if;
17459
 
17460
               elsif Present (Expression (Discr)) then
17461
                  Error_Msg_N
17462
                    ("(Ada 2005) access discriminants of nonlimited types",
17463
                     Expression (Discr));
17464
                  Error_Msg_N ("\cannot have defaults", Expression (Discr));
17465
               end if;
17466
            end if;
17467
         end if;
17468
 
17469
         Next (Discr);
17470
      end loop;
17471
 
17472
      --  An element list consisting of the default expressions of the
17473
      --  discriminants is constructed in the above loop and used to set
17474
      --  the Discriminant_Constraint attribute for the type. If an object
17475
      --  is declared of this (record or task) type without any explicit
17476
      --  discriminant constraint given, this element list will form the
17477
      --  actual parameters for the corresponding initialization procedure
17478
      --  for the type.
17479
 
17480
      Set_Discriminant_Constraint (Current_Scope, Elist);
17481
      Set_Stored_Constraint (Current_Scope, No_Elist);
17482
 
17483
      --  Default expressions must be provided either for all or for none
17484
      --  of the discriminants of a discriminant part. (RM 3.7.1)
17485
 
17486
      if Default_Present and then Default_Not_Present then
17487
         Error_Msg_N
17488
           ("incomplete specification of defaults for discriminants", N);
17489
      end if;
17490
 
17491
      --  The use of the name of a discriminant is not allowed in default
17492
      --  expressions of a discriminant part if the specification of the
17493
      --  discriminant is itself given in the discriminant part. (RM 3.7.1)
17494
 
17495
      --  To detect this, the discriminant names are entered initially with an
17496
      --  Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
17497
      --  attempt to use a void entity (for example in an expression that is
17498
      --  type-checked) produces the error message: premature usage. Now after
17499
      --  completing the semantic analysis of the discriminant part, we can set
17500
      --  the Ekind of all the discriminants appropriately.
17501
 
17502
      Discr := First (Discriminant_Specifications (N));
17503
      Discr_Number := Uint_1;
17504
      while Present (Discr) loop
17505
         Id := Defining_Identifier (Discr);
17506
         Set_Ekind (Id, E_Discriminant);
17507
         Init_Component_Location (Id);
17508
         Init_Esize (Id);
17509
         Set_Discriminant_Number (Id, Discr_Number);
17510
 
17511
         --  Make sure this is always set, even in illegal programs
17512
 
17513
         Set_Corresponding_Discriminant (Id, Empty);
17514
 
17515
         --  Initialize the Original_Record_Component to the entity itself.
17516
         --  Inherit_Components will propagate the right value to
17517
         --  discriminants in derived record types.
17518
 
17519
         Set_Original_Record_Component (Id, Id);
17520
 
17521
         --  Create the discriminal for the discriminant
17522
 
17523
         Build_Discriminal (Id);
17524
 
17525
         Next (Discr);
17526
         Discr_Number := Discr_Number + 1;
17527
      end loop;
17528
 
17529
      Set_Has_Discriminants (Current_Scope);
17530
   end Process_Discriminants;
17531
 
17532
   -----------------------
17533
   -- Process_Full_View --
17534
   -----------------------
17535
 
17536
   procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
17537
      Priv_Parent : Entity_Id;
17538
      Full_Parent : Entity_Id;
17539
      Full_Indic  : Node_Id;
17540
 
17541
      procedure Collect_Implemented_Interfaces
17542
        (Typ    : Entity_Id;
17543
         Ifaces : Elist_Id);
17544
      --  Ada 2005: Gather all the interfaces that Typ directly or
17545
      --  inherently implements. Duplicate entries are not added to
17546
      --  the list Ifaces.
17547
 
17548
      ------------------------------------
17549
      -- Collect_Implemented_Interfaces --
17550
      ------------------------------------
17551
 
17552
      procedure Collect_Implemented_Interfaces
17553
        (Typ    : Entity_Id;
17554
         Ifaces : Elist_Id)
17555
      is
17556
         Iface      : Entity_Id;
17557
         Iface_Elmt : Elmt_Id;
17558
 
17559
      begin
17560
         --  Abstract interfaces are only associated with tagged record types
17561
 
17562
         if not Is_Tagged_Type (Typ)
17563
           or else not Is_Record_Type (Typ)
17564
         then
17565
            return;
17566
         end if;
17567
 
17568
         --  Recursively climb to the ancestors
17569
 
17570
         if Etype (Typ) /= Typ
17571
 
17572
            --  Protect the frontend against wrong cyclic declarations like:
17573
 
17574
            --     type B is new A with private;
17575
            --     type C is new A with private;
17576
            --  private
17577
            --     type B is new C with null record;
17578
            --     type C is new B with null record;
17579
 
17580
           and then Etype (Typ) /= Priv_T
17581
           and then Etype (Typ) /= Full_T
17582
         then
17583
            --  Keep separate the management of private type declarations
17584
 
17585
            if Ekind (Typ) = E_Record_Type_With_Private then
17586
 
17587
               --  Handle the following erroneous case:
17588
               --      type Private_Type is tagged private;
17589
               --   private
17590
               --      type Private_Type is new Type_Implementing_Iface;
17591
 
17592
               if Present (Full_View (Typ))
17593
                 and then Etype (Typ) /= Full_View (Typ)
17594
               then
17595
                  if Is_Interface (Etype (Typ)) then
17596
                     Append_Unique_Elmt (Etype (Typ), Ifaces);
17597
                  end if;
17598
 
17599
                  Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
17600
               end if;
17601
 
17602
            --  Non-private types
17603
 
17604
            else
17605
               if Is_Interface (Etype (Typ)) then
17606
                  Append_Unique_Elmt (Etype (Typ), Ifaces);
17607
               end if;
17608
 
17609
               Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
17610
            end if;
17611
         end if;
17612
 
17613
         --  Handle entities in the list of abstract interfaces
17614
 
17615
         if Present (Interfaces (Typ)) then
17616
            Iface_Elmt := First_Elmt (Interfaces (Typ));
17617
            while Present (Iface_Elmt) loop
17618
               Iface := Node (Iface_Elmt);
17619
 
17620
               pragma Assert (Is_Interface (Iface));
17621
 
17622
               if not Contain_Interface (Iface, Ifaces) then
17623
                  Append_Elmt (Iface, Ifaces);
17624
                  Collect_Implemented_Interfaces (Iface, Ifaces);
17625
               end if;
17626
 
17627
               Next_Elmt (Iface_Elmt);
17628
            end loop;
17629
         end if;
17630
      end Collect_Implemented_Interfaces;
17631
 
17632
   --  Start of processing for Process_Full_View
17633
 
17634
   begin
17635
      --  First some sanity checks that must be done after semantic
17636
      --  decoration of the full view and thus cannot be placed with other
17637
      --  similar checks in Find_Type_Name
17638
 
17639
      if not Is_Limited_Type (Priv_T)
17640
        and then (Is_Limited_Type (Full_T)
17641
                   or else Is_Limited_Composite (Full_T))
17642
      then
17643
         if In_Instance then
17644
            null;
17645
         else
17646
            Error_Msg_N
17647
              ("completion of nonlimited type cannot be limited", Full_T);
17648
            Explain_Limited_Type (Full_T, Full_T);
17649
         end if;
17650
 
17651
      elsif Is_Abstract_Type (Full_T)
17652
        and then not Is_Abstract_Type (Priv_T)
17653
      then
17654
         Error_Msg_N
17655
           ("completion of nonabstract type cannot be abstract", Full_T);
17656
 
17657
      elsif Is_Tagged_Type (Priv_T)
17658
        and then Is_Limited_Type (Priv_T)
17659
        and then not Is_Limited_Type (Full_T)
17660
      then
17661
         --  If pragma CPP_Class was applied to the private declaration
17662
         --  propagate the limitedness to the full-view
17663
 
17664
         if Is_CPP_Class (Priv_T) then
17665
            Set_Is_Limited_Record (Full_T);
17666
 
17667
         --  GNAT allow its own definition of Limited_Controlled to disobey
17668
         --  this rule in order in ease the implementation. This test is safe
17669
         --  because Root_Controlled is defined in a child of System that
17670
         --  normal programs are not supposed to use.
17671
 
17672
         elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then
17673
            Set_Is_Limited_Composite (Full_T);
17674
         else
17675
            Error_Msg_N
17676
              ("completion of limited tagged type must be limited", Full_T);
17677
         end if;
17678
 
17679
      elsif Is_Generic_Type (Priv_T) then
17680
         Error_Msg_N ("generic type cannot have a completion", Full_T);
17681
      end if;
17682
 
17683
      --  Check that ancestor interfaces of private and full views are
17684
      --  consistent. We omit this check for synchronized types because
17685
      --  they are performed on the corresponding record type when frozen.
17686
 
17687
      if Ada_Version >= Ada_2005
17688
        and then Is_Tagged_Type (Priv_T)
17689
        and then Is_Tagged_Type (Full_T)
17690
        and then not Is_Concurrent_Type (Full_T)
17691
      then
17692
         declare
17693
            Iface         : Entity_Id;
17694
            Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
17695
            Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
17696
 
17697
         begin
17698
            Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
17699
            Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
17700
 
17701
            --  Ada 2005 (AI-251): The partial view shall be a descendant of
17702
            --  an interface type if and only if the full type is descendant
17703
            --  of the interface type (AARM 7.3 (7.3/2)).
17704
 
17705
            Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
17706
 
17707
            if Present (Iface) then
17708
               Error_Msg_NE
17709
                 ("interface & not implemented by full type " &
17710
                  "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
17711
            end if;
17712
 
17713
            Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
17714
 
17715
            if Present (Iface) then
17716
               Error_Msg_NE
17717
                 ("interface & not implemented by partial view " &
17718
                  "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
17719
            end if;
17720
         end;
17721
      end if;
17722
 
17723
      if Is_Tagged_Type (Priv_T)
17724
        and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
17725
        and then Is_Derived_Type (Full_T)
17726
      then
17727
         Priv_Parent := Etype (Priv_T);
17728
 
17729
         --  The full view of a private extension may have been transformed
17730
         --  into an unconstrained derived type declaration and a subtype
17731
         --  declaration (see build_derived_record_type for details).
17732
 
17733
         if Nkind (N) = N_Subtype_Declaration then
17734
            Full_Indic  := Subtype_Indication (N);
17735
            Full_Parent := Etype (Base_Type (Full_T));
17736
         else
17737
            Full_Indic  := Subtype_Indication (Type_Definition (N));
17738
            Full_Parent := Etype (Full_T);
17739
         end if;
17740
 
17741
         --  Check that the parent type of the full type is a descendant of
17742
         --  the ancestor subtype given in the private extension. If either
17743
         --  entity has an Etype equal to Any_Type then we had some previous
17744
         --  error situation [7.3(8)].
17745
 
17746
         if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
17747
            return;
17748
 
17749
         --  Ada 2005 (AI-251): Interfaces in the full-typ can be given in
17750
         --  any order. Therefore we don't have to check that its parent must
17751
         --  be a descendant of the parent of the private type declaration.
17752
 
17753
         elsif Is_Interface (Priv_Parent)
17754
           and then Is_Interface (Full_Parent)
17755
         then
17756
            null;
17757
 
17758
         --  Ada 2005 (AI-251): If the parent of the private type declaration
17759
         --  is an interface there is no need to check that it is an ancestor
17760
         --  of the associated full type declaration. The required tests for
17761
         --  this case are performed by Build_Derived_Record_Type.
17762
 
17763
         elsif not Is_Interface (Base_Type (Priv_Parent))
17764
           and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
17765
         then
17766
            Error_Msg_N
17767
              ("parent of full type must descend from parent"
17768
                  & " of private extension", Full_Indic);
17769
 
17770
         --  First check a formal restriction, and then proceed with checking
17771
         --  Ada rules. Since the formal restriction is not a serious error, we
17772
         --  don't prevent further error detection for this check, hence the
17773
         --  ELSE.
17774
 
17775
         else
17776
 
17777
            --  In formal mode, when completing a private extension the type
17778
            --  named in the private part must be exactly the same as that
17779
            --  named in the visible part.
17780
 
17781
            if Priv_Parent /= Full_Parent then
17782
               Error_Msg_Name_1 := Chars (Priv_Parent);
17783
               Check_SPARK_Restriction ("% expected", Full_Indic);
17784
            end if;
17785
 
17786
            --  Check the rules of 7.3(10): if the private extension inherits
17787
            --  known discriminants, then the full type must also inherit those
17788
            --  discriminants from the same (ancestor) type, and the parent
17789
            --  subtype of the full type must be constrained if and only if
17790
            --  the ancestor subtype of the private extension is constrained.
17791
 
17792
            if No (Discriminant_Specifications (Parent (Priv_T)))
17793
              and then not Has_Unknown_Discriminants (Priv_T)
17794
              and then Has_Discriminants (Base_Type (Priv_Parent))
17795
            then
17796
               declare
17797
                  Priv_Indic  : constant Node_Id :=
17798
                                  Subtype_Indication (Parent (Priv_T));
17799
 
17800
                  Priv_Constr : constant Boolean :=
17801
                                  Is_Constrained (Priv_Parent)
17802
                                    or else
17803
                                      Nkind (Priv_Indic) = N_Subtype_Indication
17804
                                    or else
17805
                                      Is_Constrained (Entity (Priv_Indic));
17806
 
17807
                  Full_Constr : constant Boolean :=
17808
                                  Is_Constrained (Full_Parent)
17809
                                    or else
17810
                                      Nkind (Full_Indic) = N_Subtype_Indication
17811
                                    or else
17812
                                      Is_Constrained (Entity (Full_Indic));
17813
 
17814
                  Priv_Discr : Entity_Id;
17815
                  Full_Discr : Entity_Id;
17816
 
17817
               begin
17818
                  Priv_Discr := First_Discriminant (Priv_Parent);
17819
                  Full_Discr := First_Discriminant (Full_Parent);
17820
                  while Present (Priv_Discr) and then Present (Full_Discr) loop
17821
                     if Original_Record_Component (Priv_Discr) =
17822
                        Original_Record_Component (Full_Discr)
17823
                       or else
17824
                         Corresponding_Discriminant (Priv_Discr) =
17825
                         Corresponding_Discriminant (Full_Discr)
17826
                     then
17827
                        null;
17828
                     else
17829
                        exit;
17830
                     end if;
17831
 
17832
                     Next_Discriminant (Priv_Discr);
17833
                     Next_Discriminant (Full_Discr);
17834
                  end loop;
17835
 
17836
                  if Present (Priv_Discr) or else Present (Full_Discr) then
17837
                     Error_Msg_N
17838
                       ("full view must inherit discriminants of the parent"
17839
                        & " type used in the private extension", Full_Indic);
17840
 
17841
                  elsif Priv_Constr and then not Full_Constr then
17842
                     Error_Msg_N
17843
                       ("parent subtype of full type must be constrained",
17844
                        Full_Indic);
17845
 
17846
                  elsif Full_Constr and then not Priv_Constr then
17847
                     Error_Msg_N
17848
                       ("parent subtype of full type must be unconstrained",
17849
                        Full_Indic);
17850
                  end if;
17851
               end;
17852
 
17853
               --  Check the rules of 7.3(12): if a partial view has neither
17854
               --  known or unknown discriminants, then the full type
17855
               --  declaration shall define a definite subtype.
17856
 
17857
            elsif      not Has_Unknown_Discriminants (Priv_T)
17858
              and then not Has_Discriminants (Priv_T)
17859
              and then not Is_Constrained (Full_T)
17860
            then
17861
               Error_Msg_N
17862
                 ("full view must define a constrained type if partial view"
17863
                  & " has no discriminants", Full_T);
17864
            end if;
17865
 
17866
            --  ??????? Do we implement the following properly ?????
17867
            --  If the ancestor subtype of a private extension has constrained
17868
            --  discriminants, then the parent subtype of the full view shall
17869
            --  impose a statically matching constraint on those discriminants
17870
            --  [7.3(13)].
17871
         end if;
17872
 
17873
      else
17874
         --  For untagged types, verify that a type without discriminants
17875
         --  is not completed with an unconstrained type.
17876
 
17877
         if not Is_Indefinite_Subtype (Priv_T)
17878
           and then Is_Indefinite_Subtype (Full_T)
17879
         then
17880
            Error_Msg_N ("full view of type must be definite subtype", Full_T);
17881
         end if;
17882
      end if;
17883
 
17884
      --  AI-419: verify that the use of "limited" is consistent
17885
 
17886
      declare
17887
         Orig_Decl : constant Node_Id := Original_Node (N);
17888
 
17889
      begin
17890
         if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
17891
           and then not Limited_Present (Parent (Priv_T))
17892
           and then not Synchronized_Present (Parent (Priv_T))
17893
           and then Nkind (Orig_Decl) = N_Full_Type_Declaration
17894
           and then Nkind
17895
             (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
17896
           and then Limited_Present (Type_Definition (Orig_Decl))
17897
         then
17898
            Error_Msg_N
17899
              ("full view of non-limited extension cannot be limited", N);
17900
         end if;
17901
      end;
17902
 
17903
      --  Ada 2005 (AI-443): A synchronized private extension must be
17904
      --  completed by a task or protected type.
17905
 
17906
      if Ada_Version >= Ada_2005
17907
        and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
17908
        and then Synchronized_Present (Parent (Priv_T))
17909
        and then not Is_Concurrent_Type (Full_T)
17910
      then
17911
         Error_Msg_N ("full view of synchronized extension must " &
17912
                      "be synchronized type", N);
17913
      end if;
17914
 
17915
      --  Ada 2005 AI-363: if the full view has discriminants with
17916
      --  defaults, it is illegal to declare constrained access subtypes
17917
      --  whose designated type is the current type. This allows objects
17918
      --  of the type that are declared in the heap to be unconstrained.
17919
 
17920
      if not Has_Unknown_Discriminants (Priv_T)
17921
        and then not Has_Discriminants (Priv_T)
17922
        and then Has_Discriminants (Full_T)
17923
        and then
17924
          Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
17925
      then
17926
         Set_Has_Constrained_Partial_View (Full_T);
17927
         Set_Has_Constrained_Partial_View (Priv_T);
17928
      end if;
17929
 
17930
      --  Create a full declaration for all its subtypes recorded in
17931
      --  Private_Dependents and swap them similarly to the base type. These
17932
      --  are subtypes that have been define before the full declaration of
17933
      --  the private type. We also swap the entry in Private_Dependents list
17934
      --  so we can properly restore the private view on exit from the scope.
17935
 
17936
      declare
17937
         Priv_Elmt : Elmt_Id;
17938
         Priv      : Entity_Id;
17939
         Full      : Entity_Id;
17940
 
17941
      begin
17942
         Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
17943
         while Present (Priv_Elmt) loop
17944
            Priv := Node (Priv_Elmt);
17945
 
17946
            if Ekind_In (Priv, E_Private_Subtype,
17947
                               E_Limited_Private_Subtype,
17948
                               E_Record_Subtype_With_Private)
17949
            then
17950
               Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
17951
               Set_Is_Itype (Full);
17952
               Set_Parent (Full, Parent (Priv));
17953
               Set_Associated_Node_For_Itype (Full, N);
17954
 
17955
               --  Now we need to complete the private subtype, but since the
17956
               --  base type has already been swapped, we must also swap the
17957
               --  subtypes (and thus, reverse the arguments in the call to
17958
               --  Complete_Private_Subtype).
17959
 
17960
               Copy_And_Swap (Priv, Full);
17961
               Complete_Private_Subtype (Full, Priv, Full_T, N);
17962
               Replace_Elmt (Priv_Elmt, Full);
17963
            end if;
17964
 
17965
            Next_Elmt (Priv_Elmt);
17966
         end loop;
17967
      end;
17968
 
17969
      --  If the private view was tagged, copy the new primitive operations
17970
      --  from the private view to the full view.
17971
 
17972
      if Is_Tagged_Type (Full_T) then
17973
         declare
17974
            Disp_Typ  : Entity_Id;
17975
            Full_List : Elist_Id;
17976
            Prim      : Entity_Id;
17977
            Prim_Elmt : Elmt_Id;
17978
            Priv_List : Elist_Id;
17979
 
17980
            function Contains
17981
              (E : Entity_Id;
17982
               L : Elist_Id) return Boolean;
17983
            --  Determine whether list L contains element E
17984
 
17985
            --------------
17986
            -- Contains --
17987
            --------------
17988
 
17989
            function Contains
17990
              (E : Entity_Id;
17991
               L : Elist_Id) return Boolean
17992
            is
17993
               List_Elmt : Elmt_Id;
17994
 
17995
            begin
17996
               List_Elmt := First_Elmt (L);
17997
               while Present (List_Elmt) loop
17998
                  if Node (List_Elmt) = E then
17999
                     return True;
18000
                  end if;
18001
 
18002
                  Next_Elmt (List_Elmt);
18003
               end loop;
18004
 
18005
               return False;
18006
            end Contains;
18007
 
18008
         --  Start of processing
18009
 
18010
         begin
18011
            if Is_Tagged_Type (Priv_T) then
18012
               Priv_List := Primitive_Operations (Priv_T);
18013
               Prim_Elmt := First_Elmt (Priv_List);
18014
 
18015
               --  In the case of a concurrent type completing a private tagged
18016
               --  type, primitives may have been declared in between the two
18017
               --  views. These subprograms need to be wrapped the same way
18018
               --  entries and protected procedures are handled because they
18019
               --  cannot be directly shared by the two views.
18020
 
18021
               if Is_Concurrent_Type (Full_T) then
18022
                  declare
18023
                     Conc_Typ  : constant Entity_Id :=
18024
                                   Corresponding_Record_Type (Full_T);
18025
                     Curr_Nod  : Node_Id := Parent (Conc_Typ);
18026
                     Wrap_Spec : Node_Id;
18027
 
18028
                  begin
18029
                     while Present (Prim_Elmt) loop
18030
                        Prim := Node (Prim_Elmt);
18031
 
18032
                        if Comes_From_Source (Prim)
18033
                          and then not Is_Abstract_Subprogram (Prim)
18034
                        then
18035
                           Wrap_Spec :=
18036
                             Make_Subprogram_Declaration (Sloc (Prim),
18037
                               Specification =>
18038
                                 Build_Wrapper_Spec
18039
                                   (Subp_Id => Prim,
18040
                                    Obj_Typ => Conc_Typ,
18041
                                    Formals =>
18042
                                      Parameter_Specifications (
18043
                                        Parent (Prim))));
18044
 
18045
                           Insert_After (Curr_Nod, Wrap_Spec);
18046
                           Curr_Nod := Wrap_Spec;
18047
 
18048
                           Analyze (Wrap_Spec);
18049
                        end if;
18050
 
18051
                        Next_Elmt (Prim_Elmt);
18052
                     end loop;
18053
 
18054
                     return;
18055
                  end;
18056
 
18057
               --  For non-concurrent types, transfer explicit primitives, but
18058
               --  omit those inherited from the parent of the private view
18059
               --  since they will be re-inherited later on.
18060
 
18061
               else
18062
                  Full_List := Primitive_Operations (Full_T);
18063
 
18064
                  while Present (Prim_Elmt) loop
18065
                     Prim := Node (Prim_Elmt);
18066
 
18067
                     if Comes_From_Source (Prim)
18068
                       and then not Contains (Prim, Full_List)
18069
                     then
18070
                        Append_Elmt (Prim, Full_List);
18071
                     end if;
18072
 
18073
                     Next_Elmt (Prim_Elmt);
18074
                  end loop;
18075
               end if;
18076
 
18077
            --  Untagged private view
18078
 
18079
            else
18080
               Full_List := Primitive_Operations (Full_T);
18081
 
18082
               --  In this case the partial view is untagged, so here we locate
18083
               --  all of the earlier primitives that need to be treated as
18084
               --  dispatching (those that appear between the two views). Note
18085
               --  that these additional operations must all be new operations
18086
               --  (any earlier operations that override inherited operations
18087
               --  of the full view will already have been inserted in the
18088
               --  primitives list, marked by Check_Operation_From_Private_View
18089
               --  as dispatching. Note that implicit "/=" operators are
18090
               --  excluded from being added to the primitives list since they
18091
               --  shouldn't be treated as dispatching (tagged "/=" is handled
18092
               --  specially).
18093
 
18094
               Prim := Next_Entity (Full_T);
18095
               while Present (Prim) and then Prim /= Priv_T loop
18096
                  if Ekind_In (Prim, E_Procedure, E_Function) then
18097
                     Disp_Typ := Find_Dispatching_Type (Prim);
18098
 
18099
                     if Disp_Typ = Full_T
18100
                       and then (Chars (Prim) /= Name_Op_Ne
18101
                                  or else Comes_From_Source (Prim))
18102
                     then
18103
                        Check_Controlling_Formals (Full_T, Prim);
18104
 
18105
                        if not Is_Dispatching_Operation (Prim) then
18106
                           Append_Elmt (Prim, Full_List);
18107
                           Set_Is_Dispatching_Operation (Prim, True);
18108
                           Set_DT_Position (Prim, No_Uint);
18109
                        end if;
18110
 
18111
                     elsif Is_Dispatching_Operation (Prim)
18112
                       and then Disp_Typ  /= Full_T
18113
                     then
18114
 
18115
                        --  Verify that it is not otherwise controlled by a
18116
                        --  formal or a return value of type T.
18117
 
18118
                        Check_Controlling_Formals (Disp_Typ, Prim);
18119
                     end if;
18120
                  end if;
18121
 
18122
                  Next_Entity (Prim);
18123
               end loop;
18124
            end if;
18125
 
18126
            --  For the tagged case, the two views can share the same primitive
18127
            --  operations list and the same class-wide type. Update attributes
18128
            --  of the class-wide type which depend on the full declaration.
18129
 
18130
            if Is_Tagged_Type (Priv_T) then
18131
               Set_Direct_Primitive_Operations (Priv_T, Full_List);
18132
               Set_Class_Wide_Type
18133
                 (Base_Type (Full_T), Class_Wide_Type (Priv_T));
18134
 
18135
               Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
18136
            end if;
18137
         end;
18138
      end if;
18139
 
18140
      --  Ada 2005 AI 161: Check preelaboratable initialization consistency
18141
 
18142
      if Known_To_Have_Preelab_Init (Priv_T) then
18143
 
18144
         --  Case where there is a pragma Preelaborable_Initialization. We
18145
         --  always allow this in predefined units, which is a bit of a kludge,
18146
         --  but it means we don't have to struggle to meet the requirements in
18147
         --  the RM for having Preelaborable Initialization. Otherwise we
18148
         --  require that the type meets the RM rules. But we can't check that
18149
         --  yet, because of the rule about overriding Initialize, so we simply
18150
         --  set a flag that will be checked at freeze time.
18151
 
18152
         if not In_Predefined_Unit (Full_T) then
18153
            Set_Must_Have_Preelab_Init (Full_T);
18154
         end if;
18155
      end if;
18156
 
18157
      --  If pragma CPP_Class was applied to the private type declaration,
18158
      --  propagate it now to the full type declaration.
18159
 
18160
      if Is_CPP_Class (Priv_T) then
18161
         Set_Is_CPP_Class (Full_T);
18162
         Set_Convention   (Full_T, Convention_CPP);
18163
 
18164
         --  Check that components of imported CPP types do not have default
18165
         --  expressions.
18166
 
18167
         Check_CPP_Type_Has_No_Defaults (Full_T);
18168
      end if;
18169
 
18170
      --  If the private view has user specified stream attributes, then so has
18171
      --  the full view.
18172
 
18173
      --  Why the test, how could these flags be already set in Full_T ???
18174
 
18175
      if Has_Specified_Stream_Read (Priv_T) then
18176
         Set_Has_Specified_Stream_Read (Full_T);
18177
      end if;
18178
 
18179
      if Has_Specified_Stream_Write (Priv_T) then
18180
         Set_Has_Specified_Stream_Write (Full_T);
18181
      end if;
18182
 
18183
      if Has_Specified_Stream_Input (Priv_T) then
18184
         Set_Has_Specified_Stream_Input (Full_T);
18185
      end if;
18186
 
18187
      if Has_Specified_Stream_Output (Priv_T) then
18188
         Set_Has_Specified_Stream_Output (Full_T);
18189
      end if;
18190
 
18191
      --  Propagate invariants to full type
18192
 
18193
      if Has_Invariants (Priv_T) then
18194
         Set_Has_Invariants (Full_T);
18195
         Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
18196
      end if;
18197
 
18198
      if Has_Inheritable_Invariants (Priv_T) then
18199
         Set_Has_Inheritable_Invariants (Full_T);
18200
      end if;
18201
 
18202
      --  Propagate predicates to full type
18203
 
18204
      if Has_Predicates (Priv_T) then
18205
         Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
18206
         Set_Has_Predicates (Full_T);
18207
      end if;
18208
   end Process_Full_View;
18209
 
18210
   -----------------------------------
18211
   -- Process_Incomplete_Dependents --
18212
   -----------------------------------
18213
 
18214
   procedure Process_Incomplete_Dependents
18215
     (N      : Node_Id;
18216
      Full_T : Entity_Id;
18217
      Inc_T  : Entity_Id)
18218
   is
18219
      Inc_Elmt : Elmt_Id;
18220
      Priv_Dep : Entity_Id;
18221
      New_Subt : Entity_Id;
18222
 
18223
      Disc_Constraint : Elist_Id;
18224
 
18225
   begin
18226
      if No (Private_Dependents (Inc_T)) then
18227
         return;
18228
      end if;
18229
 
18230
      --  Itypes that may be generated by the completion of an incomplete
18231
      --  subtype are not used by the back-end and not attached to the tree.
18232
      --  They are created only for constraint-checking purposes.
18233
 
18234
      Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
18235
      while Present (Inc_Elmt) loop
18236
         Priv_Dep := Node (Inc_Elmt);
18237
 
18238
         if Ekind (Priv_Dep) = E_Subprogram_Type then
18239
 
18240
            --  An Access_To_Subprogram type may have a return type or a
18241
            --  parameter type that is incomplete. Replace with the full view.
18242
 
18243
            if Etype (Priv_Dep) = Inc_T then
18244
               Set_Etype (Priv_Dep, Full_T);
18245
            end if;
18246
 
18247
            declare
18248
               Formal : Entity_Id;
18249
 
18250
            begin
18251
               Formal := First_Formal (Priv_Dep);
18252
               while Present (Formal) loop
18253
                  if Etype (Formal) = Inc_T then
18254
                     Set_Etype (Formal, Full_T);
18255
                  end if;
18256
 
18257
                  Next_Formal (Formal);
18258
               end loop;
18259
            end;
18260
 
18261
         elsif Is_Overloadable (Priv_Dep) then
18262
 
18263
            --  If a subprogram in the incomplete dependents list is primitive
18264
            --  for a tagged full type then mark it as a dispatching operation,
18265
            --  check whether it overrides an inherited subprogram, and check
18266
            --  restrictions on its controlling formals. Note that a protected
18267
            --  operation is never dispatching: only its wrapper operation
18268
            --  (which has convention Ada) is.
18269
 
18270
            if Is_Tagged_Type (Full_T)
18271
              and then Is_Primitive (Priv_Dep)
18272
              and then Convention (Priv_Dep) /= Convention_Protected
18273
            then
18274
               Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
18275
               Set_Is_Dispatching_Operation (Priv_Dep);
18276
               Check_Controlling_Formals (Full_T, Priv_Dep);
18277
            end if;
18278
 
18279
         elsif Ekind (Priv_Dep) = E_Subprogram_Body then
18280
 
18281
            --  Can happen during processing of a body before the completion
18282
            --  of a TA type. Ignore, because spec is also on dependent list.
18283
 
18284
            return;
18285
 
18286
         --  Ada 2005 (AI-412): Transform a regular incomplete subtype into a
18287
         --  corresponding subtype of the full view.
18288
 
18289
         elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
18290
            Set_Subtype_Indication
18291
              (Parent (Priv_Dep), New_Reference_To (Full_T, Sloc (Priv_Dep)));
18292
            Set_Etype (Priv_Dep, Full_T);
18293
            Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
18294
            Set_Analyzed (Parent (Priv_Dep), False);
18295
 
18296
            --  Reanalyze the declaration, suppressing the call to
18297
            --  Enter_Name to avoid duplicate names.
18298
 
18299
            Analyze_Subtype_Declaration
18300
              (N    => Parent (Priv_Dep),
18301
               Skip => True);
18302
 
18303
         --  Dependent is a subtype
18304
 
18305
         else
18306
            --  We build a new subtype indication using the full view of the
18307
            --  incomplete parent. The discriminant constraints have been
18308
            --  elaborated already at the point of the subtype declaration.
18309
 
18310
            New_Subt := Create_Itype (E_Void, N);
18311
 
18312
            if Has_Discriminants (Full_T) then
18313
               Disc_Constraint := Discriminant_Constraint (Priv_Dep);
18314
            else
18315
               Disc_Constraint := No_Elist;
18316
            end if;
18317
 
18318
            Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
18319
            Set_Full_View (Priv_Dep, New_Subt);
18320
         end if;
18321
 
18322
         Next_Elmt (Inc_Elmt);
18323
      end loop;
18324
   end Process_Incomplete_Dependents;
18325
 
18326
   --------------------------------
18327
   -- Process_Range_Expr_In_Decl --
18328
   --------------------------------
18329
 
18330
   procedure Process_Range_Expr_In_Decl
18331
     (R            : Node_Id;
18332
      T            : Entity_Id;
18333
      Check_List   : List_Id := Empty_List;
18334
      R_Check_Off  : Boolean := False;
18335
      In_Iter_Schm : Boolean := False)
18336
   is
18337
      Lo, Hi      : Node_Id;
18338
      R_Checks    : Check_Result;
18339
      Insert_Node : Node_Id;
18340
      Def_Id      : Entity_Id;
18341
 
18342
   begin
18343
      Analyze_And_Resolve (R, Base_Type (T));
18344
 
18345
      if Nkind (R) = N_Range then
18346
 
18347
         --  In SPARK, all ranges should be static, with the exception of the
18348
         --  discrete type definition of a loop parameter specification.
18349
 
18350
         if not In_Iter_Schm
18351
           and then not Is_Static_Range (R)
18352
         then
18353
            Check_SPARK_Restriction ("range should be static", R);
18354
         end if;
18355
 
18356
         Lo := Low_Bound (R);
18357
         Hi := High_Bound (R);
18358
 
18359
         --  We need to ensure validity of the bounds here, because if we
18360
         --  go ahead and do the expansion, then the expanded code will get
18361
         --  analyzed with range checks suppressed and we miss the check.
18362
 
18363
         Validity_Check_Range (R);
18364
 
18365
         --  If there were errors in the declaration, try and patch up some
18366
         --  common mistakes in the bounds. The cases handled are literals
18367
         --  which are Integer where the expected type is Real and vice versa.
18368
         --  These corrections allow the compilation process to proceed further
18369
         --  along since some basic assumptions of the format of the bounds
18370
         --  are guaranteed.
18371
 
18372
         if Etype (R) = Any_Type then
18373
 
18374
            if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
18375
               Rewrite (Lo,
18376
                 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
18377
 
18378
            elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
18379
               Rewrite (Hi,
18380
                 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
18381
 
18382
            elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
18383
               Rewrite (Lo,
18384
                 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
18385
 
18386
            elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
18387
               Rewrite (Hi,
18388
                 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
18389
            end if;
18390
 
18391
            Set_Etype (Lo, T);
18392
            Set_Etype (Hi, T);
18393
         end if;
18394
 
18395
         --  If the bounds of the range have been mistakenly given as string
18396
         --  literals (perhaps in place of character literals), then an error
18397
         --  has already been reported, but we rewrite the string literal as a
18398
         --  bound of the range's type to avoid blowups in later processing
18399
         --  that looks at static values.
18400
 
18401
         if Nkind (Lo) = N_String_Literal then
18402
            Rewrite (Lo,
18403
              Make_Attribute_Reference (Sloc (Lo),
18404
                Attribute_Name => Name_First,
18405
                Prefix => New_Reference_To (T, Sloc (Lo))));
18406
            Analyze_And_Resolve (Lo);
18407
         end if;
18408
 
18409
         if Nkind (Hi) = N_String_Literal then
18410
            Rewrite (Hi,
18411
              Make_Attribute_Reference (Sloc (Hi),
18412
                Attribute_Name => Name_First,
18413
                Prefix => New_Reference_To (T, Sloc (Hi))));
18414
            Analyze_And_Resolve (Hi);
18415
         end if;
18416
 
18417
         --  If bounds aren't scalar at this point then exit, avoiding
18418
         --  problems with further processing of the range in this procedure.
18419
 
18420
         if not Is_Scalar_Type (Etype (Lo)) then
18421
            return;
18422
         end if;
18423
 
18424
         --  Resolve (actually Sem_Eval) has checked that the bounds are in
18425
         --  then range of the base type. Here we check whether the bounds
18426
         --  are in the range of the subtype itself. Note that if the bounds
18427
         --  represent the null range the Constraint_Error exception should
18428
         --  not be raised.
18429
 
18430
         --  ??? The following code should be cleaned up as follows
18431
 
18432
         --  1. The Is_Null_Range (Lo, Hi) test should disappear since it
18433
         --     is done in the call to Range_Check (R, T); below
18434
 
18435
         --  2. The use of R_Check_Off should be investigated and possibly
18436
         --     removed, this would clean up things a bit.
18437
 
18438
         if Is_Null_Range (Lo, Hi) then
18439
            null;
18440
 
18441
         else
18442
            --  Capture values of bounds and generate temporaries for them
18443
            --  if needed, before applying checks, since checks may cause
18444
            --  duplication of the expression without forcing evaluation.
18445
 
18446
            --  The forced evaluation removes side effects from expressions,
18447
            --  which should occur also in Alfa mode. Otherwise, we end up with
18448
            --  unexpected insertions of actions at places where this is not
18449
            --  supposed to occur, e.g. on default parameters of a call.
18450
 
18451
            if Expander_Active then
18452
               Force_Evaluation (Lo);
18453
               Force_Evaluation (Hi);
18454
            end if;
18455
 
18456
            --  We use a flag here instead of suppressing checks on the
18457
            --  type because the type we check against isn't necessarily
18458
            --  the place where we put the check.
18459
 
18460
            if not R_Check_Off then
18461
               R_Checks := Get_Range_Checks (R, T);
18462
 
18463
               --  Look up tree to find an appropriate insertion point. We
18464
               --  can't just use insert_actions because later processing
18465
               --  depends on the insertion node. Prior to Ada 2012 the
18466
               --  insertion point could only be a declaration or a loop, but
18467
               --  quantified expressions can appear within any context in an
18468
               --  expression, and the insertion point can be any statement,
18469
               --  pragma, or declaration.
18470
 
18471
               Insert_Node := Parent (R);
18472
               while Present (Insert_Node) loop
18473
                  exit when
18474
                    Nkind (Insert_Node) in N_Declaration
18475
                    and then
18476
                      not Nkind_In
18477
                        (Insert_Node, N_Component_Declaration,
18478
                                      N_Loop_Parameter_Specification,
18479
                                      N_Function_Specification,
18480
                                      N_Procedure_Specification);
18481
 
18482
                  exit when Nkind (Insert_Node) in N_Later_Decl_Item
18483
                    or else Nkind (Insert_Node) in
18484
                              N_Statement_Other_Than_Procedure_Call
18485
                    or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
18486
                                                   N_Pragma);
18487
 
18488
                  Insert_Node := Parent (Insert_Node);
18489
               end loop;
18490
 
18491
               --  Why would Type_Decl not be present???  Without this test,
18492
               --  short regression tests fail.
18493
 
18494
               if Present (Insert_Node) then
18495
 
18496
                  --  Case of loop statement. Verify that the range is part
18497
                  --  of the subtype indication of the iteration scheme.
18498
 
18499
                  if Nkind (Insert_Node) = N_Loop_Statement then
18500
                     declare
18501
                        Indic : Node_Id;
18502
 
18503
                     begin
18504
                        Indic := Parent (R);
18505
                        while Present (Indic)
18506
                          and then Nkind (Indic) /= N_Subtype_Indication
18507
                        loop
18508
                           Indic := Parent (Indic);
18509
                        end loop;
18510
 
18511
                        if Present (Indic) then
18512
                           Def_Id := Etype (Subtype_Mark (Indic));
18513
 
18514
                           Insert_Range_Checks
18515
                             (R_Checks,
18516
                              Insert_Node,
18517
                              Def_Id,
18518
                              Sloc (Insert_Node),
18519
                              R,
18520
                              Do_Before => True);
18521
                        end if;
18522
                     end;
18523
 
18524
                  --  Insertion before a declaration. If the declaration
18525
                  --  includes discriminants, the list of applicable checks
18526
                  --  is given by the caller.
18527
 
18528
                  elsif Nkind (Insert_Node) in N_Declaration then
18529
                     Def_Id := Defining_Identifier (Insert_Node);
18530
 
18531
                     if (Ekind (Def_Id) = E_Record_Type
18532
                          and then Depends_On_Discriminant (R))
18533
                       or else
18534
                        (Ekind (Def_Id) = E_Protected_Type
18535
                          and then Has_Discriminants (Def_Id))
18536
                     then
18537
                        Append_Range_Checks
18538
                          (R_Checks,
18539
                            Check_List, Def_Id, Sloc (Insert_Node), R);
18540
 
18541
                     else
18542
                        Insert_Range_Checks
18543
                          (R_Checks,
18544
                            Insert_Node, Def_Id, Sloc (Insert_Node), R);
18545
 
18546
                     end if;
18547
 
18548
                  --  Insertion before a statement. Range appears in the
18549
                  --  context of a quantified expression. Insertion will
18550
                  --  take place when expression is expanded.
18551
 
18552
                  else
18553
                     null;
18554
                  end if;
18555
               end if;
18556
            end if;
18557
         end if;
18558
 
18559
      --  Case of other than an explicit N_Range node
18560
 
18561
      --  The forced evaluation removes side effects from expressions, which
18562
      --  should occur also in Alfa mode. Otherwise, we end up with unexpected
18563
      --  insertions of actions at places where this is not supposed to occur,
18564
      --  e.g. on default parameters of a call.
18565
 
18566
      elsif Expander_Active then
18567
         Get_Index_Bounds (R, Lo, Hi);
18568
         Force_Evaluation (Lo);
18569
         Force_Evaluation (Hi);
18570
      end if;
18571
   end Process_Range_Expr_In_Decl;
18572
 
18573
   --------------------------------------
18574
   -- Process_Real_Range_Specification --
18575
   --------------------------------------
18576
 
18577
   procedure Process_Real_Range_Specification (Def : Node_Id) is
18578
      Spec : constant Node_Id := Real_Range_Specification (Def);
18579
      Lo   : Node_Id;
18580
      Hi   : Node_Id;
18581
      Err  : Boolean := False;
18582
 
18583
      procedure Analyze_Bound (N : Node_Id);
18584
      --  Analyze and check one bound
18585
 
18586
      -------------------
18587
      -- Analyze_Bound --
18588
      -------------------
18589
 
18590
      procedure Analyze_Bound (N : Node_Id) is
18591
      begin
18592
         Analyze_And_Resolve (N, Any_Real);
18593
 
18594
         if not Is_OK_Static_Expression (N) then
18595
            Flag_Non_Static_Expr
18596
              ("bound in real type definition is not static!", N);
18597
            Err := True;
18598
         end if;
18599
      end Analyze_Bound;
18600
 
18601
   --  Start of processing for Process_Real_Range_Specification
18602
 
18603
   begin
18604
      if Present (Spec) then
18605
         Lo := Low_Bound (Spec);
18606
         Hi := High_Bound (Spec);
18607
         Analyze_Bound (Lo);
18608
         Analyze_Bound (Hi);
18609
 
18610
         --  If error, clear away junk range specification
18611
 
18612
         if Err then
18613
            Set_Real_Range_Specification (Def, Empty);
18614
         end if;
18615
      end if;
18616
   end Process_Real_Range_Specification;
18617
 
18618
   ---------------------
18619
   -- Process_Subtype --
18620
   ---------------------
18621
 
18622
   function Process_Subtype
18623
     (S           : Node_Id;
18624
      Related_Nod : Node_Id;
18625
      Related_Id  : Entity_Id := Empty;
18626
      Suffix      : Character := ' ') return Entity_Id
18627
   is
18628
      P               : Node_Id;
18629
      Def_Id          : Entity_Id;
18630
      Error_Node      : Node_Id;
18631
      Full_View_Id    : Entity_Id;
18632
      Subtype_Mark_Id : Entity_Id;
18633
 
18634
      May_Have_Null_Exclusion : Boolean;
18635
 
18636
      procedure Check_Incomplete (T : Entity_Id);
18637
      --  Called to verify that an incomplete type is not used prematurely
18638
 
18639
      ----------------------
18640
      -- Check_Incomplete --
18641
      ----------------------
18642
 
18643
      procedure Check_Incomplete (T : Entity_Id) is
18644
      begin
18645
         --  Ada 2005 (AI-412): Incomplete subtypes are legal
18646
 
18647
         if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
18648
           and then
18649
             not (Ada_Version >= Ada_2005
18650
                    and then
18651
                       (Nkind (Parent (T)) = N_Subtype_Declaration
18652
                          or else
18653
                            (Nkind (Parent (T)) = N_Subtype_Indication
18654
                               and then Nkind (Parent (Parent (T))) =
18655
                                          N_Subtype_Declaration)))
18656
         then
18657
            Error_Msg_N ("invalid use of type before its full declaration", T);
18658
         end if;
18659
      end Check_Incomplete;
18660
 
18661
   --  Start of processing for Process_Subtype
18662
 
18663
   begin
18664
      --  Case of no constraints present
18665
 
18666
      if Nkind (S) /= N_Subtype_Indication then
18667
         Find_Type (S);
18668
         Check_Incomplete (S);
18669
         P := Parent (S);
18670
 
18671
         --  Ada 2005 (AI-231): Static check
18672
 
18673
         if Ada_Version >= Ada_2005
18674
           and then Present (P)
18675
           and then Null_Exclusion_Present (P)
18676
           and then Nkind (P) /= N_Access_To_Object_Definition
18677
           and then not Is_Access_Type (Entity (S))
18678
         then
18679
            Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
18680
         end if;
18681
 
18682
         --  The following is ugly, can't we have a range or even a flag???
18683
 
18684
         May_Have_Null_Exclusion :=
18685
           Nkind_In (P, N_Access_Definition,
18686
                        N_Access_Function_Definition,
18687
                        N_Access_Procedure_Definition,
18688
                        N_Access_To_Object_Definition,
18689
                        N_Allocator,
18690
                        N_Component_Definition)
18691
             or else
18692
           Nkind_In (P, N_Derived_Type_Definition,
18693
                        N_Discriminant_Specification,
18694
                        N_Formal_Object_Declaration,
18695
                        N_Object_Declaration,
18696
                        N_Object_Renaming_Declaration,
18697
                        N_Parameter_Specification,
18698
                        N_Subtype_Declaration);
18699
 
18700
         --  Create an Itype that is a duplicate of Entity (S) but with the
18701
         --  null-exclusion attribute.
18702
 
18703
         if May_Have_Null_Exclusion
18704
           and then Is_Access_Type (Entity (S))
18705
           and then Null_Exclusion_Present (P)
18706
 
18707
            --  No need to check the case of an access to object definition.
18708
            --  It is correct to define double not-null pointers.
18709
 
18710
            --  Example:
18711
            --     type Not_Null_Int_Ptr is not null access Integer;
18712
            --     type Acc is not null access Not_Null_Int_Ptr;
18713
 
18714
           and then Nkind (P) /= N_Access_To_Object_Definition
18715
         then
18716
            if Can_Never_Be_Null (Entity (S)) then
18717
               case Nkind (Related_Nod) is
18718
                  when N_Full_Type_Declaration =>
18719
                     if Nkind (Type_Definition (Related_Nod))
18720
                       in N_Array_Type_Definition
18721
                     then
18722
                        Error_Node :=
18723
                          Subtype_Indication
18724
                            (Component_Definition
18725
                             (Type_Definition (Related_Nod)));
18726
                     else
18727
                        Error_Node :=
18728
                          Subtype_Indication (Type_Definition (Related_Nod));
18729
                     end if;
18730
 
18731
                  when N_Subtype_Declaration =>
18732
                     Error_Node := Subtype_Indication (Related_Nod);
18733
 
18734
                  when N_Object_Declaration =>
18735
                     Error_Node := Object_Definition (Related_Nod);
18736
 
18737
                  when N_Component_Declaration =>
18738
                     Error_Node :=
18739
                       Subtype_Indication (Component_Definition (Related_Nod));
18740
 
18741
                  when N_Allocator =>
18742
                     Error_Node := Expression (Related_Nod);
18743
 
18744
                  when others =>
18745
                     pragma Assert (False);
18746
                     Error_Node := Related_Nod;
18747
               end case;
18748
 
18749
               Error_Msg_NE
18750
                 ("`NOT NULL` not allowed (& already excludes null)",
18751
                  Error_Node,
18752
                  Entity (S));
18753
            end if;
18754
 
18755
            Set_Etype  (S,
18756
              Create_Null_Excluding_Itype
18757
                (T           => Entity (S),
18758
                 Related_Nod => P));
18759
            Set_Entity (S, Etype (S));
18760
         end if;
18761
 
18762
         return Entity (S);
18763
 
18764
      --  Case of constraint present, so that we have an N_Subtype_Indication
18765
      --  node (this node is created only if constraints are present).
18766
 
18767
      else
18768
         Find_Type (Subtype_Mark (S));
18769
 
18770
         if Nkind (Parent (S)) /= N_Access_To_Object_Definition
18771
           and then not
18772
            (Nkind (Parent (S)) = N_Subtype_Declaration
18773
              and then Is_Itype (Defining_Identifier (Parent (S))))
18774
         then
18775
            Check_Incomplete (Subtype_Mark (S));
18776
         end if;
18777
 
18778
         P := Parent (S);
18779
         Subtype_Mark_Id := Entity (Subtype_Mark (S));
18780
 
18781
         --  Explicit subtype declaration case
18782
 
18783
         if Nkind (P) = N_Subtype_Declaration then
18784
            Def_Id := Defining_Identifier (P);
18785
 
18786
         --  Explicit derived type definition case
18787
 
18788
         elsif Nkind (P) = N_Derived_Type_Definition then
18789
            Def_Id := Defining_Identifier (Parent (P));
18790
 
18791
         --  Implicit case, the Def_Id must be created as an implicit type.
18792
         --  The one exception arises in the case of concurrent types, array
18793
         --  and access types, where other subsidiary implicit types may be
18794
         --  created and must appear before the main implicit type. In these
18795
         --  cases we leave Def_Id set to Empty as a signal that Create_Itype
18796
         --  has not yet been called to create Def_Id.
18797
 
18798
         else
18799
            if Is_Array_Type (Subtype_Mark_Id)
18800
              or else Is_Concurrent_Type (Subtype_Mark_Id)
18801
              or else Is_Access_Type (Subtype_Mark_Id)
18802
            then
18803
               Def_Id := Empty;
18804
 
18805
            --  For the other cases, we create a new unattached Itype,
18806
            --  and set the indication to ensure it gets attached later.
18807
 
18808
            else
18809
               Def_Id :=
18810
                 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
18811
            end if;
18812
         end if;
18813
 
18814
         --  If the kind of constraint is invalid for this kind of type,
18815
         --  then give an error, and then pretend no constraint was given.
18816
 
18817
         if not Is_Valid_Constraint_Kind
18818
                   (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
18819
         then
18820
            Error_Msg_N
18821
              ("incorrect constraint for this kind of type", Constraint (S));
18822
 
18823
            Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
18824
 
18825
            --  Set Ekind of orphan itype, to prevent cascaded errors
18826
 
18827
            if Present (Def_Id) then
18828
               Set_Ekind (Def_Id, Ekind (Any_Type));
18829
            end if;
18830
 
18831
            --  Make recursive call, having got rid of the bogus constraint
18832
 
18833
            return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
18834
         end if;
18835
 
18836
         --  Remaining processing depends on type. Select on Base_Type kind to
18837
         --  ensure getting to the concrete type kind in the case of a private
18838
         --  subtype (needed when only doing semantic analysis).
18839
 
18840
         case Ekind (Base_Type (Subtype_Mark_Id)) is
18841
            when Access_Kind =>
18842
               Constrain_Access (Def_Id, S, Related_Nod);
18843
 
18844
               if Expander_Active
18845
                 and then  Is_Itype (Designated_Type (Def_Id))
18846
                 and then Nkind (Related_Nod) = N_Subtype_Declaration
18847
                 and then not Is_Incomplete_Type (Designated_Type (Def_Id))
18848
               then
18849
                  Build_Itype_Reference
18850
                    (Designated_Type (Def_Id), Related_Nod);
18851
               end if;
18852
 
18853
            when Array_Kind =>
18854
               Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
18855
 
18856
            when Decimal_Fixed_Point_Kind =>
18857
               Constrain_Decimal (Def_Id, S);
18858
 
18859
            when Enumeration_Kind =>
18860
               Constrain_Enumeration (Def_Id, S);
18861
 
18862
            when Ordinary_Fixed_Point_Kind =>
18863
               Constrain_Ordinary_Fixed (Def_Id, S);
18864
 
18865
            when Float_Kind =>
18866
               Constrain_Float (Def_Id, S);
18867
 
18868
            when Integer_Kind =>
18869
               Constrain_Integer (Def_Id, S);
18870
 
18871
            when E_Record_Type     |
18872
                 E_Record_Subtype  |
18873
                 Class_Wide_Kind   |
18874
                 E_Incomplete_Type =>
18875
               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
18876
 
18877
               if Ekind (Def_Id) = E_Incomplete_Type then
18878
                  Set_Private_Dependents (Def_Id, New_Elmt_List);
18879
               end if;
18880
 
18881
            when Private_Kind =>
18882
               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
18883
               Set_Private_Dependents (Def_Id, New_Elmt_List);
18884
 
18885
               --  In case of an invalid constraint prevent further processing
18886
               --  since the type constructed is missing expected fields.
18887
 
18888
               if Etype (Def_Id) = Any_Type then
18889
                  return Def_Id;
18890
               end if;
18891
 
18892
               --  If the full view is that of a task with discriminants,
18893
               --  we must constrain both the concurrent type and its
18894
               --  corresponding record type. Otherwise we will just propagate
18895
               --  the constraint to the full view, if available.
18896
 
18897
               if Present (Full_View (Subtype_Mark_Id))
18898
                 and then Has_Discriminants (Subtype_Mark_Id)
18899
                 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
18900
               then
18901
                  Full_View_Id :=
18902
                    Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
18903
 
18904
                  Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
18905
                  Constrain_Concurrent (Full_View_Id, S,
18906
                    Related_Nod, Related_Id, Suffix);
18907
                  Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
18908
                  Set_Full_View (Def_Id, Full_View_Id);
18909
 
18910
                  --  Introduce an explicit reference to the private subtype,
18911
                  --  to prevent scope anomalies in gigi if first use appears
18912
                  --  in a nested context, e.g. a later function body.
18913
                  --  Should this be generated in other contexts than a full
18914
                  --  type declaration?
18915
 
18916
                  if Is_Itype (Def_Id)
18917
                    and then
18918
                      Nkind (Parent (P)) = N_Full_Type_Declaration
18919
                  then
18920
                     Build_Itype_Reference (Def_Id, Parent (P));
18921
                  end if;
18922
 
18923
               else
18924
                  Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
18925
               end if;
18926
 
18927
            when Concurrent_Kind  =>
18928
               Constrain_Concurrent (Def_Id, S,
18929
                 Related_Nod, Related_Id, Suffix);
18930
 
18931
            when others =>
18932
               Error_Msg_N ("invalid subtype mark in subtype indication", S);
18933
         end case;
18934
 
18935
         --  Size and Convention are always inherited from the base type
18936
 
18937
         Set_Size_Info  (Def_Id,            (Subtype_Mark_Id));
18938
         Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
18939
 
18940
         return Def_Id;
18941
      end if;
18942
   end Process_Subtype;
18943
 
18944
   ---------------------------------------
18945
   -- Check_Anonymous_Access_Components --
18946
   ---------------------------------------
18947
 
18948
   procedure Check_Anonymous_Access_Components
18949
      (Typ_Decl  : Node_Id;
18950
       Typ       : Entity_Id;
18951
       Prev      : Entity_Id;
18952
       Comp_List : Node_Id)
18953
   is
18954
      Loc         : constant Source_Ptr := Sloc (Typ_Decl);
18955
      Anon_Access : Entity_Id;
18956
      Acc_Def     : Node_Id;
18957
      Comp        : Node_Id;
18958
      Comp_Def    : Node_Id;
18959
      Decl        : Node_Id;
18960
      Type_Def    : Node_Id;
18961
 
18962
      procedure Build_Incomplete_Type_Declaration;
18963
      --  If the record type contains components that include an access to the
18964
      --  current record, then create an incomplete type declaration for the
18965
      --  record, to be used as the designated type of the anonymous access.
18966
      --  This is done only once, and only if there is no previous partial
18967
      --  view of the type.
18968
 
18969
      function Designates_T (Subt : Node_Id) return Boolean;
18970
      --  Check whether a node designates the enclosing record type, or 'Class
18971
      --  of that type
18972
 
18973
      function Mentions_T (Acc_Def : Node_Id) return Boolean;
18974
      --  Check whether an access definition includes a reference to
18975
      --  the enclosing record type. The reference can be a subtype mark
18976
      --  in the access definition itself, a 'Class attribute reference, or
18977
      --  recursively a reference appearing in a parameter specification
18978
      --  or result definition of an access_to_subprogram definition.
18979
 
18980
      --------------------------------------
18981
      -- Build_Incomplete_Type_Declaration --
18982
      --------------------------------------
18983
 
18984
      procedure Build_Incomplete_Type_Declaration is
18985
         Decl  : Node_Id;
18986
         Inc_T : Entity_Id;
18987
         H     : Entity_Id;
18988
 
18989
         --  Is_Tagged indicates whether the type is tagged. It is tagged if
18990
         --  it's "is new ... with record" or else "is tagged record ...".
18991
 
18992
         Is_Tagged : constant Boolean :=
18993
             (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
18994
                 and then
18995
                   Present
18996
                     (Record_Extension_Part (Type_Definition (Typ_Decl))))
18997
           or else
18998
             (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
18999
                 and then Tagged_Present (Type_Definition (Typ_Decl)));
19000
 
19001
      begin
19002
         --  If there is a previous partial view, no need to create a new one
19003
         --  If the partial view, given by Prev, is incomplete,  If Prev is
19004
         --  a private declaration, full declaration is flagged accordingly.
19005
 
19006
         if Prev /= Typ then
19007
            if Is_Tagged then
19008
               Make_Class_Wide_Type (Prev);
19009
               Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
19010
               Set_Etype (Class_Wide_Type (Typ), Typ);
19011
            end if;
19012
 
19013
            return;
19014
 
19015
         elsif Has_Private_Declaration (Typ) then
19016
 
19017
            --  If we refer to T'Class inside T, and T is the completion of a
19018
            --  private type, then we need to make sure the class-wide type
19019
            --  exists.
19020
 
19021
            if Is_Tagged then
19022
               Make_Class_Wide_Type (Typ);
19023
            end if;
19024
 
19025
            return;
19026
 
19027
         --  If there was a previous anonymous access type, the incomplete
19028
         --  type declaration will have been created already.
19029
 
19030
         elsif Present (Current_Entity (Typ))
19031
           and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
19032
           and then Full_View (Current_Entity (Typ)) = Typ
19033
         then
19034
            if Is_Tagged
19035
              and then Comes_From_Source (Current_Entity (Typ))
19036
              and then not Is_Tagged_Type (Current_Entity (Typ))
19037
            then
19038
               Make_Class_Wide_Type (Typ);
19039
               Error_Msg_N
19040
                 ("incomplete view of tagged type should be declared tagged?",
19041
                  Parent (Current_Entity (Typ)));
19042
            end if;
19043
            return;
19044
 
19045
         else
19046
            Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
19047
            Decl  := Make_Incomplete_Type_Declaration (Loc, Inc_T);
19048
 
19049
            --  Type has already been inserted into the current scope. Remove
19050
            --  it, and add incomplete declaration for type, so that subsequent
19051
            --  anonymous access types can use it. The entity is unchained from
19052
            --  the homonym list and from immediate visibility. After analysis,
19053
            --  the entity in the incomplete declaration becomes immediately
19054
            --  visible in the record declaration that follows.
19055
 
19056
            H := Current_Entity (Typ);
19057
 
19058
            if H = Typ then
19059
               Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
19060
            else
19061
               while Present (H)
19062
                 and then Homonym (H) /= Typ
19063
               loop
19064
                  H := Homonym (Typ);
19065
               end loop;
19066
 
19067
               Set_Homonym (H, Homonym (Typ));
19068
            end if;
19069
 
19070
            Insert_Before (Typ_Decl, Decl);
19071
            Analyze (Decl);
19072
            Set_Full_View (Inc_T, Typ);
19073
 
19074
            if Is_Tagged then
19075
 
19076
               --  Create a common class-wide type for both views, and set the
19077
               --  Etype of the class-wide type to the full view.
19078
 
19079
               Make_Class_Wide_Type (Inc_T);
19080
               Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
19081
               Set_Etype (Class_Wide_Type (Typ), Typ);
19082
            end if;
19083
         end if;
19084
      end Build_Incomplete_Type_Declaration;
19085
 
19086
      ------------------
19087
      -- Designates_T --
19088
      ------------------
19089
 
19090
      function Designates_T (Subt : Node_Id) return Boolean is
19091
         Type_Id : constant Name_Id := Chars (Typ);
19092
 
19093
         function Names_T (Nam : Node_Id) return Boolean;
19094
         --  The record type has not been introduced in the current scope
19095
         --  yet, so we must examine the name of the type itself, either
19096
         --  an identifier T, or an expanded name of the form P.T, where
19097
         --  P denotes the current scope.
19098
 
19099
         -------------
19100
         -- Names_T --
19101
         -------------
19102
 
19103
         function Names_T (Nam : Node_Id) return Boolean is
19104
         begin
19105
            if Nkind (Nam) = N_Identifier then
19106
               return Chars (Nam) = Type_Id;
19107
 
19108
            elsif Nkind (Nam) = N_Selected_Component then
19109
               if Chars (Selector_Name (Nam)) = Type_Id then
19110
                  if Nkind (Prefix (Nam)) = N_Identifier then
19111
                     return Chars (Prefix (Nam)) = Chars (Current_Scope);
19112
 
19113
                  elsif Nkind (Prefix (Nam)) = N_Selected_Component then
19114
                     return Chars (Selector_Name (Prefix (Nam))) =
19115
                            Chars (Current_Scope);
19116
                  else
19117
                     return False;
19118
                  end if;
19119
 
19120
               else
19121
                  return False;
19122
               end if;
19123
 
19124
            else
19125
               return False;
19126
            end if;
19127
         end Names_T;
19128
 
19129
      --  Start of processing for Designates_T
19130
 
19131
      begin
19132
         if Nkind (Subt) = N_Identifier then
19133
            return Chars (Subt) = Type_Id;
19134
 
19135
            --  Reference can be through an expanded name which has not been
19136
            --  analyzed yet, and which designates enclosing scopes.
19137
 
19138
         elsif Nkind (Subt) = N_Selected_Component then
19139
            if Names_T (Subt) then
19140
               return True;
19141
 
19142
            --  Otherwise it must denote an entity that is already visible.
19143
            --  The access definition may name a subtype of the enclosing
19144
            --  type, if there is a previous incomplete declaration for it.
19145
 
19146
            else
19147
               Find_Selected_Component (Subt);
19148
               return
19149
                 Is_Entity_Name (Subt)
19150
                   and then Scope (Entity (Subt)) = Current_Scope
19151
                   and then
19152
                     (Chars (Base_Type (Entity (Subt))) = Type_Id
19153
                       or else
19154
                         (Is_Class_Wide_Type (Entity (Subt))
19155
                           and then
19156
                           Chars (Etype (Base_Type (Entity (Subt)))) =
19157
                                                                  Type_Id));
19158
            end if;
19159
 
19160
         --  A reference to the current type may appear as the prefix of
19161
         --  a 'Class attribute.
19162
 
19163
         elsif Nkind (Subt) = N_Attribute_Reference
19164
           and then Attribute_Name (Subt) = Name_Class
19165
         then
19166
            return Names_T (Prefix (Subt));
19167
 
19168
         else
19169
            return False;
19170
         end if;
19171
      end Designates_T;
19172
 
19173
      ----------------
19174
      -- Mentions_T --
19175
      ----------------
19176
 
19177
      function Mentions_T (Acc_Def : Node_Id) return Boolean is
19178
         Param_Spec : Node_Id;
19179
 
19180
         Acc_Subprg : constant Node_Id :=
19181
                        Access_To_Subprogram_Definition (Acc_Def);
19182
 
19183
      begin
19184
         if No (Acc_Subprg) then
19185
            return Designates_T (Subtype_Mark (Acc_Def));
19186
         end if;
19187
 
19188
         --  Component is an access_to_subprogram: examine its formals,
19189
         --  and result definition in the case of an access_to_function.
19190
 
19191
         Param_Spec := First (Parameter_Specifications (Acc_Subprg));
19192
         while Present (Param_Spec) loop
19193
            if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
19194
              and then Mentions_T (Parameter_Type (Param_Spec))
19195
            then
19196
               return True;
19197
 
19198
            elsif Designates_T (Parameter_Type (Param_Spec)) then
19199
               return True;
19200
            end if;
19201
 
19202
            Next (Param_Spec);
19203
         end loop;
19204
 
19205
         if Nkind (Acc_Subprg) = N_Access_Function_Definition then
19206
            if Nkind (Result_Definition (Acc_Subprg)) =
19207
                 N_Access_Definition
19208
            then
19209
               return Mentions_T (Result_Definition (Acc_Subprg));
19210
            else
19211
               return Designates_T (Result_Definition (Acc_Subprg));
19212
            end if;
19213
         end if;
19214
 
19215
         return False;
19216
      end Mentions_T;
19217
 
19218
   --  Start of processing for Check_Anonymous_Access_Components
19219
 
19220
   begin
19221
      if No (Comp_List) then
19222
         return;
19223
      end if;
19224
 
19225
      Comp := First (Component_Items (Comp_List));
19226
      while Present (Comp) loop
19227
         if Nkind (Comp) = N_Component_Declaration
19228
           and then Present
19229
             (Access_Definition (Component_Definition (Comp)))
19230
           and then
19231
             Mentions_T (Access_Definition (Component_Definition (Comp)))
19232
         then
19233
            Comp_Def := Component_Definition (Comp);
19234
            Acc_Def :=
19235
              Access_To_Subprogram_Definition
19236
                (Access_Definition (Comp_Def));
19237
 
19238
            Build_Incomplete_Type_Declaration;
19239
            Anon_Access := Make_Temporary (Loc, 'S');
19240
 
19241
            --  Create a declaration for the anonymous access type: either
19242
            --  an access_to_object or an access_to_subprogram.
19243
 
19244
            if Present (Acc_Def) then
19245
               if Nkind (Acc_Def) = N_Access_Function_Definition then
19246
                  Type_Def :=
19247
                    Make_Access_Function_Definition (Loc,
19248
                      Parameter_Specifications =>
19249
                        Parameter_Specifications (Acc_Def),
19250
                      Result_Definition => Result_Definition (Acc_Def));
19251
               else
19252
                  Type_Def :=
19253
                    Make_Access_Procedure_Definition (Loc,
19254
                      Parameter_Specifications =>
19255
                        Parameter_Specifications (Acc_Def));
19256
               end if;
19257
 
19258
            else
19259
               Type_Def :=
19260
                 Make_Access_To_Object_Definition (Loc,
19261
                   Subtype_Indication =>
19262
                      Relocate_Node
19263
                        (Subtype_Mark
19264
                          (Access_Definition (Comp_Def))));
19265
 
19266
               Set_Constant_Present
19267
                 (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
19268
               Set_All_Present
19269
                 (Type_Def, All_Present (Access_Definition (Comp_Def)));
19270
            end if;
19271
 
19272
            Set_Null_Exclusion_Present
19273
              (Type_Def,
19274
               Null_Exclusion_Present (Access_Definition (Comp_Def)));
19275
 
19276
            Decl :=
19277
              Make_Full_Type_Declaration (Loc,
19278
                Defining_Identifier => Anon_Access,
19279
                Type_Definition     => Type_Def);
19280
 
19281
            Insert_Before (Typ_Decl, Decl);
19282
            Analyze (Decl);
19283
 
19284
            --  If an access to subprogram, create the extra formals
19285
 
19286
            if Present (Acc_Def) then
19287
               Create_Extra_Formals (Designated_Type (Anon_Access));
19288
 
19289
            --  If an access to object, preserve entity of designated type,
19290
            --  for ASIS use, before rewriting the component definition.
19291
 
19292
            else
19293
               declare
19294
                  Desig : Entity_Id;
19295
 
19296
               begin
19297
                  Desig := Entity (Subtype_Indication (Type_Def));
19298
 
19299
                  --  If the access definition is to the current  record,
19300
                  --  the visible entity at this point is an  incomplete
19301
                  --  type. Retrieve the full view to simplify  ASIS queries
19302
 
19303
                  if Ekind (Desig) = E_Incomplete_Type then
19304
                     Desig := Full_View (Desig);
19305
                  end if;
19306
 
19307
                  Set_Entity
19308
                    (Subtype_Mark (Access_Definition  (Comp_Def)), Desig);
19309
               end;
19310
            end if;
19311
 
19312
            Rewrite (Comp_Def,
19313
              Make_Component_Definition (Loc,
19314
                Subtype_Indication =>
19315
               New_Occurrence_Of (Anon_Access, Loc)));
19316
 
19317
            if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
19318
               Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
19319
            else
19320
               Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
19321
            end if;
19322
 
19323
            Set_Is_Local_Anonymous_Access (Anon_Access);
19324
         end if;
19325
 
19326
         Next (Comp);
19327
      end loop;
19328
 
19329
      if Present (Variant_Part (Comp_List)) then
19330
         declare
19331
            V : Node_Id;
19332
         begin
19333
            V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
19334
            while Present (V) loop
19335
               Check_Anonymous_Access_Components
19336
                 (Typ_Decl, Typ, Prev, Component_List (V));
19337
               Next_Non_Pragma (V);
19338
            end loop;
19339
         end;
19340
      end if;
19341
   end Check_Anonymous_Access_Components;
19342
 
19343
   --------------------------------
19344
   -- Preanalyze_Spec_Expression --
19345
   --------------------------------
19346
 
19347
   procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
19348
      Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
19349
   begin
19350
      In_Spec_Expression := True;
19351
      Preanalyze_And_Resolve (N, T);
19352
      In_Spec_Expression := Save_In_Spec_Expression;
19353
   end Preanalyze_Spec_Expression;
19354
 
19355
   -----------------------------
19356
   -- Record_Type_Declaration --
19357
   -----------------------------
19358
 
19359
   procedure Record_Type_Declaration
19360
     (T    : Entity_Id;
19361
      N    : Node_Id;
19362
      Prev : Entity_Id)
19363
   is
19364
      Def       : constant Node_Id := Type_Definition (N);
19365
      Is_Tagged : Boolean;
19366
      Tag_Comp  : Entity_Id;
19367
 
19368
   begin
19369
      --  These flags must be initialized before calling Process_Discriminants
19370
      --  because this routine makes use of them.
19371
 
19372
      Set_Ekind             (T, E_Record_Type);
19373
      Set_Etype             (T, T);
19374
      Init_Size_Align       (T);
19375
      Set_Interfaces        (T, No_Elist);
19376
      Set_Stored_Constraint (T, No_Elist);
19377
 
19378
      --  Normal case
19379
 
19380
      if Ada_Version < Ada_2005
19381
        or else not Interface_Present (Def)
19382
      then
19383
         if Limited_Present (Def) then
19384
            Check_SPARK_Restriction ("limited is not allowed", N);
19385
         end if;
19386
 
19387
         if Abstract_Present (Def) then
19388
            Check_SPARK_Restriction ("abstract is not allowed", N);
19389
         end if;
19390
 
19391
         --  The flag Is_Tagged_Type might have already been set by
19392
         --  Find_Type_Name if it detected an error for declaration T. This
19393
         --  arises in the case of private tagged types where the full view
19394
         --  omits the word tagged.
19395
 
19396
         Is_Tagged :=
19397
           Tagged_Present (Def)
19398
             or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
19399
 
19400
         Set_Is_Tagged_Type      (T, Is_Tagged);
19401
         Set_Is_Limited_Record   (T, Limited_Present (Def));
19402
 
19403
         --  Type is abstract if full declaration carries keyword, or if
19404
         --  previous partial view did.
19405
 
19406
         Set_Is_Abstract_Type    (T, Is_Abstract_Type (T)
19407
                                      or else Abstract_Present (Def));
19408
 
19409
      else
19410
         Check_SPARK_Restriction ("interface is not allowed", N);
19411
 
19412
         Is_Tagged := True;
19413
         Analyze_Interface_Declaration (T, Def);
19414
 
19415
         if Present (Discriminant_Specifications (N)) then
19416
            Error_Msg_N
19417
              ("interface types cannot have discriminants",
19418
                Defining_Identifier
19419
                  (First (Discriminant_Specifications (N))));
19420
         end if;
19421
      end if;
19422
 
19423
      --  First pass: if there are self-referential access components,
19424
      --  create the required anonymous access type declarations, and if
19425
      --  need be an incomplete type declaration for T itself.
19426
 
19427
      Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def));
19428
 
19429
      if Ada_Version >= Ada_2005
19430
        and then Present (Interface_List (Def))
19431
      then
19432
         Check_Interfaces (N, Def);
19433
 
19434
         declare
19435
            Ifaces_List : Elist_Id;
19436
 
19437
         begin
19438
            --  Ada 2005 (AI-251): Collect the list of progenitors that are not
19439
            --  already in the parents.
19440
 
19441
            Collect_Interfaces
19442
              (T               => T,
19443
               Ifaces_List     => Ifaces_List,
19444
               Exclude_Parents => True);
19445
 
19446
            Set_Interfaces (T, Ifaces_List);
19447
         end;
19448
      end if;
19449
 
19450
      --  Records constitute a scope for the component declarations within.
19451
      --  The scope is created prior to the processing of these declarations.
19452
      --  Discriminants are processed first, so that they are visible when
19453
      --  processing the other components. The Ekind of the record type itself
19454
      --  is set to E_Record_Type (subtypes appear as E_Record_Subtype).
19455
 
19456
      --  Enter record scope
19457
 
19458
      Push_Scope (T);
19459
 
19460
      --  If an incomplete or private type declaration was already given for
19461
      --  the type, then this scope already exists, and the discriminants have
19462
      --  been declared within. We must verify that the full declaration
19463
      --  matches the incomplete one.
19464
 
19465
      Check_Or_Process_Discriminants (N, T, Prev);
19466
 
19467
      Set_Is_Constrained     (T, not Has_Discriminants (T));
19468
      Set_Has_Delayed_Freeze (T, True);
19469
 
19470
      --  For tagged types add a manually analyzed component corresponding
19471
      --  to the component _tag, the corresponding piece of tree will be
19472
      --  expanded as part of the freezing actions if it is not a CPP_Class.
19473
 
19474
      if Is_Tagged then
19475
 
19476
         --  Do not add the tag unless we are in expansion mode
19477
 
19478
         if Expander_Active then
19479
            Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
19480
            Enter_Name (Tag_Comp);
19481
 
19482
            Set_Ekind                     (Tag_Comp, E_Component);
19483
            Set_Is_Tag                    (Tag_Comp);
19484
            Set_Is_Aliased                (Tag_Comp);
19485
            Set_Etype                     (Tag_Comp, RTE (RE_Tag));
19486
            Set_DT_Entry_Count            (Tag_Comp, No_Uint);
19487
            Set_Original_Record_Component (Tag_Comp, Tag_Comp);
19488
            Init_Component_Location       (Tag_Comp);
19489
 
19490
            --  Ada 2005 (AI-251): Addition of the Tag corresponding to all the
19491
            --  implemented interfaces.
19492
 
19493
            if Has_Interfaces (T) then
19494
               Add_Interface_Tag_Components (N, T);
19495
            end if;
19496
         end if;
19497
 
19498
         Make_Class_Wide_Type (T);
19499
         Set_Direct_Primitive_Operations (T, New_Elmt_List);
19500
      end if;
19501
 
19502
      --  We must suppress range checks when processing record components in
19503
      --  the presence of discriminants, since we don't want spurious checks to
19504
      --  be generated during their analysis, but Suppress_Range_Checks flags
19505
      --  must be reset the after processing the record definition.
19506
 
19507
      --  Note: this is the only use of Kill_Range_Checks, and is a bit odd,
19508
      --  couldn't we just use the normal range check suppression method here.
19509
      --  That would seem cleaner ???
19510
 
19511
      if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then
19512
         Set_Kill_Range_Checks (T, True);
19513
         Record_Type_Definition (Def, Prev);
19514
         Set_Kill_Range_Checks (T, False);
19515
      else
19516
         Record_Type_Definition (Def, Prev);
19517
      end if;
19518
 
19519
      --  Exit from record scope
19520
 
19521
      End_Scope;
19522
 
19523
      --  Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all
19524
      --  the implemented interfaces and associate them an aliased entity.
19525
 
19526
      if Is_Tagged
19527
        and then not Is_Empty_List (Interface_List (Def))
19528
      then
19529
         Derive_Progenitor_Subprograms (T, T);
19530
      end if;
19531
   end Record_Type_Declaration;
19532
 
19533
   ----------------------------
19534
   -- Record_Type_Definition --
19535
   ----------------------------
19536
 
19537
   procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is
19538
      Component          : Entity_Id;
19539
      Ctrl_Components    : Boolean := False;
19540
      Final_Storage_Only : Boolean;
19541
      T                  : Entity_Id;
19542
 
19543
   begin
19544
      if Ekind (Prev_T) = E_Incomplete_Type then
19545
         T := Full_View (Prev_T);
19546
      else
19547
         T := Prev_T;
19548
      end if;
19549
 
19550
      --  In SPARK, tagged types and type extensions may only be declared in
19551
      --  the specification of library unit packages.
19552
 
19553
      if Present (Def) and then Is_Tagged_Type (T) then
19554
         declare
19555
            Typ  : Node_Id;
19556
            Ctxt : Node_Id;
19557
 
19558
         begin
19559
            if Nkind (Parent (Def)) = N_Full_Type_Declaration then
19560
               Typ := Parent (Def);
19561
            else
19562
               pragma Assert
19563
                 (Nkind (Parent (Def)) = N_Derived_Type_Definition);
19564
               Typ := Parent (Parent (Def));
19565
            end if;
19566
 
19567
            Ctxt := Parent (Typ);
19568
 
19569
            if Nkind (Ctxt) = N_Package_Body
19570
              and then Nkind (Parent (Ctxt)) = N_Compilation_Unit
19571
            then
19572
               Check_SPARK_Restriction
19573
                 ("type should be defined in package specification", Typ);
19574
 
19575
            elsif Nkind (Ctxt) /= N_Package_Specification
19576
              or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit
19577
            then
19578
               Check_SPARK_Restriction
19579
                 ("type should be defined in library unit package", Typ);
19580
            end if;
19581
         end;
19582
      end if;
19583
 
19584
      Final_Storage_Only := not Is_Controlled (T);
19585
 
19586
      --  Ada 2005: check whether an explicit Limited is present in a derived
19587
      --  type declaration.
19588
 
19589
      if Nkind (Parent (Def)) = N_Derived_Type_Definition
19590
        and then Limited_Present (Parent (Def))
19591
      then
19592
         Set_Is_Limited_Record (T);
19593
      end if;
19594
 
19595
      --  If the component list of a record type is defined by the reserved
19596
      --  word null and there is no discriminant part, then the record type has
19597
      --  no components and all records of the type are null records (RM 3.7)
19598
      --  This procedure is also called to process the extension part of a
19599
      --  record extension, in which case the current scope may have inherited
19600
      --  components.
19601
 
19602
      if No (Def)
19603
        or else No (Component_List (Def))
19604
        or else Null_Present (Component_List (Def))
19605
      then
19606
         if not Is_Tagged_Type (T) then
19607
            Check_SPARK_Restriction ("non-tagged record cannot be null", Def);
19608
         end if;
19609
 
19610
      else
19611
         Analyze_Declarations (Component_Items (Component_List (Def)));
19612
 
19613
         if Present (Variant_Part (Component_List (Def))) then
19614
            Check_SPARK_Restriction ("variant part is not allowed", Def);
19615
            Analyze (Variant_Part (Component_List (Def)));
19616
         end if;
19617
      end if;
19618
 
19619
      --  After completing the semantic analysis of the record definition,
19620
      --  record components, both new and inherited, are accessible. Set their
19621
      --  kind accordingly. Exclude malformed itypes from illegal declarations,
19622
      --  whose Ekind may be void.
19623
 
19624
      Component := First_Entity (Current_Scope);
19625
      while Present (Component) loop
19626
         if Ekind (Component) = E_Void
19627
           and then not Is_Itype (Component)
19628
         then
19629
            Set_Ekind (Component, E_Component);
19630
            Init_Component_Location (Component);
19631
         end if;
19632
 
19633
         if Has_Task (Etype (Component)) then
19634
            Set_Has_Task (T);
19635
         end if;
19636
 
19637
         if Ekind (Component) /= E_Component then
19638
            null;
19639
 
19640
         --  Do not set Has_Controlled_Component on a class-wide equivalent
19641
         --  type. See Make_CW_Equivalent_Type.
19642
 
19643
         elsif not Is_Class_Wide_Equivalent_Type (T)
19644
           and then (Has_Controlled_Component (Etype (Component))
19645
                      or else (Chars (Component) /= Name_uParent
19646
                                and then Is_Controlled (Etype (Component))))
19647
         then
19648
            Set_Has_Controlled_Component (T, True);
19649
            Final_Storage_Only :=
19650
              Final_Storage_Only
19651
                and then Finalize_Storage_Only (Etype (Component));
19652
            Ctrl_Components := True;
19653
         end if;
19654
 
19655
         Next_Entity (Component);
19656
      end loop;
19657
 
19658
      --  A Type is Finalize_Storage_Only only if all its controlled components
19659
      --  are also.
19660
 
19661
      if Ctrl_Components then
19662
         Set_Finalize_Storage_Only (T, Final_Storage_Only);
19663
      end if;
19664
 
19665
      --  Place reference to end record on the proper entity, which may
19666
      --  be a partial view.
19667
 
19668
      if Present (Def) then
19669
         Process_End_Label (Def, 'e', Prev_T);
19670
      end if;
19671
   end Record_Type_Definition;
19672
 
19673
   ------------------------
19674
   -- Replace_Components --
19675
   ------------------------
19676
 
19677
   procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
19678
      function Process (N : Node_Id) return Traverse_Result;
19679
 
19680
      -------------
19681
      -- Process --
19682
      -------------
19683
 
19684
      function Process (N : Node_Id) return Traverse_Result is
19685
         Comp : Entity_Id;
19686
 
19687
      begin
19688
         if Nkind (N) = N_Discriminant_Specification then
19689
            Comp := First_Discriminant (Typ);
19690
            while Present (Comp) loop
19691
               if Chars (Comp) = Chars (Defining_Identifier (N)) then
19692
                  Set_Defining_Identifier (N, Comp);
19693
                  exit;
19694
               end if;
19695
 
19696
               Next_Discriminant (Comp);
19697
            end loop;
19698
 
19699
         elsif Nkind (N) = N_Component_Declaration then
19700
            Comp := First_Component (Typ);
19701
            while Present (Comp) loop
19702
               if Chars (Comp) = Chars (Defining_Identifier (N)) then
19703
                  Set_Defining_Identifier (N, Comp);
19704
                  exit;
19705
               end if;
19706
 
19707
               Next_Component (Comp);
19708
            end loop;
19709
         end if;
19710
 
19711
         return OK;
19712
      end Process;
19713
 
19714
      procedure Replace is new Traverse_Proc (Process);
19715
 
19716
   --  Start of processing for Replace_Components
19717
 
19718
   begin
19719
      Replace (Decl);
19720
   end Replace_Components;
19721
 
19722
   -------------------------------
19723
   -- Set_Completion_Referenced --
19724
   -------------------------------
19725
 
19726
   procedure Set_Completion_Referenced (E : Entity_Id) is
19727
   begin
19728
      --  If in main unit, mark entity that is a completion as referenced,
19729
      --  warnings go on the partial view when needed.
19730
 
19731
      if In_Extended_Main_Source_Unit (E) then
19732
         Set_Referenced (E);
19733
      end if;
19734
   end Set_Completion_Referenced;
19735
 
19736
   ---------------------
19737
   -- Set_Fixed_Range --
19738
   ---------------------
19739
 
19740
   --  The range for fixed-point types is complicated by the fact that we
19741
   --  do not know the exact end points at the time of the declaration. This
19742
   --  is true for three reasons:
19743
 
19744
   --     A size clause may affect the fudging of the end-points.
19745
   --     A small clause may affect the values of the end-points.
19746
   --     We try to include the end-points if it does not affect the size.
19747
 
19748
   --  This means that the actual end-points must be established at the
19749
   --  point when the type is frozen. Meanwhile, we first narrow the range
19750
   --  as permitted (so that it will fit if necessary in a small specified
19751
   --  size), and then build a range subtree with these narrowed bounds.
19752
   --  Set_Fixed_Range constructs the range from real literal values, and
19753
   --  sets the range as the Scalar_Range of the given fixed-point type entity.
19754
 
19755
   --  The parent of this range is set to point to the entity so that it is
19756
   --  properly hooked into the tree (unlike normal Scalar_Range entries for
19757
   --  other scalar types, which are just pointers to the range in the
19758
   --  original tree, this would otherwise be an orphan).
19759
 
19760
   --  The tree is left unanalyzed. When the type is frozen, the processing
19761
   --  in Freeze.Freeze_Fixed_Point_Type notices that the range is not
19762
   --  analyzed, and uses this as an indication that it should complete
19763
   --  work on the range (it will know the final small and size values).
19764
 
19765
   procedure Set_Fixed_Range
19766
     (E   : Entity_Id;
19767
      Loc : Source_Ptr;
19768
      Lo  : Ureal;
19769
      Hi  : Ureal)
19770
   is
19771
      S : constant Node_Id :=
19772
            Make_Range (Loc,
19773
              Low_Bound  => Make_Real_Literal (Loc, Lo),
19774
              High_Bound => Make_Real_Literal (Loc, Hi));
19775
   begin
19776
      Set_Scalar_Range (E, S);
19777
      Set_Parent (S, E);
19778
 
19779
      --  Before the freeze point, the bounds of a fixed point are universal
19780
      --  and carry the corresponding type.
19781
 
19782
      Set_Etype (Low_Bound (S),  Universal_Real);
19783
      Set_Etype (High_Bound (S), Universal_Real);
19784
   end Set_Fixed_Range;
19785
 
19786
   ----------------------------------
19787
   -- Set_Scalar_Range_For_Subtype --
19788
   ----------------------------------
19789
 
19790
   procedure Set_Scalar_Range_For_Subtype
19791
     (Def_Id : Entity_Id;
19792
      R      : Node_Id;
19793
      Subt   : Entity_Id)
19794
   is
19795
      Kind : constant Entity_Kind :=  Ekind (Def_Id);
19796
 
19797
   begin
19798
      --  Defend against previous error
19799
 
19800
      if Nkind (R) = N_Error then
19801
         return;
19802
      end if;
19803
 
19804
      Set_Scalar_Range (Def_Id, R);
19805
 
19806
      --  We need to link the range into the tree before resolving it so
19807
      --  that types that are referenced, including importantly the subtype
19808
      --  itself, are properly frozen (Freeze_Expression requires that the
19809
      --  expression be properly linked into the tree). Of course if it is
19810
      --  already linked in, then we do not disturb the current link.
19811
 
19812
      if No (Parent (R)) then
19813
         Set_Parent (R, Def_Id);
19814
      end if;
19815
 
19816
      --  Reset the kind of the subtype during analysis of the range, to
19817
      --  catch possible premature use in the bounds themselves.
19818
 
19819
      Set_Ekind (Def_Id, E_Void);
19820
      Process_Range_Expr_In_Decl (R, Subt);
19821
      Set_Ekind (Def_Id, Kind);
19822
   end Set_Scalar_Range_For_Subtype;
19823
 
19824
   --------------------------------------------------------
19825
   -- Set_Stored_Constraint_From_Discriminant_Constraint --
19826
   --------------------------------------------------------
19827
 
19828
   procedure Set_Stored_Constraint_From_Discriminant_Constraint
19829
     (E : Entity_Id)
19830
   is
19831
   begin
19832
      --  Make sure set if encountered during Expand_To_Stored_Constraint
19833
 
19834
      Set_Stored_Constraint (E, No_Elist);
19835
 
19836
      --  Give it the right value
19837
 
19838
      if Is_Constrained (E) and then Has_Discriminants (E) then
19839
         Set_Stored_Constraint (E,
19840
           Expand_To_Stored_Constraint (E, Discriminant_Constraint (E)));
19841
      end if;
19842
   end Set_Stored_Constraint_From_Discriminant_Constraint;
19843
 
19844
   -------------------------------------
19845
   -- Signed_Integer_Type_Declaration --
19846
   -------------------------------------
19847
 
19848
   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
19849
      Implicit_Base : Entity_Id;
19850
      Base_Typ      : Entity_Id;
19851
      Lo_Val        : Uint;
19852
      Hi_Val        : Uint;
19853
      Errs          : Boolean := False;
19854
      Lo            : Node_Id;
19855
      Hi            : Node_Id;
19856
 
19857
      function Can_Derive_From (E : Entity_Id) return Boolean;
19858
      --  Determine whether given bounds allow derivation from specified type
19859
 
19860
      procedure Check_Bound (Expr : Node_Id);
19861
      --  Check bound to make sure it is integral and static. If not, post
19862
      --  appropriate error message and set Errs flag
19863
 
19864
      ---------------------
19865
      -- Can_Derive_From --
19866
      ---------------------
19867
 
19868
      --  Note we check both bounds against both end values, to deal with
19869
      --  strange types like ones with a range of 0 .. -12341234.
19870
 
19871
      function Can_Derive_From (E : Entity_Id) return Boolean is
19872
         Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
19873
         Hi : constant Uint := Expr_Value (Type_High_Bound (E));
19874
      begin
19875
         return Lo <= Lo_Val and then Lo_Val <= Hi
19876
                  and then
19877
                Lo <= Hi_Val and then Hi_Val <= Hi;
19878
      end Can_Derive_From;
19879
 
19880
      -----------------
19881
      -- Check_Bound --
19882
      -----------------
19883
 
19884
      procedure Check_Bound (Expr : Node_Id) is
19885
      begin
19886
         --  If a range constraint is used as an integer type definition, each
19887
         --  bound of the range must be defined by a static expression of some
19888
         --  integer type, but the two bounds need not have the same integer
19889
         --  type (Negative bounds are allowed.) (RM 3.5.4)
19890
 
19891
         if not Is_Integer_Type (Etype (Expr)) then
19892
            Error_Msg_N
19893
              ("integer type definition bounds must be of integer type", Expr);
19894
            Errs := True;
19895
 
19896
         elsif not Is_OK_Static_Expression (Expr) then
19897
            Flag_Non_Static_Expr
19898
              ("non-static expression used for integer type bound!", Expr);
19899
            Errs := True;
19900
 
19901
         --  The bounds are folded into literals, and we set their type to be
19902
         --  universal, to avoid typing difficulties: we cannot set the type
19903
         --  of the literal to the new type, because this would be a forward
19904
         --  reference for the back end,  and if the original type is user-
19905
         --  defined this can lead to spurious semantic errors (e.g. 2928-003).
19906
 
19907
         else
19908
            if Is_Entity_Name (Expr) then
19909
               Fold_Uint (Expr, Expr_Value (Expr), True);
19910
            end if;
19911
 
19912
            Set_Etype (Expr, Universal_Integer);
19913
         end if;
19914
      end Check_Bound;
19915
 
19916
   --  Start of processing for Signed_Integer_Type_Declaration
19917
 
19918
   begin
19919
      --  Create an anonymous base type
19920
 
19921
      Implicit_Base :=
19922
        Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
19923
 
19924
      --  Analyze and check the bounds, they can be of any integer type
19925
 
19926
      Lo := Low_Bound (Def);
19927
      Hi := High_Bound (Def);
19928
 
19929
      --  Arbitrarily use Integer as the type if either bound had an error
19930
 
19931
      if Hi = Error or else Lo = Error then
19932
         Base_Typ := Any_Integer;
19933
         Set_Error_Posted (T, True);
19934
 
19935
      --  Here both bounds are OK expressions
19936
 
19937
      else
19938
         Analyze_And_Resolve (Lo, Any_Integer);
19939
         Analyze_And_Resolve (Hi, Any_Integer);
19940
 
19941
         Check_Bound (Lo);
19942
         Check_Bound (Hi);
19943
 
19944
         if Errs then
19945
            Hi := Type_High_Bound (Standard_Long_Long_Integer);
19946
            Lo := Type_Low_Bound (Standard_Long_Long_Integer);
19947
         end if;
19948
 
19949
         --  Find type to derive from
19950
 
19951
         Lo_Val := Expr_Value (Lo);
19952
         Hi_Val := Expr_Value (Hi);
19953
 
19954
         if Can_Derive_From (Standard_Short_Short_Integer) then
19955
            Base_Typ := Base_Type (Standard_Short_Short_Integer);
19956
 
19957
         elsif Can_Derive_From (Standard_Short_Integer) then
19958
            Base_Typ := Base_Type (Standard_Short_Integer);
19959
 
19960
         elsif Can_Derive_From (Standard_Integer) then
19961
            Base_Typ := Base_Type (Standard_Integer);
19962
 
19963
         elsif Can_Derive_From (Standard_Long_Integer) then
19964
            Base_Typ := Base_Type (Standard_Long_Integer);
19965
 
19966
         elsif Can_Derive_From (Standard_Long_Long_Integer) then
19967
            Base_Typ := Base_Type (Standard_Long_Long_Integer);
19968
 
19969
         else
19970
            Base_Typ := Base_Type (Standard_Long_Long_Integer);
19971
            Error_Msg_N ("integer type definition bounds out of range", Def);
19972
            Hi := Type_High_Bound (Standard_Long_Long_Integer);
19973
            Lo := Type_Low_Bound (Standard_Long_Long_Integer);
19974
         end if;
19975
      end if;
19976
 
19977
      --  Complete both implicit base and declared first subtype entities
19978
 
19979
      Set_Etype          (Implicit_Base, Base_Typ);
19980
      Set_Size_Info      (Implicit_Base,                (Base_Typ));
19981
      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
19982
      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
19983
 
19984
      Set_Ekind          (T, E_Signed_Integer_Subtype);
19985
      Set_Etype          (T, Implicit_Base);
19986
 
19987
      --  In formal verification mode, restrict the base type's range to the
19988
      --  minimum allowed by RM 3.5.4, namely the smallest symmetric range
19989
      --  around zero with a possible extra negative value that contains the
19990
      --  subtype range. Keep Size, RM_Size and First_Rep_Item info, which
19991
      --  should not be relied upon in formal verification.
19992
 
19993
      if Strict_Alfa_Mode then
19994
         declare
19995
            Sym_Hi_Val : Uint;
19996
            Sym_Lo_Val : Uint;
19997
            Dloc       : constant Source_Ptr := Sloc (Def);
19998
            Lbound     : Node_Id;
19999
            Ubound     : Node_Id;
20000
            Bounds     : Node_Id;
20001
 
20002
         begin
20003
            --  If the subtype range is empty, the smallest base type range
20004
            --  is the symmetric range around zero containing Lo_Val and
20005
            --  Hi_Val.
20006
 
20007
            if UI_Gt (Lo_Val, Hi_Val) then
20008
               Sym_Hi_Val := UI_Max (UI_Abs (Lo_Val), UI_Abs (Hi_Val));
20009
               Sym_Lo_Val := UI_Negate (Sym_Hi_Val);
20010
 
20011
               --  Otherwise, if the subtype range is not empty and Hi_Val has
20012
               --  the largest absolute value, Hi_Val is non negative and the
20013
               --  smallest base type range is the symmetric range around zero
20014
               --  containing Hi_Val.
20015
 
20016
            elsif UI_Le (UI_Abs (Lo_Val), UI_Abs (Hi_Val)) then
20017
               Sym_Hi_Val := Hi_Val;
20018
               Sym_Lo_Val := UI_Negate (Hi_Val);
20019
 
20020
               --  Otherwise, the subtype range is not empty, Lo_Val has the
20021
               --  strictly largest absolute value, Lo_Val is negative and the
20022
               --  smallest base type range is the symmetric range around zero
20023
               --  with an extra negative value Lo_Val.
20024
 
20025
            else
20026
               Sym_Lo_Val := Lo_Val;
20027
               Sym_Hi_Val := UI_Sub (UI_Negate (Lo_Val), Uint_1);
20028
            end if;
20029
 
20030
            Lbound := Make_Integer_Literal (Dloc, Sym_Lo_Val);
20031
            Ubound := Make_Integer_Literal (Dloc, Sym_Hi_Val);
20032
            Set_Is_Static_Expression (Lbound);
20033
            Set_Is_Static_Expression (Ubound);
20034
            Analyze_And_Resolve (Lbound, Any_Integer);
20035
            Analyze_And_Resolve (Ubound, Any_Integer);
20036
 
20037
            Bounds := Make_Range (Dloc, Lbound, Ubound);
20038
            Set_Etype (Bounds, Base_Typ);
20039
 
20040
            Set_Scalar_Range (Implicit_Base, Bounds);
20041
         end;
20042
 
20043
      else
20044
         Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
20045
      end if;
20046
 
20047
      Set_Size_Info      (T,                (Implicit_Base));
20048
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
20049
      Set_Scalar_Range   (T, Def);
20050
      Set_RM_Size        (T, UI_From_Int (Minimum_Size (T)));
20051
      Set_Is_Constrained (T);
20052
   end Signed_Integer_Type_Declaration;
20053
 
20054
end Sem_Ch3;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.