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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch3.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 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-2009, 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_Disp; use Sem_Disp;
60
with Sem_Dist; use Sem_Dist;
61
with Sem_Elim; use Sem_Elim;
62
with Sem_Eval; use Sem_Eval;
63
with Sem_Mech; use Sem_Mech;
64
with Sem_Res;  use Sem_Res;
65
with Sem_Smem; use Sem_Smem;
66
with Sem_Type; use Sem_Type;
67
with Sem_Util; use Sem_Util;
68
with Sem_Warn; use Sem_Warn;
69
with Stand;    use Stand;
70
with Sinfo;    use Sinfo;
71
with Snames;   use Snames;
72
with Targparm; use Targparm;
73
with Tbuild;   use Tbuild;
74
with Ttypes;   use Ttypes;
75
with Uintp;    use Uintp;
76
with Urealp;   use Urealp;
77
 
78
package body Sem_Ch3 is
79
 
80
   -----------------------
81
   -- Local Subprograms --
82
   -----------------------
83
 
84
   procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id);
85
   --  Ada 2005 (AI-251): Add the tag components corresponding to all the
86
   --  abstract interface types implemented by a record type or a derived
87
   --  record type.
88
 
89
   procedure Build_Derived_Type
90
     (N             : Node_Id;
91
      Parent_Type   : Entity_Id;
92
      Derived_Type  : Entity_Id;
93
      Is_Completion : Boolean;
94
      Derive_Subps  : Boolean := True);
95
   --  Create and decorate a Derived_Type given the Parent_Type entity. N is
96
   --  the N_Full_Type_Declaration node containing the derived type definition.
97
   --  Parent_Type is the entity for the parent type in the derived type
98
   --  definition and Derived_Type the actual derived type. Is_Completion must
99
   --  be set to False if Derived_Type is the N_Defining_Identifier node in N
100
   --  (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the
101
   --  completion of a private type declaration. If Is_Completion is set to
102
   --  True, N is the completion of a private type declaration and Derived_Type
103
   --  is different from the defining identifier inside N (i.e. Derived_Type /=
104
   --  Defining_Identifier (N)). Derive_Subps indicates whether the parent
105
   --  subprograms should be derived. The only case where this parameter is
106
   --  False is when Build_Derived_Type is recursively called to process an
107
   --  implicit derived full type for a type derived from a private type (in
108
   --  that case the subprograms must only be derived for the private view of
109
   --  the type).
110
   --
111
   --  ??? These flags need a bit of re-examination and re-documentation:
112
   --  ???  are they both necessary (both seem related to the recursion)?
113
 
114
   procedure Build_Derived_Access_Type
115
     (N            : Node_Id;
116
      Parent_Type  : Entity_Id;
117
      Derived_Type : Entity_Id);
118
   --  Subsidiary procedure to Build_Derived_Type. For a derived access type,
119
   --  create an implicit base if the parent type is constrained or if the
120
   --  subtype indication has a constraint.
121
 
122
   procedure Build_Derived_Array_Type
123
     (N            : Node_Id;
124
      Parent_Type  : Entity_Id;
125
      Derived_Type : Entity_Id);
126
   --  Subsidiary procedure to Build_Derived_Type. For a derived array type,
127
   --  create an implicit base if the parent type is constrained or if the
128
   --  subtype indication has a constraint.
129
 
130
   procedure Build_Derived_Concurrent_Type
131
     (N            : Node_Id;
132
      Parent_Type  : Entity_Id;
133
      Derived_Type : Entity_Id);
134
   --  Subsidiary procedure to Build_Derived_Type. For a derived task or
135
   --  protected type, inherit entries and protected subprograms, check
136
   --  legality of discriminant constraints if any.
137
 
138
   procedure Build_Derived_Enumeration_Type
139
     (N            : Node_Id;
140
      Parent_Type  : Entity_Id;
141
      Derived_Type : Entity_Id);
142
   --  Subsidiary procedure to Build_Derived_Type. For a derived enumeration
143
   --  type, we must create a new list of literals. Types derived from
144
   --  Character and [Wide_]Wide_Character are special-cased.
145
 
146
   procedure Build_Derived_Numeric_Type
147
     (N            : Node_Id;
148
      Parent_Type  : Entity_Id;
149
      Derived_Type : Entity_Id);
150
   --  Subsidiary procedure to Build_Derived_Type. For numeric types, create
151
   --  an anonymous base type, and propagate constraint to subtype if needed.
152
 
153
   procedure Build_Derived_Private_Type
154
     (N             : Node_Id;
155
      Parent_Type   : Entity_Id;
156
      Derived_Type  : Entity_Id;
157
      Is_Completion : Boolean;
158
      Derive_Subps  : Boolean := True);
159
   --  Subsidiary procedure to Build_Derived_Type. This procedure is complex
160
   --  because the parent may or may not have a completion, and the derivation
161
   --  may itself be a completion.
162
 
163
   procedure Build_Derived_Record_Type
164
     (N            : Node_Id;
165
      Parent_Type  : Entity_Id;
166
      Derived_Type : Entity_Id;
167
      Derive_Subps : Boolean := True);
168
   --  Subsidiary procedure for Build_Derived_Type and
169
   --  Analyze_Private_Extension_Declaration used for tagged and untagged
170
   --  record types. All parameters are as in Build_Derived_Type except that
171
   --  N, in addition to being an N_Full_Type_Declaration node, can also be an
172
   --  N_Private_Extension_Declaration node. See the definition of this routine
173
   --  for much more info. Derive_Subps indicates whether subprograms should
174
   --  be derived from the parent type. The only case where Derive_Subps is
175
   --  False is for an implicit derived full type for a type derived from a
176
   --  private type (see Build_Derived_Type).
177
 
178
   procedure Build_Discriminal (Discrim : Entity_Id);
179
   --  Create the discriminal corresponding to discriminant Discrim, that is
180
   --  the parameter corresponding to Discrim to be used in initialization
181
   --  procedures for the type where Discrim is a discriminant. Discriminals
182
   --  are not used during semantic analysis, and are not fully defined
183
   --  entities until expansion. Thus they are not given a scope until
184
   --  initialization procedures are built.
185
 
186
   function Build_Discriminant_Constraints
187
     (T           : Entity_Id;
188
      Def         : Node_Id;
189
      Derived_Def : Boolean := False) return Elist_Id;
190
   --  Validate discriminant constraints and return the list of the constraints
191
   --  in order of discriminant declarations, where T is the discriminated
192
   --  unconstrained type. Def is the N_Subtype_Indication node where the
193
   --  discriminants constraints for T are specified. Derived_Def is True
194
   --  when building the discriminant constraints in a derived type definition
195
   --  of the form "type D (...) is new T (xxx)". In this case T is the parent
196
   --  type and Def is the constraint "(xxx)" on T and this routine sets the
197
   --  Corresponding_Discriminant field of the discriminants in the derived
198
   --  type D to point to the corresponding discriminants in the parent type T.
199
 
200
   procedure Build_Discriminated_Subtype
201
     (T           : Entity_Id;
202
      Def_Id      : Entity_Id;
203
      Elist       : Elist_Id;
204
      Related_Nod : Node_Id;
205
      For_Access  : Boolean := False);
206
   --  Subsidiary procedure to Constrain_Discriminated_Type and to
207
   --  Process_Incomplete_Dependents. Given
208
   --
209
   --     T (a possibly discriminated base type)
210
   --     Def_Id (a very partially built subtype for T),
211
   --
212
   --  the call completes Def_Id to be the appropriate E_*_Subtype.
213
   --
214
   --  The Elist is the list of discriminant constraints if any (it is set
215
   --  to No_Elist if T is not a discriminated type, and to an empty list if
216
   --  T has discriminants but there are no discriminant constraints). The
217
   --  Related_Nod is the same as Decl_Node in Create_Constrained_Components.
218
   --  The For_Access says whether or not this subtype is really constraining
219
   --  an access type. That is its sole purpose is the designated type of an
220
   --  access type -- in which case a Private_Subtype Is_For_Access_Subtype
221
   --  is built to avoid freezing T when the access subtype is frozen.
222
 
223
   function Build_Scalar_Bound
224
     (Bound : Node_Id;
225
      Par_T : Entity_Id;
226
      Der_T : Entity_Id) return Node_Id;
227
   --  The bounds of a derived scalar type are conversions of the bounds of
228
   --  the parent type. Optimize the representation if the bounds are literals.
229
   --  Needs a more complete spec--what are the parameters exactly, and what
230
   --  exactly is the returned value, and how is Bound affected???
231
 
232
   procedure Build_Underlying_Full_View
233
     (N   : Node_Id;
234
      Typ : Entity_Id;
235
      Par : Entity_Id);
236
   --  If the completion of a private type is itself derived from a private
237
   --  type, or if the full view of a private subtype is itself private, the
238
   --  back-end has no way to compute the actual size of this type. We build
239
   --  an internal subtype declaration of the proper parent type to convey
240
   --  this information. This extra mechanism is needed because a full
241
   --  view cannot itself have a full view (it would get clobbered during
242
   --  view exchanges).
243
 
244
   procedure Check_Access_Discriminant_Requires_Limited
245
     (D   : Node_Id;
246
      Loc : Node_Id);
247
   --  Check the restriction that the type to which an access discriminant
248
   --  belongs must be a concurrent type or a descendant of a type with
249
   --  the reserved word 'limited' in its declaration.
250
 
251
   procedure Check_Anonymous_Access_Components
252
      (Typ_Decl  : Node_Id;
253
       Typ       : Entity_Id;
254
       Prev      : Entity_Id;
255
       Comp_List : Node_Id);
256
   --  Ada 2005 AI-382: an access component in a record definition can refer to
257
   --  the enclosing record, in which case it denotes the type itself, and not
258
   --  the current instance of the type. We create an anonymous access type for
259
   --  the component, and flag it as an access to a component, so accessibility
260
   --  checks are properly performed on it. The declaration of the access type
261
   --  is placed ahead of that of the record to prevent order-of-elaboration
262
   --  circularity issues in Gigi. We create an incomplete type for the record
263
   --  declaration, which is the designated type of the anonymous access.
264
 
265
   procedure Check_Delta_Expression (E : Node_Id);
266
   --  Check that the expression represented by E is suitable for use as a
267
   --  delta expression, i.e. it is of real type and is static.
268
 
269
   procedure Check_Digits_Expression (E : Node_Id);
270
   --  Check that the expression represented by E is suitable for use as a
271
   --  digits expression, i.e. it is of integer type, positive and static.
272
 
273
   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
274
   --  Validate the initialization of an object declaration. T is the required
275
   --  type, and Exp is the initialization expression.
276
 
277
   procedure Check_Interfaces (N : Node_Id; Def : Node_Id);
278
   --  Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
279
 
280
   procedure Check_Or_Process_Discriminants
281
     (N    : Node_Id;
282
      T    : Entity_Id;
283
      Prev : Entity_Id := Empty);
284
   --  If T is the full declaration of an incomplete or private type, check the
285
   --  conformance of the discriminants, otherwise process them. Prev is the
286
   --  entity of the partial declaration, if any.
287
 
288
   procedure Check_Real_Bound (Bound : Node_Id);
289
   --  Check given bound for being of real type and static. If not, post an
290
   --  appropriate message, and rewrite the bound with the real literal zero.
291
 
292
   procedure Constant_Redeclaration
293
     (Id : Entity_Id;
294
      N  : Node_Id;
295
      T  : out Entity_Id);
296
   --  Various checks on legality of full declaration of deferred constant.
297
   --  Id is the entity for the redeclaration, N is the N_Object_Declaration,
298
   --  node. The caller has not yet set any attributes of this entity.
299
 
300
   function Contain_Interface
301
     (Iface  : Entity_Id;
302
      Ifaces : Elist_Id) return Boolean;
303
   --  Ada 2005: Determine whether Iface is present in the list Ifaces
304
 
305
   procedure Convert_Scalar_Bounds
306
     (N            : Node_Id;
307
      Parent_Type  : Entity_Id;
308
      Derived_Type : Entity_Id;
309
      Loc          : Source_Ptr);
310
   --  For derived scalar types, convert the bounds in the type definition to
311
   --  the derived type, and complete their analysis. Given a constraint of the
312
   --  form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with
313
   --  T'Base, the parent_type. The bounds of the derived type (the anonymous
314
   --  base) are copies of Lo and Hi. Finally, the bounds of the derived
315
   --  subtype are conversions of those bounds to the derived_type, so that
316
   --  their typing is consistent.
317
 
318
   procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
319
   --  Copies attributes from array base type T2 to array base type T1. Copies
320
   --  only attributes that apply to base types, but not subtypes.
321
 
322
   procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
323
   --  Copies attributes from array subtype T2 to array subtype T1. Copies
324
   --  attributes that apply to both subtypes and base types.
325
 
326
   procedure Create_Constrained_Components
327
     (Subt        : Entity_Id;
328
      Decl_Node   : Node_Id;
329
      Typ         : Entity_Id;
330
      Constraints : Elist_Id);
331
   --  Build the list of entities for a constrained discriminated record
332
   --  subtype. If a component depends on a discriminant, replace its subtype
333
   --  using the discriminant values in the discriminant constraint. Subt
334
   --  is the defining identifier for the subtype whose list of constrained
335
   --  entities we will create. Decl_Node is the type declaration node where
336
   --  we will attach all the itypes created. Typ is the base discriminated
337
   --  type for the subtype Subt. Constraints is the list of discriminant
338
   --  constraints for Typ.
339
 
340
   function Constrain_Component_Type
341
     (Comp            : Entity_Id;
342
      Constrained_Typ : Entity_Id;
343
      Related_Node    : Node_Id;
344
      Typ             : Entity_Id;
345
      Constraints     : Elist_Id) return Entity_Id;
346
   --  Given a discriminated base type Typ, a list of discriminant constraint
347
   --  Constraints for Typ and a component of Typ, with type Compon_Type,
348
   --  create and return the type corresponding to Compon_type where all
349
   --  discriminant references are replaced with the corresponding constraint.
350
   --  If no discriminant references occur in Compon_Typ then return it as is.
351
   --  Constrained_Typ is the final constrained subtype to which the
352
   --  constrained Compon_Type belongs. Related_Node is the node where we will
353
   --  attach all the itypes created.
354
   --
355
   --  Above description is confused, what is Compon_Type???
356
 
357
   procedure Constrain_Access
358
     (Def_Id      : in out Entity_Id;
359
      S           : Node_Id;
360
      Related_Nod : Node_Id);
361
   --  Apply a list of constraints to an access type. If Def_Id is empty, it is
362
   --  an anonymous type created for a subtype indication. In that case it is
363
   --  created in the procedure and attached to Related_Nod.
364
 
365
   procedure Constrain_Array
366
     (Def_Id      : in out Entity_Id;
367
      SI          : Node_Id;
368
      Related_Nod : Node_Id;
369
      Related_Id  : Entity_Id;
370
      Suffix      : Character);
371
   --  Apply a list of index constraints to an unconstrained array type. The
372
   --  first parameter is the entity for the resulting subtype. A value of
373
   --  Empty for Def_Id indicates that an implicit type must be created, but
374
   --  creation is delayed (and must be done by this procedure) because other
375
   --  subsidiary implicit types must be created first (which is why Def_Id
376
   --  is an in/out parameter). The second parameter is a subtype indication
377
   --  node for the constrained array to be created (e.g. something of the
378
   --  form string (1 .. 10)). Related_Nod gives the place where this type
379
   --  has to be inserted in the tree. The Related_Id and Suffix parameters
380
   --  are used to build the associated Implicit type name.
381
 
382
   procedure Constrain_Concurrent
383
     (Def_Id      : in out Entity_Id;
384
      SI          : Node_Id;
385
      Related_Nod : Node_Id;
386
      Related_Id  : Entity_Id;
387
      Suffix      : Character);
388
   --  Apply list of discriminant constraints to an unconstrained concurrent
389
   --  type.
390
   --
391
   --    SI is the N_Subtype_Indication node containing the constraint and
392
   --    the unconstrained type to constrain.
393
   --
394
   --    Def_Id is the entity for the resulting constrained subtype. A value
395
   --    of Empty for Def_Id indicates that an implicit type must be created,
396
   --    but creation is delayed (and must be done by this procedure) because
397
   --    other subsidiary implicit types must be created first (which is why
398
   --    Def_Id is an in/out parameter).
399
   --
400
   --    Related_Nod gives the place where this type has to be inserted
401
   --    in the tree
402
   --
403
   --  The last two arguments are used to create its external name if needed.
404
 
405
   function Constrain_Corresponding_Record
406
     (Prot_Subt   : Entity_Id;
407
      Corr_Rec    : Entity_Id;
408
      Related_Nod : Node_Id;
409
      Related_Id  : Entity_Id) return Entity_Id;
410
   --  When constraining a protected type or task type with discriminants,
411
   --  constrain the corresponding record with the same discriminant values.
412
 
413
   procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id);
414
   --  Constrain a decimal fixed point type with a digits constraint and/or a
415
   --  range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
416
 
417
   procedure Constrain_Discriminated_Type
418
     (Def_Id      : Entity_Id;
419
      S           : Node_Id;
420
      Related_Nod : Node_Id;
421
      For_Access  : Boolean := False);
422
   --  Process discriminant constraints of composite type. Verify that values
423
   --  have been provided for all discriminants, that the original type is
424
   --  unconstrained, and that the types of the supplied expressions match
425
   --  the discriminant types. The first three parameters are like in routine
426
   --  Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
427
   --  of For_Access.
428
 
429
   procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
430
   --  Constrain an enumeration type with a range constraint. This is identical
431
   --  to Constrain_Integer, but for the Ekind of the resulting subtype.
432
 
433
   procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id);
434
   --  Constrain a floating point type with either a digits constraint
435
   --  and/or a range constraint, building a E_Floating_Point_Subtype.
436
 
437
   procedure Constrain_Index
438
     (Index        : Node_Id;
439
      S            : Node_Id;
440
      Related_Nod  : Node_Id;
441
      Related_Id   : Entity_Id;
442
      Suffix       : Character;
443
      Suffix_Index : Nat);
444
   --  Process an index constraint in a constrained array declaration. The
445
   --  constraint can be a subtype name, or a range with or without an explicit
446
   --  subtype mark. The index is the corresponding index of the unconstrained
447
   --  array. The Related_Id and Suffix parameters are used to build the
448
   --  associated Implicit type name.
449
 
450
   procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
451
   --  Build subtype of a signed or modular integer type
452
 
453
   procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
454
   --  Constrain an ordinary fixed point type with a range constraint, and
455
   --  build an E_Ordinary_Fixed_Point_Subtype entity.
456
 
457
   procedure Copy_And_Swap (Priv, Full : Entity_Id);
458
   --  Copy the Priv entity into the entity of its full declaration then swap
459
   --  the two entities in such a manner that the former private type is now
460
   --  seen as a full type.
461
 
462
   procedure Decimal_Fixed_Point_Type_Declaration
463
     (T   : Entity_Id;
464
      Def : Node_Id);
465
   --  Create a new decimal fixed point type, and apply the constraint to
466
   --  obtain a subtype of this new type.
467
 
468
   procedure Complete_Private_Subtype
469
     (Priv        : Entity_Id;
470
      Full        : Entity_Id;
471
      Full_Base   : Entity_Id;
472
      Related_Nod : Node_Id);
473
   --  Complete the implicit full view of a private subtype by setting the
474
   --  appropriate semantic fields. If the full view of the parent is a record
475
   --  type, build constrained components of subtype.
476
 
477
   procedure Derive_Progenitor_Subprograms
478
     (Parent_Type : Entity_Id;
479
      Tagged_Type : Entity_Id);
480
   --  Ada 2005 (AI-251): To complete type derivation, collect the primitive
481
   --  operations of progenitors of Tagged_Type, and replace the subsidiary
482
   --  subtypes with Tagged_Type, to build the specs of the inherited interface
483
   --  primitives. The derived primitives are aliased to those of the
484
   --  interface. This routine takes care also of transferring to the full-view
485
   --  subprograms associated with the partial-view of Tagged_Type that cover
486
   --  interface primitives.
487
 
488
   procedure Derived_Standard_Character
489
     (N             : Node_Id;
490
      Parent_Type   : Entity_Id;
491
      Derived_Type  : Entity_Id);
492
   --  Subsidiary procedure to Build_Derived_Enumeration_Type which handles
493
   --  derivations from types Standard.Character and Standard.Wide_Character.
494
 
495
   procedure Derived_Type_Declaration
496
     (T             : Entity_Id;
497
      N             : Node_Id;
498
      Is_Completion : Boolean);
499
   --  Process a derived type declaration. Build_Derived_Type is invoked
500
   --  to process the actual derived type definition. Parameters N and
501
   --  Is_Completion have the same meaning as in Build_Derived_Type.
502
   --  T is the N_Defining_Identifier for the entity defined in the
503
   --  N_Full_Type_Declaration node N, that is T is the derived type.
504
 
505
   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
506
   --  Insert each literal in symbol table, as an overloadable identifier. Each
507
   --  enumeration type is mapped into a sequence of integers, and each literal
508
   --  is defined as a constant with integer value. If any of the literals are
509
   --  character literals, the type is a character type, which means that
510
   --  strings are legal aggregates for arrays of components of the type.
511
 
512
   function Expand_To_Stored_Constraint
513
     (Typ        : Entity_Id;
514
      Constraint : Elist_Id) return Elist_Id;
515
   --  Given a constraint (i.e. a list of expressions) on the discriminants of
516
   --  Typ, expand it into a constraint on the stored discriminants and return
517
   --  the new list of expressions constraining the stored discriminants.
518
 
519
   function Find_Type_Of_Object
520
     (Obj_Def     : Node_Id;
521
      Related_Nod : Node_Id) return Entity_Id;
522
   --  Get type entity for object referenced by Obj_Def, attaching the
523
   --  implicit types generated to Related_Nod
524
 
525
   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
526
   --  Create a new float and apply the constraint to obtain subtype of it
527
 
528
   function Has_Range_Constraint (N : Node_Id) return Boolean;
529
   --  Given an N_Subtype_Indication node N, return True if a range constraint
530
   --  is present, either directly, or as part of a digits or delta constraint.
531
   --  In addition, a digits constraint in the decimal case returns True, since
532
   --  it establishes a default range if no explicit range is present.
533
 
534
   function Inherit_Components
535
     (N             : Node_Id;
536
      Parent_Base   : Entity_Id;
537
      Derived_Base  : Entity_Id;
538
      Is_Tagged     : Boolean;
539
      Inherit_Discr : Boolean;
540
      Discs         : Elist_Id) return Elist_Id;
541
   --  Called from Build_Derived_Record_Type to inherit the components of
542
   --  Parent_Base (a base type) into the Derived_Base (the derived base type).
543
   --  For more information on derived types and component inheritance please
544
   --  consult the comment above the body of Build_Derived_Record_Type.
545
   --
546
   --    N is the original derived type declaration
547
   --
548
   --    Is_Tagged is set if we are dealing with tagged types
549
   --
550
   --    If Inherit_Discr is set, Derived_Base inherits its discriminants from
551
   --    Parent_Base, otherwise no discriminants are inherited.
552
   --
553
   --    Discs gives the list of constraints that apply to Parent_Base in the
554
   --    derived type declaration. If Discs is set to No_Elist, then we have
555
   --    the following situation:
556
   --
557
   --      type Parent (D1..Dn : ..) is [tagged] record ...;
558
   --      type Derived is new Parent [with ...];
559
   --
560
   --    which gets treated as
561
   --
562
   --      type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
563
   --
564
   --  For untagged types the returned value is an association list. The list
565
   --  starts from the association (Parent_Base => Derived_Base), and then it
566
   --  contains a sequence of the associations of the form
567
   --
568
   --    (Old_Component => New_Component),
569
   --
570
   --  where Old_Component is the Entity_Id of a component in Parent_Base and
571
   --  New_Component is the Entity_Id of the corresponding component in
572
   --  Derived_Base. For untagged records, this association list is needed when
573
   --  copying the record declaration for the derived base. In the tagged case
574
   --  the value returned is irrelevant.
575
 
576
   function Is_Progenitor
577
     (Iface : Entity_Id;
578
      Typ   : Entity_Id) return Boolean;
579
   --  Determine whether the interface Iface is implemented by Typ. It requires
580
   --  traversing the list of abstract interfaces of the type, as well as that
581
   --  of the ancestor types. The predicate is used to determine when a formal
582
   --  in the signature of an inherited operation must carry the derived type.
583
 
584
   function Is_Valid_Constraint_Kind
585
     (T_Kind          : Type_Kind;
586
      Constraint_Kind : Node_Kind) return Boolean;
587
   --  Returns True if it is legal to apply the given kind of constraint to the
588
   --  given kind of type (index constraint to an array type, for example).
589
 
590
   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
591
   --  Create new modular type. Verify that modulus is in bounds and is
592
   --  a power of two (implementation restriction).
593
 
594
   procedure New_Concatenation_Op (Typ : Entity_Id);
595
   --  Create an abbreviated declaration for an operator in order to
596
   --  materialize concatenation on array types.
597
 
598
   procedure Ordinary_Fixed_Point_Type_Declaration
599
     (T   : Entity_Id;
600
      Def : Node_Id);
601
   --  Create a new ordinary fixed point type, and apply the constraint to
602
   --  obtain subtype of it.
603
 
604
   procedure Prepare_Private_Subtype_Completion
605
     (Id          : Entity_Id;
606
      Related_Nod : Node_Id);
607
   --  Id is a subtype of some private type. Creates the full declaration
608
   --  associated with Id whenever possible, i.e. when the full declaration
609
   --  of the base type is already known. Records each subtype into
610
   --  Private_Dependents of the base type.
611
 
612
   procedure Process_Incomplete_Dependents
613
     (N      : Node_Id;
614
      Full_T : Entity_Id;
615
      Inc_T  : Entity_Id);
616
   --  Process all entities that depend on an incomplete type. There include
617
   --  subtypes, subprogram types that mention the incomplete type in their
618
   --  profiles, and subprogram with access parameters that designate the
619
   --  incomplete type.
620
 
621
   --  Inc_T is the defining identifier of an incomplete type declaration, its
622
   --  Ekind is E_Incomplete_Type.
623
   --
624
   --    N is the corresponding N_Full_Type_Declaration for Inc_T.
625
   --
626
   --    Full_T is N's defining identifier.
627
   --
628
   --  Subtypes of incomplete types with discriminants are completed when the
629
   --  parent type is. This is simpler than private subtypes, because they can
630
   --  only appear in the same scope, and there is no need to exchange views.
631
   --  Similarly, access_to_subprogram types may have a parameter or a return
632
   --  type that is an incomplete type, and that must be replaced with the
633
   --  full type.
634
   --
635
   --  If the full type is tagged, subprogram with access parameters that
636
   --  designated the incomplete may be primitive operations of the full type,
637
   --  and have to be processed accordingly.
638
 
639
   procedure Process_Real_Range_Specification (Def : Node_Id);
640
   --  Given the type definition for a real type, this procedure processes and
641
   --  checks the real range specification of this type definition if one is
642
   --  present. If errors are found, error messages are posted, and the
643
   --  Real_Range_Specification of Def is reset to Empty.
644
 
645
   procedure Record_Type_Declaration
646
     (T    : Entity_Id;
647
      N    : Node_Id;
648
      Prev : Entity_Id);
649
   --  Process a record type declaration (for both untagged and tagged
650
   --  records). Parameters T and N are exactly like in procedure
651
   --  Derived_Type_Declaration, except that no flag Is_Completion is needed
652
   --  for this routine. If this is the completion of an incomplete type
653
   --  declaration, Prev is the entity of the incomplete declaration, used for
654
   --  cross-referencing. Otherwise Prev = T.
655
 
656
   procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id);
657
   --  This routine is used to process the actual record type definition (both
658
   --  for untagged and tagged records). Def is a record type definition node.
659
   --  This procedure analyzes the components in this record type definition.
660
   --  Prev_T is the entity for the enclosing record type. It is provided so
661
   --  that its Has_Task flag can be set if any of the component have Has_Task
662
   --  set. If the declaration is the completion of an incomplete type
663
   --  declaration, Prev_T is the original incomplete type, whose full view is
664
   --  the record type.
665
 
666
   procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
667
   --  Subsidiary to Build_Derived_Record_Type. For untagged records, we
668
   --  build a copy of the declaration tree of the parent, and we create
669
   --  independently the list of components for the derived type. Semantic
670
   --  information uses the component entities, but record representation
671
   --  clauses are validated on the declaration tree. This procedure replaces
672
   --  discriminants and components in the declaration with those that have
673
   --  been created by Inherit_Components.
674
 
675
   procedure Set_Fixed_Range
676
     (E   : Entity_Id;
677
      Loc : Source_Ptr;
678
      Lo  : Ureal;
679
      Hi  : Ureal);
680
   --  Build a range node with the given bounds and set it as the Scalar_Range
681
   --  of the given fixed-point type entity. Loc is the source location used
682
   --  for the constructed range. See body for further details.
683
 
684
   procedure Set_Scalar_Range_For_Subtype
685
     (Def_Id : Entity_Id;
686
      R      : Node_Id;
687
      Subt   : Entity_Id);
688
   --  This routine is used to set the scalar range field for a subtype given
689
   --  Def_Id, the entity for the subtype, and R, the range expression for the
690
   --  scalar range. Subt provides the parent subtype to be used to analyze,
691
   --  resolve, and check the given range.
692
 
693
   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
694
   --  Create a new signed integer entity, and apply the constraint to obtain
695
   --  the required first named subtype of this type.
696
 
697
   procedure Set_Stored_Constraint_From_Discriminant_Constraint
698
     (E : Entity_Id);
699
   --  E is some record type. This routine computes E's Stored_Constraint
700
   --  from its Discriminant_Constraint.
701
 
702
   procedure Diagnose_Interface (N : Node_Id;  E : Entity_Id);
703
   --  Check that an entity in a list of progenitors is an interface,
704
   --  emit error otherwise.
705
 
706
   -----------------------
707
   -- Access_Definition --
708
   -----------------------
709
 
710
   function Access_Definition
711
     (Related_Nod : Node_Id;
712
      N           : Node_Id) return Entity_Id
713
   is
714
      Loc                 : constant Source_Ptr := Sloc (Related_Nod);
715
      Anon_Type           : Entity_Id;
716
      Anon_Scope          : Entity_Id;
717
      Desig_Type          : Entity_Id;
718
      Decl                : Entity_Id;
719
      Enclosing_Prot_Type : Entity_Id := Empty;
720
 
721
   begin
722
      if Is_Entry (Current_Scope)
723
        and then Is_Task_Type (Etype (Scope (Current_Scope)))
724
      then
725
         Error_Msg_N ("task entries cannot have access parameters", N);
726
         return Empty;
727
      end if;
728
 
729
      --  Ada 2005: for an object declaration the corresponding anonymous
730
      --  type is declared in the current scope.
731
 
732
      --  If the access definition is the return type of another access to
733
      --  function, scope is the current one, because it is the one of the
734
      --  current type declaration.
735
 
736
      if Nkind_In (Related_Nod, N_Object_Declaration,
737
                                N_Access_Function_Definition)
738
      then
739
         Anon_Scope := Current_Scope;
740
 
741
      --  For the anonymous function result case, retrieve the scope of the
742
      --  function specification's associated entity rather than using the
743
      --  current scope. The current scope will be the function itself if the
744
      --  formal part is currently being analyzed, but will be the parent scope
745
      --  in the case of a parameterless function, and we always want to use
746
      --  the function's parent scope. Finally, if the function is a child
747
      --  unit, we must traverse the tree to retrieve the proper entity.
748
 
749
      elsif Nkind (Related_Nod) = N_Function_Specification
750
        and then Nkind (Parent (N)) /= N_Parameter_Specification
751
      then
752
         --  If the current scope is a protected type, the anonymous access
753
         --  is associated with one of the protected operations, and must
754
         --  be available in the scope that encloses the protected declaration.
755
         --  Otherwise the type is in the scope enclosing the subprogram.
756
 
757
         --  If the function has formals, The return type of a subprogram
758
         --  declaration is analyzed in the scope of the subprogram (see
759
         --  Process_Formals) and thus the protected type, if present, is
760
         --  the scope of the current function scope.
761
 
762
         if Ekind (Current_Scope) = E_Protected_Type then
763
            Enclosing_Prot_Type := Current_Scope;
764
 
765
         elsif Ekind (Current_Scope) = E_Function
766
           and then Ekind (Scope (Current_Scope)) = E_Protected_Type
767
         then
768
            Enclosing_Prot_Type := Scope (Current_Scope);
769
         end if;
770
 
771
         if Present (Enclosing_Prot_Type) then
772
            Anon_Scope := Scope (Enclosing_Prot_Type);
773
 
774
         else
775
            Anon_Scope := Scope (Defining_Entity (Related_Nod));
776
         end if;
777
 
778
      else
779
         --  For access formals, access components, and access discriminants,
780
         --  the scope is that of the enclosing declaration,
781
 
782
         Anon_Scope := Scope (Current_Scope);
783
      end if;
784
 
785
      Anon_Type :=
786
        Create_Itype
787
         (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope);
788
 
789
      if All_Present (N)
790
        and then Ada_Version >= Ada_05
791
      then
792
         Error_Msg_N ("ALL is not permitted for anonymous access types", N);
793
      end if;
794
 
795
      --  Ada 2005 (AI-254): In case of anonymous access to subprograms call
796
      --  the corresponding semantic routine
797
 
798
      if Present (Access_To_Subprogram_Definition (N)) then
799
         Access_Subprogram_Declaration
800
           (T_Name => Anon_Type,
801
            T_Def  => Access_To_Subprogram_Definition (N));
802
 
803
         if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
804
            Set_Ekind
805
              (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
806
         else
807
            Set_Ekind
808
              (Anon_Type, E_Anonymous_Access_Subprogram_Type);
809
         end if;
810
 
811
         Set_Can_Use_Internal_Rep
812
           (Anon_Type, not Always_Compatible_Rep_On_Target);
813
 
814
         --  If the anonymous access is associated with a protected operation
815
         --  create a reference to it after the enclosing protected definition
816
         --  because the itype will be used in the subsequent bodies.
817
 
818
         if Ekind (Current_Scope) = E_Protected_Type then
819
            Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
820
         end if;
821
 
822
         return Anon_Type;
823
      end if;
824
 
825
      Find_Type (Subtype_Mark (N));
826
      Desig_Type := Entity (Subtype_Mark (N));
827
 
828
      Set_Directly_Designated_Type (Anon_Type, Desig_Type);
829
      Set_Etype (Anon_Type, Anon_Type);
830
 
831
      --  Make sure the anonymous access type has size and alignment fields
832
      --  set, as required by gigi. This is necessary in the case of the
833
      --  Task_Body_Procedure.
834
 
835
      if not Has_Private_Component (Desig_Type) then
836
         Layout_Type (Anon_Type);
837
      end if;
838
 
839
      --  ???The following makes no sense, because Anon_Type is an access type
840
      --  and therefore cannot have components, private or otherwise. Hence
841
      --  the assertion. Not sure what was meant, here.
842
      Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
843
      pragma Assert (not Depends_On_Private (Anon_Type));
844
 
845
      --  Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
846
      --  from Ada 95 semantics. In Ada 2005, anonymous access must specify if
847
      --  the null value is allowed. In Ada 95 the null value is never allowed.
848
 
849
      if Ada_Version >= Ada_05 then
850
         Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
851
      else
852
         Set_Can_Never_Be_Null (Anon_Type, True);
853
      end if;
854
 
855
      --  The anonymous access type is as public as the discriminated type or
856
      --  subprogram that defines it. It is imported (for back-end purposes)
857
      --  if the designated type is.
858
 
859
      Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
860
 
861
      --  Ada 2005 (AI-231): Propagate the access-constant attribute
862
 
863
      Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
864
 
865
      --  The context is either a subprogram declaration, object declaration,
866
      --  or an access discriminant, in a private or a full type declaration.
867
      --  In the case of a subprogram, if the designated type is incomplete,
868
      --  the operation will be a primitive operation of the full type, to be
869
      --  updated subsequently. If the type is imported through a limited_with
870
      --  clause, the subprogram is not a primitive operation of the type
871
      --  (which is declared elsewhere in some other scope).
872
 
873
      if Ekind (Desig_Type) = E_Incomplete_Type
874
        and then not From_With_Type (Desig_Type)
875
        and then Is_Overloadable (Current_Scope)
876
      then
877
         Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
878
         Set_Has_Delayed_Freeze (Current_Scope);
879
      end if;
880
 
881
      --  Ada 2005: if the designated type is an interface that may contain
882
      --  tasks, create a Master entity for the declaration. This must be done
883
      --  before expansion of the full declaration, because the declaration may
884
      --  include an expression that is an allocator, whose expansion needs the
885
      --  proper Master for the created tasks.
886
 
887
      if Nkind (Related_Nod) = N_Object_Declaration
888
         and then Expander_Active
889
      then
890
         if Is_Interface (Desig_Type)
891
           and then Is_Limited_Record (Desig_Type)
892
         then
893
            Build_Class_Wide_Master (Anon_Type);
894
 
895
         --  Similarly, if the type is an anonymous access that designates
896
         --  tasks, create a master entity for it in the current context.
897
 
898
         elsif Has_Task (Desig_Type)
899
           and then Comes_From_Source (Related_Nod)
900
         then
901
            if not Has_Master_Entity (Current_Scope) then
902
               Decl :=
903
                 Make_Object_Declaration (Loc,
904
                   Defining_Identifier =>
905
                     Make_Defining_Identifier (Loc, Name_uMaster),
906
                   Constant_Present => True,
907
                   Object_Definition =>
908
                     New_Reference_To (RTE (RE_Master_Id), Loc),
909
                   Expression =>
910
                     Make_Explicit_Dereference (Loc,
911
                       New_Reference_To (RTE (RE_Current_Master), Loc)));
912
 
913
               Insert_Before (Related_Nod, Decl);
914
               Analyze (Decl);
915
 
916
               Set_Master_Id (Anon_Type, Defining_Identifier (Decl));
917
               Set_Has_Master_Entity (Current_Scope);
918
            else
919
               Build_Master_Renaming (Related_Nod, Anon_Type);
920
            end if;
921
         end if;
922
      end if;
923
 
924
      --  For a private component of a protected type, it is imperative that
925
      --  the back-end elaborate the type immediately after the protected
926
      --  declaration, because this type will be used in the declarations
927
      --  created for the component within each protected body, so we must
928
      --  create an itype reference for it now.
929
 
930
      if Nkind (Parent (Related_Nod)) = N_Protected_Definition then
931
         Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
932
 
933
      --  Similarly, if the access definition is the return result of a
934
      --  function, create an itype reference for it because it will be used
935
      --  within the function body. For a regular function that is not a
936
      --  compilation unit, insert reference after the declaration. For a
937
      --  protected operation, insert it after the enclosing protected type
938
      --  declaration. In either case, do not create a reference for a type
939
      --  obtained through a limited_with clause, because this would introduce
940
      --  semantic dependencies.
941
 
942
      --  Similarly, do not create a reference if the designated type is a
943
      --  generic formal, because no use of it will reach the backend.
944
 
945
      elsif Nkind (Related_Nod) = N_Function_Specification
946
        and then not From_With_Type (Desig_Type)
947
        and then not Is_Generic_Type (Desig_Type)
948
      then
949
         if Present (Enclosing_Prot_Type) then
950
            Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
951
 
952
         elsif Is_List_Member (Parent (Related_Nod))
953
           and then Nkind (Parent (N)) /= N_Parameter_Specification
954
         then
955
            Build_Itype_Reference (Anon_Type, Parent (Related_Nod));
956
         end if;
957
 
958
      --  Finally, create an itype reference for an object declaration of an
959
      --  anonymous access type. This is strictly necessary only for deferred
960
      --  constants, but in any case will avoid out-of-scope problems in the
961
      --  back-end.
962
 
963
      elsif Nkind (Related_Nod) = N_Object_Declaration then
964
         Build_Itype_Reference (Anon_Type, Related_Nod);
965
      end if;
966
 
967
      return Anon_Type;
968
   end Access_Definition;
969
 
970
   -----------------------------------
971
   -- Access_Subprogram_Declaration --
972
   -----------------------------------
973
 
974
   procedure Access_Subprogram_Declaration
975
     (T_Name : Entity_Id;
976
      T_Def  : Node_Id)
977
   is
978
 
979
      procedure Check_For_Premature_Usage (Def : Node_Id);
980
      --  Check that type T_Name is not used, directly or recursively, as a
981
      --  parameter or a return type in Def. Def is either a subtype, an
982
      --  access_definition, or an access_to_subprogram_definition.
983
 
984
      -------------------------------
985
      -- Check_For_Premature_Usage --
986
      -------------------------------
987
 
988
      procedure Check_For_Premature_Usage (Def : Node_Id) is
989
         Param : Node_Id;
990
 
991
      begin
992
         --  Check for a subtype mark
993
 
994
         if Nkind (Def) in N_Has_Etype then
995
            if Etype (Def) = T_Name then
996
               Error_Msg_N
997
                 ("type& cannot be used before end of its declaration", Def);
998
            end if;
999
 
1000
         --  If this is not a subtype, then this is an access_definition
1001
 
1002
         elsif Nkind (Def) = N_Access_Definition then
1003
            if Present (Access_To_Subprogram_Definition (Def)) then
1004
               Check_For_Premature_Usage
1005
                 (Access_To_Subprogram_Definition (Def));
1006
            else
1007
               Check_For_Premature_Usage (Subtype_Mark (Def));
1008
            end if;
1009
 
1010
         --  The only cases left are N_Access_Function_Definition and
1011
         --  N_Access_Procedure_Definition.
1012
 
1013
         else
1014
            if Present (Parameter_Specifications (Def)) then
1015
               Param := First (Parameter_Specifications (Def));
1016
               while Present (Param) loop
1017
                  Check_For_Premature_Usage (Parameter_Type (Param));
1018
                  Param := Next (Param);
1019
               end loop;
1020
            end if;
1021
 
1022
            if Nkind (Def) = N_Access_Function_Definition then
1023
               Check_For_Premature_Usage (Result_Definition (Def));
1024
            end if;
1025
         end if;
1026
      end Check_For_Premature_Usage;
1027
 
1028
      --  Local variables
1029
 
1030
      Formals    : constant List_Id := Parameter_Specifications (T_Def);
1031
      Formal     : Entity_Id;
1032
      D_Ityp     : Node_Id;
1033
      Desig_Type : constant Entity_Id :=
1034
                     Create_Itype (E_Subprogram_Type, Parent (T_Def));
1035
 
1036
   --  Start of processing for Access_Subprogram_Declaration
1037
 
1038
   begin
1039
      --  Associate the Itype node with the inner full-type declaration or
1040
      --  subprogram spec. This is required to handle nested anonymous
1041
      --  declarations. For example:
1042
 
1043
      --      procedure P
1044
      --       (X : access procedure
1045
      --                     (Y : access procedure
1046
      --                                   (Z : access T)))
1047
 
1048
      D_Ityp := Associated_Node_For_Itype (Desig_Type);
1049
      while not (Nkind_In (D_Ityp, N_Full_Type_Declaration,
1050
                                   N_Private_Type_Declaration,
1051
                                   N_Private_Extension_Declaration,
1052
                                   N_Procedure_Specification,
1053
                                   N_Function_Specification)
1054
                   or else
1055
                 Nkind_In (D_Ityp, N_Object_Declaration,
1056
                                   N_Object_Renaming_Declaration,
1057
                                   N_Formal_Object_Declaration,
1058
                                   N_Formal_Type_Declaration,
1059
                                   N_Task_Type_Declaration,
1060
                                   N_Protected_Type_Declaration))
1061
      loop
1062
         D_Ityp := Parent (D_Ityp);
1063
         pragma Assert (D_Ityp /= Empty);
1064
      end loop;
1065
 
1066
      Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
1067
 
1068
      if Nkind_In (D_Ityp, N_Procedure_Specification,
1069
                           N_Function_Specification)
1070
      then
1071
         Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
1072
 
1073
      elsif Nkind_In (D_Ityp, N_Full_Type_Declaration,
1074
                              N_Object_Declaration,
1075
                              N_Object_Renaming_Declaration,
1076
                              N_Formal_Type_Declaration)
1077
      then
1078
         Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
1079
      end if;
1080
 
1081
      if Nkind (T_Def) = N_Access_Function_Definition then
1082
         if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
1083
            declare
1084
               Acc : constant Node_Id := Result_Definition (T_Def);
1085
 
1086
            begin
1087
               if Present (Access_To_Subprogram_Definition (Acc))
1088
                 and then
1089
                   Protected_Present (Access_To_Subprogram_Definition (Acc))
1090
               then
1091
                  Set_Etype
1092
                    (Desig_Type,
1093
                       Replace_Anonymous_Access_To_Protected_Subprogram
1094
                         (T_Def));
1095
 
1096
               else
1097
                  Set_Etype
1098
                    (Desig_Type,
1099
                       Access_Definition (T_Def, Result_Definition (T_Def)));
1100
               end if;
1101
            end;
1102
 
1103
         else
1104
            Analyze (Result_Definition (T_Def));
1105
 
1106
            declare
1107
               Typ : constant Entity_Id := Entity (Result_Definition (T_Def));
1108
 
1109
            begin
1110
               --  If a null exclusion is imposed on the result type, then
1111
               --  create a null-excluding itype (an access subtype) and use
1112
               --  it as the function's Etype.
1113
 
1114
               if Is_Access_Type (Typ)
1115
                 and then Null_Exclusion_In_Return_Present (T_Def)
1116
               then
1117
                  Set_Etype  (Desig_Type,
1118
                    Create_Null_Excluding_Itype
1119
                      (T           => Typ,
1120
                       Related_Nod => T_Def,
1121
                       Scope_Id    => Current_Scope));
1122
 
1123
               else
1124
                  if From_With_Type (Typ) then
1125
                     Error_Msg_NE
1126
                      ("illegal use of incomplete type&",
1127
                         Result_Definition (T_Def), Typ);
1128
 
1129
                  elsif Ekind (Current_Scope) = E_Package
1130
                    and then In_Private_Part (Current_Scope)
1131
                  then
1132
                     if Ekind (Typ) = E_Incomplete_Type then
1133
                        Append_Elmt (Desig_Type, Private_Dependents (Typ));
1134
 
1135
                     elsif Is_Class_Wide_Type (Typ)
1136
                       and then Ekind (Etype (Typ)) = E_Incomplete_Type
1137
                     then
1138
                        Append_Elmt
1139
                          (Desig_Type, Private_Dependents (Etype (Typ)));
1140
                     end if;
1141
                  end if;
1142
 
1143
                  Set_Etype (Desig_Type, Typ);
1144
               end if;
1145
            end;
1146
         end if;
1147
 
1148
         if not (Is_Type (Etype (Desig_Type))) then
1149
            Error_Msg_N
1150
              ("expect type in function specification",
1151
               Result_Definition (T_Def));
1152
         end if;
1153
 
1154
      else
1155
         Set_Etype (Desig_Type, Standard_Void_Type);
1156
      end if;
1157
 
1158
      if Present (Formals) then
1159
         Push_Scope (Desig_Type);
1160
 
1161
         --  A bit of a kludge here. These kludges will be removed when Itypes
1162
         --  have proper parent pointers to their declarations???
1163
 
1164
         --  Kludge 1) Link defining_identifier of formals. Required by
1165
         --  First_Formal to provide its functionality.
1166
 
1167
         declare
1168
            F : Node_Id;
1169
 
1170
         begin
1171
            F := First (Formals);
1172
            while Present (F) loop
1173
               if No (Parent (Defining_Identifier (F))) then
1174
                  Set_Parent (Defining_Identifier (F), F);
1175
               end if;
1176
 
1177
               Next (F);
1178
            end loop;
1179
         end;
1180
 
1181
         Process_Formals (Formals, Parent (T_Def));
1182
 
1183
         --  Kludge 2) End_Scope requires that the parent pointer be set to
1184
         --  something reasonable, but Itypes don't have parent pointers. So
1185
         --  we set it and then unset it ???
1186
 
1187
         Set_Parent (Desig_Type, T_Name);
1188
         End_Scope;
1189
         Set_Parent (Desig_Type, Empty);
1190
      end if;
1191
 
1192
      --  Check for premature usage of the type being defined
1193
 
1194
      Check_For_Premature_Usage (T_Def);
1195
 
1196
      --  The return type and/or any parameter type may be incomplete. Mark
1197
      --  the subprogram_type as depending on the incomplete type, so that
1198
      --  it can be updated when the full type declaration is seen. This
1199
      --  only applies to incomplete types declared in some enclosing scope,
1200
      --  not to limited views from other packages.
1201
 
1202
      if Present (Formals) then
1203
         Formal := First_Formal (Desig_Type);
1204
         while Present (Formal) loop
1205
            if Ekind (Formal) /= E_In_Parameter
1206
              and then Nkind (T_Def) = N_Access_Function_Definition
1207
            then
1208
               Error_Msg_N ("functions can only have IN parameters", Formal);
1209
            end if;
1210
 
1211
            if Ekind (Etype (Formal)) = E_Incomplete_Type
1212
              and then In_Open_Scopes (Scope (Etype (Formal)))
1213
            then
1214
               Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
1215
               Set_Has_Delayed_Freeze (Desig_Type);
1216
            end if;
1217
 
1218
            Next_Formal (Formal);
1219
         end loop;
1220
      end if;
1221
 
1222
      --  If the return type is incomplete, this is legal as long as the
1223
      --  type is declared in the current scope and will be completed in
1224
      --  it (rather than being part of limited view).
1225
 
1226
      if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
1227
        and then not Has_Delayed_Freeze (Desig_Type)
1228
        and then In_Open_Scopes (Scope (Etype (Desig_Type)))
1229
      then
1230
         Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
1231
         Set_Has_Delayed_Freeze (Desig_Type);
1232
      end if;
1233
 
1234
      Check_Delayed_Subprogram (Desig_Type);
1235
 
1236
      if Protected_Present (T_Def) then
1237
         Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
1238
         Set_Convention (Desig_Type, Convention_Protected);
1239
      else
1240
         Set_Ekind (T_Name, E_Access_Subprogram_Type);
1241
      end if;
1242
 
1243
      Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
1244
 
1245
      Set_Etype                    (T_Name, T_Name);
1246
      Init_Size_Align              (T_Name);
1247
      Set_Directly_Designated_Type (T_Name, Desig_Type);
1248
 
1249
      --  Ada 2005 (AI-231): Propagate the null-excluding attribute
1250
 
1251
      Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
1252
 
1253
      Check_Restriction (No_Access_Subprograms, T_Def);
1254
   end Access_Subprogram_Declaration;
1255
 
1256
   ----------------------------
1257
   -- Access_Type_Declaration --
1258
   ----------------------------
1259
 
1260
   procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
1261
      S : constant Node_Id := Subtype_Indication (Def);
1262
      P : constant Node_Id := Parent (Def);
1263
   begin
1264
      --  Check for permissible use of incomplete type
1265
 
1266
      if Nkind (S) /= N_Subtype_Indication then
1267
         Analyze (S);
1268
 
1269
         if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
1270
            Set_Directly_Designated_Type (T, Entity (S));
1271
         else
1272
            Set_Directly_Designated_Type (T,
1273
              Process_Subtype (S, P, T, 'P'));
1274
         end if;
1275
 
1276
      else
1277
         Set_Directly_Designated_Type (T,
1278
           Process_Subtype (S, P, T, 'P'));
1279
      end if;
1280
 
1281
      if All_Present (Def) or Constant_Present (Def) then
1282
         Set_Ekind (T, E_General_Access_Type);
1283
      else
1284
         Set_Ekind (T, E_Access_Type);
1285
      end if;
1286
 
1287
      if Base_Type (Designated_Type (T)) = T then
1288
         Error_Msg_N ("access type cannot designate itself", S);
1289
 
1290
      --  In Ada 2005, the type may have a limited view through some unit
1291
      --  in its own context, allowing the following circularity that cannot
1292
      --  be detected earlier
1293
 
1294
      elsif Is_Class_Wide_Type (Designated_Type (T))
1295
        and then Etype (Designated_Type (T)) = T
1296
      then
1297
         Error_Msg_N
1298
           ("access type cannot designate its own classwide type", S);
1299
 
1300
         --  Clean up indication of tagged status to prevent cascaded errors
1301
 
1302
         Set_Is_Tagged_Type (T, False);
1303
      end if;
1304
 
1305
      Set_Etype (T, T);
1306
 
1307
      --  If the type has appeared already in a with_type clause, it is
1308
      --  frozen and the pointer size is already set. Else, initialize.
1309
 
1310
      if not From_With_Type (T) then
1311
         Init_Size_Align (T);
1312
      end if;
1313
 
1314
      --  Note that Has_Task is always false, since the access type itself
1315
      --  is not a task type. See Einfo for more description on this point.
1316
      --  Exactly the same consideration applies to Has_Controlled_Component.
1317
 
1318
      Set_Has_Task (T, False);
1319
      Set_Has_Controlled_Component (T, False);
1320
 
1321
      --  Initialize Associated_Final_Chain explicitly to Empty, to avoid
1322
      --  problems where an incomplete view of this entity has been previously
1323
      --  established by a limited with and an overlaid version of this field
1324
      --  (Stored_Constraint) was initialized for the incomplete view.
1325
 
1326
      Set_Associated_Final_Chain (T, Empty);
1327
 
1328
      --  Ada 2005 (AI-231): Propagate the null-excluding and access-constant
1329
      --  attributes
1330
 
1331
      Set_Can_Never_Be_Null  (T, Null_Exclusion_Present (Def));
1332
      Set_Is_Access_Constant (T, Constant_Present (Def));
1333
   end Access_Type_Declaration;
1334
 
1335
   ----------------------------------
1336
   -- Add_Interface_Tag_Components --
1337
   ----------------------------------
1338
 
1339
   procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is
1340
      Loc      : constant Source_Ptr := Sloc (N);
1341
      L        : List_Id;
1342
      Last_Tag : Node_Id;
1343
 
1344
      procedure Add_Tag (Iface : Entity_Id);
1345
      --  Add tag for one of the progenitor interfaces
1346
 
1347
      -------------
1348
      -- Add_Tag --
1349
      -------------
1350
 
1351
      procedure Add_Tag (Iface : Entity_Id) is
1352
         Decl   : Node_Id;
1353
         Def    : Node_Id;
1354
         Tag    : Entity_Id;
1355
         Offset : Entity_Id;
1356
 
1357
      begin
1358
         pragma Assert (Is_Tagged_Type (Iface)
1359
           and then Is_Interface (Iface));
1360
 
1361
         Def :=
1362
           Make_Component_Definition (Loc,
1363
             Aliased_Present    => True,
1364
             Subtype_Indication =>
1365
               New_Occurrence_Of (RTE (RE_Interface_Tag), Loc));
1366
 
1367
         Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
1368
 
1369
         Decl :=
1370
           Make_Component_Declaration (Loc,
1371
             Defining_Identifier  => Tag,
1372
             Component_Definition => Def);
1373
 
1374
         Analyze_Component_Declaration (Decl);
1375
 
1376
         Set_Analyzed (Decl);
1377
         Set_Ekind               (Tag, E_Component);
1378
         Set_Is_Tag              (Tag);
1379
         Set_Is_Aliased          (Tag);
1380
         Set_Related_Type        (Tag, Iface);
1381
         Init_Component_Location (Tag);
1382
 
1383
         pragma Assert (Is_Frozen (Iface));
1384
 
1385
         Set_DT_Entry_Count    (Tag,
1386
           DT_Entry_Count (First_Entity (Iface)));
1387
 
1388
         if No (Last_Tag) then
1389
            Prepend (Decl, L);
1390
         else
1391
            Insert_After (Last_Tag, Decl);
1392
         end if;
1393
 
1394
         Last_Tag := Decl;
1395
 
1396
         --  If the ancestor has discriminants we need to give special support
1397
         --  to store the offset_to_top value of the secondary dispatch tables.
1398
         --  For this purpose we add a supplementary component just after the
1399
         --  field that contains the tag associated with each secondary DT.
1400
 
1401
         if Typ /= Etype (Typ)
1402
           and then Has_Discriminants (Etype (Typ))
1403
         then
1404
            Def :=
1405
              Make_Component_Definition (Loc,
1406
                Subtype_Indication =>
1407
                  New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
1408
 
1409
            Offset :=
1410
              Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
1411
 
1412
            Decl :=
1413
              Make_Component_Declaration (Loc,
1414
                Defining_Identifier  => Offset,
1415
                Component_Definition => Def);
1416
 
1417
            Analyze_Component_Declaration (Decl);
1418
 
1419
            Set_Analyzed (Decl);
1420
            Set_Ekind               (Offset, E_Component);
1421
            Set_Is_Aliased          (Offset);
1422
            Set_Related_Type        (Offset, Iface);
1423
            Init_Component_Location (Offset);
1424
            Insert_After (Last_Tag, Decl);
1425
            Last_Tag := Decl;
1426
         end if;
1427
      end Add_Tag;
1428
 
1429
      --  Local variables
1430
 
1431
      Elmt : Elmt_Id;
1432
      Ext  : Node_Id;
1433
      Comp : Node_Id;
1434
 
1435
   --  Start of processing for Add_Interface_Tag_Components
1436
 
1437
   begin
1438
      if not RTE_Available (RE_Interface_Tag) then
1439
         Error_Msg
1440
           ("(Ada 2005) interface types not supported by this run-time!",
1441
            Sloc (N));
1442
         return;
1443
      end if;
1444
 
1445
      if Ekind (Typ) /= E_Record_Type
1446
        or else (Is_Concurrent_Record_Type (Typ)
1447
                  and then Is_Empty_List (Abstract_Interface_List (Typ)))
1448
        or else (not Is_Concurrent_Record_Type (Typ)
1449
                  and then No (Interfaces (Typ))
1450
                  and then Is_Empty_Elmt_List (Interfaces (Typ)))
1451
      then
1452
         return;
1453
      end if;
1454
 
1455
      --  Find the current last tag
1456
 
1457
      if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1458
         Ext := Record_Extension_Part (Type_Definition (N));
1459
      else
1460
         pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
1461
         Ext := Type_Definition (N);
1462
      end if;
1463
 
1464
      Last_Tag := Empty;
1465
 
1466
      if not (Present (Component_List (Ext))) then
1467
         Set_Null_Present (Ext, False);
1468
         L := New_List;
1469
         Set_Component_List (Ext,
1470
           Make_Component_List (Loc,
1471
             Component_Items => L,
1472
             Null_Present => False));
1473
      else
1474
         if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
1475
            L := Component_Items
1476
                   (Component_List
1477
                     (Record_Extension_Part
1478
                       (Type_Definition (N))));
1479
         else
1480
            L := Component_Items
1481
                   (Component_List
1482
                     (Type_Definition (N)));
1483
         end if;
1484
 
1485
         --  Find the last tag component
1486
 
1487
         Comp := First (L);
1488
         while Present (Comp) loop
1489
            if Nkind (Comp) = N_Component_Declaration
1490
              and then Is_Tag (Defining_Identifier (Comp))
1491
            then
1492
               Last_Tag := Comp;
1493
            end if;
1494
 
1495
            Next (Comp);
1496
         end loop;
1497
      end if;
1498
 
1499
      --  At this point L references the list of components and Last_Tag
1500
      --  references the current last tag (if any). Now we add the tag
1501
      --  corresponding with all the interfaces that are not implemented
1502
      --  by the parent.
1503
 
1504
      if Present (Interfaces (Typ)) then
1505
         Elmt := First_Elmt (Interfaces (Typ));
1506
         while Present (Elmt) loop
1507
            Add_Tag (Node (Elmt));
1508
            Next_Elmt (Elmt);
1509
         end loop;
1510
      end if;
1511
   end Add_Interface_Tag_Components;
1512
 
1513
   -------------------------------------
1514
   -- Add_Internal_Interface_Entities --
1515
   -------------------------------------
1516
 
1517
   procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
1518
      Elmt        : Elmt_Id;
1519
      Iface       : Entity_Id;
1520
      Iface_Elmt  : Elmt_Id;
1521
      Iface_Prim  : Entity_Id;
1522
      Ifaces_List : Elist_Id;
1523
      New_Subp    : Entity_Id := Empty;
1524
      Prim        : Entity_Id;
1525
 
1526
   begin
1527
      pragma Assert (Ada_Version >= Ada_05
1528
        and then Is_Record_Type (Tagged_Type)
1529
        and then Is_Tagged_Type (Tagged_Type)
1530
        and then Has_Interfaces (Tagged_Type)
1531
        and then not Is_Interface (Tagged_Type));
1532
 
1533
      Collect_Interfaces (Tagged_Type, Ifaces_List);
1534
 
1535
      Iface_Elmt := First_Elmt (Ifaces_List);
1536
      while Present (Iface_Elmt) loop
1537
         Iface := Node (Iface_Elmt);
1538
 
1539
         --  Exclude from this processing interfaces that are parents of
1540
         --  Tagged_Type because their primitives are located in the primary
1541
         --  dispatch table (and hence no auxiliary internal entities are
1542
         --  required to handle secondary dispatch tables in such case).
1543
 
1544
         if not Is_Ancestor (Iface, Tagged_Type) then
1545
            Elmt := First_Elmt (Primitive_Operations (Iface));
1546
            while Present (Elmt) loop
1547
               Iface_Prim := Node (Elmt);
1548
 
1549
               if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
1550
                  Prim :=
1551
                    Find_Primitive_Covering_Interface
1552
                      (Tagged_Type => Tagged_Type,
1553
                       Iface_Prim  => Iface_Prim);
1554
 
1555
                  pragma Assert (Present (Prim));
1556
 
1557
                  Derive_Subprogram
1558
                    (New_Subp     => New_Subp,
1559
                     Parent_Subp  => Iface_Prim,
1560
                     Derived_Type => Tagged_Type,
1561
                     Parent_Type  => Iface);
1562
 
1563
                  --  Ada 2005 (AI-251): Decorate internal entity Iface_Subp
1564
                  --  associated with interface types. These entities are
1565
                  --  only registered in the list of primitives of its
1566
                  --  corresponding tagged type because they are only used
1567
                  --  to fill the contents of the secondary dispatch tables.
1568
                  --  Therefore they are removed from the homonym chains.
1569
 
1570
                  Set_Is_Hidden (New_Subp);
1571
                  Set_Is_Internal (New_Subp);
1572
                  Set_Alias (New_Subp, Prim);
1573
                  Set_Is_Abstract_Subprogram (New_Subp,
1574
                    Is_Abstract_Subprogram (Prim));
1575
                  Set_Interface_Alias (New_Subp, Iface_Prim);
1576
 
1577
                  --  Internal entities associated with interface types are
1578
                  --  only registered in the list of primitives of the tagged
1579
                  --  type. They are only used to fill the contents of the
1580
                  --  secondary dispatch tables. Therefore they are not needed
1581
                  --  in the homonym chains.
1582
 
1583
                  Remove_Homonym (New_Subp);
1584
 
1585
                  --  Hidden entities associated with interfaces must have set
1586
                  --  the Has_Delay_Freeze attribute to ensure that, in case of
1587
                  --  locally defined tagged types (or compiling with static
1588
                  --  dispatch tables generation disabled) the corresponding
1589
                  --  entry of the secondary dispatch table is filled when
1590
                  --  such an entity is frozen.
1591
 
1592
                  Set_Has_Delayed_Freeze (New_Subp);
1593
               end if;
1594
 
1595
               Next_Elmt (Elmt);
1596
            end loop;
1597
         end if;
1598
 
1599
         Next_Elmt (Iface_Elmt);
1600
      end loop;
1601
   end Add_Internal_Interface_Entities;
1602
 
1603
   -----------------------------------
1604
   -- Analyze_Component_Declaration --
1605
   -----------------------------------
1606
 
1607
   procedure Analyze_Component_Declaration (N : Node_Id) is
1608
      Id : constant Entity_Id := Defining_Identifier (N);
1609
      E  : constant Node_Id   := Expression (N);
1610
      T  : Entity_Id;
1611
      P  : Entity_Id;
1612
 
1613
      function Contains_POC (Constr : Node_Id) return Boolean;
1614
      --  Determines whether a constraint uses the discriminant of a record
1615
      --  type thus becoming a per-object constraint (POC).
1616
 
1617
      function Is_Known_Limited (Typ : Entity_Id) return Boolean;
1618
      --  Typ is the type of the current component, check whether this type is
1619
      --  a limited type. Used to validate declaration against that of
1620
      --  enclosing record.
1621
 
1622
      ------------------
1623
      -- Contains_POC --
1624
      ------------------
1625
 
1626
      function Contains_POC (Constr : Node_Id) return Boolean is
1627
      begin
1628
         --  Prevent cascaded errors
1629
 
1630
         if Error_Posted (Constr) then
1631
            return False;
1632
         end if;
1633
 
1634
         case Nkind (Constr) is
1635
            when N_Attribute_Reference =>
1636
               return
1637
                 Attribute_Name (Constr) = Name_Access
1638
                   and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
1639
 
1640
            when N_Discriminant_Association =>
1641
               return Denotes_Discriminant (Expression (Constr));
1642
 
1643
            when N_Identifier =>
1644
               return Denotes_Discriminant (Constr);
1645
 
1646
            when N_Index_Or_Discriminant_Constraint =>
1647
               declare
1648
                  IDC : Node_Id;
1649
 
1650
               begin
1651
                  IDC := First (Constraints (Constr));
1652
                  while Present (IDC) loop
1653
 
1654
                     --  One per-object constraint is sufficient
1655
 
1656
                     if Contains_POC (IDC) then
1657
                        return True;
1658
                     end if;
1659
 
1660
                     Next (IDC);
1661
                  end loop;
1662
 
1663
                  return False;
1664
               end;
1665
 
1666
            when N_Range =>
1667
               return Denotes_Discriminant (Low_Bound (Constr))
1668
                        or else
1669
                      Denotes_Discriminant (High_Bound (Constr));
1670
 
1671
            when N_Range_Constraint =>
1672
               return Denotes_Discriminant (Range_Expression (Constr));
1673
 
1674
            when others =>
1675
               return False;
1676
 
1677
         end case;
1678
      end Contains_POC;
1679
 
1680
      ----------------------
1681
      -- Is_Known_Limited --
1682
      ----------------------
1683
 
1684
      function Is_Known_Limited (Typ : Entity_Id) return Boolean is
1685
         P : constant Entity_Id := Etype (Typ);
1686
         R : constant Entity_Id := Root_Type (Typ);
1687
 
1688
      begin
1689
         if Is_Limited_Record (Typ) then
1690
            return True;
1691
 
1692
         --  If the root type is limited (and not a limited interface)
1693
         --  so is the current type
1694
 
1695
         elsif Is_Limited_Record (R)
1696
           and then
1697
             (not Is_Interface (R)
1698
               or else not Is_Limited_Interface (R))
1699
         then
1700
            return True;
1701
 
1702
         --  Else the type may have a limited interface progenitor, but a
1703
         --  limited record parent.
1704
 
1705
         elsif R /= P
1706
           and then Is_Limited_Record (P)
1707
         then
1708
            return True;
1709
 
1710
         else
1711
            return False;
1712
         end if;
1713
      end Is_Known_Limited;
1714
 
1715
   --  Start of processing for Analyze_Component_Declaration
1716
 
1717
   begin
1718
      Generate_Definition (Id);
1719
      Enter_Name (Id);
1720
 
1721
      if Present (Subtype_Indication (Component_Definition (N))) then
1722
         T := Find_Type_Of_Object
1723
                (Subtype_Indication (Component_Definition (N)), N);
1724
 
1725
      --  Ada 2005 (AI-230): Access Definition case
1726
 
1727
      else
1728
         pragma Assert (Present
1729
                          (Access_Definition (Component_Definition (N))));
1730
 
1731
         T := Access_Definition
1732
                (Related_Nod => N,
1733
                 N => Access_Definition (Component_Definition (N)));
1734
         Set_Is_Local_Anonymous_Access (T);
1735
 
1736
         --  Ada 2005 (AI-254)
1737
 
1738
         if Present (Access_To_Subprogram_Definition
1739
                      (Access_Definition (Component_Definition (N))))
1740
           and then Protected_Present (Access_To_Subprogram_Definition
1741
                                        (Access_Definition
1742
                                          (Component_Definition (N))))
1743
         then
1744
            T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
1745
         end if;
1746
      end if;
1747
 
1748
      --  If the subtype is a constrained subtype of the enclosing record,
1749
      --  (which must have a partial view) the back-end does not properly
1750
      --  handle the recursion. Rewrite the component declaration with an
1751
      --  explicit subtype indication, which is acceptable to Gigi. We can copy
1752
      --  the tree directly because side effects have already been removed from
1753
      --  discriminant constraints.
1754
 
1755
      if Ekind (T) = E_Access_Subtype
1756
        and then Is_Entity_Name (Subtype_Indication (Component_Definition (N)))
1757
        and then Comes_From_Source (T)
1758
        and then Nkind (Parent (T)) = N_Subtype_Declaration
1759
        and then Etype (Directly_Designated_Type (T)) = Current_Scope
1760
      then
1761
         Rewrite
1762
           (Subtype_Indication (Component_Definition (N)),
1763
             New_Copy_Tree (Subtype_Indication (Parent (T))));
1764
         T := Find_Type_Of_Object
1765
                 (Subtype_Indication (Component_Definition (N)), N);
1766
      end if;
1767
 
1768
      --  If the component declaration includes a default expression, then we
1769
      --  check that the component is not of a limited type (RM 3.7(5)),
1770
      --  and do the special preanalysis of the expression (see section on
1771
      --  "Handling of Default and Per-Object Expressions" in the spec of
1772
      --  package Sem).
1773
 
1774
      if Present (E) then
1775
         Preanalyze_Spec_Expression (E, T);
1776
         Check_Initialization (T, E);
1777
 
1778
         if Ada_Version >= Ada_05
1779
           and then Ekind (T) = E_Anonymous_Access_Type
1780
           and then Etype (E) /= Any_Type
1781
         then
1782
            --  Check RM 3.9.2(9): "if the expected type for an expression is
1783
            --  an anonymous access-to-specific tagged type, then the object
1784
            --  designated by the expression shall not be dynamically tagged
1785
            --  unless it is a controlling operand in a call on a dispatching
1786
            --  operation"
1787
 
1788
            if Is_Tagged_Type (Directly_Designated_Type (T))
1789
              and then
1790
                Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
1791
              and then
1792
                Ekind (Directly_Designated_Type (Etype (E))) =
1793
                  E_Class_Wide_Type
1794
            then
1795
               Error_Msg_N
1796
                 ("access to specific tagged type required (RM 3.9.2(9))", E);
1797
            end if;
1798
 
1799
            --  (Ada 2005: AI-230): Accessibility check for anonymous
1800
            --  components
1801
 
1802
            if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then
1803
               Error_Msg_N
1804
                 ("expression has deeper access level than component " &
1805
                  "(RM 3.10.2 (12.2))", E);
1806
            end if;
1807
 
1808
            --  The initialization expression is a reference to an access
1809
            --  discriminant. The type of the discriminant is always deeper
1810
            --  than any access type.
1811
 
1812
            if Ekind (Etype (E)) = E_Anonymous_Access_Type
1813
              and then Is_Entity_Name (E)
1814
              and then Ekind (Entity (E)) = E_In_Parameter
1815
              and then Present (Discriminal_Link (Entity (E)))
1816
            then
1817
               Error_Msg_N
1818
                 ("discriminant has deeper accessibility level than target",
1819
                  E);
1820
            end if;
1821
         end if;
1822
      end if;
1823
 
1824
      --  The parent type may be a private view with unknown discriminants,
1825
      --  and thus unconstrained. Regular components must be constrained.
1826
 
1827
      if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
1828
         if Is_Class_Wide_Type (T) then
1829
            Error_Msg_N
1830
               ("class-wide subtype with unknown discriminants" &
1831
                 " in component declaration",
1832
                 Subtype_Indication (Component_Definition (N)));
1833
         else
1834
            Error_Msg_N
1835
              ("unconstrained subtype in component declaration",
1836
               Subtype_Indication (Component_Definition (N)));
1837
         end if;
1838
 
1839
      --  Components cannot be abstract, except for the special case of
1840
      --  the _Parent field (case of extending an abstract tagged type)
1841
 
1842
      elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then
1843
         Error_Msg_N ("type of a component cannot be abstract", N);
1844
      end if;
1845
 
1846
      Set_Etype (Id, T);
1847
      Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
1848
 
1849
      --  The component declaration may have a per-object constraint, set
1850
      --  the appropriate flag in the defining identifier of the subtype.
1851
 
1852
      if Present (Subtype_Indication (Component_Definition (N))) then
1853
         declare
1854
            Sindic : constant Node_Id :=
1855
                       Subtype_Indication (Component_Definition (N));
1856
         begin
1857
            if Nkind (Sindic) = N_Subtype_Indication
1858
              and then Present (Constraint (Sindic))
1859
              and then Contains_POC (Constraint (Sindic))
1860
            then
1861
               Set_Has_Per_Object_Constraint (Id);
1862
            end if;
1863
         end;
1864
      end if;
1865
 
1866
      --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
1867
      --  out some static checks.
1868
 
1869
      if Ada_Version >= Ada_05
1870
        and then Can_Never_Be_Null (T)
1871
      then
1872
         Null_Exclusion_Static_Checks (N);
1873
      end if;
1874
 
1875
      --  If this component is private (or depends on a private type), flag the
1876
      --  record type to indicate that some operations are not available.
1877
 
1878
      P := Private_Component (T);
1879
 
1880
      if Present (P) then
1881
 
1882
         --  Check for circular definitions
1883
 
1884
         if P = Any_Type then
1885
            Set_Etype (Id, Any_Type);
1886
 
1887
         --  There is a gap in the visibility of operations only if the
1888
         --  component type is not defined in the scope of the record type.
1889
 
1890
         elsif Scope (P) = Scope (Current_Scope) then
1891
            null;
1892
 
1893
         elsif Is_Limited_Type (P) then
1894
            Set_Is_Limited_Composite (Current_Scope);
1895
 
1896
         else
1897
            Set_Is_Private_Composite (Current_Scope);
1898
         end if;
1899
      end if;
1900
 
1901
      if P /= Any_Type
1902
        and then Is_Limited_Type (T)
1903
        and then Chars (Id) /= Name_uParent
1904
        and then Is_Tagged_Type (Current_Scope)
1905
      then
1906
         if Is_Derived_Type (Current_Scope)
1907
           and then not Is_Known_Limited (Current_Scope)
1908
         then
1909
            Error_Msg_N
1910
              ("extension of nonlimited type cannot have limited components",
1911
               N);
1912
 
1913
            if Is_Interface (Root_Type (Current_Scope)) then
1914
               Error_Msg_N
1915
                 ("\limitedness is not inherited from limited interface", N);
1916
               Error_Msg_N
1917
                 ("\add LIMITED to type indication", N);
1918
            end if;
1919
 
1920
            Explain_Limited_Type (T, N);
1921
            Set_Etype (Id, Any_Type);
1922
            Set_Is_Limited_Composite (Current_Scope, False);
1923
 
1924
         elsif not Is_Derived_Type (Current_Scope)
1925
           and then not Is_Limited_Record (Current_Scope)
1926
           and then not Is_Concurrent_Type (Current_Scope)
1927
         then
1928
            Error_Msg_N
1929
              ("nonlimited tagged type cannot have limited components", N);
1930
            Explain_Limited_Type (T, N);
1931
            Set_Etype (Id, Any_Type);
1932
            Set_Is_Limited_Composite (Current_Scope, False);
1933
         end if;
1934
      end if;
1935
 
1936
      Set_Original_Record_Component (Id, Id);
1937
   end Analyze_Component_Declaration;
1938
 
1939
   --------------------------
1940
   -- Analyze_Declarations --
1941
   --------------------------
1942
 
1943
   procedure Analyze_Declarations (L : List_Id) is
1944
      D           : Node_Id;
1945
      Freeze_From : Entity_Id := Empty;
1946
      Next_Node   : Node_Id;
1947
 
1948
      procedure Adjust_D;
1949
      --  Adjust D not to include implicit label declarations, since these
1950
      --  have strange Sloc values that result in elaboration check problems.
1951
      --  (They have the sloc of the label as found in the source, and that
1952
      --  is ahead of the current declarative part).
1953
 
1954
      --------------
1955
      -- Adjust_D --
1956
      --------------
1957
 
1958
      procedure Adjust_D is
1959
      begin
1960
         while Present (Prev (D))
1961
           and then Nkind (D) = N_Implicit_Label_Declaration
1962
         loop
1963
            Prev (D);
1964
         end loop;
1965
      end Adjust_D;
1966
 
1967
   --  Start of processing for Analyze_Declarations
1968
 
1969
   begin
1970
      D := First (L);
1971
      while Present (D) loop
1972
 
1973
         --  Complete analysis of declaration
1974
 
1975
         Analyze (D);
1976
         Next_Node := Next (D);
1977
 
1978
         if No (Freeze_From) then
1979
            Freeze_From := First_Entity (Current_Scope);
1980
         end if;
1981
 
1982
         --  At the end of a declarative part, freeze remaining entities
1983
         --  declared in it. The end of the visible declarations of package
1984
         --  specification is not the end of a declarative part if private
1985
         --  declarations are present. The end of a package declaration is a
1986
         --  freezing point only if it a library package. A task definition or
1987
         --  protected type definition is not a freeze point either. Finally,
1988
         --  we do not freeze entities in generic scopes, because there is no
1989
         --  code generated for them and freeze nodes will be generated for
1990
         --  the instance.
1991
 
1992
         --  The end of a package instantiation is not a freeze point, but
1993
         --  for now we make it one, because the generic body is inserted
1994
         --  (currently) immediately after. Generic instantiations will not
1995
         --  be a freeze point once delayed freezing of bodies is implemented.
1996
         --  (This is needed in any case for early instantiations ???).
1997
 
1998
         if No (Next_Node) then
1999
            if Nkind_In (Parent (L), N_Component_List,
2000
                                     N_Task_Definition,
2001
                                     N_Protected_Definition)
2002
            then
2003
               null;
2004
 
2005
            elsif Nkind (Parent (L)) /= N_Package_Specification then
2006
               if Nkind (Parent (L)) = N_Package_Body then
2007
                  Freeze_From := First_Entity (Current_Scope);
2008
               end if;
2009
 
2010
               Adjust_D;
2011
               Freeze_All (Freeze_From, D);
2012
               Freeze_From := Last_Entity (Current_Scope);
2013
 
2014
            elsif Scope (Current_Scope) /= Standard_Standard
2015
              and then not Is_Child_Unit (Current_Scope)
2016
              and then No (Generic_Parent (Parent (L)))
2017
            then
2018
               null;
2019
 
2020
            elsif L /= Visible_Declarations (Parent (L))
2021
               or else No (Private_Declarations (Parent (L)))
2022
               or else Is_Empty_List (Private_Declarations (Parent (L)))
2023
            then
2024
               Adjust_D;
2025
               Freeze_All (Freeze_From, D);
2026
               Freeze_From := Last_Entity (Current_Scope);
2027
            end if;
2028
 
2029
         --  If next node is a body then freeze all types before the body.
2030
         --  An exception occurs for some expander-generated bodies. If these
2031
         --  are generated at places where in general language rules would not
2032
         --  allow a freeze point, then we assume that the expander has
2033
         --  explicitly checked that all required types are properly frozen,
2034
         --  and we do not cause general freezing here. This special circuit
2035
         --  is used when the encountered body is marked as having already
2036
         --  been analyzed.
2037
 
2038
         --  In all other cases (bodies that come from source, and expander
2039
         --  generated bodies that have not been analyzed yet), freeze all
2040
         --  types now. Note that in the latter case, the expander must take
2041
         --  care to attach the bodies at a proper place in the tree so as to
2042
         --  not cause unwanted freezing at that point.
2043
 
2044
         elsif not Analyzed (Next_Node)
2045
           and then (Nkind_In (Next_Node, N_Subprogram_Body,
2046
                                          N_Entry_Body,
2047
                                          N_Package_Body,
2048
                                          N_Protected_Body,
2049
                                          N_Task_Body)
2050
                       or else
2051
                     Nkind (Next_Node) in N_Body_Stub)
2052
         then
2053
            Adjust_D;
2054
            Freeze_All (Freeze_From, D);
2055
            Freeze_From := Last_Entity (Current_Scope);
2056
         end if;
2057
 
2058
         D := Next_Node;
2059
      end loop;
2060
   end Analyze_Declarations;
2061
 
2062
   ----------------------------------
2063
   -- Analyze_Incomplete_Type_Decl --
2064
   ----------------------------------
2065
 
2066
   procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
2067
      F : constant Boolean := Is_Pure (Current_Scope);
2068
      T : Entity_Id;
2069
 
2070
   begin
2071
      Generate_Definition (Defining_Identifier (N));
2072
 
2073
      --  Process an incomplete declaration. The identifier must not have been
2074
      --  declared already in the scope. However, an incomplete declaration may
2075
      --  appear in the private part of a package, for a private type that has
2076
      --  already been declared.
2077
 
2078
      --  In this case, the discriminants (if any) must match
2079
 
2080
      T := Find_Type_Name (N);
2081
 
2082
      Set_Ekind (T, E_Incomplete_Type);
2083
      Init_Size_Align (T);
2084
      Set_Is_First_Subtype (T, True);
2085
      Set_Etype (T, T);
2086
 
2087
      --  Ada 2005 (AI-326): Minimum decoration to give support to tagged
2088
      --  incomplete types.
2089
 
2090
      if Tagged_Present (N) then
2091
         Set_Is_Tagged_Type (T);
2092
         Make_Class_Wide_Type (T);
2093
         Set_Primitive_Operations (T, New_Elmt_List);
2094
      end if;
2095
 
2096
      Push_Scope (T);
2097
 
2098
      Set_Stored_Constraint (T, No_Elist);
2099
 
2100
      if Present (Discriminant_Specifications (N)) then
2101
         Process_Discriminants (N);
2102
      end if;
2103
 
2104
      End_Scope;
2105
 
2106
      --  If the type has discriminants, non-trivial subtypes may be
2107
      --  declared before the full view of the type. The full views of those
2108
      --  subtypes will be built after the full view of the type.
2109
 
2110
      Set_Private_Dependents (T, New_Elmt_List);
2111
      Set_Is_Pure (T, F);
2112
   end Analyze_Incomplete_Type_Decl;
2113
 
2114
   -----------------------------------
2115
   -- Analyze_Interface_Declaration --
2116
   -----------------------------------
2117
 
2118
   procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
2119
      CW : constant Entity_Id := Class_Wide_Type (T);
2120
 
2121
   begin
2122
      Set_Is_Tagged_Type (T);
2123
 
2124
      Set_Is_Limited_Record (T, Limited_Present (Def)
2125
                                  or else Task_Present (Def)
2126
                                  or else Protected_Present (Def)
2127
                                  or else Synchronized_Present (Def));
2128
 
2129
      --  Type is abstract if full declaration carries keyword, or if previous
2130
      --  partial view did.
2131
 
2132
      Set_Is_Abstract_Type (T);
2133
      Set_Is_Interface (T);
2134
 
2135
      --  Type is a limited interface if it includes the keyword limited, task,
2136
      --  protected, or synchronized.
2137
 
2138
      Set_Is_Limited_Interface
2139
        (T, Limited_Present (Def)
2140
              or else Protected_Present (Def)
2141
              or else Synchronized_Present (Def)
2142
              or else Task_Present (Def));
2143
 
2144
      Set_Is_Protected_Interface (T, Protected_Present (Def));
2145
      Set_Is_Task_Interface (T, Task_Present (Def));
2146
 
2147
      --  Type is a synchronized interface if it includes the keyword task,
2148
      --  protected, or synchronized.
2149
 
2150
      Set_Is_Synchronized_Interface
2151
        (T, Synchronized_Present (Def)
2152
              or else Protected_Present (Def)
2153
              or else Task_Present (Def));
2154
 
2155
      Set_Interfaces (T, New_Elmt_List);
2156
      Set_Primitive_Operations (T, New_Elmt_List);
2157
 
2158
      --  Complete the decoration of the class-wide entity if it was already
2159
      --  built (i.e. during the creation of the limited view)
2160
 
2161
      if Present (CW) then
2162
         Set_Is_Interface (CW);
2163
         Set_Is_Limited_Interface      (CW, Is_Limited_Interface (T));
2164
         Set_Is_Protected_Interface    (CW, Is_Protected_Interface (T));
2165
         Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T));
2166
         Set_Is_Task_Interface         (CW, Is_Task_Interface (T));
2167
      end if;
2168
 
2169
      --  Check runtime support for synchronized interfaces
2170
 
2171
      if VM_Target = No_VM
2172
        and then (Is_Task_Interface (T)
2173
                    or else Is_Protected_Interface (T)
2174
                    or else Is_Synchronized_Interface (T))
2175
        and then not RTE_Available (RE_Select_Specific_Data)
2176
      then
2177
         Error_Msg_CRT ("synchronized interfaces", T);
2178
      end if;
2179
   end Analyze_Interface_Declaration;
2180
 
2181
   -----------------------------
2182
   -- Analyze_Itype_Reference --
2183
   -----------------------------
2184
 
2185
   --  Nothing to do. This node is placed in the tree only for the benefit of
2186
   --  back end processing, and has no effect on the semantic processing.
2187
 
2188
   procedure Analyze_Itype_Reference (N : Node_Id) is
2189
   begin
2190
      pragma Assert (Is_Itype (Itype (N)));
2191
      null;
2192
   end Analyze_Itype_Reference;
2193
 
2194
   --------------------------------
2195
   -- Analyze_Number_Declaration --
2196
   --------------------------------
2197
 
2198
   procedure Analyze_Number_Declaration (N : Node_Id) is
2199
      Id    : constant Entity_Id := Defining_Identifier (N);
2200
      E     : constant Node_Id   := Expression (N);
2201
      T     : Entity_Id;
2202
      Index : Interp_Index;
2203
      It    : Interp;
2204
 
2205
   begin
2206
      Generate_Definition (Id);
2207
      Enter_Name (Id);
2208
 
2209
      --  This is an optimization of a common case of an integer literal
2210
 
2211
      if Nkind (E) = N_Integer_Literal then
2212
         Set_Is_Static_Expression (E, True);
2213
         Set_Etype                (E, Universal_Integer);
2214
 
2215
         Set_Etype     (Id, Universal_Integer);
2216
         Set_Ekind     (Id, E_Named_Integer);
2217
         Set_Is_Frozen (Id, True);
2218
         return;
2219
      end if;
2220
 
2221
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
2222
 
2223
      --  Process expression, replacing error by integer zero, to avoid
2224
      --  cascaded errors or aborts further along in the processing
2225
 
2226
      --  Replace Error by integer zero, which seems least likely to
2227
      --  cause cascaded errors.
2228
 
2229
      if E = Error then
2230
         Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
2231
         Set_Error_Posted (E);
2232
      end if;
2233
 
2234
      Analyze (E);
2235
 
2236
      --  Verify that the expression is static and numeric. If
2237
      --  the expression is overloaded, we apply the preference
2238
      --  rule that favors root numeric types.
2239
 
2240
      if not Is_Overloaded (E) then
2241
         T := Etype (E);
2242
 
2243
      else
2244
         T := Any_Type;
2245
 
2246
         Get_First_Interp (E, Index, It);
2247
         while Present (It.Typ) loop
2248
            if (Is_Integer_Type (It.Typ)
2249
                 or else Is_Real_Type (It.Typ))
2250
              and then (Scope (Base_Type (It.Typ))) = Standard_Standard
2251
            then
2252
               if T = Any_Type then
2253
                  T := It.Typ;
2254
 
2255
               elsif It.Typ = Universal_Real
2256
                 or else It.Typ = Universal_Integer
2257
               then
2258
                  --  Choose universal interpretation over any other
2259
 
2260
                  T := It.Typ;
2261
                  exit;
2262
               end if;
2263
            end if;
2264
 
2265
            Get_Next_Interp (Index, It);
2266
         end loop;
2267
      end if;
2268
 
2269
      if Is_Integer_Type (T)  then
2270
         Resolve (E, T);
2271
         Set_Etype (Id, Universal_Integer);
2272
         Set_Ekind (Id, E_Named_Integer);
2273
 
2274
      elsif Is_Real_Type (T) then
2275
 
2276
         --  Because the real value is converted to universal_real, this is a
2277
         --  legal context for a universal fixed expression.
2278
 
2279
         if T = Universal_Fixed then
2280
            declare
2281
               Loc  : constant Source_Ptr := Sloc (N);
2282
               Conv : constant Node_Id := Make_Type_Conversion (Loc,
2283
                        Subtype_Mark =>
2284
                          New_Occurrence_Of (Universal_Real, Loc),
2285
                        Expression => Relocate_Node (E));
2286
 
2287
            begin
2288
               Rewrite (E, Conv);
2289
               Analyze (E);
2290
            end;
2291
 
2292
         elsif T = Any_Fixed then
2293
            Error_Msg_N ("illegal context for mixed mode operation", E);
2294
 
2295
            --  Expression is of the form : universal_fixed * integer. Try to
2296
            --  resolve as universal_real.
2297
 
2298
            T := Universal_Real;
2299
            Set_Etype (E, T);
2300
         end if;
2301
 
2302
         Resolve (E, T);
2303
         Set_Etype (Id, Universal_Real);
2304
         Set_Ekind (Id, E_Named_Real);
2305
 
2306
      else
2307
         Wrong_Type (E, Any_Numeric);
2308
         Resolve (E, T);
2309
 
2310
         Set_Etype               (Id, T);
2311
         Set_Ekind               (Id, E_Constant);
2312
         Set_Never_Set_In_Source (Id, True);
2313
         Set_Is_True_Constant    (Id, True);
2314
         return;
2315
      end if;
2316
 
2317
      if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
2318
         Set_Etype (E, Etype (Id));
2319
      end if;
2320
 
2321
      if not Is_OK_Static_Expression (E) then
2322
         Flag_Non_Static_Expr
2323
           ("non-static expression used in number declaration!", E);
2324
         Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
2325
         Set_Etype (E, Any_Type);
2326
      end if;
2327
   end Analyze_Number_Declaration;
2328
 
2329
   --------------------------------
2330
   -- Analyze_Object_Declaration --
2331
   --------------------------------
2332
 
2333
   procedure Analyze_Object_Declaration (N : Node_Id) is
2334
      Loc   : constant Source_Ptr := Sloc (N);
2335
      Id    : constant Entity_Id  := Defining_Identifier (N);
2336
      T     : Entity_Id;
2337
      Act_T : Entity_Id;
2338
 
2339
      E : Node_Id := Expression (N);
2340
      --  E is set to Expression (N) throughout this routine. When
2341
      --  Expression (N) is modified, E is changed accordingly.
2342
 
2343
      Prev_Entity : Entity_Id := Empty;
2344
 
2345
      function Count_Tasks (T : Entity_Id) return Uint;
2346
      --  This function is called when a non-generic library level object of a
2347
      --  task type is declared. Its function is to count the static number of
2348
      --  tasks declared within the type (it is only called if Has_Tasks is set
2349
      --  for T). As a side effect, if an array of tasks with non-static bounds
2350
      --  or a variant record type is encountered, Check_Restrictions is called
2351
      --  indicating the count is unknown.
2352
 
2353
      -----------------
2354
      -- Count_Tasks --
2355
      -----------------
2356
 
2357
      function Count_Tasks (T : Entity_Id) return Uint is
2358
         C : Entity_Id;
2359
         X : Node_Id;
2360
         V : Uint;
2361
 
2362
      begin
2363
         if Is_Task_Type (T) then
2364
            return Uint_1;
2365
 
2366
         elsif Is_Record_Type (T) then
2367
            if Has_Discriminants (T) then
2368
               Check_Restriction (Max_Tasks, N);
2369
               return Uint_0;
2370
 
2371
            else
2372
               V := Uint_0;
2373
               C := First_Component (T);
2374
               while Present (C) loop
2375
                  V := V + Count_Tasks (Etype (C));
2376
                  Next_Component (C);
2377
               end loop;
2378
 
2379
               return V;
2380
            end if;
2381
 
2382
         elsif Is_Array_Type (T) then
2383
            X := First_Index (T);
2384
            V := Count_Tasks (Component_Type (T));
2385
            while Present (X) loop
2386
               C := Etype (X);
2387
 
2388
               if not Is_Static_Subtype (C) then
2389
                  Check_Restriction (Max_Tasks, N);
2390
                  return Uint_0;
2391
               else
2392
                  V := V * (UI_Max (Uint_0,
2393
                                    Expr_Value (Type_High_Bound (C)) -
2394
                                    Expr_Value (Type_Low_Bound (C)) + Uint_1));
2395
               end if;
2396
 
2397
               Next_Index (X);
2398
            end loop;
2399
 
2400
            return V;
2401
 
2402
         else
2403
            return Uint_0;
2404
         end if;
2405
      end Count_Tasks;
2406
 
2407
   --  Start of processing for Analyze_Object_Declaration
2408
 
2409
   begin
2410
      --  There are three kinds of implicit types generated by an
2411
      --  object declaration:
2412
 
2413
      --   1. Those for generated by the original Object Definition
2414
 
2415
      --   2. Those generated by the Expression
2416
 
2417
      --   3. Those used to constrained the Object Definition with the
2418
      --       expression constraints when it is unconstrained
2419
 
2420
      --  They must be generated in this order to avoid order of elaboration
2421
      --  issues. Thus the first step (after entering the name) is to analyze
2422
      --  the object definition.
2423
 
2424
      if Constant_Present (N) then
2425
         Prev_Entity := Current_Entity_In_Scope (Id);
2426
 
2427
         if Present (Prev_Entity)
2428
           and then
2429
             --  If the homograph is an implicit subprogram, it is overridden
2430
             --  by the current declaration.
2431
 
2432
             ((Is_Overloadable (Prev_Entity)
2433
                and then Is_Inherited_Operation (Prev_Entity))
2434
 
2435
               --  The current object is a discriminal generated for an entry
2436
               --  family index. Even though the index is a constant, in this
2437
               --  particular context there is no true constant redeclaration.
2438
               --  Enter_Name will handle the visibility.
2439
 
2440
               or else
2441
                (Is_Discriminal (Id)
2442
                   and then Ekind (Discriminal_Link (Id)) =
2443
                              E_Entry_Index_Parameter)
2444
 
2445
               --  The current object is the renaming for a generic declared
2446
               --  within the instance.
2447
 
2448
               or else
2449
                (Ekind (Prev_Entity) = E_Package
2450
                  and then Nkind (Parent (Prev_Entity)) =
2451
                                         N_Package_Renaming_Declaration
2452
                  and then not Comes_From_Source (Prev_Entity)
2453
                  and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
2454
         then
2455
            Prev_Entity := Empty;
2456
         end if;
2457
      end if;
2458
 
2459
      if Present (Prev_Entity) then
2460
         Constant_Redeclaration (Id, N, T);
2461
 
2462
         Generate_Reference (Prev_Entity, Id, 'c');
2463
         Set_Completion_Referenced (Id);
2464
 
2465
         if Error_Posted (N) then
2466
 
2467
            --  Type mismatch or illegal redeclaration, Do not analyze
2468
            --  expression to avoid cascaded errors.
2469
 
2470
            T := Find_Type_Of_Object (Object_Definition (N), N);
2471
            Set_Etype (Id, T);
2472
            Set_Ekind (Id, E_Variable);
2473
            return;
2474
         end if;
2475
 
2476
      --  In the normal case, enter identifier at the start to catch premature
2477
      --  usage in the initialization expression.
2478
 
2479
      else
2480
         Generate_Definition (Id);
2481
         Enter_Name (Id);
2482
 
2483
         Mark_Coextensions (N, Object_Definition (N));
2484
 
2485
         T := Find_Type_Of_Object (Object_Definition (N), N);
2486
 
2487
         if Nkind (Object_Definition (N)) = N_Access_Definition
2488
           and then Present
2489
             (Access_To_Subprogram_Definition (Object_Definition (N)))
2490
           and then Protected_Present
2491
             (Access_To_Subprogram_Definition (Object_Definition (N)))
2492
         then
2493
            T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
2494
         end if;
2495
 
2496
         if Error_Posted (Id) then
2497
            Set_Etype (Id, T);
2498
            Set_Ekind (Id, E_Variable);
2499
            return;
2500
         end if;
2501
      end if;
2502
 
2503
      --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
2504
      --  out some static checks
2505
 
2506
      if Ada_Version >= Ada_05
2507
        and then Can_Never_Be_Null (T)
2508
      then
2509
         --  In case of aggregates we must also take care of the correct
2510
         --  initialization of nested aggregates bug this is done at the
2511
         --  point of the analysis of the aggregate (see sem_aggr.adb)
2512
 
2513
         if Present (Expression (N))
2514
           and then Nkind (Expression (N)) = N_Aggregate
2515
         then
2516
            null;
2517
 
2518
         else
2519
            declare
2520
               Save_Typ : constant Entity_Id := Etype (Id);
2521
            begin
2522
               Set_Etype (Id, T); --  Temp. decoration for static checks
2523
               Null_Exclusion_Static_Checks (N);
2524
               Set_Etype (Id, Save_Typ);
2525
            end;
2526
         end if;
2527
      end if;
2528
 
2529
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
2530
 
2531
      --  If deferred constant, make sure context is appropriate. We detect
2532
      --  a deferred constant as a constant declaration with no expression.
2533
      --  A deferred constant can appear in a package body if its completion
2534
      --  is by means of an interface pragma.
2535
 
2536
      if Constant_Present (N)
2537
        and then No (E)
2538
      then
2539
         --  A deferred constant may appear in the declarative part of the
2540
         --  following constructs:
2541
 
2542
         --     blocks
2543
         --     entry bodies
2544
         --     extended return statements
2545
         --     package specs
2546
         --     package bodies
2547
         --     subprogram bodies
2548
         --     task bodies
2549
 
2550
         --  When declared inside a package spec, a deferred constant must be
2551
         --  completed by a full constant declaration or pragma Import. In all
2552
         --  other cases, the only proper completion is pragma Import. Extended
2553
         --  return statements are flagged as invalid contexts because they do
2554
         --  not have a declarative part and so cannot accommodate the pragma.
2555
 
2556
         if Ekind (Current_Scope) = E_Return_Statement then
2557
            Error_Msg_N
2558
              ("invalid context for deferred constant declaration (RM 7.4)",
2559
               N);
2560
            Error_Msg_N
2561
              ("\declaration requires an initialization expression",
2562
                N);
2563
            Set_Constant_Present (N, False);
2564
 
2565
         --  In Ada 83, deferred constant must be of private type
2566
 
2567
         elsif not Is_Private_Type (T) then
2568
            if Ada_Version = Ada_83 and then Comes_From_Source (N) then
2569
               Error_Msg_N
2570
                 ("(Ada 83) deferred constant must be private type", N);
2571
            end if;
2572
         end if;
2573
 
2574
      --  If not a deferred constant, then object declaration freezes its type
2575
 
2576
      else
2577
         Check_Fully_Declared (T, N);
2578
         Freeze_Before (N, T);
2579
      end if;
2580
 
2581
      --  If the object was created by a constrained array definition, then
2582
      --  set the link in both the anonymous base type and anonymous subtype
2583
      --  that are built to represent the array type to point to the object.
2584
 
2585
      if Nkind (Object_Definition (Declaration_Node (Id))) =
2586
                        N_Constrained_Array_Definition
2587
      then
2588
         Set_Related_Array_Object (T, Id);
2589
         Set_Related_Array_Object (Base_Type (T), Id);
2590
      end if;
2591
 
2592
      --  Special checks for protected objects not at library level
2593
 
2594
      if Is_Protected_Type (T)
2595
        and then not Is_Library_Level_Entity (Id)
2596
      then
2597
         Check_Restriction (No_Local_Protected_Objects, Id);
2598
 
2599
         --  Protected objects with interrupt handlers must be at library level
2600
 
2601
         --  Ada 2005: this test is not needed (and the corresponding clause
2602
         --  in the RM is removed) because accessibility checks are sufficient
2603
         --  to make handlers not at the library level illegal.
2604
 
2605
         if Has_Interrupt_Handler (T)
2606
           and then Ada_Version < Ada_05
2607
         then
2608
            Error_Msg_N
2609
              ("interrupt object can only be declared at library level", Id);
2610
         end if;
2611
      end if;
2612
 
2613
      --  The actual subtype of the object is the nominal subtype, unless
2614
      --  the nominal one is unconstrained and obtained from the expression.
2615
 
2616
      Act_T := T;
2617
 
2618
      --  Process initialization expression if present and not in error
2619
 
2620
      if Present (E) and then E /= Error then
2621
 
2622
         --  Generate an error in case of CPP class-wide object initialization.
2623
         --  Required because otherwise the expansion of the class-wide
2624
         --  assignment would try to use 'size to initialize the object
2625
         --  (primitive that is not available in CPP tagged types).
2626
 
2627
         if Is_Class_Wide_Type (Act_T)
2628
           and then
2629
             (Is_CPP_Class (Root_Type (Etype (Act_T)))
2630
               or else
2631
                 (Present (Full_View (Root_Type (Etype (Act_T))))
2632
                    and then
2633
                      Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
2634
         then
2635
            Error_Msg_N
2636
              ("predefined assignment not available for 'C'P'P tagged types",
2637
               E);
2638
         end if;
2639
 
2640
         Mark_Coextensions (N, E);
2641
         Analyze (E);
2642
 
2643
         --  In case of errors detected in the analysis of the expression,
2644
         --  decorate it with the expected type to avoid cascaded errors
2645
 
2646
         if No (Etype (E)) then
2647
            Set_Etype (E, T);
2648
         end if;
2649
 
2650
         --  If an initialization expression is present, then we set the
2651
         --  Is_True_Constant flag. It will be reset if this is a variable
2652
         --  and it is indeed modified.
2653
 
2654
         Set_Is_True_Constant (Id, True);
2655
 
2656
         --  If we are analyzing a constant declaration, set its completion
2657
         --  flag after analyzing and resolving the expression.
2658
 
2659
         if Constant_Present (N) then
2660
            Set_Has_Completion (Id);
2661
         end if;
2662
 
2663
         --  Set type and resolve (type may be overridden later on)
2664
 
2665
         Set_Etype (Id, T);
2666
         Resolve (E, T);
2667
 
2668
         --  If E is null and has been replaced by an N_Raise_Constraint_Error
2669
         --  node (which was marked already-analyzed), we need to set the type
2670
         --  to something other than Any_Access in order to keep gigi happy.
2671
 
2672
         if Etype (E) = Any_Access then
2673
            Set_Etype (E, T);
2674
         end if;
2675
 
2676
         --  If the object is an access to variable, the initialization
2677
         --  expression cannot be an access to constant.
2678
 
2679
         if Is_Access_Type (T)
2680
           and then not Is_Access_Constant (T)
2681
           and then Is_Access_Type (Etype (E))
2682
           and then Is_Access_Constant (Etype (E))
2683
         then
2684
            Error_Msg_N
2685
              ("access to variable cannot be initialized "
2686
               & "with an access-to-constant expression", E);
2687
         end if;
2688
 
2689
         if not Assignment_OK (N) then
2690
            Check_Initialization (T, E);
2691
         end if;
2692
 
2693
         Check_Unset_Reference (E);
2694
 
2695
         --  If this is a variable, then set current value. If this is a
2696
         --  declared constant of a scalar type with a static expression,
2697
         --  indicate that it is always valid.
2698
 
2699
         if not Constant_Present (N) then
2700
            if Compile_Time_Known_Value (E) then
2701
               Set_Current_Value (Id, E);
2702
            end if;
2703
 
2704
         elsif Is_Scalar_Type (T)
2705
           and then Is_OK_Static_Expression (E)
2706
         then
2707
            Set_Is_Known_Valid (Id);
2708
         end if;
2709
 
2710
         --  Deal with setting of null flags
2711
 
2712
         if Is_Access_Type (T) then
2713
            if Known_Non_Null (E) then
2714
               Set_Is_Known_Non_Null (Id, True);
2715
            elsif Known_Null (E)
2716
              and then not Can_Never_Be_Null (Id)
2717
            then
2718
               Set_Is_Known_Null (Id, True);
2719
            end if;
2720
         end if;
2721
 
2722
         --  Check incorrect use of dynamically tagged expressions.
2723
 
2724
         if Is_Tagged_Type (T) then
2725
            Check_Dynamically_Tagged_Expression
2726
              (Expr        => E,
2727
               Typ         => T,
2728
               Related_Nod => N);
2729
         end if;
2730
 
2731
         Apply_Scalar_Range_Check (E, T);
2732
         Apply_Static_Length_Check (E, T);
2733
      end if;
2734
 
2735
      --  If the No_Streams restriction is set, check that the type of the
2736
      --  object is not, and does not contain, any subtype derived from
2737
      --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
2738
      --  Has_Stream just for efficiency reasons. There is no point in
2739
      --  spending time on a Has_Stream check if the restriction is not set.
2740
 
2741
      if Restrictions.Set (No_Streams) then
2742
         if Has_Stream (T) then
2743
            Check_Restriction (No_Streams, N);
2744
         end if;
2745
      end if;
2746
 
2747
      --  Case of unconstrained type
2748
 
2749
      if Is_Indefinite_Subtype (T) then
2750
 
2751
         --  Nothing to do in deferred constant case
2752
 
2753
         if Constant_Present (N) and then No (E) then
2754
            null;
2755
 
2756
         --  Case of no initialization present
2757
 
2758
         elsif No (E) then
2759
            if No_Initialization (N) then
2760
               null;
2761
 
2762
            elsif Is_Class_Wide_Type (T) then
2763
               Error_Msg_N
2764
                 ("initialization required in class-wide declaration ", N);
2765
 
2766
            else
2767
               Error_Msg_N
2768
                 ("unconstrained subtype not allowed (need initialization)",
2769
                  Object_Definition (N));
2770
 
2771
               if Is_Record_Type (T) and then Has_Discriminants (T) then
2772
                  Error_Msg_N
2773
                    ("\provide initial value or explicit discriminant values",
2774
                     Object_Definition (N));
2775
 
2776
                  Error_Msg_NE
2777
                    ("\or give default discriminant values for type&",
2778
                     Object_Definition (N), T);
2779
 
2780
               elsif Is_Array_Type (T) then
2781
                  Error_Msg_N
2782
                    ("\provide initial value or explicit array bounds",
2783
                     Object_Definition (N));
2784
               end if;
2785
            end if;
2786
 
2787
         --  Case of initialization present but in error. Set initial
2788
         --  expression as absent (but do not make above complaints)
2789
 
2790
         elsif E = Error then
2791
            Set_Expression (N, Empty);
2792
            E := Empty;
2793
 
2794
         --  Case of initialization present
2795
 
2796
         else
2797
            --  Not allowed in Ada 83
2798
 
2799
            if not Constant_Present (N) then
2800
               if Ada_Version = Ada_83
2801
                 and then Comes_From_Source (Object_Definition (N))
2802
               then
2803
                  Error_Msg_N
2804
                    ("(Ada 83) unconstrained variable not allowed",
2805
                     Object_Definition (N));
2806
               end if;
2807
            end if;
2808
 
2809
            --  Now we constrain the variable from the initializing expression
2810
 
2811
            --  If the expression is an aggregate, it has been expanded into
2812
            --  individual assignments. Retrieve the actual type from the
2813
            --  expanded construct.
2814
 
2815
            if Is_Array_Type (T)
2816
              and then No_Initialization (N)
2817
              and then Nkind (Original_Node (E)) = N_Aggregate
2818
            then
2819
               Act_T := Etype (E);
2820
 
2821
            --  In case of class-wide interface object declarations we delay
2822
            --  the generation of the equivalent record type declarations until
2823
            --  its expansion because there are cases in they are not required.
2824
 
2825
            elsif Is_Interface (T) then
2826
               null;
2827
 
2828
            else
2829
               Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
2830
               Act_T := Find_Type_Of_Object (Object_Definition (N), N);
2831
            end if;
2832
 
2833
            Set_Is_Constr_Subt_For_U_Nominal (Act_T);
2834
 
2835
            if Aliased_Present (N) then
2836
               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
2837
            end if;
2838
 
2839
            Freeze_Before (N, Act_T);
2840
            Freeze_Before (N, T);
2841
         end if;
2842
 
2843
      elsif Is_Array_Type (T)
2844
        and then No_Initialization (N)
2845
        and then Nkind (Original_Node (E)) = N_Aggregate
2846
      then
2847
         if not Is_Entity_Name (Object_Definition (N)) then
2848
            Act_T := Etype (E);
2849
            Check_Compile_Time_Size (Act_T);
2850
 
2851
            if Aliased_Present (N) then
2852
               Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
2853
            end if;
2854
         end if;
2855
 
2856
         --  When the given object definition and the aggregate are specified
2857
         --  independently, and their lengths might differ do a length check.
2858
         --  This cannot happen if the aggregate is of the form (others =>...)
2859
 
2860
         if not Is_Constrained (T) then
2861
            null;
2862
 
2863
         elsif Nkind (E) = N_Raise_Constraint_Error then
2864
 
2865
            --  Aggregate is statically illegal. Place back in declaration
2866
 
2867
            Set_Expression (N, E);
2868
            Set_No_Initialization (N, False);
2869
 
2870
         elsif T = Etype (E) then
2871
            null;
2872
 
2873
         elsif Nkind (E) = N_Aggregate
2874
           and then Present (Component_Associations (E))
2875
           and then Present (Choices (First (Component_Associations (E))))
2876
           and then Nkind (First
2877
            (Choices (First (Component_Associations (E))))) = N_Others_Choice
2878
         then
2879
            null;
2880
 
2881
         else
2882
            Apply_Length_Check (E, T);
2883
         end if;
2884
 
2885
      --  If the type is limited unconstrained with defaulted discriminants and
2886
      --  there is no expression, then the object is constrained by the
2887
      --  defaults, so it is worthwhile building the corresponding subtype.
2888
 
2889
      elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T))
2890
        and then not Is_Constrained (T)
2891
        and then Has_Discriminants (T)
2892
      then
2893
         if No (E) then
2894
            Act_T := Build_Default_Subtype (T, N);
2895
         else
2896
            --  Ada 2005:  a limited object may be initialized by means of an
2897
            --  aggregate. If the type has default discriminants it has an
2898
            --  unconstrained nominal type, Its actual subtype will be obtained
2899
            --  from the aggregate, and not from the default discriminants.
2900
 
2901
            Act_T := Etype (E);
2902
         end if;
2903
 
2904
         Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
2905
 
2906
      elsif Present (Underlying_Type (T))
2907
        and then not Is_Constrained (Underlying_Type (T))
2908
        and then Has_Discriminants (Underlying_Type (T))
2909
        and then Nkind (E) = N_Function_Call
2910
        and then Constant_Present (N)
2911
      then
2912
         --  The back-end has problems with constants of a discriminated type
2913
         --  with defaults, if the initial value is a function call. We
2914
         --  generate an intermediate temporary for the result of the call.
2915
         --  It is unclear why this should make it acceptable to gcc. ???
2916
 
2917
         Remove_Side_Effects (E);
2918
      end if;
2919
 
2920
      --  Check No_Wide_Characters restriction
2921
 
2922
      if T = Standard_Wide_Character
2923
        or else T = Standard_Wide_Wide_Character
2924
        or else Root_Type (T) = Standard_Wide_String
2925
        or else Root_Type (T) = Standard_Wide_Wide_String
2926
      then
2927
         Check_Restriction (No_Wide_Characters, Object_Definition (N));
2928
      end if;
2929
 
2930
      --  Indicate this is not set in source. Certainly true for constants,
2931
      --  and true for variables so far (will be reset for a variable if and
2932
      --  when we encounter a modification in the source).
2933
 
2934
      Set_Never_Set_In_Source (Id, True);
2935
 
2936
      --  Now establish the proper kind and type of the object
2937
 
2938
      if Constant_Present (N) then
2939
         Set_Ekind            (Id, E_Constant);
2940
         Set_Is_True_Constant (Id, True);
2941
 
2942
      else
2943
         Set_Ekind (Id, E_Variable);
2944
 
2945
         --  A variable is set as shared passive if it appears in a shared
2946
         --  passive package, and is at the outer level. This is not done
2947
         --  for entities generated during expansion, because those are
2948
         --  always manipulated locally.
2949
 
2950
         if Is_Shared_Passive (Current_Scope)
2951
           and then Is_Library_Level_Entity (Id)
2952
           and then Comes_From_Source (Id)
2953
         then
2954
            Set_Is_Shared_Passive (Id);
2955
            Check_Shared_Var (Id, T, N);
2956
         end if;
2957
 
2958
         --  Set Has_Initial_Value if initializing expression present. Note
2959
         --  that if there is no initializing expression, we leave the state
2960
         --  of this flag unchanged (usually it will be False, but notably in
2961
         --  the case of exception choice variables, it will already be true).
2962
 
2963
         if Present (E) then
2964
            Set_Has_Initial_Value (Id, True);
2965
         end if;
2966
      end if;
2967
 
2968
      --  Initialize alignment and size and capture alignment setting
2969
 
2970
      Init_Alignment               (Id);
2971
      Init_Esize                   (Id);
2972
      Set_Optimize_Alignment_Flags (Id);
2973
 
2974
      --  Deal with aliased case
2975
 
2976
      if Aliased_Present (N) then
2977
         Set_Is_Aliased (Id);
2978
 
2979
         --  If the object is aliased and the type is unconstrained with
2980
         --  defaulted discriminants and there is no expression, then the
2981
         --  object is constrained by the defaults, so it is worthwhile
2982
         --  building the corresponding subtype.
2983
 
2984
         --  Ada 2005 (AI-363): If the aliased object is discriminated and
2985
         --  unconstrained, then only establish an actual subtype if the
2986
         --  nominal subtype is indefinite. In definite cases the object is
2987
         --  unconstrained in Ada 2005.
2988
 
2989
         if No (E)
2990
           and then Is_Record_Type (T)
2991
           and then not Is_Constrained (T)
2992
           and then Has_Discriminants (T)
2993
           and then (Ada_Version < Ada_05 or else Is_Indefinite_Subtype (T))
2994
         then
2995
            Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
2996
         end if;
2997
      end if;
2998
 
2999
      --  Now we can set the type of the object
3000
 
3001
      Set_Etype (Id, Act_T);
3002
 
3003
      --  Deal with controlled types
3004
 
3005
      if Has_Controlled_Component (Etype (Id))
3006
        or else Is_Controlled (Etype (Id))
3007
      then
3008
         if not Is_Library_Level_Entity (Id) then
3009
            Check_Restriction (No_Nested_Finalization, N);
3010
         else
3011
            Validate_Controlled_Object (Id);
3012
         end if;
3013
 
3014
         --  Generate a warning when an initialization causes an obvious ABE
3015
         --  violation. If the init expression is a simple aggregate there
3016
         --  shouldn't be any initialize/adjust call generated. This will be
3017
         --  true as soon as aggregates are built in place when possible.
3018
 
3019
         --  ??? at the moment we do not generate warnings for temporaries
3020
         --  created for those aggregates although Program_Error might be
3021
         --  generated if compiled with -gnato.
3022
 
3023
         if Is_Controlled (Etype (Id))
3024
            and then Comes_From_Source (Id)
3025
         then
3026
            declare
3027
               BT : constant Entity_Id := Base_Type (Etype (Id));
3028
 
3029
               Implicit_Call : Entity_Id;
3030
               pragma Warnings (Off, Implicit_Call);
3031
               --  ??? what is this for (never referenced!)
3032
 
3033
               function Is_Aggr (N : Node_Id) return Boolean;
3034
               --  Check that N is an aggregate
3035
 
3036
               -------------
3037
               -- Is_Aggr --
3038
               -------------
3039
 
3040
               function Is_Aggr (N : Node_Id) return Boolean is
3041
               begin
3042
                  case Nkind (Original_Node (N)) is
3043
                     when N_Aggregate | N_Extension_Aggregate =>
3044
                        return True;
3045
 
3046
                     when N_Qualified_Expression |
3047
                          N_Type_Conversion      |
3048
                          N_Unchecked_Type_Conversion =>
3049
                        return Is_Aggr (Expression (Original_Node (N)));
3050
 
3051
                     when others =>
3052
                        return False;
3053
                  end case;
3054
               end Is_Aggr;
3055
 
3056
            begin
3057
               --  If no underlying type, we already are in an error situation.
3058
               --  Do not try to add a warning since we do not have access to
3059
               --  prim-op list.
3060
 
3061
               if No (Underlying_Type (BT)) then
3062
                  Implicit_Call := Empty;
3063
 
3064
               --  A generic type does not have usable primitive operators.
3065
               --  Initialization calls are built for instances.
3066
 
3067
               elsif Is_Generic_Type (BT) then
3068
                  Implicit_Call := Empty;
3069
 
3070
               --  If the init expression is not an aggregate, an adjust call
3071
               --  will be generated
3072
 
3073
               elsif Present (E) and then not Is_Aggr (E) then
3074
                  Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
3075
 
3076
               --  If no init expression and we are not in the deferred
3077
               --  constant case, an Initialize call will be generated
3078
 
3079
               elsif No (E) and then not Constant_Present (N) then
3080
                  Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
3081
 
3082
               else
3083
                  Implicit_Call := Empty;
3084
               end if;
3085
            end;
3086
         end if;
3087
      end if;
3088
 
3089
      if Has_Task (Etype (Id)) then
3090
         Check_Restriction (No_Tasking, N);
3091
 
3092
         --  Deal with counting max tasks
3093
 
3094
         --  Nothing to do if inside a generic
3095
 
3096
         if Inside_A_Generic then
3097
            null;
3098
 
3099
         --  If library level entity, then count tasks
3100
 
3101
         elsif Is_Library_Level_Entity (Id) then
3102
            Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id)));
3103
 
3104
         --  If not library level entity, then indicate we don't know max
3105
         --  tasks and also check task hierarchy restriction and blocking
3106
         --  operation (since starting a task is definitely blocking!)
3107
 
3108
         else
3109
            Check_Restriction (Max_Tasks, N);
3110
            Check_Restriction (No_Task_Hierarchy, N);
3111
            Check_Potentially_Blocking_Operation (N);
3112
         end if;
3113
 
3114
         --  A rather specialized test. If we see two tasks being declared
3115
         --  of the same type in the same object declaration, and the task
3116
         --  has an entry with an address clause, we know that program error
3117
         --  will be raised at run-time since we can't have two tasks with
3118
         --  entries at the same address.
3119
 
3120
         if Is_Task_Type (Etype (Id)) and then More_Ids (N) then
3121
            declare
3122
               E : Entity_Id;
3123
 
3124
            begin
3125
               E := First_Entity (Etype (Id));
3126
               while Present (E) loop
3127
                  if Ekind (E) = E_Entry
3128
                    and then Present (Get_Attribute_Definition_Clause
3129
                                        (E, Attribute_Address))
3130
                  then
3131
                     Error_Msg_N
3132
                       ("?more than one task with same entry address", N);
3133
                     Error_Msg_N
3134
                       ("\?Program_Error will be raised at run time", N);
3135
                     Insert_Action (N,
3136
                       Make_Raise_Program_Error (Loc,
3137
                         Reason => PE_Duplicated_Entry_Address));
3138
                     exit;
3139
                  end if;
3140
 
3141
                  Next_Entity (E);
3142
               end loop;
3143
            end;
3144
         end if;
3145
      end if;
3146
 
3147
      --  Some simple constant-propagation: if the expression is a constant
3148
      --  string initialized with a literal, share the literal. This avoids
3149
      --  a run-time copy.
3150
 
3151
      if Present (E)
3152
        and then Is_Entity_Name (E)
3153
        and then Ekind (Entity (E)) = E_Constant
3154
        and then Base_Type (Etype (E)) = Standard_String
3155
      then
3156
         declare
3157
            Val : constant Node_Id := Constant_Value (Entity (E));
3158
         begin
3159
            if Present (Val)
3160
              and then Nkind (Val) = N_String_Literal
3161
            then
3162
               Rewrite (E, New_Copy (Val));
3163
            end if;
3164
         end;
3165
      end if;
3166
 
3167
      --  Another optimization: if the nominal subtype is unconstrained and
3168
      --  the expression is a function call that returns an unconstrained
3169
      --  type, rewrite the declaration as a renaming of the result of the
3170
      --  call. The exceptions below are cases where the copy is expected,
3171
      --  either by the back end (Aliased case) or by the semantics, as for
3172
      --  initializing controlled types or copying tags for classwide types.
3173
 
3174
      if Present (E)
3175
        and then Nkind (E) = N_Explicit_Dereference
3176
        and then Nkind (Original_Node (E)) = N_Function_Call
3177
        and then not Is_Library_Level_Entity (Id)
3178
        and then not Is_Constrained (Underlying_Type (T))
3179
        and then not Is_Aliased (Id)
3180
        and then not Is_Class_Wide_Type (T)
3181
        and then not Is_Controlled (T)
3182
        and then not Has_Controlled_Component (Base_Type (T))
3183
        and then Expander_Active
3184
      then
3185
         Rewrite (N,
3186
           Make_Object_Renaming_Declaration (Loc,
3187
             Defining_Identifier => Id,
3188
             Access_Definition   => Empty,
3189
             Subtype_Mark        => New_Occurrence_Of
3190
                                      (Base_Type (Etype (Id)), Loc),
3191
             Name                => E));
3192
 
3193
         Set_Renamed_Object (Id, E);
3194
 
3195
         --  Force generation of debugging information for the constant and for
3196
         --  the renamed function call.
3197
 
3198
         Set_Debug_Info_Needed (Id);
3199
         Set_Debug_Info_Needed (Entity (Prefix (E)));
3200
      end if;
3201
 
3202
      if Present (Prev_Entity)
3203
        and then Is_Frozen (Prev_Entity)
3204
        and then not Error_Posted (Id)
3205
      then
3206
         Error_Msg_N ("full constant declaration appears too late", N);
3207
      end if;
3208
 
3209
      Check_Eliminated (Id);
3210
 
3211
      --  Deal with setting In_Private_Part flag if in private part
3212
 
3213
      if Ekind (Scope (Id)) = E_Package
3214
        and then In_Private_Part (Scope (Id))
3215
      then
3216
         Set_In_Private_Part (Id);
3217
      end if;
3218
 
3219
      --  Check for violation of No_Local_Timing_Events
3220
 
3221
      if Is_RTE (Etype (Id), RE_Timing_Event)
3222
        and then not Is_Library_Level_Entity (Id)
3223
      then
3224
         Check_Restriction (No_Local_Timing_Events, N);
3225
      end if;
3226
   end Analyze_Object_Declaration;
3227
 
3228
   ---------------------------
3229
   -- Analyze_Others_Choice --
3230
   ---------------------------
3231
 
3232
   --  Nothing to do for the others choice node itself, the semantic analysis
3233
   --  of the others choice will occur as part of the processing of the parent
3234
 
3235
   procedure Analyze_Others_Choice (N : Node_Id) is
3236
      pragma Warnings (Off, N);
3237
   begin
3238
      null;
3239
   end Analyze_Others_Choice;
3240
 
3241
   -------------------------------------------
3242
   -- Analyze_Private_Extension_Declaration --
3243
   -------------------------------------------
3244
 
3245
   procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
3246
      T           : constant Entity_Id := Defining_Identifier (N);
3247
      Indic       : constant Node_Id   := Subtype_Indication (N);
3248
      Parent_Type : Entity_Id;
3249
      Parent_Base : Entity_Id;
3250
 
3251
   begin
3252
      --  Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
3253
 
3254
      if Is_Non_Empty_List (Interface_List (N)) then
3255
         declare
3256
            Intf : Node_Id;
3257
            T    : Entity_Id;
3258
 
3259
         begin
3260
            Intf := First (Interface_List (N));
3261
            while Present (Intf) loop
3262
               T := Find_Type_Of_Subtype_Indic (Intf);
3263
 
3264
               Diagnose_Interface (Intf, T);
3265
               Next (Intf);
3266
            end loop;
3267
         end;
3268
      end if;
3269
 
3270
      Generate_Definition (T);
3271
      Enter_Name (T);
3272
 
3273
      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
3274
      Parent_Base := Base_Type (Parent_Type);
3275
 
3276
      if Parent_Type = Any_Type
3277
        or else Etype (Parent_Type) = Any_Type
3278
      then
3279
         Set_Ekind (T, Ekind (Parent_Type));
3280
         Set_Etype (T, Any_Type);
3281
         return;
3282
 
3283
      elsif not Is_Tagged_Type (Parent_Type) then
3284
         Error_Msg_N
3285
           ("parent of type extension must be a tagged type ", Indic);
3286
         return;
3287
 
3288
      elsif Ekind (Parent_Type) = E_Void
3289
        or else Ekind (Parent_Type) = E_Incomplete_Type
3290
      then
3291
         Error_Msg_N ("premature derivation of incomplete type", Indic);
3292
         return;
3293
 
3294
      elsif Is_Concurrent_Type (Parent_Type) then
3295
         Error_Msg_N
3296
           ("parent type of a private extension cannot be "
3297
            & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
3298
 
3299
         Set_Etype              (T, Any_Type);
3300
         Set_Ekind              (T, E_Limited_Private_Type);
3301
         Set_Private_Dependents (T, New_Elmt_List);
3302
         Set_Error_Posted       (T);
3303
         return;
3304
      end if;
3305
 
3306
      --  Perhaps the parent type should be changed to the class-wide type's
3307
      --  specific type in this case to prevent cascading errors ???
3308
 
3309
      if Is_Class_Wide_Type (Parent_Type) then
3310
         Error_Msg_N
3311
           ("parent of type extension must not be a class-wide type", Indic);
3312
         return;
3313
      end if;
3314
 
3315
      if (not Is_Package_Or_Generic_Package (Current_Scope)
3316
           and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
3317
        or else In_Private_Part (Current_Scope)
3318
 
3319
      then
3320
         Error_Msg_N ("invalid context for private extension", N);
3321
      end if;
3322
 
3323
      --  Set common attributes
3324
 
3325
      Set_Is_Pure          (T, Is_Pure (Current_Scope));
3326
      Set_Scope            (T, Current_Scope);
3327
      Set_Ekind            (T, E_Record_Type_With_Private);
3328
      Init_Size_Align      (T);
3329
 
3330
      Set_Etype            (T,            Parent_Base);
3331
      Set_Has_Task         (T, Has_Task  (Parent_Base));
3332
 
3333
      Set_Convention       (T, Convention     (Parent_Type));
3334
      Set_First_Rep_Item   (T, First_Rep_Item (Parent_Type));
3335
      Set_Is_First_Subtype (T);
3336
      Make_Class_Wide_Type (T);
3337
 
3338
      if Unknown_Discriminants_Present (N) then
3339
         Set_Discriminant_Constraint (T, No_Elist);
3340
      end if;
3341
 
3342
      Build_Derived_Record_Type (N, Parent_Type, T);
3343
 
3344
      --  Ada 2005 (AI-443): Synchronized private extension or a rewritten
3345
      --  synchronized formal derived type.
3346
 
3347
      if Ada_Version >= Ada_05
3348
        and then Synchronized_Present (N)
3349
      then
3350
         Set_Is_Limited_Record (T);
3351
 
3352
         --  Formal derived type case
3353
 
3354
         if Is_Generic_Type (T) then
3355
 
3356
            --  The parent must be a tagged limited type or a synchronized
3357
            --  interface.
3358
 
3359
            if (not Is_Tagged_Type (Parent_Type)
3360
                  or else not Is_Limited_Type (Parent_Type))
3361
              and then
3362
               (not Is_Interface (Parent_Type)
3363
                  or else not Is_Synchronized_Interface (Parent_Type))
3364
            then
3365
               Error_Msg_NE ("parent type of & must be tagged limited " &
3366
                             "or synchronized", N, T);
3367
            end if;
3368
 
3369
            --  The progenitors (if any) must be limited or synchronized
3370
            --  interfaces.
3371
 
3372
            if Present (Interfaces (T)) then
3373
               declare
3374
                  Iface      : Entity_Id;
3375
                  Iface_Elmt : Elmt_Id;
3376
 
3377
               begin
3378
                  Iface_Elmt := First_Elmt (Interfaces (T));
3379
                  while Present (Iface_Elmt) loop
3380
                     Iface := Node (Iface_Elmt);
3381
 
3382
                     if not Is_Limited_Interface (Iface)
3383
                       and then not Is_Synchronized_Interface (Iface)
3384
                     then
3385
                        Error_Msg_NE ("progenitor & must be limited " &
3386
                                      "or synchronized", N, Iface);
3387
                     end if;
3388
 
3389
                     Next_Elmt (Iface_Elmt);
3390
                  end loop;
3391
               end;
3392
            end if;
3393
 
3394
         --  Regular derived extension, the parent must be a limited or
3395
         --  synchronized interface.
3396
 
3397
         else
3398
            if not Is_Interface (Parent_Type)
3399
              or else (not Is_Limited_Interface (Parent_Type)
3400
                         and then
3401
                       not Is_Synchronized_Interface (Parent_Type))
3402
            then
3403
               Error_Msg_NE
3404
                 ("parent type of & must be limited interface", N, T);
3405
            end if;
3406
         end if;
3407
 
3408
      --  A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
3409
      --  extension with a synchronized parent must be explicitly declared
3410
      --  synchronized, because the full view will be a synchronized type.
3411
      --  This must be checked before the check for limited types below,
3412
      --  to ensure that types declared limited are not allowed to extend
3413
      --  synchronized interfaces.
3414
 
3415
      elsif Is_Interface (Parent_Type)
3416
        and then Is_Synchronized_Interface (Parent_Type)
3417
        and then not Synchronized_Present (N)
3418
      then
3419
         Error_Msg_NE
3420
           ("private extension of& must be explicitly synchronized",
3421
             N, Parent_Type);
3422
 
3423
      elsif Limited_Present (N) then
3424
         Set_Is_Limited_Record (T);
3425
 
3426
         if not Is_Limited_Type (Parent_Type)
3427
           and then
3428
             (not Is_Interface (Parent_Type)
3429
               or else not Is_Limited_Interface (Parent_Type))
3430
         then
3431
            Error_Msg_NE ("parent type& of limited extension must be limited",
3432
              N, Parent_Type);
3433
         end if;
3434
      end if;
3435
   end Analyze_Private_Extension_Declaration;
3436
 
3437
   ---------------------------------
3438
   -- Analyze_Subtype_Declaration --
3439
   ---------------------------------
3440
 
3441
   procedure Analyze_Subtype_Declaration
3442
     (N    : Node_Id;
3443
      Skip : Boolean := False)
3444
   is
3445
      Id       : constant Entity_Id := Defining_Identifier (N);
3446
      T        : Entity_Id;
3447
      R_Checks : Check_Result;
3448
 
3449
   begin
3450
      Generate_Definition (Id);
3451
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
3452
      Init_Size_Align (Id);
3453
 
3454
      --  The following guard condition on Enter_Name is to handle cases where
3455
      --  the defining identifier has already been entered into the scope but
3456
      --  the declaration as a whole needs to be analyzed.
3457
 
3458
      --  This case in particular happens for derived enumeration types. The
3459
      --  derived enumeration type is processed as an inserted enumeration type
3460
      --  declaration followed by a rewritten subtype declaration. The defining
3461
      --  identifier, however, is entered into the name scope very early in the
3462
      --  processing of the original type declaration and therefore needs to be
3463
      --  avoided here, when the created subtype declaration is analyzed. (See
3464
      --  Build_Derived_Types)
3465
 
3466
      --  This also happens when the full view of a private type is derived
3467
      --  type with constraints. In this case the entity has been introduced
3468
      --  in the private declaration.
3469
 
3470
      if Skip
3471
        or else (Present (Etype (Id))
3472
                   and then (Is_Private_Type (Etype (Id))
3473
                               or else Is_Task_Type (Etype (Id))
3474
                               or else Is_Rewrite_Substitution (N)))
3475
      then
3476
         null;
3477
 
3478
      else
3479
         Enter_Name (Id);
3480
      end if;
3481
 
3482
      T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
3483
 
3484
      --  Inherit common attributes
3485
 
3486
      Set_Is_Generic_Type   (Id, Is_Generic_Type   (Base_Type (T)));
3487
      Set_Is_Volatile       (Id, Is_Volatile       (T));
3488
      Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
3489
      Set_Is_Atomic         (Id, Is_Atomic         (T));
3490
      Set_Is_Ada_2005_Only  (Id, Is_Ada_2005_Only  (T));
3491
      Set_Convention        (Id, Convention        (T));
3492
 
3493
      --  In the case where there is no constraint given in the subtype
3494
      --  indication, Process_Subtype just returns the Subtype_Mark, so its
3495
      --  semantic attributes must be established here.
3496
 
3497
      if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
3498
         Set_Etype (Id, Base_Type (T));
3499
 
3500
         case Ekind (T) is
3501
            when Array_Kind =>
3502
               Set_Ekind                       (Id, E_Array_Subtype);
3503
               Copy_Array_Subtype_Attributes   (Id, T);
3504
 
3505
            when Decimal_Fixed_Point_Kind =>
3506
               Set_Ekind                (Id, E_Decimal_Fixed_Point_Subtype);
3507
               Set_Digits_Value         (Id, Digits_Value       (T));
3508
               Set_Delta_Value          (Id, Delta_Value        (T));
3509
               Set_Scale_Value          (Id, Scale_Value        (T));
3510
               Set_Small_Value          (Id, Small_Value        (T));
3511
               Set_Scalar_Range         (Id, Scalar_Range       (T));
3512
               Set_Machine_Radix_10     (Id, Machine_Radix_10   (T));
3513
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3514
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
3515
               Set_RM_Size              (Id, RM_Size            (T));
3516
 
3517
            when Enumeration_Kind =>
3518
               Set_Ekind                (Id, E_Enumeration_Subtype);
3519
               Set_First_Literal        (Id, First_Literal (Base_Type (T)));
3520
               Set_Scalar_Range         (Id, Scalar_Range       (T));
3521
               Set_Is_Character_Type    (Id, Is_Character_Type  (T));
3522
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3523
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
3524
               Set_RM_Size              (Id, RM_Size            (T));
3525
 
3526
            when Ordinary_Fixed_Point_Kind =>
3527
               Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
3528
               Set_Scalar_Range         (Id, Scalar_Range       (T));
3529
               Set_Small_Value          (Id, Small_Value        (T));
3530
               Set_Delta_Value          (Id, Delta_Value        (T));
3531
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3532
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
3533
               Set_RM_Size              (Id, RM_Size            (T));
3534
 
3535
            when Float_Kind =>
3536
               Set_Ekind                (Id, E_Floating_Point_Subtype);
3537
               Set_Scalar_Range         (Id, Scalar_Range       (T));
3538
               Set_Digits_Value         (Id, Digits_Value       (T));
3539
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3540
 
3541
            when Signed_Integer_Kind =>
3542
               Set_Ekind                (Id, E_Signed_Integer_Subtype);
3543
               Set_Scalar_Range         (Id, Scalar_Range       (T));
3544
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3545
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
3546
               Set_RM_Size              (Id, RM_Size            (T));
3547
 
3548
            when Modular_Integer_Kind =>
3549
               Set_Ekind                (Id, E_Modular_Integer_Subtype);
3550
               Set_Scalar_Range         (Id, Scalar_Range       (T));
3551
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3552
               Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
3553
               Set_RM_Size              (Id, RM_Size            (T));
3554
 
3555
            when Class_Wide_Kind =>
3556
               Set_Ekind                (Id, E_Class_Wide_Subtype);
3557
               Set_First_Entity         (Id, First_Entity       (T));
3558
               Set_Last_Entity          (Id, Last_Entity        (T));
3559
               Set_Class_Wide_Type      (Id, Class_Wide_Type    (T));
3560
               Set_Cloned_Subtype       (Id, T);
3561
               Set_Is_Tagged_Type       (Id, True);
3562
               Set_Has_Unknown_Discriminants
3563
                                        (Id, True);
3564
 
3565
               if Ekind (T) = E_Class_Wide_Subtype then
3566
                  Set_Equivalent_Type   (Id, Equivalent_Type    (T));
3567
               end if;
3568
 
3569
            when E_Record_Type | E_Record_Subtype =>
3570
               Set_Ekind                (Id, E_Record_Subtype);
3571
 
3572
               if Ekind (T) = E_Record_Subtype
3573
                 and then Present (Cloned_Subtype (T))
3574
               then
3575
                  Set_Cloned_Subtype    (Id, Cloned_Subtype (T));
3576
               else
3577
                  Set_Cloned_Subtype    (Id, T);
3578
               end if;
3579
 
3580
               Set_First_Entity         (Id, First_Entity       (T));
3581
               Set_Last_Entity          (Id, Last_Entity        (T));
3582
               Set_Has_Discriminants    (Id, Has_Discriminants  (T));
3583
               Set_Is_Constrained       (Id, Is_Constrained     (T));
3584
               Set_Is_Limited_Record    (Id, Is_Limited_Record  (T));
3585
               Set_Has_Unknown_Discriminants
3586
                                        (Id, Has_Unknown_Discriminants (T));
3587
 
3588
               if Has_Discriminants (T) then
3589
                  Set_Discriminant_Constraint
3590
                                        (Id, Discriminant_Constraint (T));
3591
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3592
 
3593
               elsif Has_Unknown_Discriminants (Id) then
3594
                  Set_Discriminant_Constraint (Id, No_Elist);
3595
               end if;
3596
 
3597
               if Is_Tagged_Type (T) then
3598
                  Set_Is_Tagged_Type    (Id);
3599
                  Set_Is_Abstract_Type  (Id, Is_Abstract_Type (T));
3600
                  Set_Primitive_Operations
3601
                                        (Id, Primitive_Operations (T));
3602
                  Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
3603
 
3604
                  if Is_Interface (T) then
3605
                     Set_Is_Interface (Id);
3606
                     Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
3607
                  end if;
3608
               end if;
3609
 
3610
            when Private_Kind =>
3611
               Set_Ekind              (Id, Subtype_Kind (Ekind   (T)));
3612
               Set_Has_Discriminants  (Id, Has_Discriminants     (T));
3613
               Set_Is_Constrained     (Id, Is_Constrained        (T));
3614
               Set_First_Entity       (Id, First_Entity          (T));
3615
               Set_Last_Entity        (Id, Last_Entity           (T));
3616
               Set_Private_Dependents (Id, New_Elmt_List);
3617
               Set_Is_Limited_Record  (Id, Is_Limited_Record     (T));
3618
               Set_Has_Unknown_Discriminants
3619
                                      (Id, Has_Unknown_Discriminants (T));
3620
               Set_Known_To_Have_Preelab_Init
3621
                                      (Id, Known_To_Have_Preelab_Init (T));
3622
 
3623
               if Is_Tagged_Type (T) then
3624
                  Set_Is_Tagged_Type       (Id);
3625
                  Set_Is_Abstract_Type     (Id, Is_Abstract_Type (T));
3626
                  Set_Primitive_Operations (Id, Primitive_Operations (T));
3627
                  Set_Class_Wide_Type      (Id, Class_Wide_Type (T));
3628
               end if;
3629
 
3630
               --  In general the attributes of the subtype of a private type
3631
               --  are the attributes of the partial view of parent. However,
3632
               --  the full view may be a discriminated type, and the subtype
3633
               --  must share the discriminant constraint to generate correct
3634
               --  calls to initialization procedures.
3635
 
3636
               if Has_Discriminants (T) then
3637
                  Set_Discriminant_Constraint
3638
                                     (Id, Discriminant_Constraint (T));
3639
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3640
 
3641
               elsif Present (Full_View (T))
3642
                 and then Has_Discriminants (Full_View (T))
3643
               then
3644
                  Set_Discriminant_Constraint
3645
                               (Id, Discriminant_Constraint (Full_View (T)));
3646
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3647
 
3648
                  --  This would seem semantically correct, but apparently
3649
                  --  confuses the back-end. To be explained and checked with
3650
                  --  current version ???
3651
 
3652
                  --  Set_Has_Discriminants (Id);
3653
               end if;
3654
 
3655
               Prepare_Private_Subtype_Completion (Id, N);
3656
 
3657
            when Access_Kind =>
3658
               Set_Ekind             (Id, E_Access_Subtype);
3659
               Set_Is_Constrained    (Id, Is_Constrained        (T));
3660
               Set_Is_Access_Constant
3661
                                     (Id, Is_Access_Constant    (T));
3662
               Set_Directly_Designated_Type
3663
                                     (Id, Designated_Type       (T));
3664
               Set_Can_Never_Be_Null (Id, Can_Never_Be_Null     (T));
3665
 
3666
               --  A Pure library_item must not contain the declaration of a
3667
               --  named access type, except within a subprogram, generic
3668
               --  subprogram, task unit, or protected unit, or if it has
3669
               --  a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
3670
 
3671
               if Comes_From_Source (Id)
3672
                 and then In_Pure_Unit
3673
                 and then not In_Subprogram_Task_Protected_Unit
3674
                 and then not No_Pool_Assigned (Id)
3675
               then
3676
                  Error_Msg_N
3677
                    ("named access types not allowed in pure unit", N);
3678
               end if;
3679
 
3680
            when Concurrent_Kind =>
3681
               Set_Ekind                (Id, Subtype_Kind (Ekind   (T)));
3682
               Set_Corresponding_Record_Type (Id,
3683
                                         Corresponding_Record_Type (T));
3684
               Set_First_Entity         (Id, First_Entity          (T));
3685
               Set_First_Private_Entity (Id, First_Private_Entity  (T));
3686
               Set_Has_Discriminants    (Id, Has_Discriminants     (T));
3687
               Set_Is_Constrained       (Id, Is_Constrained        (T));
3688
               Set_Is_Tagged_Type       (Id, Is_Tagged_Type        (T));
3689
               Set_Last_Entity          (Id, Last_Entity           (T));
3690
 
3691
               if Has_Discriminants (T) then
3692
                  Set_Discriminant_Constraint (Id,
3693
                                           Discriminant_Constraint (T));
3694
                  Set_Stored_Constraint_From_Discriminant_Constraint (Id);
3695
               end if;
3696
 
3697
            when E_Incomplete_Type =>
3698
               if Ada_Version >= Ada_05 then
3699
                  Set_Ekind (Id, E_Incomplete_Subtype);
3700
 
3701
                  --  Ada 2005 (AI-412): Decorate an incomplete subtype
3702
                  --  of an incomplete type visible through a limited
3703
                  --  with clause.
3704
 
3705
                  if From_With_Type (T)
3706
                    and then Present (Non_Limited_View (T))
3707
                  then
3708
                     Set_From_With_Type   (Id);
3709
                     Set_Non_Limited_View (Id, Non_Limited_View (T));
3710
 
3711
                  --  Ada 2005 (AI-412): Add the regular incomplete subtype
3712
                  --  to the private dependents of the original incomplete
3713
                  --  type for future transformation.
3714
 
3715
                  else
3716
                     Append_Elmt (Id, Private_Dependents (T));
3717
                  end if;
3718
 
3719
               --  If the subtype name denotes an incomplete type an error
3720
               --  was already reported by Process_Subtype.
3721
 
3722
               else
3723
                  Set_Etype (Id, Any_Type);
3724
               end if;
3725
 
3726
            when others =>
3727
               raise Program_Error;
3728
         end case;
3729
      end if;
3730
 
3731
      if Etype (Id) = Any_Type then
3732
         return;
3733
      end if;
3734
 
3735
      --  Some common processing on all types
3736
 
3737
      Set_Size_Info      (Id,                 T);
3738
      Set_First_Rep_Item (Id, First_Rep_Item (T));
3739
 
3740
      T := Etype (Id);
3741
 
3742
      Set_Is_Immediately_Visible   (Id, True);
3743
      Set_Depends_On_Private       (Id, Has_Private_Component (T));
3744
      Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
3745
 
3746
      if Is_Interface (T) then
3747
         Set_Is_Interface (Id);
3748
      end if;
3749
 
3750
      if Present (Generic_Parent_Type (N))
3751
        and then
3752
          (Nkind
3753
             (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
3754
            or else Nkind
3755
              (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
3756
                /=  N_Formal_Private_Type_Definition)
3757
      then
3758
         if Is_Tagged_Type (Id) then
3759
 
3760
            --  If this is a generic actual subtype for a synchronized type,
3761
            --  the primitive operations are those of the corresponding record
3762
            --  for which there is a separate subtype declaration.
3763
 
3764
            if Is_Concurrent_Type (Id) then
3765
               null;
3766
            elsif Is_Class_Wide_Type (Id) then
3767
               Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
3768
            else
3769
               Derive_Subprograms (Generic_Parent_Type (N), Id, T);
3770
            end if;
3771
 
3772
         elsif Scope (Etype (Id)) /= Standard_Standard then
3773
            Derive_Subprograms (Generic_Parent_Type (N), Id);
3774
         end if;
3775
      end if;
3776
 
3777
      if Is_Private_Type (T)
3778
        and then Present (Full_View (T))
3779
      then
3780
         Conditional_Delay (Id, Full_View (T));
3781
 
3782
      --  The subtypes of components or subcomponents of protected types
3783
      --  do not need freeze nodes, which would otherwise appear in the
3784
      --  wrong scope (before the freeze node for the protected type). The
3785
      --  proper subtypes are those of the subcomponents of the corresponding
3786
      --  record.
3787
 
3788
      elsif Ekind (Scope (Id)) /= E_Protected_Type
3789
        and then Present (Scope (Scope (Id))) -- error defense!
3790
        and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
3791
      then
3792
         Conditional_Delay (Id, T);
3793
      end if;
3794
 
3795
      --  Check that constraint_error is raised for a scalar subtype
3796
      --  indication when the lower or upper bound of a non-null range
3797
      --  lies outside the range of the type mark.
3798
 
3799
      if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
3800
         if Is_Scalar_Type (Etype (Id))
3801
            and then Scalar_Range (Id) /=
3802
                     Scalar_Range (Etype (Subtype_Mark
3803
                                           (Subtype_Indication (N))))
3804
         then
3805
            Apply_Range_Check
3806
              (Scalar_Range (Id),
3807
               Etype (Subtype_Mark (Subtype_Indication (N))));
3808
 
3809
         elsif Is_Array_Type (Etype (Id))
3810
           and then Present (First_Index (Id))
3811
         then
3812
            --  This really should be a subprogram that finds the indications
3813
            --  to check???
3814
 
3815
            if ((Nkind (First_Index (Id)) = N_Identifier
3816
                   and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
3817
                 or else Nkind (First_Index (Id)) = N_Subtype_Indication)
3818
              and then
3819
                Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
3820
            then
3821
               declare
3822
                  Target_Typ : constant Entity_Id :=
3823
                                 Etype
3824
                                   (First_Index (Etype
3825
                                     (Subtype_Mark (Subtype_Indication (N)))));
3826
               begin
3827
                  R_Checks :=
3828
                    Get_Range_Checks
3829
                      (Scalar_Range (Etype (First_Index (Id))),
3830
                       Target_Typ,
3831
                       Etype (First_Index (Id)),
3832
                       Defining_Identifier (N));
3833
 
3834
                  Insert_Range_Checks
3835
                    (R_Checks,
3836
                     N,
3837
                     Target_Typ,
3838
                     Sloc (Defining_Identifier (N)));
3839
               end;
3840
            end if;
3841
         end if;
3842
      end if;
3843
 
3844
      Set_Optimize_Alignment_Flags (Id);
3845
      Check_Eliminated (Id);
3846
   end Analyze_Subtype_Declaration;
3847
 
3848
   --------------------------------
3849
   -- Analyze_Subtype_Indication --
3850
   --------------------------------
3851
 
3852
   procedure Analyze_Subtype_Indication (N : Node_Id) is
3853
      T : constant Entity_Id := Subtype_Mark (N);
3854
      R : constant Node_Id   := Range_Expression (Constraint (N));
3855
 
3856
   begin
3857
      Analyze (T);
3858
 
3859
      if R /= Error then
3860
         Analyze (R);
3861
         Set_Etype (N, Etype (R));
3862
         Resolve (R, Entity (T));
3863
      else
3864
         Set_Error_Posted (R);
3865
         Set_Error_Posted (T);
3866
      end if;
3867
   end Analyze_Subtype_Indication;
3868
 
3869
   ------------------------------
3870
   -- Analyze_Type_Declaration --
3871
   ------------------------------
3872
 
3873
   procedure Analyze_Type_Declaration (N : Node_Id) is
3874
      Def    : constant Node_Id   := Type_Definition (N);
3875
      Def_Id : constant Entity_Id := Defining_Identifier (N);
3876
      T      : Entity_Id;
3877
      Prev   : Entity_Id;
3878
 
3879
      Is_Remote : constant Boolean :=
3880
                    (Is_Remote_Types (Current_Scope)
3881
                       or else Is_Remote_Call_Interface (Current_Scope))
3882
                    and then not (In_Private_Part (Current_Scope)
3883
                                    or else In_Package_Body (Current_Scope));
3884
 
3885
      procedure Check_Ops_From_Incomplete_Type;
3886
      --  If there is a tagged incomplete partial view of the type, transfer
3887
      --  its operations to the full view, and indicate that the type of the
3888
      --  controlling parameter (s) is this full view.
3889
 
3890
      ------------------------------------
3891
      -- Check_Ops_From_Incomplete_Type --
3892
      ------------------------------------
3893
 
3894
      procedure Check_Ops_From_Incomplete_Type is
3895
         Elmt   : Elmt_Id;
3896
         Formal : Entity_Id;
3897
         Op     : Entity_Id;
3898
 
3899
      begin
3900
         if Prev /= T
3901
           and then Ekind (Prev) = E_Incomplete_Type
3902
           and then Is_Tagged_Type (Prev)
3903
           and then Is_Tagged_Type (T)
3904
         then
3905
            Elmt := First_Elmt (Primitive_Operations (Prev));
3906
            while Present (Elmt) loop
3907
               Op := Node (Elmt);
3908
               Prepend_Elmt (Op, Primitive_Operations (T));
3909
 
3910
               Formal := First_Formal (Op);
3911
               while Present (Formal) loop
3912
                  if Etype (Formal) = Prev then
3913
                     Set_Etype (Formal, T);
3914
                  end if;
3915
 
3916
                  Next_Formal (Formal);
3917
               end loop;
3918
 
3919
               if Etype (Op) = Prev then
3920
                  Set_Etype (Op, T);
3921
               end if;
3922
 
3923
               Next_Elmt (Elmt);
3924
            end loop;
3925
         end if;
3926
      end Check_Ops_From_Incomplete_Type;
3927
 
3928
   --  Start of processing for Analyze_Type_Declaration
3929
 
3930
   begin
3931
      Prev := Find_Type_Name (N);
3932
 
3933
      --  The full view, if present, now points to the current type
3934
 
3935
      --  Ada 2005 (AI-50217): If the type was previously decorated when
3936
      --  imported through a LIMITED WITH clause, it appears as incomplete
3937
      --  but has no full view.
3938
      --  If the incomplete view is tagged, a class_wide type has been
3939
      --  created already. Use it for the full view as well, to prevent
3940
      --  multiple incompatible class-wide types that may be  created for
3941
      --  self-referential anonymous access components.
3942
 
3943
      if Ekind (Prev) = E_Incomplete_Type
3944
        and then Present (Full_View (Prev))
3945
      then
3946
         T := Full_View (Prev);
3947
 
3948
         if Is_Tagged_Type (Prev)
3949
           and then Present (Class_Wide_Type (Prev))
3950
         then
3951
            Set_Ekind (T, Ekind (Prev));         --  will be reset later
3952
            Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
3953
            Set_Etype (Class_Wide_Type (T), T);
3954
         end if;
3955
 
3956
      else
3957
         T := Prev;
3958
      end if;
3959
 
3960
      Set_Is_Pure (T, Is_Pure (Current_Scope));
3961
 
3962
      --  We set the flag Is_First_Subtype here. It is needed to set the
3963
      --  corresponding flag for the Implicit class-wide-type created
3964
      --  during tagged types processing.
3965
 
3966
      Set_Is_First_Subtype (T, True);
3967
 
3968
      --  Only composite types other than array types are allowed to have
3969
      --  discriminants.
3970
 
3971
      case Nkind (Def) is
3972
 
3973
         --  For derived types, the rule will be checked once we've figured
3974
         --  out the parent type.
3975
 
3976
         when N_Derived_Type_Definition =>
3977
            null;
3978
 
3979
         --  For record types, discriminants are allowed
3980
 
3981
         when N_Record_Definition =>
3982
            null;
3983
 
3984
         when others =>
3985
            if Present (Discriminant_Specifications (N)) then
3986
               Error_Msg_N
3987
                 ("elementary or array type cannot have discriminants",
3988
                  Defining_Identifier
3989
                  (First (Discriminant_Specifications (N))));
3990
            end if;
3991
      end case;
3992
 
3993
      --  Elaborate the type definition according to kind, and generate
3994
      --  subsidiary (implicit) subtypes where needed. We skip this if it was
3995
      --  already done (this happens during the reanalysis that follows a call
3996
      --  to the high level optimizer).
3997
 
3998
      if not Analyzed (T) then
3999
         Set_Analyzed (T);
4000
 
4001
         case Nkind (Def) is
4002
 
4003
            when N_Access_To_Subprogram_Definition =>
4004
               Access_Subprogram_Declaration (T, Def);
4005
 
4006
               --  If this is a remote access to subprogram, we must create the
4007
               --  equivalent fat pointer type, and related subprograms.
4008
 
4009
               if Is_Remote then
4010
                  Process_Remote_AST_Declaration (N);
4011
               end if;
4012
 
4013
               --  Validate categorization rule against access type declaration
4014
               --  usually a violation in Pure unit, Shared_Passive unit.
4015
 
4016
               Validate_Access_Type_Declaration (T, N);
4017
 
4018
            when N_Access_To_Object_Definition =>
4019
               Access_Type_Declaration (T, Def);
4020
 
4021
               --  Validate categorization rule against access type declaration
4022
               --  usually a violation in Pure unit, Shared_Passive unit.
4023
 
4024
               Validate_Access_Type_Declaration (T, N);
4025
 
4026
               --  If we are in a Remote_Call_Interface package and define a
4027
               --  RACW, then calling stubs and specific stream attributes
4028
               --  must be added.
4029
 
4030
               if Is_Remote
4031
                 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
4032
               then
4033
                  Add_RACW_Features (Def_Id);
4034
               end if;
4035
 
4036
               --  Set no strict aliasing flag if config pragma seen
4037
 
4038
               if Opt.No_Strict_Aliasing then
4039
                  Set_No_Strict_Aliasing (Base_Type (Def_Id));
4040
               end if;
4041
 
4042
            when N_Array_Type_Definition =>
4043
               Array_Type_Declaration (T, Def);
4044
 
4045
            when N_Derived_Type_Definition =>
4046
               Derived_Type_Declaration (T, N, T /= Def_Id);
4047
 
4048
            when N_Enumeration_Type_Definition =>
4049
               Enumeration_Type_Declaration (T, Def);
4050
 
4051
            when N_Floating_Point_Definition =>
4052
               Floating_Point_Type_Declaration (T, Def);
4053
 
4054
            when N_Decimal_Fixed_Point_Definition =>
4055
               Decimal_Fixed_Point_Type_Declaration (T, Def);
4056
 
4057
            when N_Ordinary_Fixed_Point_Definition =>
4058
               Ordinary_Fixed_Point_Type_Declaration (T, Def);
4059
 
4060
            when N_Signed_Integer_Type_Definition =>
4061
               Signed_Integer_Type_Declaration (T, Def);
4062
 
4063
            when N_Modular_Type_Definition =>
4064
               Modular_Type_Declaration (T, Def);
4065
 
4066
            when N_Record_Definition =>
4067
               Record_Type_Declaration (T, N, Prev);
4068
 
4069
            when others =>
4070
               raise Program_Error;
4071
 
4072
         end case;
4073
      end if;
4074
 
4075
      if Etype (T) = Any_Type then
4076
         return;
4077
      end if;
4078
 
4079
      --  Some common processing for all types
4080
 
4081
      Set_Depends_On_Private (T, Has_Private_Component (T));
4082
      Check_Ops_From_Incomplete_Type;
4083
 
4084
      --  Both the declared entity, and its anonymous base type if one
4085
      --  was created, need freeze nodes allocated.
4086
 
4087
      declare
4088
         B : constant Entity_Id := Base_Type (T);
4089
 
4090
      begin
4091
         --  In the case where the base type differs from the first subtype, we
4092
         --  pre-allocate a freeze node, and set the proper link to the first
4093
         --  subtype. Freeze_Entity will use this preallocated freeze node when
4094
         --  it freezes the entity.
4095
 
4096
         --  This does not apply if the base type is a generic type, whose
4097
         --  declaration is independent of the current derived definition.
4098
 
4099
         if B /= T and then not Is_Generic_Type (B) then
4100
            Ensure_Freeze_Node (B);
4101
            Set_First_Subtype_Link (Freeze_Node (B), T);
4102
         end if;
4103
 
4104
         --  A type that is imported through a limited_with clause cannot
4105
         --  generate any code, and thus need not be frozen. However, an access
4106
         --  type with an imported designated type needs a finalization list,
4107
         --  which may be referenced in some other package that has non-limited
4108
         --  visibility on the designated type. Thus we must create the
4109
         --  finalization list at the point the access type is frozen, to
4110
         --  prevent unsatisfied references at link time.
4111
 
4112
         if not From_With_Type (T) or else Is_Access_Type (T) then
4113
            Set_Has_Delayed_Freeze (T);
4114
         end if;
4115
      end;
4116
 
4117
      --  Case where T is the full declaration of some private type which has
4118
      --  been swapped in Defining_Identifier (N).
4119
 
4120
      if T /= Def_Id and then Is_Private_Type (Def_Id) then
4121
         Process_Full_View (N, T, Def_Id);
4122
 
4123
         --  Record the reference. The form of this is a little strange, since
4124
         --  the full declaration has been swapped in. So the first parameter
4125
         --  here represents the entity to which a reference is made which is
4126
         --  the "real" entity, i.e. the one swapped in, and the second
4127
         --  parameter provides the reference location.
4128
 
4129
         --  Also, we want to kill Has_Pragma_Unreferenced temporarily here
4130
         --  since we don't want a complaint about the full type being an
4131
         --  unwanted reference to the private type
4132
 
4133
         declare
4134
            B : constant Boolean := Has_Pragma_Unreferenced (T);
4135
         begin
4136
            Set_Has_Pragma_Unreferenced (T, False);
4137
            Generate_Reference (T, T, 'c');
4138
            Set_Has_Pragma_Unreferenced (T, B);
4139
         end;
4140
 
4141
         Set_Completion_Referenced (Def_Id);
4142
 
4143
      --  For completion of incomplete type, process incomplete dependents
4144
      --  and always mark the full type as referenced (it is the incomplete
4145
      --  type that we get for any real reference).
4146
 
4147
      elsif Ekind (Prev) = E_Incomplete_Type then
4148
         Process_Incomplete_Dependents (N, T, Prev);
4149
         Generate_Reference (Prev, Def_Id, 'c');
4150
         Set_Completion_Referenced (Def_Id);
4151
 
4152
      --  If not private type or incomplete type completion, this is a real
4153
      --  definition of a new entity, so record it.
4154
 
4155
      else
4156
         Generate_Definition (Def_Id);
4157
      end if;
4158
 
4159
      if Chars (Scope (Def_Id)) = Name_System
4160
        and then Chars (Def_Id) = Name_Address
4161
        and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
4162
      then
4163
         Set_Is_Descendent_Of_Address (Def_Id);
4164
         Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
4165
         Set_Is_Descendent_Of_Address (Prev);
4166
      end if;
4167
 
4168
      Set_Optimize_Alignment_Flags (Def_Id);
4169
      Check_Eliminated (Def_Id);
4170
   end Analyze_Type_Declaration;
4171
 
4172
   --------------------------
4173
   -- Analyze_Variant_Part --
4174
   --------------------------
4175
 
4176
   procedure Analyze_Variant_Part (N : Node_Id) is
4177
 
4178
      procedure Non_Static_Choice_Error (Choice : Node_Id);
4179
      --  Error routine invoked by the generic instantiation below when the
4180
      --  variant part has a non static choice.
4181
 
4182
      procedure Process_Declarations (Variant : Node_Id);
4183
      --  Analyzes all the declarations associated with a Variant. Needed by
4184
      --  the generic instantiation below.
4185
 
4186
      package Variant_Choices_Processing is new
4187
        Generic_Choices_Processing
4188
          (Get_Alternatives          => Variants,
4189
           Get_Choices               => Discrete_Choices,
4190
           Process_Empty_Choice      => No_OP,
4191
           Process_Non_Static_Choice => Non_Static_Choice_Error,
4192
           Process_Associated_Node   => Process_Declarations);
4193
      use Variant_Choices_Processing;
4194
      --  Instantiation of the generic choice processing package
4195
 
4196
      -----------------------------
4197
      -- Non_Static_Choice_Error --
4198
      -----------------------------
4199
 
4200
      procedure Non_Static_Choice_Error (Choice : Node_Id) is
4201
      begin
4202
         Flag_Non_Static_Expr
4203
           ("choice given in variant part is not static!", Choice);
4204
      end Non_Static_Choice_Error;
4205
 
4206
      --------------------------
4207
      -- Process_Declarations --
4208
      --------------------------
4209
 
4210
      procedure Process_Declarations (Variant : Node_Id) is
4211
      begin
4212
         if not Null_Present (Component_List (Variant)) then
4213
            Analyze_Declarations (Component_Items (Component_List (Variant)));
4214
 
4215
            if Present (Variant_Part (Component_List (Variant))) then
4216
               Analyze (Variant_Part (Component_List (Variant)));
4217
            end if;
4218
         end if;
4219
      end Process_Declarations;
4220
 
4221
      --  Local Variables
4222
 
4223
      Discr_Name : Node_Id;
4224
      Discr_Type : Entity_Id;
4225
 
4226
      Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
4227
      Last_Choice    : Nat;
4228
      Dont_Care      : Boolean;
4229
      Others_Present : Boolean := False;
4230
 
4231
      pragma Warnings (Off, Case_Table);
4232
      pragma Warnings (Off, Last_Choice);
4233
      pragma Warnings (Off, Dont_Care);
4234
      pragma Warnings (Off, Others_Present);
4235
      --  We don't care about the assigned values of any of these
4236
 
4237
   --  Start of processing for Analyze_Variant_Part
4238
 
4239
   begin
4240
      Discr_Name := Name (N);
4241
      Analyze (Discr_Name);
4242
 
4243
      --  If Discr_Name bad, get out (prevent cascaded errors)
4244
 
4245
      if Etype (Discr_Name) = Any_Type then
4246
         return;
4247
      end if;
4248
 
4249
      --  Check invalid discriminant in variant part
4250
 
4251
      if Ekind (Entity (Discr_Name)) /= E_Discriminant then
4252
         Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
4253
      end if;
4254
 
4255
      Discr_Type := Etype (Entity (Discr_Name));
4256
 
4257
      if not Is_Discrete_Type (Discr_Type) then
4258
         Error_Msg_N
4259
           ("discriminant in a variant part must be of a discrete type",
4260
             Name (N));
4261
         return;
4262
      end if;
4263
 
4264
      --  Call the instantiated Analyze_Choices which does the rest of the work
4265
 
4266
      Analyze_Choices
4267
        (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
4268
   end Analyze_Variant_Part;
4269
 
4270
   ----------------------------
4271
   -- Array_Type_Declaration --
4272
   ----------------------------
4273
 
4274
   procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
4275
      Component_Def : constant Node_Id := Component_Definition (Def);
4276
      Element_Type  : Entity_Id;
4277
      Implicit_Base : Entity_Id;
4278
      Index         : Node_Id;
4279
      Related_Id    : Entity_Id := Empty;
4280
      Nb_Index      : Nat;
4281
      P             : constant Node_Id := Parent (Def);
4282
      Priv          : Entity_Id;
4283
 
4284
   begin
4285
      if Nkind (Def) = N_Constrained_Array_Definition then
4286
         Index := First (Discrete_Subtype_Definitions (Def));
4287
      else
4288
         Index := First (Subtype_Marks (Def));
4289
      end if;
4290
 
4291
      --  Find proper names for the implicit types which may be public. In case
4292
      --  of anonymous arrays we use the name of the first object of that type
4293
      --  as prefix.
4294
 
4295
      if No (T) then
4296
         Related_Id :=  Defining_Identifier (P);
4297
      else
4298
         Related_Id := T;
4299
      end if;
4300
 
4301
      Nb_Index := 1;
4302
      while Present (Index) loop
4303
         Analyze (Index);
4304
 
4305
         --  Add a subtype declaration for each index of private array type
4306
         --  declaration whose etype is also private. For example:
4307
 
4308
         --     package Pkg is
4309
         --        type Index is private;
4310
         --     private
4311
         --        type Table is array (Index) of ...
4312
         --     end;
4313
 
4314
         --  This is currently required by the expander for the internally
4315
         --  generated equality subprogram of records with variant parts in
4316
         --  which the etype of some component is such private type.
4317
 
4318
         if Ekind (Current_Scope) = E_Package
4319
           and then In_Private_Part (Current_Scope)
4320
           and then Has_Private_Declaration (Etype (Index))
4321
         then
4322
            declare
4323
               Loc   : constant Source_Ptr := Sloc (Def);
4324
               New_E : Entity_Id;
4325
               Decl  : Entity_Id;
4326
 
4327
            begin
4328
               New_E :=
4329
                 Make_Defining_Identifier (Loc,
4330
                   Chars => New_Internal_Name ('T'));
4331
               Set_Is_Internal (New_E);
4332
 
4333
               Decl :=
4334
                 Make_Subtype_Declaration (Loc,
4335
                   Defining_Identifier => New_E,
4336
                   Subtype_Indication  =>
4337
                     New_Occurrence_Of (Etype (Index), Loc));
4338
 
4339
               Insert_Before (Parent (Def), Decl);
4340
               Analyze (Decl);
4341
               Set_Etype (Index, New_E);
4342
 
4343
               --  If the index is a range the Entity attribute is not
4344
               --  available. Example:
4345
 
4346
               --     package Pkg is
4347
               --        type T is private;
4348
               --     private
4349
               --        type T is new Natural;
4350
               --        Table : array (T(1) .. T(10)) of Boolean;
4351
               --     end Pkg;
4352
 
4353
               if Nkind (Index) /= N_Range then
4354
                  Set_Entity (Index, New_E);
4355
               end if;
4356
            end;
4357
         end if;
4358
 
4359
         Make_Index (Index, P, Related_Id, Nb_Index);
4360
         Next_Index (Index);
4361
         Nb_Index := Nb_Index + 1;
4362
      end loop;
4363
 
4364
      --  Process subtype indication if one is present
4365
 
4366
      if Present (Subtype_Indication (Component_Def)) then
4367
         Element_Type :=
4368
           Process_Subtype
4369
             (Subtype_Indication (Component_Def), P, Related_Id, 'C');
4370
 
4371
      --  Ada 2005 (AI-230): Access Definition case
4372
 
4373
      else pragma Assert (Present (Access_Definition (Component_Def)));
4374
 
4375
         --  Indicate that the anonymous access type is created by the
4376
         --  array type declaration.
4377
 
4378
         Element_Type := Access_Definition
4379
                           (Related_Nod => P,
4380
                            N           => Access_Definition (Component_Def));
4381
         Set_Is_Local_Anonymous_Access (Element_Type);
4382
 
4383
         --  Propagate the parent. This field is needed if we have to generate
4384
         --  the master_id associated with an anonymous access to task type
4385
         --  component (see Expand_N_Full_Type_Declaration.Build_Master)
4386
 
4387
         Set_Parent (Element_Type, Parent (T));
4388
 
4389
         --  Ada 2005 (AI-230): In case of components that are anonymous access
4390
         --  types the level of accessibility depends on the enclosing type
4391
         --  declaration
4392
 
4393
         Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
4394
 
4395
         --  Ada 2005 (AI-254)
4396
 
4397
         declare
4398
            CD : constant Node_Id :=
4399
                   Access_To_Subprogram_Definition
4400
                     (Access_Definition (Component_Def));
4401
         begin
4402
            if Present (CD) and then Protected_Present (CD) then
4403
               Element_Type :=
4404
                 Replace_Anonymous_Access_To_Protected_Subprogram (Def);
4405
            end if;
4406
         end;
4407
      end if;
4408
 
4409
      --  Constrained array case
4410
 
4411
      if No (T) then
4412
         T := Create_Itype (E_Void, P, Related_Id, 'T');
4413
      end if;
4414
 
4415
      if Nkind (Def) = N_Constrained_Array_Definition then
4416
 
4417
         --  Establish Implicit_Base as unconstrained base type
4418
 
4419
         Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
4420
 
4421
         Set_Etype              (Implicit_Base, Implicit_Base);
4422
         Set_Scope              (Implicit_Base, Current_Scope);
4423
         Set_Has_Delayed_Freeze (Implicit_Base);
4424
 
4425
         --  The constrained array type is a subtype of the unconstrained one
4426
 
4427
         Set_Ekind          (T, E_Array_Subtype);
4428
         Init_Size_Align    (T);
4429
         Set_Etype          (T, Implicit_Base);
4430
         Set_Scope          (T, Current_Scope);
4431
         Set_Is_Constrained (T, True);
4432
         Set_First_Index    (T, First (Discrete_Subtype_Definitions (Def)));
4433
         Set_Has_Delayed_Freeze (T);
4434
 
4435
         --  Complete setup of implicit base type
4436
 
4437
         Set_First_Index       (Implicit_Base, First_Index (T));
4438
         Set_Component_Type    (Implicit_Base, Element_Type);
4439
         Set_Has_Task          (Implicit_Base, Has_Task (Element_Type));
4440
         Set_Component_Size    (Implicit_Base, Uint_0);
4441
         Set_Packed_Array_Type (Implicit_Base, Empty);
4442
         Set_Has_Controlled_Component
4443
                               (Implicit_Base, Has_Controlled_Component
4444
                                                        (Element_Type)
4445
                                                 or else Is_Controlled
4446
                                                        (Element_Type));
4447
         Set_Finalize_Storage_Only
4448
                               (Implicit_Base, Finalize_Storage_Only
4449
                                                        (Element_Type));
4450
 
4451
      --  Unconstrained array case
4452
 
4453
      else
4454
         Set_Ekind                    (T, E_Array_Type);
4455
         Init_Size_Align              (T);
4456
         Set_Etype                    (T, T);
4457
         Set_Scope                    (T, Current_Scope);
4458
         Set_Component_Size           (T, Uint_0);
4459
         Set_Is_Constrained           (T, False);
4460
         Set_First_Index              (T, First (Subtype_Marks (Def)));
4461
         Set_Has_Delayed_Freeze       (T, True);
4462
         Set_Has_Task                 (T, Has_Task      (Element_Type));
4463
         Set_Has_Controlled_Component (T, Has_Controlled_Component
4464
                                                        (Element_Type)
4465
                                            or else
4466
                                          Is_Controlled (Element_Type));
4467
         Set_Finalize_Storage_Only    (T, Finalize_Storage_Only
4468
                                                        (Element_Type));
4469
      end if;
4470
 
4471
      --  Common attributes for both cases
4472
 
4473
      Set_Component_Type (Base_Type (T), Element_Type);
4474
      Set_Packed_Array_Type (T, Empty);
4475
 
4476
      if Aliased_Present (Component_Definition (Def)) then
4477
         Set_Has_Aliased_Components (Etype (T));
4478
      end if;
4479
 
4480
      --  Ada 2005 (AI-231): Propagate the null-excluding attribute to the
4481
      --  array type to ensure that objects of this type are initialized.
4482
 
4483
      if Ada_Version >= Ada_05
4484
        and then Can_Never_Be_Null (Element_Type)
4485
      then
4486
         Set_Can_Never_Be_Null (T);
4487
 
4488
         if Null_Exclusion_Present (Component_Definition (Def))
4489
 
4490
            --  No need to check itypes because in their case this check was
4491
            --  done at their point of creation
4492
 
4493
           and then not Is_Itype (Element_Type)
4494
         then
4495
            Error_Msg_N
4496
              ("`NOT NULL` not allowed (null already excluded)",
4497
               Subtype_Indication (Component_Definition (Def)));
4498
         end if;
4499
      end if;
4500
 
4501
      Priv := Private_Component (Element_Type);
4502
 
4503
      if Present (Priv) then
4504
 
4505
         --  Check for circular definitions
4506
 
4507
         if Priv = Any_Type then
4508
            Set_Component_Type (Etype (T), Any_Type);
4509
 
4510
         --  There is a gap in the visibility of operations on the composite
4511
         --  type only if the component type is defined in a different scope.
4512
 
4513
         elsif Scope (Priv) = Current_Scope then
4514
            null;
4515
 
4516
         elsif Is_Limited_Type (Priv) then
4517
            Set_Is_Limited_Composite (Etype (T));
4518
            Set_Is_Limited_Composite (T);
4519
         else
4520
            Set_Is_Private_Composite (Etype (T));
4521
            Set_Is_Private_Composite (T);
4522
         end if;
4523
      end if;
4524
 
4525
      --  A syntax error in the declaration itself may lead to an empty index
4526
      --  list, in which case do a minimal patch.
4527
 
4528
      if No (First_Index (T)) then
4529
         Error_Msg_N ("missing index definition in array type declaration", T);
4530
 
4531
         declare
4532
            Indices : constant List_Id :=
4533
                        New_List (New_Occurrence_Of (Any_Id, Sloc (T)));
4534
         begin
4535
            Set_Discrete_Subtype_Definitions (Def, Indices);
4536
            Set_First_Index (T, First (Indices));
4537
            return;
4538
         end;
4539
      end if;
4540
 
4541
      --  Create a concatenation operator for the new type. Internal array
4542
      --  types created for packed entities do not need such, they are
4543
      --  compatible with the user-defined type.
4544
 
4545
      if Number_Dimensions (T) = 1
4546
         and then not Is_Packed_Array_Type (T)
4547
      then
4548
         New_Concatenation_Op (T);
4549
      end if;
4550
 
4551
      --  In the case of an unconstrained array the parser has already verified
4552
      --  that all the indices are unconstrained but we still need to make sure
4553
      --  that the element type is constrained.
4554
 
4555
      if Is_Indefinite_Subtype (Element_Type) then
4556
         Error_Msg_N
4557
           ("unconstrained element type in array declaration",
4558
            Subtype_Indication (Component_Def));
4559
 
4560
      elsif Is_Abstract_Type (Element_Type) then
4561
         Error_Msg_N
4562
           ("the type of a component cannot be abstract",
4563
            Subtype_Indication (Component_Def));
4564
      end if;
4565
   end Array_Type_Declaration;
4566
 
4567
   ------------------------------------------------------
4568
   -- Replace_Anonymous_Access_To_Protected_Subprogram --
4569
   ------------------------------------------------------
4570
 
4571
   function Replace_Anonymous_Access_To_Protected_Subprogram
4572
     (N : Node_Id) return Entity_Id
4573
   is
4574
      Loc : constant Source_Ptr := Sloc (N);
4575
 
4576
      Curr_Scope : constant Scope_Stack_Entry :=
4577
                     Scope_Stack.Table (Scope_Stack.Last);
4578
 
4579
      Anon : constant Entity_Id :=
4580
               Make_Defining_Identifier (Loc,
4581
                 Chars => New_Internal_Name ('S'));
4582
 
4583
      Acc  : Node_Id;
4584
      Comp : Node_Id;
4585
      Decl : Node_Id;
4586
      P    : Node_Id;
4587
 
4588
   begin
4589
      Set_Is_Internal (Anon);
4590
 
4591
      case Nkind (N) is
4592
         when N_Component_Declaration       |
4593
           N_Unconstrained_Array_Definition |
4594
           N_Constrained_Array_Definition   =>
4595
            Comp := Component_Definition (N);
4596
            Acc  := Access_Definition (Comp);
4597
 
4598
         when N_Discriminant_Specification =>
4599
            Comp := Discriminant_Type (N);
4600
            Acc  := Comp;
4601
 
4602
         when N_Parameter_Specification =>
4603
            Comp := Parameter_Type (N);
4604
            Acc  := Comp;
4605
 
4606
         when N_Access_Function_Definition  =>
4607
            Comp := Result_Definition (N);
4608
            Acc  := Comp;
4609
 
4610
         when N_Object_Declaration  =>
4611
            Comp := Object_Definition (N);
4612
            Acc  := Comp;
4613
 
4614
         when N_Function_Specification =>
4615
            Comp := Result_Definition (N);
4616
            Acc  := Comp;
4617
 
4618
         when others =>
4619
            raise Program_Error;
4620
      end case;
4621
 
4622
      Decl := Make_Full_Type_Declaration (Loc,
4623
                Defining_Identifier => Anon,
4624
                Type_Definition   =>
4625
                  Copy_Separate_Tree (Access_To_Subprogram_Definition (Acc)));
4626
 
4627
      Mark_Rewrite_Insertion (Decl);
4628
 
4629
      --  Insert the new declaration in the nearest enclosing scope. If the
4630
      --  node is a body and N is its return type, the declaration belongs in
4631
      --  the enclosing scope.
4632
 
4633
      P := Parent (N);
4634
 
4635
      if Nkind (P) = N_Subprogram_Body
4636
        and then Nkind (N) = N_Function_Specification
4637
      then
4638
         P := Parent (P);
4639
      end if;
4640
 
4641
      while Present (P) and then not Has_Declarations (P) loop
4642
         P := Parent (P);
4643
      end loop;
4644
 
4645
      pragma Assert (Present (P));
4646
 
4647
      if Nkind (P) = N_Package_Specification then
4648
         Prepend (Decl, Visible_Declarations (P));
4649
      else
4650
         Prepend (Decl, Declarations (P));
4651
      end if;
4652
 
4653
      --  Replace the anonymous type with an occurrence of the new declaration.
4654
      --  In all cases the rewritten node does not have the null-exclusion
4655
      --  attribute because (if present) it was already inherited by the
4656
      --  anonymous entity (Anon). Thus, in case of components we do not
4657
      --  inherit this attribute.
4658
 
4659
      if Nkind (N) = N_Parameter_Specification then
4660
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
4661
         Set_Etype (Defining_Identifier (N), Anon);
4662
         Set_Null_Exclusion_Present (N, False);
4663
 
4664
      elsif Nkind (N) = N_Object_Declaration then
4665
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
4666
         Set_Etype (Defining_Identifier (N), Anon);
4667
 
4668
      elsif Nkind (N) = N_Access_Function_Definition then
4669
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
4670
 
4671
      elsif Nkind (N) = N_Function_Specification then
4672
         Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
4673
         Set_Etype (Defining_Unit_Name (N), Anon);
4674
 
4675
      else
4676
         Rewrite (Comp,
4677
           Make_Component_Definition (Loc,
4678
             Subtype_Indication => New_Occurrence_Of (Anon, Loc)));
4679
      end if;
4680
 
4681
      Mark_Rewrite_Insertion (Comp);
4682
 
4683
      if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
4684
         Analyze (Decl);
4685
 
4686
      else
4687
         --  Temporarily remove the current scope (record or subprogram) from
4688
         --  the stack to add the new declarations to the enclosing scope.
4689
 
4690
         Scope_Stack.Decrement_Last;
4691
         Analyze (Decl);
4692
         Set_Is_Itype (Anon);
4693
         Scope_Stack.Append (Curr_Scope);
4694
      end if;
4695
 
4696
      Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
4697
      Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target);
4698
      return Anon;
4699
   end Replace_Anonymous_Access_To_Protected_Subprogram;
4700
 
4701
   -------------------------------
4702
   -- Build_Derived_Access_Type --
4703
   -------------------------------
4704
 
4705
   procedure Build_Derived_Access_Type
4706
     (N            : Node_Id;
4707
      Parent_Type  : Entity_Id;
4708
      Derived_Type : Entity_Id)
4709
   is
4710
      S : constant Node_Id := Subtype_Indication (Type_Definition (N));
4711
 
4712
      Desig_Type      : Entity_Id;
4713
      Discr           : Entity_Id;
4714
      Discr_Con_Elist : Elist_Id;
4715
      Discr_Con_El    : Elmt_Id;
4716
      Subt            : Entity_Id;
4717
 
4718
   begin
4719
      --  Set the designated type so it is available in case this is an access
4720
      --  to a self-referential type, e.g. a standard list type with a next
4721
      --  pointer. Will be reset after subtype is built.
4722
 
4723
      Set_Directly_Designated_Type
4724
        (Derived_Type, Designated_Type (Parent_Type));
4725
 
4726
      Subt := Process_Subtype (S, N);
4727
 
4728
      if Nkind (S) /= N_Subtype_Indication
4729
        and then Subt /= Base_Type (Subt)
4730
      then
4731
         Set_Ekind (Derived_Type, E_Access_Subtype);
4732
      end if;
4733
 
4734
      if Ekind (Derived_Type) = E_Access_Subtype then
4735
         declare
4736
            Pbase      : constant Entity_Id := Base_Type (Parent_Type);
4737
            Ibase      : constant Entity_Id :=
4738
                           Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
4739
            Svg_Chars  : constant Name_Id   := Chars (Ibase);
4740
            Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
4741
 
4742
         begin
4743
            Copy_Node (Pbase, Ibase);
4744
 
4745
            Set_Chars             (Ibase, Svg_Chars);
4746
            Set_Next_Entity       (Ibase, Svg_Next_E);
4747
            Set_Sloc              (Ibase, Sloc (Derived_Type));
4748
            Set_Scope             (Ibase, Scope (Derived_Type));
4749
            Set_Freeze_Node       (Ibase, Empty);
4750
            Set_Is_Frozen         (Ibase, False);
4751
            Set_Comes_From_Source (Ibase, False);
4752
            Set_Is_First_Subtype  (Ibase, False);
4753
 
4754
            Set_Etype (Ibase, Pbase);
4755
            Set_Etype (Derived_Type, Ibase);
4756
         end;
4757
      end if;
4758
 
4759
      Set_Directly_Designated_Type
4760
        (Derived_Type, Designated_Type (Subt));
4761
 
4762
      Set_Is_Constrained     (Derived_Type, Is_Constrained (Subt));
4763
      Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
4764
      Set_Size_Info          (Derived_Type,                     Parent_Type);
4765
      Set_RM_Size            (Derived_Type, RM_Size            (Parent_Type));
4766
      Set_Depends_On_Private (Derived_Type,
4767
                              Has_Private_Component (Derived_Type));
4768
      Conditional_Delay      (Derived_Type, Subt);
4769
 
4770
      --  Ada 2005 (AI-231): Set the null-exclusion attribute, and verify
4771
      --  that it is not redundant.
4772
 
4773
      if Null_Exclusion_Present (Type_Definition (N)) then
4774
         Set_Can_Never_Be_Null (Derived_Type);
4775
 
4776
         if Can_Never_Be_Null (Parent_Type)
4777
           and then False
4778
         then
4779
            Error_Msg_NE
4780
              ("`NOT NULL` not allowed (& already excludes null)",
4781
                N, Parent_Type);
4782
         end if;
4783
 
4784
      elsif Can_Never_Be_Null (Parent_Type) then
4785
         Set_Can_Never_Be_Null (Derived_Type);
4786
      end if;
4787
 
4788
      --  Note: we do not copy the Storage_Size_Variable, since we always go to
4789
      --  the root type for this information.
4790
 
4791
      --  Apply range checks to discriminants for derived record case
4792
      --  ??? THIS CODE SHOULD NOT BE HERE REALLY.
4793
 
4794
      Desig_Type := Designated_Type (Derived_Type);
4795
      if Is_Composite_Type (Desig_Type)
4796
        and then (not Is_Array_Type (Desig_Type))
4797
        and then Has_Discriminants (Desig_Type)
4798
        and then Base_Type (Desig_Type) /= Desig_Type
4799
      then
4800
         Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
4801
         Discr_Con_El := First_Elmt (Discr_Con_Elist);
4802
 
4803
         Discr := First_Discriminant (Base_Type (Desig_Type));
4804
         while Present (Discr_Con_El) loop
4805
            Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
4806
            Next_Elmt (Discr_Con_El);
4807
            Next_Discriminant (Discr);
4808
         end loop;
4809
      end if;
4810
   end Build_Derived_Access_Type;
4811
 
4812
   ------------------------------
4813
   -- Build_Derived_Array_Type --
4814
   ------------------------------
4815
 
4816
   procedure Build_Derived_Array_Type
4817
     (N            : Node_Id;
4818
      Parent_Type  : Entity_Id;
4819
      Derived_Type : Entity_Id)
4820
   is
4821
      Loc           : constant Source_Ptr := Sloc (N);
4822
      Tdef          : constant Node_Id    := Type_Definition (N);
4823
      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
4824
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
4825
      Implicit_Base : Entity_Id;
4826
      New_Indic     : Node_Id;
4827
 
4828
      procedure Make_Implicit_Base;
4829
      --  If the parent subtype is constrained, the derived type is a subtype
4830
      --  of an implicit base type derived from the parent base.
4831
 
4832
      ------------------------
4833
      -- Make_Implicit_Base --
4834
      ------------------------
4835
 
4836
      procedure Make_Implicit_Base is
4837
      begin
4838
         Implicit_Base :=
4839
           Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
4840
 
4841
         Set_Ekind (Implicit_Base, Ekind (Parent_Base));
4842
         Set_Etype (Implicit_Base, Parent_Base);
4843
 
4844
         Copy_Array_Subtype_Attributes   (Implicit_Base, Parent_Base);
4845
         Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
4846
 
4847
         Set_Has_Delayed_Freeze (Implicit_Base, True);
4848
      end Make_Implicit_Base;
4849
 
4850
   --  Start of processing for Build_Derived_Array_Type
4851
 
4852
   begin
4853
      if not Is_Constrained (Parent_Type) then
4854
         if Nkind (Indic) /= N_Subtype_Indication then
4855
            Set_Ekind (Derived_Type, E_Array_Type);
4856
 
4857
            Copy_Array_Subtype_Attributes   (Derived_Type, Parent_Type);
4858
            Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
4859
 
4860
            Set_Has_Delayed_Freeze (Derived_Type, True);
4861
 
4862
         else
4863
            Make_Implicit_Base;
4864
            Set_Etype (Derived_Type, Implicit_Base);
4865
 
4866
            New_Indic :=
4867
              Make_Subtype_Declaration (Loc,
4868
                Defining_Identifier => Derived_Type,
4869
                Subtype_Indication  =>
4870
                  Make_Subtype_Indication (Loc,
4871
                    Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
4872
                    Constraint => Constraint (Indic)));
4873
 
4874
            Rewrite (N, New_Indic);
4875
            Analyze (N);
4876
         end if;
4877
 
4878
      else
4879
         if Nkind (Indic) /= N_Subtype_Indication then
4880
            Make_Implicit_Base;
4881
 
4882
            Set_Ekind             (Derived_Type, Ekind (Parent_Type));
4883
            Set_Etype             (Derived_Type, Implicit_Base);
4884
            Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
4885
 
4886
         else
4887
            Error_Msg_N ("illegal constraint on constrained type", Indic);
4888
         end if;
4889
      end if;
4890
 
4891
      --  If parent type is not a derived type itself, and is declared in
4892
      --  closed scope (e.g. a subprogram), then we must explicitly introduce
4893
      --  the new type's concatenation operator since Derive_Subprograms
4894
      --  will not inherit the parent's operator. If the parent type is
4895
      --  unconstrained, the operator is of the unconstrained base type.
4896
 
4897
      if Number_Dimensions (Parent_Type) = 1
4898
        and then not Is_Limited_Type (Parent_Type)
4899
        and then not Is_Derived_Type (Parent_Type)
4900
        and then not Is_Package_Or_Generic_Package
4901
                       (Scope (Base_Type (Parent_Type)))
4902
      then
4903
         if not Is_Constrained (Parent_Type)
4904
           and then Is_Constrained (Derived_Type)
4905
         then
4906
            New_Concatenation_Op (Implicit_Base);
4907
         else
4908
            New_Concatenation_Op (Derived_Type);
4909
         end if;
4910
      end if;
4911
   end Build_Derived_Array_Type;
4912
 
4913
   -----------------------------------
4914
   -- Build_Derived_Concurrent_Type --
4915
   -----------------------------------
4916
 
4917
   procedure Build_Derived_Concurrent_Type
4918
     (N            : Node_Id;
4919
      Parent_Type  : Entity_Id;
4920
      Derived_Type : Entity_Id)
4921
   is
4922
      Loc : constant Source_Ptr := Sloc (N);
4923
 
4924
      Corr_Record : constant Entity_Id :=
4925
                      Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
4926
 
4927
      Corr_Decl        : Node_Id;
4928
      Corr_Decl_Needed : Boolean;
4929
      --  If the derived type has fewer discriminants than its parent, the
4930
      --  corresponding record is also a derived type, in order to account for
4931
      --  the bound discriminants. We create a full type declaration for it in
4932
      --  this case.
4933
 
4934
      Constraint_Present : constant Boolean :=
4935
                             Nkind (Subtype_Indication (Type_Definition (N))) =
4936
                                                          N_Subtype_Indication;
4937
 
4938
      D_Constraint   : Node_Id;
4939
      New_Constraint : Elist_Id;
4940
      Old_Disc       : Entity_Id;
4941
      New_Disc       : Entity_Id;
4942
      New_N          : Node_Id;
4943
 
4944
   begin
4945
      Set_Stored_Constraint (Derived_Type, No_Elist);
4946
      Corr_Decl_Needed := False;
4947
      Old_Disc := Empty;
4948
 
4949
      if Present (Discriminant_Specifications (N))
4950
        and then Constraint_Present
4951
      then
4952
         Old_Disc := First_Discriminant (Parent_Type);
4953
         New_Disc := First (Discriminant_Specifications (N));
4954
         while Present (New_Disc) and then Present (Old_Disc) loop
4955
            Next_Discriminant (Old_Disc);
4956
            Next (New_Disc);
4957
         end loop;
4958
      end if;
4959
 
4960
      if Present (Old_Disc) then
4961
 
4962
         --  The new type has fewer discriminants, so we need to create a new
4963
         --  corresponding record, which is derived from the corresponding
4964
         --  record of the parent, and has a stored constraint that captures
4965
         --  the values of the discriminant constraints.
4966
 
4967
         --  The type declaration for the derived corresponding record has
4968
         --  the same discriminant part and constraints as the current
4969
         --  declaration. Copy the unanalyzed tree to build declaration.
4970
 
4971
         Corr_Decl_Needed := True;
4972
         New_N := Copy_Separate_Tree (N);
4973
 
4974
         Corr_Decl :=
4975
           Make_Full_Type_Declaration (Loc,
4976
             Defining_Identifier => Corr_Record,
4977
             Discriminant_Specifications =>
4978
                Discriminant_Specifications (New_N),
4979
             Type_Definition =>
4980
               Make_Derived_Type_Definition (Loc,
4981
                 Subtype_Indication =>
4982
                   Make_Subtype_Indication (Loc,
4983
                     Subtype_Mark =>
4984
                        New_Occurrence_Of
4985
                          (Corresponding_Record_Type (Parent_Type), Loc),
4986
                     Constraint =>
4987
                       Constraint
4988
                         (Subtype_Indication (Type_Definition (New_N))))));
4989
      end if;
4990
 
4991
      --  Copy Storage_Size and Relative_Deadline variables if task case
4992
 
4993
      if Is_Task_Type (Parent_Type) then
4994
         Set_Storage_Size_Variable (Derived_Type,
4995
           Storage_Size_Variable (Parent_Type));
4996
         Set_Relative_Deadline_Variable (Derived_Type,
4997
           Relative_Deadline_Variable (Parent_Type));
4998
      end if;
4999
 
5000
      if Present (Discriminant_Specifications (N)) then
5001
         Push_Scope (Derived_Type);
5002
         Check_Or_Process_Discriminants (N, Derived_Type);
5003
 
5004
         if Constraint_Present then
5005
            New_Constraint :=
5006
              Expand_To_Stored_Constraint
5007
                (Parent_Type,
5008
                 Build_Discriminant_Constraints
5009
                   (Parent_Type,
5010
                    Subtype_Indication (Type_Definition (N)), True));
5011
         end if;
5012
 
5013
         End_Scope;
5014
 
5015
      elsif Constraint_Present then
5016
 
5017
         --  Build constrained subtype and derive from it
5018
 
5019
         declare
5020
            Loc  : constant Source_Ptr := Sloc (N);
5021
            Anon : constant Entity_Id :=
5022
                     Make_Defining_Identifier (Loc,
5023
                       New_External_Name (Chars (Derived_Type), 'T'));
5024
            Decl : Node_Id;
5025
 
5026
         begin
5027
            Decl :=
5028
              Make_Subtype_Declaration (Loc,
5029
                Defining_Identifier => Anon,
5030
                Subtype_Indication =>
5031
                  Subtype_Indication (Type_Definition (N)));
5032
            Insert_Before (N, Decl);
5033
            Analyze (Decl);
5034
 
5035
            Rewrite (Subtype_Indication (Type_Definition (N)),
5036
              New_Occurrence_Of (Anon, Loc));
5037
            Set_Analyzed (Derived_Type, False);
5038
            Analyze (N);
5039
            return;
5040
         end;
5041
      end if;
5042
 
5043
      --  By default, operations and private data are inherited from parent.
5044
      --  However, in the presence of bound discriminants, a new corresponding
5045
      --  record will be created, see below.
5046
 
5047
      Set_Has_Discriminants
5048
        (Derived_Type, Has_Discriminants         (Parent_Type));
5049
      Set_Corresponding_Record_Type
5050
        (Derived_Type, Corresponding_Record_Type (Parent_Type));
5051
 
5052
      --  Is_Constrained is set according the parent subtype, but is set to
5053
      --  False if the derived type is declared with new discriminants.
5054
 
5055
      Set_Is_Constrained
5056
        (Derived_Type,
5057
         (Is_Constrained (Parent_Type) or else Constraint_Present)
5058
           and then not Present (Discriminant_Specifications (N)));
5059
 
5060
      if Constraint_Present then
5061
         if not Has_Discriminants (Parent_Type) then
5062
            Error_Msg_N ("untagged parent must have discriminants", N);
5063
 
5064
         elsif Present (Discriminant_Specifications (N)) then
5065
 
5066
            --  Verify that new discriminants are used to constrain old ones
5067
 
5068
            D_Constraint :=
5069
              First
5070
                (Constraints
5071
                  (Constraint (Subtype_Indication (Type_Definition (N)))));
5072
 
5073
            Old_Disc := First_Discriminant (Parent_Type);
5074
 
5075
            while Present (D_Constraint) loop
5076
               if Nkind (D_Constraint) /= N_Discriminant_Association then
5077
 
5078
                  --  Positional constraint. If it is a reference to a new
5079
                  --  discriminant, it constrains the corresponding old one.
5080
 
5081
                  if Nkind (D_Constraint) = N_Identifier then
5082
                     New_Disc := First_Discriminant (Derived_Type);
5083
                     while Present (New_Disc) loop
5084
                        exit when Chars (New_Disc) = Chars (D_Constraint);
5085
                        Next_Discriminant (New_Disc);
5086
                     end loop;
5087
 
5088
                     if Present (New_Disc) then
5089
                        Set_Corresponding_Discriminant (New_Disc, Old_Disc);
5090
                     end if;
5091
                  end if;
5092
 
5093
                  Next_Discriminant (Old_Disc);
5094
 
5095
                  --  if this is a named constraint, search by name for the old
5096
                  --  discriminants constrained by the new one.
5097
 
5098
               elsif Nkind (Expression (D_Constraint)) = N_Identifier then
5099
 
5100
                  --  Find new discriminant with that name
5101
 
5102
                  New_Disc := First_Discriminant (Derived_Type);
5103
                  while Present (New_Disc) loop
5104
                     exit when
5105
                       Chars (New_Disc) = Chars (Expression (D_Constraint));
5106
                     Next_Discriminant (New_Disc);
5107
                  end loop;
5108
 
5109
                  if Present (New_Disc) then
5110
 
5111
                     --  Verify that new discriminant renames some discriminant
5112
                     --  of the parent type, and associate the new discriminant
5113
                     --  with one or more old ones that it renames.
5114
 
5115
                     declare
5116
                        Selector : Node_Id;
5117
 
5118
                     begin
5119
                        Selector := First (Selector_Names (D_Constraint));
5120
                        while Present (Selector) loop
5121
                           Old_Disc := First_Discriminant (Parent_Type);
5122
                           while Present (Old_Disc) loop
5123
                              exit when Chars (Old_Disc) = Chars (Selector);
5124
                              Next_Discriminant (Old_Disc);
5125
                           end loop;
5126
 
5127
                           if Present (Old_Disc) then
5128
                              Set_Corresponding_Discriminant
5129
                                (New_Disc, Old_Disc);
5130
                           end if;
5131
 
5132
                           Next (Selector);
5133
                        end loop;
5134
                     end;
5135
                  end if;
5136
               end if;
5137
 
5138
               Next (D_Constraint);
5139
            end loop;
5140
 
5141
            New_Disc := First_Discriminant (Derived_Type);
5142
            while Present (New_Disc) loop
5143
               if No (Corresponding_Discriminant (New_Disc)) then
5144
                  Error_Msg_NE
5145
                    ("new discriminant& must constrain old one", N, New_Disc);
5146
 
5147
               elsif not
5148
                 Subtypes_Statically_Compatible
5149
                   (Etype (New_Disc),
5150
                    Etype (Corresponding_Discriminant (New_Disc)))
5151
               then
5152
                  Error_Msg_NE
5153
                    ("& not statically compatible with parent discriminant",
5154
                      N, New_Disc);
5155
               end if;
5156
 
5157
               Next_Discriminant (New_Disc);
5158
            end loop;
5159
         end if;
5160
 
5161
      elsif Present (Discriminant_Specifications (N)) then
5162
         Error_Msg_N
5163
           ("missing discriminant constraint in untagged derivation", N);
5164
      end if;
5165
 
5166
      --  The entity chain of the derived type includes the new discriminants
5167
      --  but shares operations with the parent.
5168
 
5169
      if Present (Discriminant_Specifications (N)) then
5170
         Old_Disc := First_Discriminant (Parent_Type);
5171
         while Present (Old_Disc) loop
5172
            if No (Next_Entity (Old_Disc))
5173
              or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
5174
            then
5175
               Set_Next_Entity
5176
                 (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
5177
               exit;
5178
            end if;
5179
 
5180
            Next_Discriminant (Old_Disc);
5181
         end loop;
5182
 
5183
      else
5184
         Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
5185
         if Has_Discriminants (Parent_Type) then
5186
            Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
5187
            Set_Discriminant_Constraint (
5188
              Derived_Type, Discriminant_Constraint (Parent_Type));
5189
         end if;
5190
      end if;
5191
 
5192
      Set_Last_Entity  (Derived_Type, Last_Entity  (Parent_Type));
5193
 
5194
      Set_Has_Completion (Derived_Type);
5195
 
5196
      if Corr_Decl_Needed then
5197
         Set_Stored_Constraint (Derived_Type, New_Constraint);
5198
         Insert_After (N, Corr_Decl);
5199
         Analyze (Corr_Decl);
5200
         Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
5201
      end if;
5202
   end Build_Derived_Concurrent_Type;
5203
 
5204
   ------------------------------------
5205
   -- Build_Derived_Enumeration_Type --
5206
   ------------------------------------
5207
 
5208
   procedure Build_Derived_Enumeration_Type
5209
     (N            : Node_Id;
5210
      Parent_Type  : Entity_Id;
5211
      Derived_Type : Entity_Id)
5212
   is
5213
      Loc           : constant Source_Ptr := Sloc (N);
5214
      Def           : constant Node_Id    := Type_Definition (N);
5215
      Indic         : constant Node_Id    := Subtype_Indication (Def);
5216
      Implicit_Base : Entity_Id;
5217
      Literal       : Entity_Id;
5218
      New_Lit       : Entity_Id;
5219
      Literals_List : List_Id;
5220
      Type_Decl     : Node_Id;
5221
      Hi, Lo        : Node_Id;
5222
      Rang_Expr     : Node_Id;
5223
 
5224
   begin
5225
      --  Since types Standard.Character and Standard.[Wide_]Wide_Character do
5226
      --  not have explicit literals lists we need to process types derived
5227
      --  from them specially. This is handled by Derived_Standard_Character.
5228
      --  If the parent type is a generic type, there are no literals either,
5229
      --  and we construct the same skeletal representation as for the generic
5230
      --  parent type.
5231
 
5232
      if Is_Standard_Character_Type (Parent_Type) then
5233
         Derived_Standard_Character (N, Parent_Type, Derived_Type);
5234
 
5235
      elsif Is_Generic_Type (Root_Type (Parent_Type)) then
5236
         declare
5237
            Lo : Node_Id;
5238
            Hi : Node_Id;
5239
 
5240
         begin
5241
            if Nkind (Indic) /= N_Subtype_Indication then
5242
               Lo :=
5243
                  Make_Attribute_Reference (Loc,
5244
                    Attribute_Name => Name_First,
5245
                    Prefix         => New_Reference_To (Derived_Type, Loc));
5246
               Set_Etype (Lo, Derived_Type);
5247
 
5248
               Hi :=
5249
                  Make_Attribute_Reference (Loc,
5250
                    Attribute_Name => Name_Last,
5251
                    Prefix         => New_Reference_To (Derived_Type, Loc));
5252
               Set_Etype (Hi, Derived_Type);
5253
 
5254
               Set_Scalar_Range (Derived_Type,
5255
                  Make_Range (Loc,
5256
                    Low_Bound  => Lo,
5257
                    High_Bound => Hi));
5258
            else
5259
 
5260
               --   Analyze subtype indication and verify compatibility
5261
               --   with parent type.
5262
 
5263
               if Base_Type (Process_Subtype (Indic, N)) /=
5264
                  Base_Type (Parent_Type)
5265
               then
5266
                  Error_Msg_N
5267
                    ("illegal constraint for formal discrete type", N);
5268
               end if;
5269
            end if;
5270
         end;
5271
 
5272
      else
5273
         --  If a constraint is present, analyze the bounds to catch
5274
         --  premature usage of the derived literals.
5275
 
5276
         if Nkind (Indic) = N_Subtype_Indication
5277
           and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
5278
         then
5279
            Analyze (Low_Bound  (Range_Expression (Constraint (Indic))));
5280
            Analyze (High_Bound (Range_Expression (Constraint (Indic))));
5281
         end if;
5282
 
5283
         --  Introduce an implicit base type for the derived type even if there
5284
         --  is no constraint attached to it, since this seems closer to the
5285
         --  Ada semantics. Build a full type declaration tree for the derived
5286
         --  type using the implicit base type as the defining identifier. The
5287
         --  build a subtype declaration tree which applies the constraint (if
5288
         --  any) have it replace the derived type declaration.
5289
 
5290
         Literal := First_Literal (Parent_Type);
5291
         Literals_List := New_List;
5292
         while Present (Literal)
5293
           and then Ekind (Literal) = E_Enumeration_Literal
5294
         loop
5295
            --  Literals of the derived type have the same representation as
5296
            --  those of the parent type, but this representation can be
5297
            --  overridden by an explicit representation clause. Indicate
5298
            --  that there is no explicit representation given yet. These
5299
            --  derived literals are implicit operations of the new type,
5300
            --  and can be overridden by explicit ones.
5301
 
5302
            if Nkind (Literal) = N_Defining_Character_Literal then
5303
               New_Lit :=
5304
                 Make_Defining_Character_Literal (Loc, Chars (Literal));
5305
            else
5306
               New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
5307
            end if;
5308
 
5309
            Set_Ekind                (New_Lit, E_Enumeration_Literal);
5310
            Set_Enumeration_Pos      (New_Lit, Enumeration_Pos (Literal));
5311
            Set_Enumeration_Rep      (New_Lit, Enumeration_Rep (Literal));
5312
            Set_Enumeration_Rep_Expr (New_Lit, Empty);
5313
            Set_Alias                (New_Lit, Literal);
5314
            Set_Is_Known_Valid       (New_Lit, True);
5315
 
5316
            Append (New_Lit, Literals_List);
5317
            Next_Literal (Literal);
5318
         end loop;
5319
 
5320
         Implicit_Base :=
5321
           Make_Defining_Identifier (Sloc (Derived_Type),
5322
             New_External_Name (Chars (Derived_Type), 'B'));
5323
 
5324
         --  Indicate the proper nature of the derived type. This must be done
5325
         --  before analysis of the literals, to recognize cases when a literal
5326
         --  may be hidden by a previous explicit function definition (cf.
5327
         --  c83031a).
5328
 
5329
         Set_Ekind (Derived_Type, E_Enumeration_Subtype);
5330
         Set_Etype (Derived_Type, Implicit_Base);
5331
 
5332
         Type_Decl :=
5333
           Make_Full_Type_Declaration (Loc,
5334
             Defining_Identifier => Implicit_Base,
5335
             Discriminant_Specifications => No_List,
5336
             Type_Definition =>
5337
               Make_Enumeration_Type_Definition (Loc, Literals_List));
5338
 
5339
         Mark_Rewrite_Insertion (Type_Decl);
5340
         Insert_Before (N, Type_Decl);
5341
         Analyze (Type_Decl);
5342
 
5343
         --  After the implicit base is analyzed its Etype needs to be changed
5344
         --  to reflect the fact that it is derived from the parent type which
5345
         --  was ignored during analysis. We also set the size at this point.
5346
 
5347
         Set_Etype (Implicit_Base, Parent_Type);
5348
 
5349
         Set_Size_Info      (Implicit_Base,                 Parent_Type);
5350
         Set_RM_Size        (Implicit_Base, RM_Size        (Parent_Type));
5351
         Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
5352
 
5353
         Set_Has_Non_Standard_Rep
5354
                            (Implicit_Base, Has_Non_Standard_Rep
5355
                                                           (Parent_Type));
5356
         Set_Has_Delayed_Freeze (Implicit_Base);
5357
 
5358
         --  Process the subtype indication including a validation check on the
5359
         --  constraint, if any. If a constraint is given, its bounds must be
5360
         --  implicitly converted to the new type.
5361
 
5362
         if Nkind (Indic) = N_Subtype_Indication then
5363
            declare
5364
               R : constant Node_Id :=
5365
                     Range_Expression (Constraint (Indic));
5366
 
5367
            begin
5368
               if Nkind (R) = N_Range then
5369
                  Hi := Build_Scalar_Bound
5370
                          (High_Bound (R), Parent_Type, Implicit_Base);
5371
                  Lo := Build_Scalar_Bound
5372
                          (Low_Bound  (R), Parent_Type, Implicit_Base);
5373
 
5374
               else
5375
                  --  Constraint is a Range attribute. Replace with explicit
5376
                  --  mention of the bounds of the prefix, which must be a
5377
                  --  subtype.
5378
 
5379
                  Analyze (Prefix (R));
5380
                  Hi :=
5381
                    Convert_To (Implicit_Base,
5382
                      Make_Attribute_Reference (Loc,
5383
                        Attribute_Name => Name_Last,
5384
                        Prefix =>
5385
                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
5386
 
5387
                  Lo :=
5388
                    Convert_To (Implicit_Base,
5389
                      Make_Attribute_Reference (Loc,
5390
                        Attribute_Name => Name_First,
5391
                        Prefix =>
5392
                          New_Occurrence_Of (Entity (Prefix (R)), Loc)));
5393
               end if;
5394
            end;
5395
 
5396
         else
5397
            Hi :=
5398
              Build_Scalar_Bound
5399
                (Type_High_Bound (Parent_Type),
5400
                 Parent_Type, Implicit_Base);
5401
            Lo :=
5402
               Build_Scalar_Bound
5403
                 (Type_Low_Bound (Parent_Type),
5404
                  Parent_Type, Implicit_Base);
5405
         end if;
5406
 
5407
         Rang_Expr :=
5408
           Make_Range (Loc,
5409
             Low_Bound  => Lo,
5410
             High_Bound => Hi);
5411
 
5412
         --  If we constructed a default range for the case where no range
5413
         --  was given, then the expressions in the range must not freeze
5414
         --  since they do not correspond to expressions in the source.
5415
 
5416
         if Nkind (Indic) /= N_Subtype_Indication then
5417
            Set_Must_Not_Freeze (Lo);
5418
            Set_Must_Not_Freeze (Hi);
5419
            Set_Must_Not_Freeze (Rang_Expr);
5420
         end if;
5421
 
5422
         Rewrite (N,
5423
           Make_Subtype_Declaration (Loc,
5424
             Defining_Identifier => Derived_Type,
5425
             Subtype_Indication =>
5426
               Make_Subtype_Indication (Loc,
5427
                 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
5428
                 Constraint =>
5429
                   Make_Range_Constraint (Loc,
5430
                     Range_Expression => Rang_Expr))));
5431
 
5432
         Analyze (N);
5433
 
5434
         --  If pragma Discard_Names applies on the first subtype of the parent
5435
         --  type, then it must be applied on this subtype as well.
5436
 
5437
         if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
5438
            Set_Discard_Names (Derived_Type);
5439
         end if;
5440
 
5441
         --  Apply a range check. Since this range expression doesn't have an
5442
         --  Etype, we have to specifically pass the Source_Typ parameter. Is
5443
         --  this right???
5444
 
5445
         if Nkind (Indic) = N_Subtype_Indication then
5446
            Apply_Range_Check (Range_Expression (Constraint (Indic)),
5447
                               Parent_Type,
5448
                               Source_Typ => Entity (Subtype_Mark (Indic)));
5449
         end if;
5450
      end if;
5451
   end Build_Derived_Enumeration_Type;
5452
 
5453
   --------------------------------
5454
   -- Build_Derived_Numeric_Type --
5455
   --------------------------------
5456
 
5457
   procedure Build_Derived_Numeric_Type
5458
     (N            : Node_Id;
5459
      Parent_Type  : Entity_Id;
5460
      Derived_Type : Entity_Id)
5461
   is
5462
      Loc           : constant Source_Ptr := Sloc (N);
5463
      Tdef          : constant Node_Id    := Type_Definition (N);
5464
      Indic         : constant Node_Id    := Subtype_Indication (Tdef);
5465
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
5466
      No_Constraint : constant Boolean    := Nkind (Indic) /=
5467
                                                  N_Subtype_Indication;
5468
      Implicit_Base : Entity_Id;
5469
 
5470
      Lo : Node_Id;
5471
      Hi : Node_Id;
5472
 
5473
   begin
5474
      --  Process the subtype indication including a validation check on
5475
      --  the constraint if any.
5476
 
5477
      Discard_Node (Process_Subtype (Indic, N));
5478
 
5479
      --  Introduce an implicit base type for the derived type even if there
5480
      --  is no constraint attached to it, since this seems closer to the Ada
5481
      --  semantics.
5482
 
5483
      Implicit_Base :=
5484
        Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
5485
 
5486
      Set_Etype          (Implicit_Base, Parent_Base);
5487
      Set_Ekind          (Implicit_Base, Ekind          (Parent_Base));
5488
      Set_Size_Info      (Implicit_Base,                 Parent_Base);
5489
      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
5490
      Set_Parent         (Implicit_Base, Parent (Derived_Type));
5491
      Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base));
5492
 
5493
      --  Set RM Size for discrete type or decimal fixed-point type
5494
      --  Ordinary fixed-point is excluded, why???
5495
 
5496
      if Is_Discrete_Type (Parent_Base)
5497
        or else Is_Decimal_Fixed_Point_Type (Parent_Base)
5498
      then
5499
         Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
5500
      end if;
5501
 
5502
      Set_Has_Delayed_Freeze (Implicit_Base);
5503
 
5504
      Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Base));
5505
      Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
5506
 
5507
      Set_Scalar_Range (Implicit_Base,
5508
        Make_Range (Loc,
5509
          Low_Bound  => Lo,
5510
          High_Bound => Hi));
5511
 
5512
      if Has_Infinities (Parent_Base) then
5513
         Set_Includes_Infinities (Scalar_Range (Implicit_Base));
5514
      end if;
5515
 
5516
      --  The Derived_Type, which is the entity of the declaration, is a
5517
      --  subtype of the implicit base. Its Ekind is a subtype, even in the
5518
      --  absence of an explicit constraint.
5519
 
5520
      Set_Etype (Derived_Type, Implicit_Base);
5521
 
5522
      --  If we did not have a constraint, then the Ekind is set from the
5523
      --  parent type (otherwise Process_Subtype has set the bounds)
5524
 
5525
      if No_Constraint then
5526
         Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
5527
      end if;
5528
 
5529
      --  If we did not have a range constraint, then set the range from the
5530
      --  parent type. Otherwise, the call to Process_Subtype has set the
5531
      --  bounds.
5532
 
5533
      if No_Constraint
5534
        or else not Has_Range_Constraint (Indic)
5535
      then
5536
         Set_Scalar_Range (Derived_Type,
5537
           Make_Range (Loc,
5538
             Low_Bound  => New_Copy_Tree (Type_Low_Bound  (Parent_Type)),
5539
             High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
5540
         Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
5541
 
5542
         if Has_Infinities (Parent_Type) then
5543
            Set_Includes_Infinities (Scalar_Range (Derived_Type));
5544
         end if;
5545
 
5546
         Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type));
5547
      end if;
5548
 
5549
      Set_Is_Descendent_Of_Address (Derived_Type,
5550
        Is_Descendent_Of_Address (Parent_Type));
5551
      Set_Is_Descendent_Of_Address (Implicit_Base,
5552
        Is_Descendent_Of_Address (Parent_Type));
5553
 
5554
      --  Set remaining type-specific fields, depending on numeric type
5555
 
5556
      if Is_Modular_Integer_Type (Parent_Type) then
5557
         Set_Modulus (Implicit_Base, Modulus (Parent_Base));
5558
 
5559
         Set_Non_Binary_Modulus
5560
           (Implicit_Base, Non_Binary_Modulus (Parent_Base));
5561
 
5562
         Set_Is_Known_Valid
5563
           (Implicit_Base, Is_Known_Valid (Parent_Base));
5564
 
5565
      elsif Is_Floating_Point_Type (Parent_Type) then
5566
 
5567
         --  Digits of base type is always copied from the digits value of
5568
         --  the parent base type, but the digits of the derived type will
5569
         --  already have been set if there was a constraint present.
5570
 
5571
         Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
5572
         Set_Vax_Float    (Implicit_Base, Vax_Float    (Parent_Base));
5573
 
5574
         if No_Constraint then
5575
            Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
5576
         end if;
5577
 
5578
      elsif Is_Fixed_Point_Type (Parent_Type) then
5579
 
5580
         --  Small of base type and derived type are always copied from the
5581
         --  parent base type, since smalls never change. The delta of the
5582
         --  base type is also copied from the parent base type. However the
5583
         --  delta of the derived type will have been set already if a
5584
         --  constraint was present.
5585
 
5586
         Set_Small_Value (Derived_Type,  Small_Value (Parent_Base));
5587
         Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
5588
         Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
5589
 
5590
         if No_Constraint then
5591
            Set_Delta_Value (Derived_Type,  Delta_Value (Parent_Type));
5592
         end if;
5593
 
5594
         --  The scale and machine radix in the decimal case are always
5595
         --  copied from the parent base type.
5596
 
5597
         if Is_Decimal_Fixed_Point_Type (Parent_Type) then
5598
            Set_Scale_Value (Derived_Type,  Scale_Value (Parent_Base));
5599
            Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
5600
 
5601
            Set_Machine_Radix_10
5602
              (Derived_Type,  Machine_Radix_10 (Parent_Base));
5603
            Set_Machine_Radix_10
5604
              (Implicit_Base, Machine_Radix_10 (Parent_Base));
5605
 
5606
            Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
5607
 
5608
            if No_Constraint then
5609
               Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
5610
 
5611
            else
5612
               --  the analysis of the subtype_indication sets the
5613
               --  digits value of the derived type.
5614
 
5615
               null;
5616
            end if;
5617
         end if;
5618
      end if;
5619
 
5620
      --  The type of the bounds is that of the parent type, and they
5621
      --  must be converted to the derived type.
5622
 
5623
      Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
5624
 
5625
      --  The implicit_base should be frozen when the derived type is frozen,
5626
      --  but note that it is used in the conversions of the bounds. For fixed
5627
      --  types we delay the determination of the bounds until the proper
5628
      --  freezing point. For other numeric types this is rejected by GCC, for
5629
      --  reasons that are currently unclear (???), so we choose to freeze the
5630
      --  implicit base now. In the case of integers and floating point types
5631
      --  this is harmless because subsequent representation clauses cannot
5632
      --  affect anything, but it is still baffling that we cannot use the
5633
      --  same mechanism for all derived numeric types.
5634
 
5635
      --  There is a further complication: actually *some* representation
5636
      --  clauses can affect the implicit base type. Namely, attribute
5637
      --  definition clauses for stream-oriented attributes need to set the
5638
      --  corresponding TSS entries on the base type, and this normally cannot
5639
      --  be done after the base type is frozen, so the circuitry in
5640
      --  Sem_Ch13.New_Stream_Subprogram must account for this possibility and
5641
      --  not use Set_TSS in this case.
5642
 
5643
      if Is_Fixed_Point_Type (Parent_Type) then
5644
         Conditional_Delay (Implicit_Base, Parent_Type);
5645
      else
5646
         Freeze_Before (N, Implicit_Base);
5647
      end if;
5648
   end Build_Derived_Numeric_Type;
5649
 
5650
   --------------------------------
5651
   -- Build_Derived_Private_Type --
5652
   --------------------------------
5653
 
5654
   procedure Build_Derived_Private_Type
5655
     (N             : Node_Id;
5656
      Parent_Type   : Entity_Id;
5657
      Derived_Type  : Entity_Id;
5658
      Is_Completion : Boolean;
5659
      Derive_Subps  : Boolean := True)
5660
   is
5661
      Loc         : constant Source_Ptr := Sloc (N);
5662
      Der_Base    : Entity_Id;
5663
      Discr       : Entity_Id;
5664
      Full_Decl   : Node_Id := Empty;
5665
      Full_Der    : Entity_Id;
5666
      Full_P      : Entity_Id;
5667
      Last_Discr  : Entity_Id;
5668
      Par_Scope   : constant Entity_Id := Scope (Base_Type (Parent_Type));
5669
      Swapped     : Boolean := False;
5670
 
5671
      procedure Copy_And_Build;
5672
      --  Copy derived type declaration, replace parent with its full view,
5673
      --  and analyze new declaration.
5674
 
5675
      --------------------
5676
      -- Copy_And_Build --
5677
      --------------------
5678
 
5679
      procedure Copy_And_Build is
5680
         Full_N : Node_Id;
5681
 
5682
      begin
5683
         if Ekind (Parent_Type) in Record_Kind
5684
           or else
5685
             (Ekind (Parent_Type) in Enumeration_Kind
5686
               and then not Is_Standard_Character_Type (Parent_Type)
5687
               and then not Is_Generic_Type (Root_Type (Parent_Type)))
5688
         then
5689
            Full_N := New_Copy_Tree (N);
5690
            Insert_After (N, Full_N);
5691
            Build_Derived_Type (
5692
              Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
5693
 
5694
         else
5695
            Build_Derived_Type (
5696
              N, Parent_Type, Full_Der, True, Derive_Subps => False);
5697
         end if;
5698
      end Copy_And_Build;
5699
 
5700
   --  Start of processing for Build_Derived_Private_Type
5701
 
5702
   begin
5703
      if Is_Tagged_Type (Parent_Type) then
5704
         Full_P := Full_View (Parent_Type);
5705
 
5706
         --  A type extension of a type with unknown discriminants is an
5707
         --  indefinite type that the back-end cannot handle directly.
5708
         --  We treat it as a private type, and build a completion that is
5709
         --  derived from the full view of the parent, and hopefully has
5710
         --  known discriminants.
5711
 
5712
         --  If the full view of the parent type has an underlying record view,
5713
         --  use it to generate the underlying record view of this derived type
5714
         --  (required for chains of derivations with unknown discriminants).
5715
 
5716
         --  Minor optimization: we avoid the generation of useless underlying
5717
         --  record view entities if the private type declaration has unknown
5718
         --  discriminants but its corresponding full view has no
5719
         --  discriminants.
5720
 
5721
         if Has_Unknown_Discriminants (Parent_Type)
5722
           and then Present (Full_P)
5723
           and then (Has_Discriminants (Full_P)
5724
                      or else Present (Underlying_Record_View (Full_P)))
5725
           and then not In_Open_Scopes (Par_Scope)
5726
           and then Expander_Active
5727
         then
5728
            declare
5729
               Full_Der : constant Entity_Id :=
5730
                            Make_Defining_Identifier (Loc,
5731
                              Chars => New_Internal_Name ('T'));
5732
               New_Ext  : constant Node_Id :=
5733
                            Copy_Separate_Tree
5734
                              (Record_Extension_Part (Type_Definition (N)));
5735
               Decl     : Node_Id;
5736
 
5737
            begin
5738
               Build_Derived_Record_Type
5739
                 (N, Parent_Type, Derived_Type, Derive_Subps);
5740
 
5741
               --  Build anonymous completion, as a derivation from the full
5742
               --  view of the parent. This is not a completion in the usual
5743
               --  sense, because the current type is not private.
5744
 
5745
               Decl :=
5746
                 Make_Full_Type_Declaration (Loc,
5747
                   Defining_Identifier => Full_Der,
5748
                   Type_Definition     =>
5749
                     Make_Derived_Type_Definition (Loc,
5750
                       Subtype_Indication =>
5751
                         New_Copy_Tree
5752
                           (Subtype_Indication (Type_Definition (N))),
5753
                       Record_Extension_Part => New_Ext));
5754
 
5755
               --  If the parent type has an underlying record view, use it
5756
               --  here to build the new underlying record view.
5757
 
5758
               if Present (Underlying_Record_View (Full_P)) then
5759
                  pragma Assert
5760
                    (Nkind (Subtype_Indication (Type_Definition (Decl)))
5761
                       = N_Identifier);
5762
                  Set_Entity (Subtype_Indication (Type_Definition (Decl)),
5763
                    Underlying_Record_View (Full_P));
5764
               end if;
5765
 
5766
               Install_Private_Declarations (Par_Scope);
5767
               Install_Visible_Declarations (Par_Scope);
5768
               Insert_Before (N, Decl);
5769
 
5770
               --  Mark entity as an underlying record view before analysis,
5771
               --  to avoid generating the list of its primitive operations
5772
               --  (which is not really required for this entity) and thus
5773
               --  prevent spurious errors associated with missing overriding
5774
               --  of abstract primitives (overridden only for Derived_Type).
5775
 
5776
               Set_Ekind (Full_Der, E_Record_Type);
5777
               Set_Is_Underlying_Record_View (Full_Der);
5778
 
5779
               Analyze (Decl);
5780
 
5781
               pragma Assert (Has_Discriminants (Full_Der)
5782
                 and then not Has_Unknown_Discriminants (Full_Der));
5783
 
5784
               Uninstall_Declarations (Par_Scope);
5785
 
5786
               --  Freeze the underlying record view, to prevent generation of
5787
               --  useless dispatching information, which is simply shared with
5788
               --  the real derived type.
5789
 
5790
               Set_Is_Frozen (Full_Der);
5791
 
5792
               --  Set up links between real entity and underlying record view
5793
 
5794
               Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
5795
               Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type);
5796
            end;
5797
 
5798
         --  If discriminants are known, build derived record
5799
 
5800
         else
5801
            Build_Derived_Record_Type
5802
              (N, Parent_Type, Derived_Type, Derive_Subps);
5803
         end if;
5804
 
5805
         return;
5806
 
5807
      elsif Has_Discriminants (Parent_Type) then
5808
         if Present (Full_View (Parent_Type)) then
5809
            if not Is_Completion then
5810
 
5811
               --  Copy declaration for subsequent analysis, to provide a
5812
               --  completion for what is a private declaration. Indicate that
5813
               --  the full type is internally generated.
5814
 
5815
               Full_Decl := New_Copy_Tree (N);
5816
               Full_Der  := New_Copy (Derived_Type);
5817
               Set_Comes_From_Source (Full_Decl, False);
5818
               Set_Comes_From_Source (Full_Der, False);
5819
 
5820
               Insert_After (N, Full_Decl);
5821
 
5822
            else
5823
               --  If this is a completion, the full view being built is itself
5824
               --  private. We build a subtype of the parent with the same
5825
               --  constraints as this full view, to convey to the back end the
5826
               --  constrained components and the size of this subtype. If the
5827
               --  parent is constrained, its full view can serve as the
5828
               --  underlying full view of the derived type.
5829
 
5830
               if No (Discriminant_Specifications (N)) then
5831
                  if Nkind (Subtype_Indication (Type_Definition (N))) =
5832
                                                        N_Subtype_Indication
5833
                  then
5834
                     Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
5835
 
5836
                  elsif Is_Constrained (Full_View (Parent_Type)) then
5837
                     Set_Underlying_Full_View
5838
                       (Derived_Type, Full_View (Parent_Type));
5839
                  end if;
5840
 
5841
               else
5842
                  --  If there are new discriminants, the parent subtype is
5843
                  --  constrained by them, but it is not clear how to build
5844
                  --  the Underlying_Full_View in this case???
5845
 
5846
                  null;
5847
               end if;
5848
            end if;
5849
         end if;
5850
 
5851
         --  Build partial view of derived type from partial view of parent
5852
 
5853
         Build_Derived_Record_Type
5854
           (N, Parent_Type, Derived_Type, Derive_Subps);
5855
 
5856
         if Present (Full_View (Parent_Type)) and then not Is_Completion then
5857
            if not In_Open_Scopes (Par_Scope)
5858
              or else not In_Same_Source_Unit (N, Parent_Type)
5859
            then
5860
               --  Swap partial and full views temporarily
5861
 
5862
               Install_Private_Declarations (Par_Scope);
5863
               Install_Visible_Declarations (Par_Scope);
5864
               Swapped := True;
5865
            end if;
5866
 
5867
            --  Build full view of derived type from full view of parent which
5868
            --  is now installed. Subprograms have been derived on the partial
5869
            --  view, the completion does not derive them anew.
5870
 
5871
            if not Is_Tagged_Type (Parent_Type) then
5872
 
5873
               --  If the parent is itself derived from another private type,
5874
               --  installing the private declarations has not affected its
5875
               --  privacy status, so use its own full view explicitly.
5876
 
5877
               if Is_Private_Type (Parent_Type) then
5878
                  Build_Derived_Record_Type
5879
                    (Full_Decl, Full_View (Parent_Type), Full_Der, False);
5880
               else
5881
                  Build_Derived_Record_Type
5882
                    (Full_Decl, Parent_Type, Full_Der, False);
5883
               end if;
5884
 
5885
            else
5886
               --  If full view of parent is tagged, the completion inherits
5887
               --  the proper primitive operations.
5888
 
5889
               Set_Defining_Identifier (Full_Decl, Full_Der);
5890
               Build_Derived_Record_Type
5891
                 (Full_Decl, Parent_Type, Full_Der, Derive_Subps);
5892
               Set_Analyzed (Full_Decl);
5893
            end if;
5894
 
5895
            if Swapped then
5896
               Uninstall_Declarations (Par_Scope);
5897
 
5898
               if In_Open_Scopes (Par_Scope) then
5899
                  Install_Visible_Declarations (Par_Scope);
5900
               end if;
5901
            end if;
5902
 
5903
            Der_Base := Base_Type (Derived_Type);
5904
            Set_Full_View (Derived_Type, Full_Der);
5905
            Set_Full_View (Der_Base, Base_Type (Full_Der));
5906
 
5907
            --  Copy the discriminant list from full view to the partial views
5908
            --  (base type and its subtype). Gigi requires that the partial and
5909
            --  full views have the same discriminants.
5910
 
5911
            --  Note that since the partial view is pointing to discriminants
5912
            --  in the full view, their scope will be that of the full view.
5913
            --  This might cause some front end problems and need adjustment???
5914
 
5915
            Discr := First_Discriminant (Base_Type (Full_Der));
5916
            Set_First_Entity (Der_Base, Discr);
5917
 
5918
            loop
5919
               Last_Discr := Discr;
5920
               Next_Discriminant (Discr);
5921
               exit when No (Discr);
5922
            end loop;
5923
 
5924
            Set_Last_Entity (Der_Base, Last_Discr);
5925
 
5926
            Set_First_Entity (Derived_Type, First_Entity (Der_Base));
5927
            Set_Last_Entity  (Derived_Type, Last_Entity  (Der_Base));
5928
            Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
5929
 
5930
         else
5931
            --  If this is a completion, the derived type stays private and
5932
            --  there is no need to create a further full view, except in the
5933
            --  unusual case when the derivation is nested within a child unit,
5934
            --  see below.
5935
 
5936
            null;
5937
         end if;
5938
 
5939
      elsif Present (Full_View (Parent_Type))
5940
        and then  Has_Discriminants (Full_View (Parent_Type))
5941
      then
5942
         if Has_Unknown_Discriminants (Parent_Type)
5943
           and then Nkind (Subtype_Indication (Type_Definition (N))) =
5944
                                                         N_Subtype_Indication
5945
         then
5946
            Error_Msg_N
5947
              ("cannot constrain type with unknown discriminants",
5948
               Subtype_Indication (Type_Definition (N)));
5949
            return;
5950
         end if;
5951
 
5952
         --  If full view of parent is a record type, build full view as a
5953
         --  derivation from the parent's full view. Partial view remains
5954
         --  private. For code generation and linking, the full view must have
5955
         --  the same public status as the partial one. This full view is only
5956
         --  needed if the parent type is in an enclosing scope, so that the
5957
         --  full view may actually become visible, e.g. in a child unit. This
5958
         --  is both more efficient, and avoids order of freezing problems with
5959
         --  the added entities.
5960
 
5961
         if not Is_Private_Type (Full_View (Parent_Type))
5962
           and then (In_Open_Scopes (Scope (Parent_Type)))
5963
         then
5964
            Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
5965
                                              Chars (Derived_Type));
5966
            Set_Is_Itype (Full_Der);
5967
            Set_Has_Private_Declaration (Full_Der);
5968
            Set_Has_Private_Declaration (Derived_Type);
5969
            Set_Associated_Node_For_Itype (Full_Der, N);
5970
            Set_Parent (Full_Der, Parent (Derived_Type));
5971
            Set_Full_View (Derived_Type, Full_Der);
5972
            Set_Is_Public (Full_Der, Is_Public (Derived_Type));
5973
            Full_P := Full_View (Parent_Type);
5974
            Exchange_Declarations (Parent_Type);
5975
            Copy_And_Build;
5976
            Exchange_Declarations (Full_P);
5977
 
5978
         else
5979
            Build_Derived_Record_Type
5980
              (N, Full_View (Parent_Type), Derived_Type,
5981
                Derive_Subps => False);
5982
         end if;
5983
 
5984
         --  In any case, the primitive operations are inherited from the
5985
         --  parent type, not from the internal full view.
5986
 
5987
         Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
5988
 
5989
         if Derive_Subps then
5990
            Derive_Subprograms (Parent_Type, Derived_Type);
5991
         end if;
5992
 
5993
      else
5994
         --  Untagged type, No discriminants on either view
5995
 
5996
         if Nkind (Subtype_Indication (Type_Definition (N))) =
5997
                                                   N_Subtype_Indication
5998
         then
5999
            Error_Msg_N
6000
              ("illegal constraint on type without discriminants", N);
6001
         end if;
6002
 
6003
         if Present (Discriminant_Specifications (N))
6004
           and then Present (Full_View (Parent_Type))
6005
           and then not Is_Tagged_Type (Full_View (Parent_Type))
6006
         then
6007
            Error_Msg_N ("cannot add discriminants to untagged type", N);
6008
         end if;
6009
 
6010
         Set_Stored_Constraint (Derived_Type, No_Elist);
6011
         Set_Is_Constrained    (Derived_Type, Is_Constrained (Parent_Type));
6012
         Set_Is_Controlled     (Derived_Type, Is_Controlled  (Parent_Type));
6013
         Set_Has_Controlled_Component
6014
                               (Derived_Type, Has_Controlled_Component
6015
                                                             (Parent_Type));
6016
 
6017
         --  Direct controlled types do not inherit Finalize_Storage_Only flag
6018
 
6019
         if not Is_Controlled  (Parent_Type) then
6020
            Set_Finalize_Storage_Only
6021
              (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
6022
         end if;
6023
 
6024
         --  Construct the implicit full view by deriving from full view of the
6025
         --  parent type. In order to get proper visibility, we install the
6026
         --  parent scope and its declarations.
6027
 
6028
         --  ??? If the parent is untagged private and its completion is
6029
         --  tagged, this mechanism will not work because we cannot derive from
6030
         --  the tagged full view unless we have an extension.
6031
 
6032
         if Present (Full_View (Parent_Type))
6033
           and then not Is_Tagged_Type (Full_View (Parent_Type))
6034
           and then not Is_Completion
6035
         then
6036
            Full_Der :=
6037
              Make_Defining_Identifier (Sloc (Derived_Type),
6038
                Chars => Chars (Derived_Type));
6039
            Set_Is_Itype (Full_Der);
6040
            Set_Has_Private_Declaration (Full_Der);
6041
            Set_Has_Private_Declaration (Derived_Type);
6042
            Set_Associated_Node_For_Itype (Full_Der, N);
6043
            Set_Parent (Full_Der, Parent (Derived_Type));
6044
            Set_Full_View (Derived_Type, Full_Der);
6045
 
6046
            if not In_Open_Scopes (Par_Scope) then
6047
               Install_Private_Declarations (Par_Scope);
6048
               Install_Visible_Declarations (Par_Scope);
6049
               Copy_And_Build;
6050
               Uninstall_Declarations (Par_Scope);
6051
 
6052
            --  If parent scope is open and in another unit, and parent has a
6053
            --  completion, then the derivation is taking place in the visible
6054
            --  part of a child unit. In that case retrieve the full view of
6055
            --  the parent momentarily.
6056
 
6057
            elsif not In_Same_Source_Unit (N, Parent_Type) then
6058
               Full_P := Full_View (Parent_Type);
6059
               Exchange_Declarations (Parent_Type);
6060
               Copy_And_Build;
6061
               Exchange_Declarations (Full_P);
6062
 
6063
            --  Otherwise it is a local derivation
6064
 
6065
            else
6066
               Copy_And_Build;
6067
            end if;
6068
 
6069
            Set_Scope                (Full_Der, Current_Scope);
6070
            Set_Is_First_Subtype     (Full_Der,
6071
                                       Is_First_Subtype (Derived_Type));
6072
            Set_Has_Size_Clause      (Full_Der, False);
6073
            Set_Has_Alignment_Clause (Full_Der, False);
6074
            Set_Next_Entity          (Full_Der, Empty);
6075
            Set_Has_Delayed_Freeze   (Full_Der);
6076
            Set_Is_Frozen            (Full_Der, False);
6077
            Set_Freeze_Node          (Full_Der, Empty);
6078
            Set_Depends_On_Private   (Full_Der,
6079
                                       Has_Private_Component (Full_Der));
6080
            Set_Public_Status        (Full_Der);
6081
         end if;
6082
      end if;
6083
 
6084
      Set_Has_Unknown_Discriminants (Derived_Type,
6085
        Has_Unknown_Discriminants (Parent_Type));
6086
 
6087
      if Is_Private_Type (Derived_Type) then
6088
         Set_Private_Dependents (Derived_Type, New_Elmt_List);
6089
      end if;
6090
 
6091
      if Is_Private_Type (Parent_Type)
6092
        and then Base_Type (Parent_Type) = Parent_Type
6093
        and then In_Open_Scopes (Scope (Parent_Type))
6094
      then
6095
         Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
6096
 
6097
         if Is_Child_Unit (Scope (Current_Scope))
6098
           and then Is_Completion
6099
           and then In_Private_Part (Current_Scope)
6100
           and then Scope (Parent_Type) /= Current_Scope
6101
         then
6102
            --  This is the unusual case where a type completed by a private
6103
            --  derivation occurs within a package nested in a child unit, and
6104
            --  the parent is declared in an ancestor. In this case, the full
6105
            --  view of the parent type will become visible in the body of
6106
            --  the enclosing child, and only then will the current type be
6107
            --  possibly non-private. We build a underlying full view that
6108
            --  will be installed when the enclosing child body is compiled.
6109
 
6110
            Full_Der :=
6111
              Make_Defining_Identifier (Sloc (Derived_Type),
6112
                Chars => Chars (Derived_Type));
6113
            Set_Is_Itype (Full_Der);
6114
            Build_Itype_Reference (Full_Der, N);
6115
 
6116
            --  The full view will be used to swap entities on entry/exit to
6117
            --  the body, and must appear in the entity list for the package.
6118
 
6119
            Append_Entity (Full_Der, Scope (Derived_Type));
6120
            Set_Has_Private_Declaration (Full_Der);
6121
            Set_Has_Private_Declaration (Derived_Type);
6122
            Set_Associated_Node_For_Itype (Full_Der, N);
6123
            Set_Parent (Full_Der, Parent (Derived_Type));
6124
            Full_P := Full_View (Parent_Type);
6125
            Exchange_Declarations (Parent_Type);
6126
            Copy_And_Build;
6127
            Exchange_Declarations (Full_P);
6128
            Set_Underlying_Full_View (Derived_Type, Full_Der);
6129
         end if;
6130
      end if;
6131
   end Build_Derived_Private_Type;
6132
 
6133
   -------------------------------
6134
   -- Build_Derived_Record_Type --
6135
   -------------------------------
6136
 
6137
   --  1. INTRODUCTION
6138
 
6139
   --  Ideally we would like to use the same model of type derivation for
6140
   --  tagged and untagged record types. Unfortunately this is not quite
6141
   --  possible because the semantics of representation clauses is different
6142
   --  for tagged and untagged records under inheritance. Consider the
6143
   --  following:
6144
 
6145
   --     type R (...) is [tagged] record ... end record;
6146
   --     type T (...) is new R (...) [with ...];
6147
 
6148
   --  The representation clauses for T can specify a completely different
6149
   --  record layout from R's. Hence the same component can be placed in two
6150
   --  very different positions in objects of type T and R. If R and T are
6151
   --  tagged types, representation clauses for T can only specify the layout
6152
   --  of non inherited components, thus components that are common in R and T
6153
   --  have the same position in objects of type R and T.
6154
 
6155
   --  This has two implications. The first is that the entire tree for R's
6156
   --  declaration needs to be copied for T in the untagged case, so that T
6157
   --  can be viewed as a record type of its own with its own representation
6158
   --  clauses. The second implication is the way we handle discriminants.
6159
   --  Specifically, in the untagged case we need a way to communicate to Gigi
6160
   --  what are the real discriminants in the record, while for the semantics
6161
   --  we need to consider those introduced by the user to rename the
6162
   --  discriminants in the parent type. This is handled by introducing the
6163
   --  notion of stored discriminants. See below for more.
6164
 
6165
   --  Fortunately the way regular components are inherited can be handled in
6166
   --  the same way in tagged and untagged types.
6167
 
6168
   --  To complicate things a bit more the private view of a private extension
6169
   --  cannot be handled in the same way as the full view (for one thing the
6170
   --  semantic rules are somewhat different). We will explain what differs
6171
   --  below.
6172
 
6173
   --  2. DISCRIMINANTS UNDER INHERITANCE
6174
 
6175
   --  The semantic rules governing the discriminants of derived types are
6176
   --  quite subtle.
6177
 
6178
   --   type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
6179
   --      [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
6180
 
6181
   --  If parent type has discriminants, then the discriminants that are
6182
   --  declared in the derived type are [3.4 (11)]:
6183
 
6184
   --  o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
6185
   --    there is one;
6186
 
6187
   --  o Otherwise, each discriminant of the parent type (implicitly declared
6188
   --    in the same order with the same specifications). In this case, the
6189
   --    discriminants are said to be "inherited", or if unknown in the parent
6190
   --    are also unknown in the derived type.
6191
 
6192
   --  Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]:
6193
 
6194
   --  o The parent subtype shall be constrained;
6195
 
6196
   --  o If the parent type is not a tagged type, then each discriminant of
6197
   --    the derived type shall be used in the constraint defining a parent
6198
   --    subtype. [Implementation note: This ensures that the new discriminant
6199
   --    can share storage with an existing discriminant.]
6200
 
6201
   --  For the derived type each discriminant of the parent type is either
6202
   --  inherited, constrained to equal some new discriminant of the derived
6203
   --  type, or constrained to the value of an expression.
6204
 
6205
   --  When inherited or constrained to equal some new discriminant, the
6206
   --  parent discriminant and the discriminant of the derived type are said
6207
   --  to "correspond".
6208
 
6209
   --  If a discriminant of the parent type is constrained to a specific value
6210
   --  in the derived type definition, then the discriminant is said to be
6211
   --  "specified" by that derived type definition.
6212
 
6213
   --  3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES
6214
 
6215
   --  We have spoken about stored discriminants in point 1 (introduction)
6216
   --  above. There are two sort of stored discriminants: implicit and
6217
   --  explicit. As long as the derived type inherits the same discriminants as
6218
   --  the root record type, stored discriminants are the same as regular
6219
   --  discriminants, and are said to be implicit. However, if any discriminant
6220
   --  in the root type was renamed in the derived type, then the derived
6221
   --  type will contain explicit stored discriminants. Explicit stored
6222
   --  discriminants are discriminants in addition to the semantically visible
6223
   --  discriminants defined for the derived type. Stored discriminants are
6224
   --  used by Gigi to figure out what are the physical discriminants in
6225
   --  objects of the derived type (see precise definition in einfo.ads).
6226
   --  As an example, consider the following:
6227
 
6228
   --           type R  (D1, D2, D3 : Int) is record ... end record;
6229
   --           type T1 is new R;
6230
   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1);
6231
   --           type T3 is new T2;
6232
   --           type T4 (Y : Int) is new T3 (Y, 99);
6233
 
6234
   --  The following table summarizes the discriminants and stored
6235
   --  discriminants in R and T1 through T4.
6236
 
6237
   --   Type      Discrim     Stored Discrim  Comment
6238
   --    R      (D1, D2, D3)   (D1, D2, D3)   Girder discrims implicit in R
6239
   --    T1     (D1, D2, D3)   (D1, D2, D3)   Girder discrims implicit in T1
6240
   --    T2     (X1, X2)       (D1, D2, D3)   Girder discrims EXPLICIT in T2
6241
   --    T3     (X1, X2)       (D1, D2, D3)   Girder discrims EXPLICIT in T3
6242
   --    T4     (Y)            (D1, D2, D3)   Girder discrims EXPLICIT in T4
6243
 
6244
   --  Field Corresponding_Discriminant (abbreviated CD below) allows us to
6245
   --  find the corresponding discriminant in the parent type, while
6246
   --  Original_Record_Component (abbreviated ORC below), the actual physical
6247
   --  component that is renamed. Finally the field Is_Completely_Hidden
6248
   --  (abbreviated ICH below) is set for all explicit stored discriminants
6249
   --  (see einfo.ads for more info). For the above example this gives:
6250
 
6251
   --                 Discrim     CD        ORC     ICH
6252
   --                 ^^^^^^^     ^^        ^^^     ^^^
6253
   --                 D1 in R    empty     itself    no
6254
   --                 D2 in R    empty     itself    no
6255
   --                 D3 in R    empty     itself    no
6256
 
6257
   --                 D1 in T1  D1 in R    itself    no
6258
   --                 D2 in T1  D2 in R    itself    no
6259
   --                 D3 in T1  D3 in R    itself    no
6260
 
6261
   --                 X1 in T2  D3 in T1  D3 in T2   no
6262
   --                 X2 in T2  D1 in T1  D1 in T2   no
6263
   --                 D1 in T2   empty    itself    yes
6264
   --                 D2 in T2   empty    itself    yes
6265
   --                 D3 in T2   empty    itself    yes
6266
 
6267
   --                 X1 in T3  X1 in T2  D3 in T3   no
6268
   --                 X2 in T3  X2 in T2  D1 in T3   no
6269
   --                 D1 in T3   empty    itself    yes
6270
   --                 D2 in T3   empty    itself    yes
6271
   --                 D3 in T3   empty    itself    yes
6272
 
6273
   --                 Y  in T4  X1 in T3  D3 in T3   no
6274
   --                 D1 in T3   empty    itself    yes
6275
   --                 D2 in T3   empty    itself    yes
6276
   --                 D3 in T3   empty    itself    yes
6277
 
6278
   --  4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
6279
 
6280
   --  Type derivation for tagged types is fairly straightforward. If no
6281
   --  discriminants are specified by the derived type, these are inherited
6282
   --  from the parent. No explicit stored discriminants are ever necessary.
6283
   --  The only manipulation that is done to the tree is that of adding a
6284
   --  _parent field with parent type and constrained to the same constraint
6285
   --  specified for the parent in the derived type definition. For instance:
6286
 
6287
   --           type R  (D1, D2, D3 : Int) is tagged record ... end record;
6288
   --           type T1 is new R with null record;
6289
   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record;
6290
 
6291
   --  are changed into:
6292
 
6293
   --           type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record
6294
   --              _parent : R (D1, D2, D3);
6295
   --           end record;
6296
 
6297
   --           type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record
6298
   --              _parent : T1 (X2, 88, X1);
6299
   --           end record;
6300
 
6301
   --  The discriminants actually present in R, T1 and T2 as well as their CD,
6302
   --  ORC and ICH fields are:
6303
 
6304
   --                 Discrim     CD        ORC     ICH
6305
   --                 ^^^^^^^     ^^        ^^^     ^^^
6306
   --                 D1 in R    empty     itself    no
6307
   --                 D2 in R    empty     itself    no
6308
   --                 D3 in R    empty     itself    no
6309
 
6310
   --                 D1 in T1  D1 in R    D1 in R   no
6311
   --                 D2 in T1  D2 in R    D2 in R   no
6312
   --                 D3 in T1  D3 in R    D3 in R   no
6313
 
6314
   --                 X1 in T2  D3 in T1   D3 in R   no
6315
   --                 X2 in T2  D1 in T1   D1 in R   no
6316
 
6317
   --  5. FIRST TRANSFORMATION FOR DERIVED RECORDS
6318
   --
6319
   --  Regardless of whether we dealing with a tagged or untagged type
6320
   --  we will transform all derived type declarations of the form
6321
   --
6322
   --               type T is new R (...) [with ...];
6323
   --  or
6324
   --               subtype S is R (...);
6325
   --               type T is new S [with ...];
6326
   --  into
6327
   --               type BT is new R [with ...];
6328
   --               subtype T is BT (...);
6329
   --
6330
   --  That is, the base derived type is constrained only if it has no
6331
   --  discriminants. The reason for doing this is that GNAT's semantic model
6332
   --  assumes that a base type with discriminants is unconstrained.
6333
   --
6334
   --  Note that, strictly speaking, the above transformation is not always
6335
   --  correct. Consider for instance the following excerpt from ACVC b34011a:
6336
   --
6337
   --       procedure B34011A is
6338
   --          type REC (D : integer := 0) is record
6339
   --             I : Integer;
6340
   --          end record;
6341
 
6342
   --          package P is
6343
   --             type T6 is new Rec;
6344
   --             function F return T6;
6345
   --          end P;
6346
 
6347
   --          use P;
6348
   --          package Q6 is
6349
   --             type U is new T6 (Q6.F.I);                   -- ERROR: Q6.F.
6350
   --          end Q6;
6351
   --
6352
   --  The definition of Q6.U is illegal. However transforming Q6.U into
6353
 
6354
   --             type BaseU is new T6;
6355
   --             subtype U is BaseU (Q6.F.I)
6356
 
6357
   --  turns U into a legal subtype, which is incorrect. To avoid this problem
6358
   --  we always analyze the constraint (in this case (Q6.F.I)) before applying
6359
   --  the transformation described above.
6360
 
6361
   --  There is another instance where the above transformation is incorrect.
6362
   --  Consider:
6363
 
6364
   --          package Pack is
6365
   --             type Base (D : Integer) is tagged null record;
6366
   --             procedure P (X : Base);
6367
 
6368
   --             type Der is new Base (2) with null record;
6369
   --             procedure P (X : Der);
6370
   --          end Pack;
6371
 
6372
   --  Then the above transformation turns this into
6373
 
6374
   --             type Der_Base is new Base with null record;
6375
   --             --  procedure P (X : Base) is implicitly inherited here
6376
   --             --  as procedure P (X : Der_Base).
6377
 
6378
   --             subtype Der is Der_Base (2);
6379
   --             procedure P (X : Der);
6380
   --             --  The overriding of P (X : Der_Base) is illegal since we
6381
   --             --  have a parameter conformance problem.
6382
 
6383
   --  To get around this problem, after having semantically processed Der_Base
6384
   --  and the rewritten subtype declaration for Der, we copy Der_Base field
6385
   --  Discriminant_Constraint from Der so that when parameter conformance is
6386
   --  checked when P is overridden, no semantic errors are flagged.
6387
 
6388
   --  6. SECOND TRANSFORMATION FOR DERIVED RECORDS
6389
 
6390
   --  Regardless of whether we are dealing with a tagged or untagged type
6391
   --  we will transform all derived type declarations of the form
6392
 
6393
   --               type R (D1, .., Dn : ...) is [tagged] record ...;
6394
   --               type T is new R [with ...];
6395
   --  into
6396
   --               type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...];
6397
 
6398
   --  The reason for such transformation is that it allows us to implement a
6399
   --  very clean form of component inheritance as explained below.
6400
 
6401
   --  Note that this transformation is not achieved by direct tree rewriting
6402
   --  and manipulation, but rather by redoing the semantic actions that the
6403
   --  above transformation will entail. This is done directly in routine
6404
   --  Inherit_Components.
6405
 
6406
   --  7. TYPE DERIVATION AND COMPONENT INHERITANCE
6407
 
6408
   --  In both tagged and untagged derived types, regular non discriminant
6409
   --  components are inherited in the derived type from the parent type. In
6410
   --  the absence of discriminants component, inheritance is straightforward
6411
   --  as components can simply be copied from the parent.
6412
 
6413
   --  If the parent has discriminants, inheriting components constrained with
6414
   --  these discriminants requires caution. Consider the following example:
6415
 
6416
   --      type R  (D1, D2 : Positive) is [tagged] record
6417
   --         S : String (D1 .. D2);
6418
   --      end record;
6419
 
6420
   --      type T1                is new R        [with null record];
6421
   --      type T2 (X : positive) is new R (1, X) [with null record];
6422
 
6423
   --  As explained in 6. above, T1 is rewritten as
6424
   --      type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record];
6425
   --  which makes the treatment for T1 and T2 identical.
6426
 
6427
   --  What we want when inheriting S, is that references to D1 and D2 in R are
6428
   --  replaced with references to their correct constraints, i.e. D1 and D2 in
6429
   --  T1 and 1 and X in T2. So all R's discriminant references are replaced
6430
   --  with either discriminant references in the derived type or expressions.
6431
   --  This replacement is achieved as follows: before inheriting R's
6432
   --  components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
6433
   --  created in the scope of T1 (resp. scope of T2) so that discriminants D1
6434
   --  and D2 of T1 are visible (resp. discriminant X of T2 is visible).
6435
   --  For T2, for instance, this has the effect of replacing String (D1 .. D2)
6436
   --  by String (1 .. X).
6437
 
6438
   --  8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS
6439
 
6440
   --  We explain here the rules governing private type extensions relevant to
6441
   --  type derivation. These rules are explained on the following example:
6442
 
6443
   --      type D [(...)] is new A [(...)] with private;      <-- partial view
6444
   --      type D [(...)] is new P [(...)] with null record;  <-- full view
6445
 
6446
   --  Type A is called the ancestor subtype of the private extension.
6447
   --  Type P is the parent type of the full view of the private extension. It
6448
   --  must be A or a type derived from A.
6449
 
6450
   --  The rules concerning the discriminants of private type extensions are
6451
   --  [7.3(10-13)]:
6452
 
6453
   --  o If a private extension inherits known discriminants from the ancestor
6454
   --    subtype, then the full view shall also inherit its discriminants from
6455
   --    the ancestor subtype and the parent subtype of the full view shall be
6456
   --    constrained if and only if the ancestor subtype is constrained.
6457
 
6458
   --  o If a partial view has unknown discriminants, then the full view may
6459
   --    define a definite or an indefinite subtype, with or without
6460
   --    discriminants.
6461
 
6462
   --  o If a partial view has neither known nor unknown discriminants, then
6463
   --    the full view shall define a definite subtype.
6464
 
6465
   --  o If the ancestor subtype of a private extension has constrained
6466
   --    discriminants, then the parent subtype of the full view shall impose a
6467
   --    statically matching constraint on those discriminants.
6468
 
6469
   --  This means that only the following forms of private extensions are
6470
   --  allowed:
6471
 
6472
   --      type D is new A with private;      <-- partial view
6473
   --      type D is new P with null record;  <-- full view
6474
 
6475
   --  If A has no discriminants than P has no discriminants, otherwise P must
6476
   --  inherit A's discriminants.
6477
 
6478
   --      type D is new A (...) with private;      <-- partial view
6479
   --      type D is new P (:::) with null record;  <-- full view
6480
 
6481
   --  P must inherit A's discriminants and (...) and (:::) must statically
6482
   --  match.
6483
 
6484
   --      subtype A is R (...);
6485
   --      type D is new A with private;      <-- partial view
6486
   --      type D is new P with null record;  <-- full view
6487
 
6488
   --  P must have inherited R's discriminants and must be derived from A or
6489
   --  any of its subtypes.
6490
 
6491
   --      type D (..) is new A with private;              <-- partial view
6492
   --      type D (..) is new P [(:::)] with null record;  <-- full view
6493
 
6494
   --  No specific constraints on P's discriminants or constraint (:::).
6495
   --  Note that A can be unconstrained, but the parent subtype P must either
6496
   --  be constrained or (:::) must be present.
6497
 
6498
   --      type D (..) is new A [(...)] with private;      <-- partial view
6499
   --      type D (..) is new P [(:::)] with null record;  <-- full view
6500
 
6501
   --  P's constraints on A's discriminants must statically match those
6502
   --  imposed by (...).
6503
 
6504
   --  9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS
6505
 
6506
   --  The full view of a private extension is handled exactly as described
6507
   --  above. The model chose for the private view of a private extension is
6508
   --  the same for what concerns discriminants (i.e. they receive the same
6509
   --  treatment as in the tagged case). However, the private view of the
6510
   --  private extension always inherits the components of the parent base,
6511
   --  without replacing any discriminant reference. Strictly speaking this is
6512
   --  incorrect. However, Gigi never uses this view to generate code so this
6513
   --  is a purely semantic issue. In theory, a set of transformations similar
6514
   --  to those given in 5. and 6. above could be applied to private views of
6515
   --  private extensions to have the same model of component inheritance as
6516
   --  for non private extensions. However, this is not done because it would
6517
   --  further complicate private type processing. Semantically speaking, this
6518
   --  leaves us in an uncomfortable situation. As an example consider:
6519
 
6520
   --          package Pack is
6521
   --             type R (D : integer) is tagged record
6522
   --                S : String (1 .. D);
6523
   --             end record;
6524
   --             procedure P (X : R);
6525
   --             type T is new R (1) with private;
6526
   --          private
6527
   --             type T is new R (1) with null record;
6528
   --          end;
6529
 
6530
   --  This is transformed into:
6531
 
6532
   --          package Pack is
6533
   --             type R (D : integer) is tagged record
6534
   --                S : String (1 .. D);
6535
   --             end record;
6536
   --             procedure P (X : R);
6537
   --             type T is new R (1) with private;
6538
   --          private
6539
   --             type BaseT is new R with null record;
6540
   --             subtype  T is BaseT (1);
6541
   --          end;
6542
 
6543
   --  (strictly speaking the above is incorrect Ada)
6544
 
6545
   --  From the semantic standpoint the private view of private extension T
6546
   --  should be flagged as constrained since one can clearly have
6547
   --
6548
   --             Obj : T;
6549
   --
6550
   --  in a unit withing Pack. However, when deriving subprograms for the
6551
   --  private view of private extension T, T must be seen as unconstrained
6552
   --  since T has discriminants (this is a constraint of the current
6553
   --  subprogram derivation model). Thus, when processing the private view of
6554
   --  a private extension such as T, we first mark T as unconstrained, we
6555
   --  process it, we perform program derivation and just before returning from
6556
   --  Build_Derived_Record_Type we mark T as constrained.
6557
 
6558
   --  ??? Are there are other uncomfortable cases that we will have to
6559
   --      deal with.
6560
 
6561
   --  10. RECORD_TYPE_WITH_PRIVATE complications
6562
 
6563
   --  Types that are derived from a visible record type and have a private
6564
   --  extension present other peculiarities. They behave mostly like private
6565
   --  types, but if they have primitive operations defined, these will not
6566
   --  have the proper signatures for further inheritance, because other
6567
   --  primitive operations will use the implicit base that we define for
6568
   --  private derivations below. This affect subprogram inheritance (see
6569
   --  Derive_Subprograms for details). We also derive the implicit base from
6570
   --  the base type of the full view, so that the implicit base is a record
6571
   --  type and not another private type, This avoids infinite loops.
6572
 
6573
   procedure Build_Derived_Record_Type
6574
     (N            : Node_Id;
6575
      Parent_Type  : Entity_Id;
6576
      Derived_Type : Entity_Id;
6577
      Derive_Subps : Boolean := True)
6578
   is
6579
      Loc          : constant Source_Ptr := Sloc (N);
6580
      Parent_Base  : Entity_Id;
6581
      Type_Def     : Node_Id;
6582
      Indic        : Node_Id;
6583
      Discrim      : Entity_Id;
6584
      Last_Discrim : Entity_Id;
6585
      Constrs      : Elist_Id;
6586
 
6587
      Discs : Elist_Id := New_Elmt_List;
6588
      --  An empty Discs list means that there were no constraints in the
6589
      --  subtype indication or that there was an error processing it.
6590
 
6591
      Assoc_List : Elist_Id;
6592
      New_Discrs : Elist_Id;
6593
      New_Base   : Entity_Id;
6594
      New_Decl   : Node_Id;
6595
      New_Indic  : Node_Id;
6596
 
6597
      Is_Tagged          : constant Boolean := Is_Tagged_Type (Parent_Type);
6598
      Discriminant_Specs : constant Boolean :=
6599
                             Present (Discriminant_Specifications (N));
6600
      Private_Extension  : constant Boolean :=
6601
                             Nkind (N) = N_Private_Extension_Declaration;
6602
 
6603
      Constraint_Present : Boolean;
6604
      Inherit_Discrims   : Boolean := False;
6605
      Save_Etype         : Entity_Id;
6606
      Save_Discr_Constr  : Elist_Id;
6607
      Save_Next_Entity   : Entity_Id;
6608
 
6609
   begin
6610
      if Ekind (Parent_Type) = E_Record_Type_With_Private
6611
        and then Present (Full_View (Parent_Type))
6612
        and then Has_Discriminants (Parent_Type)
6613
      then
6614
         Parent_Base := Base_Type (Full_View (Parent_Type));
6615
      else
6616
         Parent_Base := Base_Type (Parent_Type);
6617
      end if;
6618
 
6619
      --  Before we start the previously documented transformations, here is
6620
      --  little fix for size and alignment of tagged types. Normally when we
6621
      --  derive type D from type P, we copy the size and alignment of P as the
6622
      --  default for D, and in the absence of explicit representation clauses
6623
      --  for D, the size and alignment are indeed the same as the parent.
6624
 
6625
      --  But this is wrong for tagged types, since fields may be added, and
6626
      --  the default size may need to be larger, and the default alignment may
6627
      --  need to be larger.
6628
 
6629
      --  We therefore reset the size and alignment fields in the tagged case.
6630
      --  Note that the size and alignment will in any case be at least as
6631
      --  large as the parent type (since the derived type has a copy of the
6632
      --  parent type in the _parent field)
6633
 
6634
      --  The type is also marked as being tagged here, which is needed when
6635
      --  processing components with a self-referential anonymous access type
6636
      --  in the call to Check_Anonymous_Access_Components below. Note that
6637
      --  this flag is also set later on for completeness.
6638
 
6639
      if Is_Tagged then
6640
         Set_Is_Tagged_Type (Derived_Type);
6641
         Init_Size_Align    (Derived_Type);
6642
      end if;
6643
 
6644
      --  STEP 0a: figure out what kind of derived type declaration we have
6645
 
6646
      if Private_Extension then
6647
         Type_Def := N;
6648
         Set_Ekind (Derived_Type, E_Record_Type_With_Private);
6649
 
6650
      else
6651
         Type_Def := Type_Definition (N);
6652
 
6653
         --  Ekind (Parent_Base) is not necessarily E_Record_Type since
6654
         --  Parent_Base can be a private type or private extension. However,
6655
         --  for tagged types with an extension the newly added fields are
6656
         --  visible and hence the Derived_Type is always an E_Record_Type.
6657
         --  (except that the parent may have its own private fields).
6658
         --  For untagged types we preserve the Ekind of the Parent_Base.
6659
 
6660
         if Present (Record_Extension_Part (Type_Def)) then
6661
            Set_Ekind (Derived_Type, E_Record_Type);
6662
 
6663
            --  Create internal access types for components with anonymous
6664
            --  access types.
6665
 
6666
            if Ada_Version >= Ada_05 then
6667
               Check_Anonymous_Access_Components
6668
                 (N, Derived_Type, Derived_Type,
6669
                   Component_List (Record_Extension_Part (Type_Def)));
6670
            end if;
6671
 
6672
         else
6673
            Set_Ekind (Derived_Type, Ekind (Parent_Base));
6674
         end if;
6675
      end if;
6676
 
6677
      --  Indic can either be an N_Identifier if the subtype indication
6678
      --  contains no constraint or an N_Subtype_Indication if the subtype
6679
      --  indication has a constraint.
6680
 
6681
      Indic := Subtype_Indication (Type_Def);
6682
      Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
6683
 
6684
      --  Check that the type has visible discriminants. The type may be
6685
      --  a private type with unknown discriminants whose full view has
6686
      --  discriminants which are invisible.
6687
 
6688
      if Constraint_Present then
6689
         if not Has_Discriminants (Parent_Base)
6690
           or else
6691
             (Has_Unknown_Discriminants (Parent_Base)
6692
                and then Is_Private_Type (Parent_Base))
6693
         then
6694
            Error_Msg_N
6695
              ("invalid constraint: type has no discriminant",
6696
                 Constraint (Indic));
6697
 
6698
            Constraint_Present := False;
6699
            Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
6700
 
6701
         elsif Is_Constrained (Parent_Type) then
6702
            Error_Msg_N
6703
               ("invalid constraint: parent type is already constrained",
6704
                  Constraint (Indic));
6705
 
6706
            Constraint_Present := False;
6707
            Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
6708
         end if;
6709
      end if;
6710
 
6711
      --  STEP 0b: If needed, apply transformation given in point 5. above
6712
 
6713
      if not Private_Extension
6714
        and then Has_Discriminants (Parent_Type)
6715
        and then not Discriminant_Specs
6716
        and then (Is_Constrained (Parent_Type) or else Constraint_Present)
6717
      then
6718
         --  First, we must analyze the constraint (see comment in point 5.)
6719
 
6720
         if Constraint_Present then
6721
            New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
6722
 
6723
            if Has_Discriminants (Derived_Type)
6724
              and then Has_Private_Declaration (Derived_Type)
6725
              and then Present (Discriminant_Constraint (Derived_Type))
6726
            then
6727
               --  Verify that constraints of the full view statically match
6728
               --  those given in the partial view.
6729
 
6730
               declare
6731
                  C1, C2 : Elmt_Id;
6732
 
6733
               begin
6734
                  C1 := First_Elmt (New_Discrs);
6735
                  C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
6736
                  while Present (C1) and then Present (C2) loop
6737
                     if Fully_Conformant_Expressions (Node (C1), Node (C2))
6738
                       or else
6739
                         (Is_OK_Static_Expression (Node (C1))
6740
                            and then
6741
                          Is_OK_Static_Expression (Node (C2))
6742
                            and then
6743
                          Expr_Value (Node (C1)) = Expr_Value (Node (C2)))
6744
                     then
6745
                        null;
6746
 
6747
                     else
6748
                        Error_Msg_N (
6749
                          "constraint not conformant to previous declaration",
6750
                             Node (C1));
6751
                     end if;
6752
 
6753
                     Next_Elmt (C1);
6754
                     Next_Elmt (C2);
6755
                  end loop;
6756
               end;
6757
            end if;
6758
         end if;
6759
 
6760
         --  Insert and analyze the declaration for the unconstrained base type
6761
 
6762
         New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
6763
 
6764
         New_Decl :=
6765
           Make_Full_Type_Declaration (Loc,
6766
              Defining_Identifier => New_Base,
6767
              Type_Definition     =>
6768
                Make_Derived_Type_Definition (Loc,
6769
                  Abstract_Present      => Abstract_Present (Type_Def),
6770
                  Limited_Present       => Limited_Present (Type_Def),
6771
                  Subtype_Indication    =>
6772
                    New_Occurrence_Of (Parent_Base, Loc),
6773
                  Record_Extension_Part =>
6774
                    Relocate_Node (Record_Extension_Part (Type_Def)),
6775
                  Interface_List        => Interface_List (Type_Def)));
6776
 
6777
         Set_Parent (New_Decl, Parent (N));
6778
         Mark_Rewrite_Insertion (New_Decl);
6779
         Insert_Before (N, New_Decl);
6780
 
6781
         --  Note that this call passes False for the Derive_Subps parameter
6782
         --  because subprogram derivation is deferred until after creating
6783
         --  the subtype (see below).
6784
 
6785
         Build_Derived_Type
6786
           (New_Decl, Parent_Base, New_Base,
6787
            Is_Completion => True, Derive_Subps => False);
6788
 
6789
         --  ??? This needs re-examination to determine whether the
6790
         --  above call can simply be replaced by a call to Analyze.
6791
 
6792
         Set_Analyzed (New_Decl);
6793
 
6794
         --  Insert and analyze the declaration for the constrained subtype
6795
 
6796
         if Constraint_Present then
6797
            New_Indic :=
6798
              Make_Subtype_Indication (Loc,
6799
                Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
6800
                Constraint   => Relocate_Node (Constraint (Indic)));
6801
 
6802
         else
6803
            declare
6804
               Constr_List : constant List_Id := New_List;
6805
               C           : Elmt_Id;
6806
               Expr        : Node_Id;
6807
 
6808
            begin
6809
               C := First_Elmt (Discriminant_Constraint (Parent_Type));
6810
               while Present (C) loop
6811
                  Expr := Node (C);
6812
 
6813
                  --  It is safe here to call New_Copy_Tree since
6814
                  --  Force_Evaluation was called on each constraint in
6815
                  --  Build_Discriminant_Constraints.
6816
 
6817
                  Append (New_Copy_Tree (Expr), To => Constr_List);
6818
 
6819
                  Next_Elmt (C);
6820
               end loop;
6821
 
6822
               New_Indic :=
6823
                 Make_Subtype_Indication (Loc,
6824
                   Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
6825
                   Constraint   =>
6826
                     Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
6827
            end;
6828
         end if;
6829
 
6830
         Rewrite (N,
6831
           Make_Subtype_Declaration (Loc,
6832
             Defining_Identifier => Derived_Type,
6833
             Subtype_Indication  => New_Indic));
6834
 
6835
         Analyze (N);
6836
 
6837
         --  Derivation of subprograms must be delayed until the full subtype
6838
         --  has been established to ensure proper overriding of subprograms
6839
         --  inherited by full types. If the derivations occurred as part of
6840
         --  the call to Build_Derived_Type above, then the check for type
6841
         --  conformance would fail because earlier primitive subprograms
6842
         --  could still refer to the full type prior the change to the new
6843
         --  subtype and hence would not match the new base type created here.
6844
 
6845
         Derive_Subprograms (Parent_Type, Derived_Type);
6846
 
6847
         --  For tagged types the Discriminant_Constraint of the new base itype
6848
         --  is inherited from the first subtype so that no subtype conformance
6849
         --  problem arise when the first subtype overrides primitive
6850
         --  operations inherited by the implicit base type.
6851
 
6852
         if Is_Tagged then
6853
            Set_Discriminant_Constraint
6854
              (New_Base, Discriminant_Constraint (Derived_Type));
6855
         end if;
6856
 
6857
         return;
6858
      end if;
6859
 
6860
      --  If we get here Derived_Type will have no discriminants or it will be
6861
      --  a discriminated unconstrained base type.
6862
 
6863
      --  STEP 1a: perform preliminary actions/checks for derived tagged types
6864
 
6865
      if Is_Tagged then
6866
 
6867
         --  The parent type is frozen for non-private extensions (RM 13.14(7))
6868
         --  The declaration of a specific descendant of an interface type
6869
         --  freezes the interface type (RM 13.14).
6870
 
6871
         if not Private_Extension
6872
           or else Is_Interface (Parent_Base)
6873
         then
6874
            Freeze_Before (N, Parent_Type);
6875
         end if;
6876
 
6877
         --  In Ada 2005 (AI-344), the restriction that a derived tagged type
6878
         --  cannot be declared at a deeper level than its parent type is
6879
         --  removed. The check on derivation within a generic body is also
6880
         --  relaxed, but there's a restriction that a derived tagged type
6881
         --  cannot be declared in a generic body if it's derived directly
6882
         --  or indirectly from a formal type of that generic.
6883
 
6884
         if Ada_Version >= Ada_05 then
6885
            if Present (Enclosing_Generic_Body (Derived_Type)) then
6886
               declare
6887
                  Ancestor_Type : Entity_Id;
6888
 
6889
               begin
6890
                  --  Check to see if any ancestor of the derived type is a
6891
                  --  formal type.
6892
 
6893
                  Ancestor_Type := Parent_Type;
6894
                  while not Is_Generic_Type (Ancestor_Type)
6895
                    and then Etype (Ancestor_Type) /= Ancestor_Type
6896
                  loop
6897
                     Ancestor_Type := Etype (Ancestor_Type);
6898
                  end loop;
6899
 
6900
                  --  If the derived type does have a formal type as an
6901
                  --  ancestor, then it's an error if the derived type is
6902
                  --  declared within the body of the generic unit that
6903
                  --  declares the formal type in its generic formal part. It's
6904
                  --  sufficient to check whether the ancestor type is declared
6905
                  --  inside the same generic body as the derived type (such as
6906
                  --  within a nested generic spec), in which case the
6907
                  --  derivation is legal. If the formal type is declared
6908
                  --  outside of that generic body, then it's guaranteed that
6909
                  --  the derived type is declared within the generic body of
6910
                  --  the generic unit declaring the formal type.
6911
 
6912
                  if Is_Generic_Type (Ancestor_Type)
6913
                    and then Enclosing_Generic_Body (Ancestor_Type) /=
6914
                               Enclosing_Generic_Body (Derived_Type)
6915
                  then
6916
                     Error_Msg_NE
6917
                       ("parent type of& must not be descendant of formal type"
6918
                          & " of an enclosing generic body",
6919
                            Indic, Derived_Type);
6920
                  end if;
6921
               end;
6922
            end if;
6923
 
6924
         elsif Type_Access_Level (Derived_Type) /=
6925
                 Type_Access_Level (Parent_Type)
6926
           and then not Is_Generic_Type (Derived_Type)
6927
         then
6928
            if Is_Controlled (Parent_Type) then
6929
               Error_Msg_N
6930
                 ("controlled type must be declared at the library level",
6931
                  Indic);
6932
            else
6933
               Error_Msg_N
6934
                 ("type extension at deeper accessibility level than parent",
6935
                  Indic);
6936
            end if;
6937
 
6938
         else
6939
            declare
6940
               GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
6941
 
6942
            begin
6943
               if Present (GB)
6944
                 and then GB /= Enclosing_Generic_Body (Parent_Base)
6945
               then
6946
                  Error_Msg_NE
6947
                    ("parent type of& must not be outside generic body"
6948
                       & " (RM 3.9.1(4))",
6949
                         Indic, Derived_Type);
6950
               end if;
6951
            end;
6952
         end if;
6953
      end if;
6954
 
6955
      --  Ada 2005 (AI-251)
6956
 
6957
      if Ada_Version = Ada_05
6958
        and then Is_Tagged
6959
      then
6960
         --  "The declaration of a specific descendant of an interface type
6961
         --  freezes the interface type" (RM 13.14).
6962
 
6963
         declare
6964
            Iface : Node_Id;
6965
         begin
6966
            if Is_Non_Empty_List (Interface_List (Type_Def)) then
6967
               Iface := First (Interface_List (Type_Def));
6968
               while Present (Iface) loop
6969
                  Freeze_Before (N, Etype (Iface));
6970
                  Next (Iface);
6971
               end loop;
6972
            end if;
6973
         end;
6974
      end if;
6975
 
6976
      --  STEP 1b : preliminary cleanup of the full view of private types
6977
 
6978
      --  If the type is already marked as having discriminants, then it's the
6979
      --  completion of a private type or private extension and we need to
6980
      --  retain the discriminants from the partial view if the current
6981
      --  declaration has Discriminant_Specifications so that we can verify
6982
      --  conformance. However, we must remove any existing components that
6983
      --  were inherited from the parent (and attached in Copy_And_Swap)
6984
      --  because the full type inherits all appropriate components anyway, and
6985
      --  we do not want the partial view's components interfering.
6986
 
6987
      if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
6988
         Discrim := First_Discriminant (Derived_Type);
6989
         loop
6990
            Last_Discrim := Discrim;
6991
            Next_Discriminant (Discrim);
6992
            exit when No (Discrim);
6993
         end loop;
6994
 
6995
         Set_Last_Entity (Derived_Type, Last_Discrim);
6996
 
6997
      --  In all other cases wipe out the list of inherited components (even
6998
      --  inherited discriminants), it will be properly rebuilt here.
6999
 
7000
      else
7001
         Set_First_Entity (Derived_Type, Empty);
7002
         Set_Last_Entity  (Derived_Type, Empty);
7003
      end if;
7004
 
7005
      --  STEP 1c: Initialize some flags for the Derived_Type
7006
 
7007
      --  The following flags must be initialized here so that
7008
      --  Process_Discriminants can check that discriminants of tagged types do
7009
      --  not have a default initial value and that access discriminants are
7010
      --  only specified for limited records. For completeness, these flags are
7011
      --  also initialized along with all the other flags below.
7012
 
7013
      --  AI-419: Limitedness is not inherited from an interface parent, so to
7014
      --  be limited in that case the type must be explicitly declared as
7015
      --  limited. However, task and protected interfaces are always limited.
7016
 
7017
      if Limited_Present (Type_Def) then
7018
         Set_Is_Limited_Record (Derived_Type);
7019
 
7020
      elsif Is_Limited_Record (Parent_Type)
7021
        or else (Present (Full_View (Parent_Type))
7022
                   and then Is_Limited_Record (Full_View (Parent_Type)))
7023
      then
7024
         if not Is_Interface (Parent_Type)
7025
           or else Is_Synchronized_Interface (Parent_Type)
7026
           or else Is_Protected_Interface (Parent_Type)
7027
           or else Is_Task_Interface (Parent_Type)
7028
         then
7029
            Set_Is_Limited_Record (Derived_Type);
7030
         end if;
7031
      end if;
7032
 
7033
      --  STEP 2a: process discriminants of derived type if any
7034
 
7035
      Push_Scope (Derived_Type);
7036
 
7037
      if Discriminant_Specs then
7038
         Set_Has_Unknown_Discriminants (Derived_Type, False);
7039
 
7040
         --  The following call initializes fields Has_Discriminants and
7041
         --  Discriminant_Constraint, unless we are processing the completion
7042
         --  of a private type declaration.
7043
 
7044
         Check_Or_Process_Discriminants (N, Derived_Type);
7045
 
7046
         --  For non-tagged types the constraint on the Parent_Type must be
7047
         --  present and is used to rename the discriminants.
7048
 
7049
         if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
7050
            Error_Msg_N ("untagged parent must have discriminants", Indic);
7051
 
7052
         elsif not Is_Tagged and then not Constraint_Present then
7053
            Error_Msg_N
7054
              ("discriminant constraint needed for derived untagged records",
7055
               Indic);
7056
 
7057
         --  Otherwise the parent subtype must be constrained unless we have a
7058
         --  private extension.
7059
 
7060
         elsif not Constraint_Present
7061
           and then not Private_Extension
7062
           and then not Is_Constrained (Parent_Type)
7063
         then
7064
            Error_Msg_N
7065
              ("unconstrained type not allowed in this context", Indic);
7066
 
7067
         elsif Constraint_Present then
7068
            --  The following call sets the field Corresponding_Discriminant
7069
            --  for the discriminants in the Derived_Type.
7070
 
7071
            Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
7072
 
7073
            --  For untagged types all new discriminants must rename
7074
            --  discriminants in the parent. For private extensions new
7075
            --  discriminants cannot rename old ones (implied by [7.3(13)]).
7076
 
7077
            Discrim := First_Discriminant (Derived_Type);
7078
            while Present (Discrim) loop
7079
               if not Is_Tagged
7080
                 and then No (Corresponding_Discriminant (Discrim))
7081
               then
7082
                  Error_Msg_N
7083
                    ("new discriminants must constrain old ones", Discrim);
7084
 
7085
               elsif Private_Extension
7086
                 and then Present (Corresponding_Discriminant (Discrim))
7087
               then
7088
                  Error_Msg_N
7089
                    ("only static constraints allowed for parent"
7090
                     & " discriminants in the partial view", Indic);
7091
                  exit;
7092
               end if;
7093
 
7094
               --  If a new discriminant is used in the constraint, then its
7095
               --  subtype must be statically compatible with the parent
7096
               --  discriminant's subtype (3.7(15)).
7097
 
7098
               if Present (Corresponding_Discriminant (Discrim))
7099
                 and then
7100
                   not Subtypes_Statically_Compatible
7101
                         (Etype (Discrim),
7102
                          Etype (Corresponding_Discriminant (Discrim)))
7103
               then
7104
                  Error_Msg_N
7105
                    ("subtype must be compatible with parent discriminant",
7106
                     Discrim);
7107
               end if;
7108
 
7109
               Next_Discriminant (Discrim);
7110
            end loop;
7111
 
7112
            --  Check whether the constraints of the full view statically
7113
            --  match those imposed by the parent subtype [7.3(13)].
7114
 
7115
            if Present (Stored_Constraint (Derived_Type)) then
7116
               declare
7117
                  C1, C2 : Elmt_Id;
7118
 
7119
               begin
7120
                  C1 := First_Elmt (Discs);
7121
                  C2 := First_Elmt (Stored_Constraint (Derived_Type));
7122
                  while Present (C1) and then Present (C2) loop
7123
                     if not
7124
                       Fully_Conformant_Expressions (Node (C1), Node (C2))
7125
                     then
7126
                        Error_Msg_N
7127
                          ("not conformant with previous declaration",
7128
                           Node (C1));
7129
                     end if;
7130
 
7131
                     Next_Elmt (C1);
7132
                     Next_Elmt (C2);
7133
                  end loop;
7134
               end;
7135
            end if;
7136
         end if;
7137
 
7138
      --  STEP 2b: No new discriminants, inherit discriminants if any
7139
 
7140
      else
7141
         if Private_Extension then
7142
            Set_Has_Unknown_Discriminants
7143
              (Derived_Type,
7144
               Has_Unknown_Discriminants (Parent_Type)
7145
                 or else Unknown_Discriminants_Present (N));
7146
 
7147
         --  The partial view of the parent may have unknown discriminants,
7148
         --  but if the full view has discriminants and the parent type is
7149
         --  in scope they must be inherited.
7150
 
7151
         elsif Has_Unknown_Discriminants (Parent_Type)
7152
           and then
7153
            (not Has_Discriminants (Parent_Type)
7154
              or else not In_Open_Scopes (Scope (Parent_Type)))
7155
         then
7156
            Set_Has_Unknown_Discriminants (Derived_Type);
7157
         end if;
7158
 
7159
         if not Has_Unknown_Discriminants (Derived_Type)
7160
           and then not Has_Unknown_Discriminants (Parent_Base)
7161
           and then Has_Discriminants (Parent_Type)
7162
         then
7163
            Inherit_Discrims := True;
7164
            Set_Has_Discriminants
7165
              (Derived_Type, True);
7166
            Set_Discriminant_Constraint
7167
              (Derived_Type, Discriminant_Constraint (Parent_Base));
7168
         end if;
7169
 
7170
         --  The following test is true for private types (remember
7171
         --  transformation 5. is not applied to those) and in an error
7172
         --  situation.
7173
 
7174
         if Constraint_Present then
7175
            Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
7176
         end if;
7177
 
7178
         --  For now mark a new derived type as constrained only if it has no
7179
         --  discriminants. At the end of Build_Derived_Record_Type we properly
7180
         --  set this flag in the case of private extensions. See comments in
7181
         --  point 9. just before body of Build_Derived_Record_Type.
7182
 
7183
         Set_Is_Constrained
7184
           (Derived_Type,
7185
            not (Inherit_Discrims
7186
                   or else Has_Unknown_Discriminants (Derived_Type)));
7187
      end if;
7188
 
7189
      --  STEP 3: initialize fields of derived type
7190
 
7191
      Set_Is_Tagged_Type    (Derived_Type, Is_Tagged);
7192
      Set_Stored_Constraint (Derived_Type, No_Elist);
7193
 
7194
      --  Ada 2005 (AI-251): Private type-declarations can implement interfaces
7195
      --  but cannot be interfaces
7196
 
7197
      if not Private_Extension
7198
         and then Ekind (Derived_Type) /= E_Private_Type
7199
         and then Ekind (Derived_Type) /= E_Limited_Private_Type
7200
      then
7201
         if Interface_Present (Type_Def) then
7202
            Analyze_Interface_Declaration (Derived_Type, Type_Def);
7203
         end if;
7204
 
7205
         Set_Interfaces (Derived_Type, No_Elist);
7206
      end if;
7207
 
7208
      --  Fields inherited from the Parent_Type
7209
 
7210
      Set_Discard_Names
7211
        (Derived_Type, Einfo.Discard_Names  (Parent_Type));
7212
      Set_Has_Specified_Layout
7213
        (Derived_Type, Has_Specified_Layout (Parent_Type));
7214
      Set_Is_Limited_Composite
7215
        (Derived_Type, Is_Limited_Composite (Parent_Type));
7216
      Set_Is_Private_Composite
7217
        (Derived_Type, Is_Private_Composite (Parent_Type));
7218
 
7219
      --  Fields inherited from the Parent_Base
7220
 
7221
      Set_Has_Controlled_Component
7222
        (Derived_Type, Has_Controlled_Component (Parent_Base));
7223
      Set_Has_Non_Standard_Rep
7224
        (Derived_Type, Has_Non_Standard_Rep     (Parent_Base));
7225
      Set_Has_Primitive_Operations
7226
        (Derived_Type, Has_Primitive_Operations (Parent_Base));
7227
 
7228
      --  Fields inherited from the Parent_Base in the non-private case
7229
 
7230
      if Ekind (Derived_Type) = E_Record_Type then
7231
         Set_Has_Complex_Representation
7232
           (Derived_Type, Has_Complex_Representation (Parent_Base));
7233
      end if;
7234
 
7235
      --  Fields inherited from the Parent_Base for record types
7236
 
7237
      if Is_Record_Type (Derived_Type) then
7238
 
7239
         --  Ekind (Parent_Base) is not necessarily E_Record_Type since
7240
         --  Parent_Base can be a private type or private extension.
7241
 
7242
         if Present (Full_View (Parent_Base)) then
7243
            Set_OK_To_Reorder_Components
7244
              (Derived_Type,
7245
               OK_To_Reorder_Components (Full_View (Parent_Base)));
7246
            Set_Reverse_Bit_Order
7247
              (Derived_Type, Reverse_Bit_Order (Full_View (Parent_Base)));
7248
         else
7249
            Set_OK_To_Reorder_Components
7250
              (Derived_Type, OK_To_Reorder_Components (Parent_Base));
7251
            Set_Reverse_Bit_Order
7252
              (Derived_Type, Reverse_Bit_Order (Parent_Base));
7253
         end if;
7254
      end if;
7255
 
7256
      --  Direct controlled types do not inherit Finalize_Storage_Only flag
7257
 
7258
      if not Is_Controlled (Parent_Type) then
7259
         Set_Finalize_Storage_Only
7260
           (Derived_Type, Finalize_Storage_Only (Parent_Type));
7261
      end if;
7262
 
7263
      --  Set fields for private derived types
7264
 
7265
      if Is_Private_Type (Derived_Type) then
7266
         Set_Depends_On_Private (Derived_Type, True);
7267
         Set_Private_Dependents (Derived_Type, New_Elmt_List);
7268
 
7269
      --  Inherit fields from non private record types. If this is the
7270
      --  completion of a derivation from a private type, the parent itself
7271
      --  is private, and the attributes come from its full view, which must
7272
      --  be present.
7273
 
7274
      else
7275
         if Is_Private_Type (Parent_Base)
7276
           and then not Is_Record_Type (Parent_Base)
7277
         then
7278
            Set_Component_Alignment
7279
              (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
7280
            Set_C_Pass_By_Copy
7281
              (Derived_Type, C_Pass_By_Copy      (Full_View (Parent_Base)));
7282
         else
7283
            Set_Component_Alignment
7284
              (Derived_Type, Component_Alignment (Parent_Base));
7285
            Set_C_Pass_By_Copy
7286
              (Derived_Type, C_Pass_By_Copy      (Parent_Base));
7287
         end if;
7288
      end if;
7289
 
7290
      --  Set fields for tagged types
7291
 
7292
      if Is_Tagged then
7293
         Set_Primitive_Operations (Derived_Type, New_Elmt_List);
7294
 
7295
         --  All tagged types defined in Ada.Finalization are controlled
7296
 
7297
         if Chars (Scope (Derived_Type)) = Name_Finalization
7298
           and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
7299
           and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
7300
         then
7301
            Set_Is_Controlled (Derived_Type);
7302
         else
7303
            Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
7304
         end if;
7305
 
7306
         --  Minor optimization: there is no need to generate the class-wide
7307
         --  entity associated with an underlying record view.
7308
 
7309
         if not Is_Underlying_Record_View (Derived_Type) then
7310
            Make_Class_Wide_Type (Derived_Type);
7311
         end if;
7312
 
7313
         Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
7314
 
7315
         if Has_Discriminants (Derived_Type)
7316
           and then Constraint_Present
7317
         then
7318
            Set_Stored_Constraint
7319
              (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
7320
         end if;
7321
 
7322
         if Ada_Version >= Ada_05 then
7323
            declare
7324
               Ifaces_List : Elist_Id;
7325
 
7326
            begin
7327
               --  Checks rules 3.9.4 (13/2 and 14/2)
7328
 
7329
               if Comes_From_Source (Derived_Type)
7330
                 and then not Is_Private_Type (Derived_Type)
7331
                 and then Is_Interface (Parent_Type)
7332
                 and then not Is_Interface (Derived_Type)
7333
               then
7334
                  if Is_Task_Interface (Parent_Type) then
7335
                     Error_Msg_N
7336
                       ("(Ada 2005) task type required (RM 3.9.4 (13.2))",
7337
                        Derived_Type);
7338
 
7339
                  elsif Is_Protected_Interface (Parent_Type) then
7340
                     Error_Msg_N
7341
                       ("(Ada 2005) protected type required (RM 3.9.4 (14.2))",
7342
                        Derived_Type);
7343
                  end if;
7344
               end if;
7345
 
7346
               --  Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
7347
 
7348
               Check_Interfaces (N, Type_Def);
7349
 
7350
               --  Ada 2005 (AI-251): Collect the list of progenitors that are
7351
               --  not already in the parents.
7352
 
7353
               Collect_Interfaces
7354
                 (T               => Derived_Type,
7355
                  Ifaces_List     => Ifaces_List,
7356
                  Exclude_Parents => True);
7357
 
7358
               Set_Interfaces (Derived_Type, Ifaces_List);
7359
            end;
7360
         end if;
7361
 
7362
      else
7363
         Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
7364
         Set_Has_Non_Standard_Rep
7365
                       (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
7366
      end if;
7367
 
7368
      --  STEP 4: Inherit components from the parent base and constrain them.
7369
      --          Apply the second transformation described in point 6. above.
7370
 
7371
      if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
7372
        or else not Has_Discriminants (Parent_Type)
7373
        or else not Is_Constrained (Parent_Type)
7374
      then
7375
         Constrs := Discs;
7376
      else
7377
         Constrs := Discriminant_Constraint (Parent_Type);
7378
      end if;
7379
 
7380
      Assoc_List :=
7381
        Inherit_Components
7382
          (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
7383
 
7384
      --  STEP 5a: Copy the parent record declaration for untagged types
7385
 
7386
      if not Is_Tagged then
7387
 
7388
         --  Discriminant_Constraint (Derived_Type) has been properly
7389
         --  constructed. Save it and temporarily set it to Empty because we
7390
         --  do not want the call to New_Copy_Tree below to mess this list.
7391
 
7392
         if Has_Discriminants (Derived_Type) then
7393
            Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
7394
            Set_Discriminant_Constraint (Derived_Type, No_Elist);
7395
         else
7396
            Save_Discr_Constr := No_Elist;
7397
         end if;
7398
 
7399
         --  Save the Etype field of Derived_Type. It is correctly set now,
7400
         --  but the call to New_Copy tree may remap it to point to itself,
7401
         --  which is not what we want. Ditto for the Next_Entity field.
7402
 
7403
         Save_Etype       := Etype (Derived_Type);
7404
         Save_Next_Entity := Next_Entity (Derived_Type);
7405
 
7406
         --  Assoc_List maps all stored discriminants in the Parent_Base to
7407
         --  stored discriminants in the Derived_Type. It is fundamental that
7408
         --  no types or itypes with discriminants other than the stored
7409
         --  discriminants appear in the entities declared inside
7410
         --  Derived_Type, since the back end cannot deal with it.
7411
 
7412
         New_Decl :=
7413
           New_Copy_Tree
7414
             (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
7415
 
7416
         --  Restore the fields saved prior to the New_Copy_Tree call
7417
         --  and compute the stored constraint.
7418
 
7419
         Set_Etype       (Derived_Type, Save_Etype);
7420
         Set_Next_Entity (Derived_Type, Save_Next_Entity);
7421
 
7422
         if Has_Discriminants (Derived_Type) then
7423
            Set_Discriminant_Constraint
7424
              (Derived_Type, Save_Discr_Constr);
7425
            Set_Stored_Constraint
7426
              (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
7427
            Replace_Components (Derived_Type, New_Decl);
7428
         end if;
7429
 
7430
         --  Insert the new derived type declaration
7431
 
7432
         Rewrite (N, New_Decl);
7433
 
7434
      --  STEP 5b: Complete the processing for record extensions in generics
7435
 
7436
      --  There is no completion for record extensions declared in the
7437
      --  parameter part of a generic, so we need to complete processing for
7438
      --  these generic record extensions here. The Record_Type_Definition call
7439
      --  will change the Ekind of the components from E_Void to E_Component.
7440
 
7441
      elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
7442
         Record_Type_Definition (Empty, Derived_Type);
7443
 
7444
      --  STEP 5c: Process the record extension for non private tagged types
7445
 
7446
      elsif not Private_Extension then
7447
 
7448
         --  Add the _parent field in the derived type
7449
 
7450
         Expand_Record_Extension (Derived_Type, Type_Def);
7451
 
7452
         --  Ada 2005 (AI-251): Addition of the Tag corresponding to all the
7453
         --  implemented interfaces if we are in expansion mode
7454
 
7455
         if Expander_Active
7456
           and then Has_Interfaces (Derived_Type)
7457
         then
7458
            Add_Interface_Tag_Components (N, Derived_Type);
7459
         end if;
7460
 
7461
         --  Analyze the record extension
7462
 
7463
         Record_Type_Definition
7464
           (Record_Extension_Part (Type_Def), Derived_Type);
7465
      end if;
7466
 
7467
      End_Scope;
7468
 
7469
      --  Nothing else to do if there is an error in the derivation.
7470
      --  An unusual case: the full view may be derived from a type in an
7471
      --  instance, when the partial view was used illegally as an actual
7472
      --  in that instance, leading to a circular definition.
7473
 
7474
      if Etype (Derived_Type) = Any_Type
7475
        or else Etype (Parent_Type) = Derived_Type
7476
      then
7477
         return;
7478
      end if;
7479
 
7480
      --  Set delayed freeze and then derive subprograms, we need to do
7481
      --  this in this order so that derived subprograms inherit the
7482
      --  derived freeze if necessary.
7483
 
7484
      Set_Has_Delayed_Freeze (Derived_Type);
7485
 
7486
      if Derive_Subps then
7487
         Derive_Subprograms (Parent_Type, Derived_Type);
7488
      end if;
7489
 
7490
      --  If we have a private extension which defines a constrained derived
7491
      --  type mark as constrained here after we have derived subprograms. See
7492
      --  comment on point 9. just above the body of Build_Derived_Record_Type.
7493
 
7494
      if Private_Extension and then Inherit_Discrims then
7495
         if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
7496
            Set_Is_Constrained          (Derived_Type, True);
7497
            Set_Discriminant_Constraint (Derived_Type, Discs);
7498
 
7499
         elsif Is_Constrained (Parent_Type) then
7500
            Set_Is_Constrained
7501
              (Derived_Type, True);
7502
            Set_Discriminant_Constraint
7503
              (Derived_Type, Discriminant_Constraint (Parent_Type));
7504
         end if;
7505
      end if;
7506
 
7507
      --  Update the class-wide type, which shares the now-completed entity
7508
      --  list with its specific type. In case of underlying record views,
7509
      --  we do not generate the corresponding class wide entity.
7510
 
7511
      if Is_Tagged
7512
        and then not Is_Underlying_Record_View (Derived_Type)
7513
      then
7514
         Set_First_Entity
7515
           (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
7516
         Set_Last_Entity
7517
           (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
7518
      end if;
7519
 
7520
      --  Update the scope of anonymous access types of discriminants and other
7521
      --  components, to prevent scope anomalies in gigi, when the derivation
7522
      --  appears in a scope nested within that of the parent.
7523
 
7524
      declare
7525
         D : Entity_Id;
7526
 
7527
      begin
7528
         D := First_Entity (Derived_Type);
7529
         while Present (D) loop
7530
            if Ekind (D) = E_Discriminant
7531
              or else Ekind (D) = E_Component
7532
            then
7533
               if Is_Itype (Etype (D))
7534
                  and then Ekind (Etype (D)) = E_Anonymous_Access_Type
7535
               then
7536
                  Set_Scope (Etype (D), Current_Scope);
7537
               end if;
7538
            end if;
7539
 
7540
            Next_Entity (D);
7541
         end loop;
7542
      end;
7543
   end Build_Derived_Record_Type;
7544
 
7545
   ------------------------
7546
   -- Build_Derived_Type --
7547
   ------------------------
7548
 
7549
   procedure Build_Derived_Type
7550
     (N             : Node_Id;
7551
      Parent_Type   : Entity_Id;
7552
      Derived_Type  : Entity_Id;
7553
      Is_Completion : Boolean;
7554
      Derive_Subps  : Boolean := True)
7555
   is
7556
      Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
7557
 
7558
   begin
7559
      --  Set common attributes
7560
 
7561
      Set_Scope         (Derived_Type, Current_Scope);
7562
 
7563
      Set_Ekind         (Derived_Type, Ekind    (Parent_Base));
7564
      Set_Etype         (Derived_Type,           Parent_Base);
7565
      Set_Has_Task      (Derived_Type, Has_Task (Parent_Base));
7566
 
7567
      Set_Size_Info      (Derived_Type,                 Parent_Type);
7568
      Set_RM_Size        (Derived_Type, RM_Size        (Parent_Type));
7569
      Set_Convention     (Derived_Type, Convention     (Parent_Type));
7570
      Set_Is_Controlled  (Derived_Type, Is_Controlled  (Parent_Type));
7571
      Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
7572
 
7573
      --  The derived type inherits the representation clauses of the parent.
7574
      --  However, for a private type that is completed by a derivation, there
7575
      --  may be operation attributes that have been specified already (stream
7576
      --  attributes and External_Tag) and those must be provided. Finally,
7577
      --  if the partial view is a private extension, the representation items
7578
      --  of the parent have been inherited already, and should not be chained
7579
      --  twice to the derived type.
7580
 
7581
      if Is_Tagged_Type (Parent_Type)
7582
        and then Present (First_Rep_Item (Derived_Type))
7583
      then
7584
         --  The existing items are either operational items or items inherited
7585
         --  from a private extension declaration.
7586
 
7587
         declare
7588
            Rep : Node_Id;
7589
            --  Used to iterate over representation items of the derived type
7590
 
7591
            Last_Rep : Node_Id;
7592
            --  Last representation item of the (non-empty) representation
7593
            --  item list of the derived type.
7594
 
7595
            Found : Boolean := False;
7596
 
7597
         begin
7598
            Rep      := First_Rep_Item (Derived_Type);
7599
            Last_Rep := Rep;
7600
            while Present (Rep) loop
7601
               if Rep = First_Rep_Item (Parent_Type) then
7602
                  Found := True;
7603
                  exit;
7604
 
7605
               else
7606
                  Rep := Next_Rep_Item (Rep);
7607
 
7608
                  if Present (Rep) then
7609
                     Last_Rep := Rep;
7610
                  end if;
7611
               end if;
7612
            end loop;
7613
 
7614
            --  Here if we either encountered the parent type's first rep
7615
            --  item on the derived type's rep item list (in which case
7616
            --  Found is True, and we have nothing else to do), or if we
7617
            --  reached the last rep item of the derived type, which is
7618
            --  Last_Rep, in which case we further chain the parent type's
7619
            --  rep items to those of the derived type.
7620
 
7621
            if not Found then
7622
               Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type));
7623
            end if;
7624
         end;
7625
 
7626
      else
7627
         Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
7628
      end if;
7629
 
7630
      case Ekind (Parent_Type) is
7631
         when Numeric_Kind =>
7632
            Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
7633
 
7634
         when Array_Kind =>
7635
            Build_Derived_Array_Type (N, Parent_Type,  Derived_Type);
7636
 
7637
         when E_Record_Type
7638
            | E_Record_Subtype
7639
            | Class_Wide_Kind  =>
7640
            Build_Derived_Record_Type
7641
              (N, Parent_Type, Derived_Type, Derive_Subps);
7642
            return;
7643
 
7644
         when Enumeration_Kind =>
7645
            Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
7646
 
7647
         when Access_Kind =>
7648
            Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
7649
 
7650
         when Incomplete_Or_Private_Kind =>
7651
            Build_Derived_Private_Type
7652
              (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
7653
 
7654
            --  For discriminated types, the derivation includes deriving
7655
            --  primitive operations. For others it is done below.
7656
 
7657
            if Is_Tagged_Type (Parent_Type)
7658
              or else Has_Discriminants (Parent_Type)
7659
              or else (Present (Full_View (Parent_Type))
7660
                        and then Has_Discriminants (Full_View (Parent_Type)))
7661
            then
7662
               return;
7663
            end if;
7664
 
7665
         when Concurrent_Kind =>
7666
            Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
7667
 
7668
         when others =>
7669
            raise Program_Error;
7670
      end case;
7671
 
7672
      if Etype (Derived_Type) = Any_Type then
7673
         return;
7674
      end if;
7675
 
7676
      --  Set delayed freeze and then derive subprograms, we need to do this
7677
      --  in this order so that derived subprograms inherit the derived freeze
7678
      --  if necessary.
7679
 
7680
      Set_Has_Delayed_Freeze (Derived_Type);
7681
      if Derive_Subps then
7682
         Derive_Subprograms (Parent_Type, Derived_Type);
7683
      end if;
7684
 
7685
      Set_Has_Primitive_Operations
7686
        (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
7687
   end Build_Derived_Type;
7688
 
7689
   -----------------------
7690
   -- Build_Discriminal --
7691
   -----------------------
7692
 
7693
   procedure Build_Discriminal (Discrim : Entity_Id) is
7694
      D_Minal : Entity_Id;
7695
      CR_Disc : Entity_Id;
7696
 
7697
   begin
7698
      --  A discriminal has the same name as the discriminant
7699
 
7700
      D_Minal :=
7701
        Make_Defining_Identifier (Sloc (Discrim),
7702
          Chars => Chars (Discrim));
7703
 
7704
      Set_Ekind     (D_Minal, E_In_Parameter);
7705
      Set_Mechanism (D_Minal, Default_Mechanism);
7706
      Set_Etype     (D_Minal, Etype (Discrim));
7707
 
7708
      Set_Discriminal (Discrim, D_Minal);
7709
      Set_Discriminal_Link (D_Minal, Discrim);
7710
 
7711
      --  For task types, build at once the discriminants of the corresponding
7712
      --  record, which are needed if discriminants are used in entry defaults
7713
      --  and in family bounds.
7714
 
7715
      if Is_Concurrent_Type (Current_Scope)
7716
        or else Is_Limited_Type (Current_Scope)
7717
      then
7718
         CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
7719
 
7720
         Set_Ekind            (CR_Disc, E_In_Parameter);
7721
         Set_Mechanism        (CR_Disc, Default_Mechanism);
7722
         Set_Etype            (CR_Disc, Etype (Discrim));
7723
         Set_Discriminal_Link (CR_Disc, Discrim);
7724
         Set_CR_Discriminant  (Discrim, CR_Disc);
7725
      end if;
7726
   end Build_Discriminal;
7727
 
7728
   ------------------------------------
7729
   -- Build_Discriminant_Constraints --
7730
   ------------------------------------
7731
 
7732
   function Build_Discriminant_Constraints
7733
     (T           : Entity_Id;
7734
      Def         : Node_Id;
7735
      Derived_Def : Boolean := False) return Elist_Id
7736
   is
7737
      C        : constant Node_Id := Constraint (Def);
7738
      Nb_Discr : constant Nat     := Number_Discriminants (T);
7739
 
7740
      Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
7741
      --  Saves the expression corresponding to a given discriminant in T
7742
 
7743
      function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
7744
      --  Return the Position number within array Discr_Expr of a discriminant
7745
      --  D within the discriminant list of the discriminated type T.
7746
 
7747
      ------------------
7748
      -- Pos_Of_Discr --
7749
      ------------------
7750
 
7751
      function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
7752
         Disc : Entity_Id;
7753
 
7754
      begin
7755
         Disc := First_Discriminant (T);
7756
         for J in Discr_Expr'Range loop
7757
            if Disc = D then
7758
               return J;
7759
            end if;
7760
 
7761
            Next_Discriminant (Disc);
7762
         end loop;
7763
 
7764
         --  Note: Since this function is called on discriminants that are
7765
         --  known to belong to the discriminated type, falling through the
7766
         --  loop with no match signals an internal compiler error.
7767
 
7768
         raise Program_Error;
7769
      end Pos_Of_Discr;
7770
 
7771
      --  Declarations local to Build_Discriminant_Constraints
7772
 
7773
      Discr : Entity_Id;
7774
      E     : Entity_Id;
7775
      Elist : constant Elist_Id := New_Elmt_List;
7776
 
7777
      Constr   : Node_Id;
7778
      Expr     : Node_Id;
7779
      Id       : Node_Id;
7780
      Position : Nat;
7781
      Found    : Boolean;
7782
 
7783
      Discrim_Present : Boolean := False;
7784
 
7785
   --  Start of processing for Build_Discriminant_Constraints
7786
 
7787
   begin
7788
      --  The following loop will process positional associations only.
7789
      --  For a positional association, the (single) discriminant is
7790
      --  implicitly specified by position, in textual order (RM 3.7.2).
7791
 
7792
      Discr  := First_Discriminant (T);
7793
      Constr := First (Constraints (C));
7794
      for D in Discr_Expr'Range loop
7795
         exit when Nkind (Constr) = N_Discriminant_Association;
7796
 
7797
         if No (Constr) then
7798
            Error_Msg_N ("too few discriminants given in constraint", C);
7799
            return New_Elmt_List;
7800
 
7801
         elsif Nkind (Constr) = N_Range
7802
           or else (Nkind (Constr) = N_Attribute_Reference
7803
                     and then
7804
                    Attribute_Name (Constr) = Name_Range)
7805
         then
7806
            Error_Msg_N
7807
              ("a range is not a valid discriminant constraint", Constr);
7808
            Discr_Expr (D) := Error;
7809
 
7810
         else
7811
            Analyze_And_Resolve (Constr, Base_Type (Etype (Discr)));
7812
            Discr_Expr (D) := Constr;
7813
         end if;
7814
 
7815
         Next_Discriminant (Discr);
7816
         Next (Constr);
7817
      end loop;
7818
 
7819
      if No (Discr) and then Present (Constr) then
7820
         Error_Msg_N ("too many discriminants given in constraint", Constr);
7821
         return New_Elmt_List;
7822
      end if;
7823
 
7824
      --  Named associations can be given in any order, but if both positional
7825
      --  and named associations are used in the same discriminant constraint,
7826
      --  then positional associations must occur first, at their normal
7827
      --  position. Hence once a named association is used, the rest of the
7828
      --  discriminant constraint must use only named associations.
7829
 
7830
      while Present (Constr) loop
7831
 
7832
         --  Positional association forbidden after a named association
7833
 
7834
         if Nkind (Constr) /= N_Discriminant_Association then
7835
            Error_Msg_N ("positional association follows named one", Constr);
7836
            return New_Elmt_List;
7837
 
7838
         --  Otherwise it is a named association
7839
 
7840
         else
7841
            --  E records the type of the discriminants in the named
7842
            --  association. All the discriminants specified in the same name
7843
            --  association must have the same type.
7844
 
7845
            E := Empty;
7846
 
7847
            --  Search the list of discriminants in T to see if the simple name
7848
            --  given in the constraint matches any of them.
7849
 
7850
            Id := First (Selector_Names (Constr));
7851
            while Present (Id) loop
7852
               Found := False;
7853
 
7854
               --  If Original_Discriminant is present, we are processing a
7855
               --  generic instantiation and this is an instance node. We need
7856
               --  to find the name of the corresponding discriminant in the
7857
               --  actual record type T and not the name of the discriminant in
7858
               --  the generic formal. Example:
7859
 
7860
               --    generic
7861
               --       type G (D : int) is private;
7862
               --    package P is
7863
               --       subtype W is G (D => 1);
7864
               --    end package;
7865
               --    type Rec (X : int) is record ... end record;
7866
               --    package Q is new P (G => Rec);
7867
 
7868
               --  At the point of the instantiation, formal type G is Rec
7869
               --  and therefore when reanalyzing "subtype W is G (D => 1);"
7870
               --  which really looks like "subtype W is Rec (D => 1);" at
7871
               --  the point of instantiation, we want to find the discriminant
7872
               --  that corresponds to D in Rec, i.e. X.
7873
 
7874
               if Present (Original_Discriminant (Id)) then
7875
                  Discr := Find_Corresponding_Discriminant (Id, T);
7876
                  Found := True;
7877
 
7878
               else
7879
                  Discr := First_Discriminant (T);
7880
                  while Present (Discr) loop
7881
                     if Chars (Discr) = Chars (Id) then
7882
                        Found := True;
7883
                        exit;
7884
                     end if;
7885
 
7886
                     Next_Discriminant (Discr);
7887
                  end loop;
7888
 
7889
                  if not Found then
7890
                     Error_Msg_N ("& does not match any discriminant", Id);
7891
                     return New_Elmt_List;
7892
 
7893
                  --  The following is only useful for the benefit of generic
7894
                  --  instances but it does not interfere with other
7895
                  --  processing for the non-generic case so we do it in all
7896
                  --  cases (for generics this statement is executed when
7897
                  --  processing the generic definition, see comment at the
7898
                  --  beginning of this if statement).
7899
 
7900
                  else
7901
                     Set_Original_Discriminant (Id, Discr);
7902
                  end if;
7903
               end if;
7904
 
7905
               Position := Pos_Of_Discr (T, Discr);
7906
 
7907
               if Present (Discr_Expr (Position)) then
7908
                  Error_Msg_N ("duplicate constraint for discriminant&", Id);
7909
 
7910
               else
7911
                  --  Each discriminant specified in the same named association
7912
                  --  must be associated with a separate copy of the
7913
                  --  corresponding expression.
7914
 
7915
                  if Present (Next (Id)) then
7916
                     Expr := New_Copy_Tree (Expression (Constr));
7917
                     Set_Parent (Expr, Parent (Expression (Constr)));
7918
                  else
7919
                     Expr := Expression (Constr);
7920
                  end if;
7921
 
7922
                  Discr_Expr (Position) := Expr;
7923
                  Analyze_And_Resolve (Expr, Base_Type (Etype (Discr)));
7924
               end if;
7925
 
7926
               --  A discriminant association with more than one discriminant
7927
               --  name is only allowed if the named discriminants are all of
7928
               --  the same type (RM 3.7.1(8)).
7929
 
7930
               if E = Empty then
7931
                  E := Base_Type (Etype (Discr));
7932
 
7933
               elsif Base_Type (Etype (Discr)) /= E then
7934
                  Error_Msg_N
7935
                    ("all discriminants in an association " &
7936
                     "must have the same type", Id);
7937
               end if;
7938
 
7939
               Next (Id);
7940
            end loop;
7941
         end if;
7942
 
7943
         Next (Constr);
7944
      end loop;
7945
 
7946
      --  A discriminant constraint must provide exactly one value for each
7947
      --  discriminant of the type (RM 3.7.1(8)).
7948
 
7949
      for J in Discr_Expr'Range loop
7950
         if No (Discr_Expr (J)) then
7951
            Error_Msg_N ("too few discriminants given in constraint", C);
7952
            return New_Elmt_List;
7953
         end if;
7954
      end loop;
7955
 
7956
      --  Determine if there are discriminant expressions in the constraint
7957
 
7958
      for J in Discr_Expr'Range loop
7959
         if Denotes_Discriminant
7960
              (Discr_Expr (J), Check_Concurrent => True)
7961
         then
7962
            Discrim_Present := True;
7963
         end if;
7964
      end loop;
7965
 
7966
      --  Build an element list consisting of the expressions given in the
7967
      --  discriminant constraint and apply the appropriate checks. The list
7968
      --  is constructed after resolving any named discriminant associations
7969
      --  and therefore the expressions appear in the textual order of the
7970
      --  discriminants.
7971
 
7972
      Discr := First_Discriminant (T);
7973
      for J in Discr_Expr'Range loop
7974
         if Discr_Expr (J) /= Error then
7975
            Append_Elmt (Discr_Expr (J), Elist);
7976
 
7977
            --  If any of the discriminant constraints is given by a
7978
            --  discriminant and we are in a derived type declaration we
7979
            --  have a discriminant renaming. Establish link between new
7980
            --  and old discriminant.
7981
 
7982
            if Denotes_Discriminant (Discr_Expr (J)) then
7983
               if Derived_Def then
7984
                  Set_Corresponding_Discriminant
7985
                    (Entity (Discr_Expr (J)), Discr);
7986
               end if;
7987
 
7988
            --  Force the evaluation of non-discriminant expressions.
7989
            --  If we have found a discriminant in the constraint 3.4(26)
7990
            --  and 3.8(18) demand that no range checks are performed are
7991
            --  after evaluation. If the constraint is for a component
7992
            --  definition that has a per-object constraint, expressions are
7993
            --  evaluated but not checked either. In all other cases perform
7994
            --  a range check.
7995
 
7996
            else
7997
               if Discrim_Present then
7998
                  null;
7999
 
8000
               elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
8001
                 and then
8002
                   Has_Per_Object_Constraint
8003
                     (Defining_Identifier (Parent (Parent (Def))))
8004
               then
8005
                  null;
8006
 
8007
               elsif Is_Access_Type (Etype (Discr)) then
8008
                  Apply_Constraint_Check (Discr_Expr (J), Etype (Discr));
8009
 
8010
               else
8011
                  Apply_Range_Check (Discr_Expr (J), Etype (Discr));
8012
               end if;
8013
 
8014
               Force_Evaluation (Discr_Expr (J));
8015
            end if;
8016
 
8017
            --  Check that the designated type of an access discriminant's
8018
            --  expression is not a class-wide type unless the discriminant's
8019
            --  designated type is also class-wide.
8020
 
8021
            if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
8022
              and then not Is_Class_Wide_Type
8023
                         (Designated_Type (Etype (Discr)))
8024
              and then Etype (Discr_Expr (J)) /= Any_Type
8025
              and then Is_Class_Wide_Type
8026
                         (Designated_Type (Etype (Discr_Expr (J))))
8027
            then
8028
               Wrong_Type (Discr_Expr (J), Etype (Discr));
8029
 
8030
            elsif Is_Access_Type (Etype (Discr))
8031
              and then not Is_Access_Constant (Etype (Discr))
8032
              and then Is_Access_Type (Etype (Discr_Expr (J)))
8033
              and then Is_Access_Constant (Etype (Discr_Expr (J)))
8034
            then
8035
               Error_Msg_NE
8036
                 ("constraint for discriminant& must be access to variable",
8037
                    Def, Discr);
8038
            end if;
8039
         end if;
8040
 
8041
         Next_Discriminant (Discr);
8042
      end loop;
8043
 
8044
      return Elist;
8045
   end Build_Discriminant_Constraints;
8046
 
8047
   ---------------------------------
8048
   -- Build_Discriminated_Subtype --
8049
   ---------------------------------
8050
 
8051
   procedure Build_Discriminated_Subtype
8052
     (T           : Entity_Id;
8053
      Def_Id      : Entity_Id;
8054
      Elist       : Elist_Id;
8055
      Related_Nod : Node_Id;
8056
      For_Access  : Boolean := False)
8057
   is
8058
      Has_Discrs  : constant Boolean := Has_Discriminants (T);
8059
      Constrained : constant Boolean :=
8060
                      (Has_Discrs
8061
                         and then not Is_Empty_Elmt_List (Elist)
8062
                         and then not Is_Class_Wide_Type (T))
8063
                        or else Is_Constrained (T);
8064
 
8065
   begin
8066
      if Ekind (T) = E_Record_Type then
8067
         if For_Access then
8068
            Set_Ekind (Def_Id, E_Private_Subtype);
8069
            Set_Is_For_Access_Subtype (Def_Id, True);
8070
         else
8071
            Set_Ekind (Def_Id, E_Record_Subtype);
8072
         end if;
8073
 
8074
         --  Inherit preelaboration flag from base, for types for which it
8075
         --  may have been set: records, private types, protected types.
8076
 
8077
         Set_Known_To_Have_Preelab_Init
8078
           (Def_Id, Known_To_Have_Preelab_Init (T));
8079
 
8080
      elsif Ekind (T) = E_Task_Type then
8081
         Set_Ekind (Def_Id, E_Task_Subtype);
8082
 
8083
      elsif Ekind (T) = E_Protected_Type then
8084
         Set_Ekind (Def_Id, E_Protected_Subtype);
8085
         Set_Known_To_Have_Preelab_Init
8086
           (Def_Id, Known_To_Have_Preelab_Init (T));
8087
 
8088
      elsif Is_Private_Type (T) then
8089
         Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
8090
         Set_Known_To_Have_Preelab_Init
8091
           (Def_Id, Known_To_Have_Preelab_Init (T));
8092
 
8093
      elsif Is_Class_Wide_Type (T) then
8094
         Set_Ekind (Def_Id, E_Class_Wide_Subtype);
8095
 
8096
      else
8097
         --  Incomplete type. Attach subtype to list of dependents, to be
8098
         --  completed with full view of parent type,  unless is it the
8099
         --  designated subtype of a record component within an init_proc.
8100
         --  This last case arises for a component of an access type whose
8101
         --  designated type is incomplete (e.g. a Taft Amendment type).
8102
         --  The designated subtype is within an inner scope, and needs no
8103
         --  elaboration, because only the access type is needed in the
8104
         --  initialization procedure.
8105
 
8106
         Set_Ekind (Def_Id, Ekind (T));
8107
 
8108
         if For_Access and then Within_Init_Proc then
8109
            null;
8110
         else
8111
            Append_Elmt (Def_Id, Private_Dependents (T));
8112
         end if;
8113
      end if;
8114
 
8115
      Set_Etype             (Def_Id, T);
8116
      Init_Size_Align       (Def_Id);
8117
      Set_Has_Discriminants (Def_Id, Has_Discrs);
8118
      Set_Is_Constrained    (Def_Id, Constrained);
8119
 
8120
      Set_First_Entity      (Def_Id, First_Entity   (T));
8121
      Set_Last_Entity       (Def_Id, Last_Entity    (T));
8122
 
8123
      --  If the subtype is the completion of a private declaration, there may
8124
      --  have been representation clauses for the partial view, and they must
8125
      --  be preserved. Build_Derived_Type chains the inherited clauses with
8126
      --  the ones appearing on the extension. If this comes from a subtype
8127
      --  declaration, all clauses are inherited.
8128
 
8129
      if No (First_Rep_Item (Def_Id)) then
8130
         Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
8131
      end if;
8132
 
8133
      if Is_Tagged_Type (T) then
8134
         Set_Is_Tagged_Type  (Def_Id);
8135
         Make_Class_Wide_Type (Def_Id);
8136
      end if;
8137
 
8138
      Set_Stored_Constraint (Def_Id, No_Elist);
8139
 
8140
      if Has_Discrs then
8141
         Set_Discriminant_Constraint (Def_Id, Elist);
8142
         Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id);
8143
      end if;
8144
 
8145
      if Is_Tagged_Type (T) then
8146
 
8147
         --  Ada 2005 (AI-251): In case of concurrent types we inherit the
8148
         --  concurrent record type (which has the list of primitive
8149
         --  operations).
8150
 
8151
         if Ada_Version >= Ada_05
8152
           and then Is_Concurrent_Type (T)
8153
         then
8154
            Set_Corresponding_Record_Type (Def_Id,
8155
               Corresponding_Record_Type (T));
8156
         else
8157
            Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
8158
         end if;
8159
 
8160
         Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
8161
      end if;
8162
 
8163
      --  Subtypes introduced by component declarations do not need to be
8164
      --  marked as delayed, and do not get freeze nodes, because the semantics
8165
      --  verifies that the parents of the subtypes are frozen before the
8166
      --  enclosing record is frozen.
8167
 
8168
      if not Is_Type (Scope (Def_Id)) then
8169
         Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
8170
 
8171
         if Is_Private_Type (T)
8172
           and then Present (Full_View (T))
8173
         then
8174
            Conditional_Delay (Def_Id, Full_View (T));
8175
         else
8176
            Conditional_Delay (Def_Id, T);
8177
         end if;
8178
      end if;
8179
 
8180
      if Is_Record_Type (T) then
8181
         Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
8182
 
8183
         if Has_Discrs
8184
            and then not Is_Empty_Elmt_List (Elist)
8185
            and then not For_Access
8186
         then
8187
            Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
8188
         elsif not For_Access then
8189
            Set_Cloned_Subtype (Def_Id, T);
8190
         end if;
8191
      end if;
8192
   end Build_Discriminated_Subtype;
8193
 
8194
   ---------------------------
8195
   -- Build_Itype_Reference --
8196
   ---------------------------
8197
 
8198
   procedure Build_Itype_Reference
8199
     (Ityp : Entity_Id;
8200
      Nod  : Node_Id)
8201
   is
8202
      IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod));
8203
   begin
8204
      Set_Itype (IR, Ityp);
8205
      Insert_After (Nod, IR);
8206
   end Build_Itype_Reference;
8207
 
8208
   ------------------------
8209
   -- Build_Scalar_Bound --
8210
   ------------------------
8211
 
8212
   function Build_Scalar_Bound
8213
     (Bound : Node_Id;
8214
      Par_T : Entity_Id;
8215
      Der_T : Entity_Id) return Node_Id
8216
   is
8217
      New_Bound : Entity_Id;
8218
 
8219
   begin
8220
      --  Note: not clear why this is needed, how can the original bound
8221
      --  be unanalyzed at this point? and if it is, what business do we
8222
      --  have messing around with it? and why is the base type of the
8223
      --  parent type the right type for the resolution. It probably is
8224
      --  not! It is OK for the new bound we are creating, but not for
8225
      --  the old one??? Still if it never happens, no problem!
8226
 
8227
      Analyze_And_Resolve (Bound, Base_Type (Par_T));
8228
 
8229
      if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then
8230
         New_Bound := New_Copy (Bound);
8231
         Set_Etype (New_Bound, Der_T);
8232
         Set_Analyzed (New_Bound);
8233
 
8234
      elsif Is_Entity_Name (Bound) then
8235
         New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
8236
 
8237
      --  The following is almost certainly wrong. What business do we have
8238
      --  relocating a node (Bound) that is presumably still attached to
8239
      --  the tree elsewhere???
8240
 
8241
      else
8242
         New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
8243
      end if;
8244
 
8245
      Set_Etype (New_Bound, Der_T);
8246
      return New_Bound;
8247
   end Build_Scalar_Bound;
8248
 
8249
   --------------------------------
8250
   -- Build_Underlying_Full_View --
8251
   --------------------------------
8252
 
8253
   procedure Build_Underlying_Full_View
8254
     (N   : Node_Id;
8255
      Typ : Entity_Id;
8256
      Par : Entity_Id)
8257
   is
8258
      Loc  : constant Source_Ptr := Sloc (N);
8259
      Subt : constant Entity_Id :=
8260
               Make_Defining_Identifier
8261
                 (Loc, New_External_Name (Chars (Typ), 'S'));
8262
 
8263
      Constr : Node_Id;
8264
      Indic  : Node_Id;
8265
      C      : Node_Id;
8266
      Id     : Node_Id;
8267
 
8268
      procedure Set_Discriminant_Name (Id : Node_Id);
8269
      --  If the derived type has discriminants, they may rename discriminants
8270
      --  of the parent. When building the full view of the parent, we need to
8271
      --  recover the names of the original discriminants if the constraint is
8272
      --  given by named associations.
8273
 
8274
      ---------------------------
8275
      -- Set_Discriminant_Name --
8276
      ---------------------------
8277
 
8278
      procedure Set_Discriminant_Name (Id : Node_Id) is
8279
         Disc : Entity_Id;
8280
 
8281
      begin
8282
         Set_Original_Discriminant (Id, Empty);
8283
 
8284
         if Has_Discriminants (Typ) then
8285
            Disc := First_Discriminant (Typ);
8286
            while Present (Disc) loop
8287
               if Chars (Disc) = Chars (Id)
8288
                 and then Present (Corresponding_Discriminant (Disc))
8289
               then
8290
                  Set_Chars (Id, Chars (Corresponding_Discriminant (Disc)));
8291
               end if;
8292
               Next_Discriminant (Disc);
8293
            end loop;
8294
         end if;
8295
      end Set_Discriminant_Name;
8296
 
8297
   --  Start of processing for Build_Underlying_Full_View
8298
 
8299
   begin
8300
      if Nkind (N) = N_Full_Type_Declaration then
8301
         Constr := Constraint (Subtype_Indication (Type_Definition (N)));
8302
 
8303
      elsif Nkind (N) = N_Subtype_Declaration then
8304
         Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
8305
 
8306
      elsif Nkind (N) = N_Component_Declaration then
8307
         Constr :=
8308
           New_Copy_Tree
8309
             (Constraint (Subtype_Indication (Component_Definition (N))));
8310
 
8311
      else
8312
         raise Program_Error;
8313
      end if;
8314
 
8315
      C := First (Constraints (Constr));
8316
      while Present (C) loop
8317
         if Nkind (C) = N_Discriminant_Association then
8318
            Id := First (Selector_Names (C));
8319
            while Present (Id) loop
8320
               Set_Discriminant_Name (Id);
8321
               Next (Id);
8322
            end loop;
8323
         end if;
8324
 
8325
         Next (C);
8326
      end loop;
8327
 
8328
      Indic :=
8329
        Make_Subtype_Declaration (Loc,
8330
          Defining_Identifier => Subt,
8331
          Subtype_Indication  =>
8332
            Make_Subtype_Indication (Loc,
8333
              Subtype_Mark => New_Reference_To (Par, Loc),
8334
              Constraint   => New_Copy_Tree (Constr)));
8335
 
8336
      --  If this is a component subtype for an outer itype, it is not
8337
      --  a list member, so simply set the parent link for analysis: if
8338
      --  the enclosing type does not need to be in a declarative list,
8339
      --  neither do the components.
8340
 
8341
      if Is_List_Member (N)
8342
        and then Nkind (N) /= N_Component_Declaration
8343
      then
8344
         Insert_Before (N, Indic);
8345
      else
8346
         Set_Parent (Indic, Parent (N));
8347
      end if;
8348
 
8349
      Analyze (Indic);
8350
      Set_Underlying_Full_View (Typ, Full_View (Subt));
8351
   end Build_Underlying_Full_View;
8352
 
8353
   -------------------------------
8354
   -- Check_Abstract_Overriding --
8355
   -------------------------------
8356
 
8357
   procedure Check_Abstract_Overriding (T : Entity_Id) is
8358
      Alias_Subp : Entity_Id;
8359
      Elmt       : Elmt_Id;
8360
      Op_List    : Elist_Id;
8361
      Subp       : Entity_Id;
8362
      Type_Def   : Node_Id;
8363
 
8364
   begin
8365
      Op_List := Primitive_Operations (T);
8366
 
8367
      --  Loop to check primitive operations
8368
 
8369
      Elmt := First_Elmt (Op_List);
8370
      while Present (Elmt) loop
8371
         Subp := Node (Elmt);
8372
         Alias_Subp := Alias (Subp);
8373
 
8374
         --  Inherited subprograms are identified by the fact that they do not
8375
         --  come from source, and the associated source location is the
8376
         --  location of the first subtype of the derived type.
8377
 
8378
         --  Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for
8379
         --  subprograms that "require overriding".
8380
 
8381
         --  Special exception, do not complain about failure to override the
8382
         --  stream routines _Input and _Output, as well as the primitive
8383
         --  operations used in dispatching selects since we always provide
8384
         --  automatic overridings for these subprograms.
8385
 
8386
         --  Also ignore this rule for convention CIL since .NET libraries
8387
         --  do bizarre things with interfaces???
8388
 
8389
         --  The partial view of T may have been a private extension, for
8390
         --  which inherited functions dispatching on result are abstract.
8391
         --  If the full view is a null extension, there is no need for
8392
         --  overriding in Ada2005, but wrappers need to be built for them
8393
         --  (see exp_ch3, Build_Controlling_Function_Wrappers).
8394
 
8395
         if Is_Null_Extension (T)
8396
           and then Has_Controlling_Result (Subp)
8397
           and then Ada_Version >= Ada_05
8398
           and then Present (Alias_Subp)
8399
           and then not Comes_From_Source (Subp)
8400
           and then not Is_Abstract_Subprogram (Alias_Subp)
8401
           and then not Is_Access_Type (Etype (Subp))
8402
         then
8403
            null;
8404
 
8405
         --  Ada 2005 (AI-251): Internal entities of interfaces need no
8406
         --  processing because this check is done with the aliased
8407
         --  entity
8408
 
8409
         elsif Present (Interface_Alias (Subp)) then
8410
            null;
8411
 
8412
         elsif (Is_Abstract_Subprogram (Subp)
8413
                 or else Requires_Overriding (Subp)
8414
                 or else
8415
                   (Has_Controlling_Result (Subp)
8416
                     and then Present (Alias_Subp)
8417
                     and then not Comes_From_Source (Subp)
8418
                     and then Sloc (Subp) = Sloc (First_Subtype (T))))
8419
           and then not Is_TSS (Subp, TSS_Stream_Input)
8420
           and then not Is_TSS (Subp, TSS_Stream_Output)
8421
           and then not Is_Abstract_Type (T)
8422
           and then Convention (T) /= Convention_CIL
8423
           and then not Is_Predefined_Interface_Primitive (Subp)
8424
 
8425
            --  Ada 2005 (AI-251): Do not consider hidden entities associated
8426
            --  with abstract interface types because the check will be done
8427
            --  with the aliased entity (otherwise we generate a duplicated
8428
            --  error message).
8429
 
8430
           and then not Present (Interface_Alias (Subp))
8431
         then
8432
            if Present (Alias_Subp) then
8433
 
8434
               --  Only perform the check for a derived subprogram when the
8435
               --  type has an explicit record extension. This avoids incorrect
8436
               --  flagging of abstract subprograms for the case of a type
8437
               --  without an extension that is derived from a formal type
8438
               --  with a tagged actual (can occur within a private part).
8439
 
8440
               --  Ada 2005 (AI-391): In the case of an inherited function with
8441
               --  a controlling result of the type, the rule does not apply if
8442
               --  the type is a null extension (unless the parent function
8443
               --  itself is abstract, in which case the function must still be
8444
               --  be overridden). The expander will generate an overriding
8445
               --  wrapper function calling the parent subprogram (see
8446
               --  Exp_Ch3.Make_Controlling_Wrapper_Functions).
8447
 
8448
               Type_Def := Type_Definition (Parent (T));
8449
 
8450
               if Nkind (Type_Def) = N_Derived_Type_Definition
8451
                 and then Present (Record_Extension_Part (Type_Def))
8452
                 and then
8453
                   (Ada_Version < Ada_05
8454
                      or else not Is_Null_Extension (T)
8455
                      or else Ekind (Subp) = E_Procedure
8456
                      or else not Has_Controlling_Result (Subp)
8457
                      or else Is_Abstract_Subprogram (Alias_Subp)
8458
                      or else Requires_Overriding (Subp)
8459
                      or else Is_Access_Type (Etype (Subp)))
8460
               then
8461
                  --  Avoid reporting error in case of abstract predefined
8462
                  --  primitive inherited from interface type because the
8463
                  --  body of internally generated predefined primitives
8464
                  --  of tagged types are generated later by Freeze_Type
8465
 
8466
                  if Is_Interface (Root_Type (T))
8467
                    and then Is_Abstract_Subprogram (Subp)
8468
                    and then Is_Predefined_Dispatching_Operation (Subp)
8469
                    and then not Comes_From_Source (Ultimate_Alias (Subp))
8470
                  then
8471
                     null;
8472
 
8473
                  else
8474
                     Error_Msg_NE
8475
                       ("type must be declared abstract or & overridden",
8476
                        T, Subp);
8477
 
8478
                     --  Traverse the whole chain of aliased subprograms to
8479
                     --  complete the error notification. This is especially
8480
                     --  useful for traceability of the chain of entities when
8481
                     --  the subprogram corresponds with an interface
8482
                     --  subprogram (which may be defined in another package).
8483
 
8484
                     if Present (Alias_Subp) then
8485
                        declare
8486
                           E : Entity_Id;
8487
 
8488
                        begin
8489
                           E := Subp;
8490
                           while Present (Alias (E)) loop
8491
                              Error_Msg_Sloc := Sloc (E);
8492
                              Error_Msg_NE
8493
                                ("\& has been inherited #", T, Subp);
8494
                              E := Alias (E);
8495
                           end loop;
8496
 
8497
                           Error_Msg_Sloc := Sloc (E);
8498
                           Error_Msg_NE
8499
                             ("\& has been inherited from subprogram #",
8500
                              T, Subp);
8501
                        end;
8502
                     end if;
8503
                  end if;
8504
 
8505
               --  Ada 2005 (AI-345): Protected or task type implementing
8506
               --  abstract interfaces.
8507
 
8508
               elsif Is_Concurrent_Record_Type (T)
8509
                 and then Present (Interfaces (T))
8510
               then
8511
                  --  The controlling formal of Subp must be of mode "out",
8512
                  --  "in out" or an access-to-variable to be overridden.
8513
 
8514
                  --  Error message below needs rewording (remember comma
8515
                  --  in -gnatj mode) ???
8516
 
8517
                  if Ekind (First_Formal (Subp)) = E_In_Parameter
8518
                    and then Ekind (Subp) /= E_Function
8519
                  then
8520
                     if not Is_Predefined_Dispatching_Operation (Subp) then
8521
                        Error_Msg_NE
8522
                          ("first formal of & must be of mode `OUT`, " &
8523
                           "`IN OUT` or access-to-variable", T, Subp);
8524
                        Error_Msg_N
8525
                          ("\to be overridden by protected procedure or " &
8526
                           "entry (RM 9.4(11.9/2))", T);
8527
                     end if;
8528
 
8529
                  --  Some other kind of overriding failure
8530
 
8531
                  else
8532
                     Error_Msg_NE
8533
                       ("interface subprogram & must be overridden",
8534
                        T, Subp);
8535
 
8536
                     --  Examine primitive operations of synchronized type,
8537
                     --  to find homonyms that have the wrong profile.
8538
 
8539
                     declare
8540
                        Prim : Entity_Id;
8541
 
8542
                     begin
8543
                        Prim :=
8544
                          First_Entity (Corresponding_Concurrent_Type (T));
8545
                        while Present (Prim) loop
8546
                           if Chars (Prim) = Chars (Subp) then
8547
                              Error_Msg_NE
8548
                                ("profile is not type conformant with "
8549
                                   & "prefixed view profile of "
8550
                                   & "inherited operation&", Prim, Subp);
8551
                           end if;
8552
 
8553
                           Next_Entity (Prim);
8554
                        end loop;
8555
                     end;
8556
                  end if;
8557
               end if;
8558
 
8559
            else
8560
               Error_Msg_Node_2 := T;
8561
               Error_Msg_N
8562
                 ("abstract subprogram& not allowed for type&", Subp);
8563
 
8564
               --  Also post unconditional warning on the type (unconditional
8565
               --  so that if there are more than one of these cases, we get
8566
               --  them all, and not just the first one).
8567
 
8568
               Error_Msg_Node_2 := Subp;
8569
               Error_Msg_N
8570
                 ("nonabstract type& has abstract subprogram&!", T);
8571
            end if;
8572
         end if;
8573
 
8574
         --  Ada 2005 (AI05-0030): Inspect hidden subprograms which provide
8575
         --  the mapping between interface and implementing type primitives.
8576
         --  If the interface alias is marked as Implemented_By_Entry, the
8577
         --  alias must be an entry wrapper.
8578
 
8579
         if Ada_Version >= Ada_05
8580
           and then Is_Hidden (Subp)
8581
           and then Present (Interface_Alias (Subp))
8582
           and then Implemented_By_Entry (Interface_Alias (Subp))
8583
           and then Present (Alias_Subp)
8584
           and then
8585
             (not Is_Primitive_Wrapper (Alias_Subp)
8586
                or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry)
8587
         then
8588
            declare
8589
               Error_Ent : Entity_Id := T;
8590
 
8591
            begin
8592
               if Is_Concurrent_Record_Type (Error_Ent) then
8593
                  Error_Ent := Corresponding_Concurrent_Type (Error_Ent);
8594
               end if;
8595
 
8596
               Error_Msg_Node_2 := Interface_Alias (Subp);
8597
               Error_Msg_NE
8598
                 ("type & must implement abstract subprogram & with an entry",
8599
                  Error_Ent, Error_Ent);
8600
            end;
8601
         end if;
8602
 
8603
         Next_Elmt (Elmt);
8604
      end loop;
8605
   end Check_Abstract_Overriding;
8606
 
8607
   ------------------------------------------------
8608
   -- Check_Access_Discriminant_Requires_Limited --
8609
   ------------------------------------------------
8610
 
8611
   procedure Check_Access_Discriminant_Requires_Limited
8612
     (D   : Node_Id;
8613
      Loc : Node_Id)
8614
   is
8615
   begin
8616
      --  A discriminant_specification for an access discriminant shall appear
8617
      --  only in the declaration for a task or protected type, or for a type
8618
      --  with the reserved word 'limited' in its definition or in one of its
8619
      --  ancestors. (RM 3.7(10))
8620
 
8621
      if Nkind (Discriminant_Type (D)) = N_Access_Definition
8622
        and then not Is_Concurrent_Type (Current_Scope)
8623
        and then not Is_Concurrent_Record_Type (Current_Scope)
8624
        and then not Is_Limited_Record (Current_Scope)
8625
        and then Ekind (Current_Scope) /= E_Limited_Private_Type
8626
      then
8627
         Error_Msg_N
8628
           ("access discriminants allowed only for limited types", Loc);
8629
      end if;
8630
   end Check_Access_Discriminant_Requires_Limited;
8631
 
8632
   -----------------------------------
8633
   -- Check_Aliased_Component_Types --
8634
   -----------------------------------
8635
 
8636
   procedure Check_Aliased_Component_Types (T : Entity_Id) is
8637
      C : Entity_Id;
8638
 
8639
   begin
8640
      --  ??? Also need to check components of record extensions, but not
8641
      --  components of protected types (which are always limited).
8642
 
8643
      --  Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
8644
      --  types to be unconstrained. This is safe because it is illegal to
8645
      --  create access subtypes to such types with explicit discriminant
8646
      --  constraints.
8647
 
8648
      if not Is_Limited_Type (T) then
8649
         if Ekind (T) = E_Record_Type then
8650
            C := First_Component (T);
8651
            while Present (C) loop
8652
               if Is_Aliased (C)
8653
                 and then Has_Discriminants (Etype (C))
8654
                 and then not Is_Constrained (Etype (C))
8655
                 and then not In_Instance_Body
8656
                 and then Ada_Version < Ada_05
8657
               then
8658
                  Error_Msg_N
8659
                    ("aliased component must be constrained (RM 3.6(11))",
8660
                      C);
8661
               end if;
8662
 
8663
               Next_Component (C);
8664
            end loop;
8665
 
8666
         elsif Ekind (T) = E_Array_Type then
8667
            if Has_Aliased_Components (T)
8668
              and then Has_Discriminants (Component_Type (T))
8669
              and then not Is_Constrained (Component_Type (T))
8670
              and then not In_Instance_Body
8671
              and then Ada_Version < Ada_05
8672
            then
8673
               Error_Msg_N
8674
                 ("aliased component type must be constrained (RM 3.6(11))",
8675
                    T);
8676
            end if;
8677
         end if;
8678
      end if;
8679
   end Check_Aliased_Component_Types;
8680
 
8681
   ----------------------
8682
   -- Check_Completion --
8683
   ----------------------
8684
 
8685
   procedure Check_Completion (Body_Id : Node_Id := Empty) is
8686
      E : Entity_Id;
8687
 
8688
      procedure Post_Error;
8689
      --  Post error message for lack of completion for entity E
8690
 
8691
      ----------------
8692
      -- Post_Error --
8693
      ----------------
8694
 
8695
      procedure Post_Error is
8696
 
8697
         procedure Missing_Body;
8698
         --  Output missing body message
8699
 
8700
         ------------------
8701
         -- Missing_Body --
8702
         ------------------
8703
 
8704
         procedure Missing_Body is
8705
         begin
8706
            --  Spec is in same unit, so we can post on spec
8707
 
8708
            if In_Same_Source_Unit (Body_Id, E) then
8709
               Error_Msg_N ("missing body for &", E);
8710
 
8711
            --  Spec is in a separate unit, so we have to post on the body
8712
 
8713
            else
8714
               Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
8715
            end if;
8716
         end Missing_Body;
8717
 
8718
      --  Start of processing for Post_Error
8719
 
8720
      begin
8721
         if not Comes_From_Source (E) then
8722
 
8723
            if Ekind (E) = E_Task_Type
8724
              or else Ekind (E) = E_Protected_Type
8725
            then
8726
               --  It may be an anonymous protected type created for a
8727
               --  single variable. Post error on variable, if present.
8728
 
8729
               declare
8730
                  Var : Entity_Id;
8731
 
8732
               begin
8733
                  Var := First_Entity (Current_Scope);
8734
                  while Present (Var) loop
8735
                     exit when Etype (Var) = E
8736
                       and then Comes_From_Source (Var);
8737
 
8738
                     Next_Entity (Var);
8739
                  end loop;
8740
 
8741
                  if Present (Var) then
8742
                     E := Var;
8743
                  end if;
8744
               end;
8745
            end if;
8746
         end if;
8747
 
8748
         --  If a generated entity has no completion, then either previous
8749
         --  semantic errors have disabled the expansion phase, or else we had
8750
         --  missing subunits, or else we are compiling without expansion,
8751
         --  or else something is very wrong.
8752
 
8753
         if not Comes_From_Source (E) then
8754
            pragma Assert
8755
              (Serious_Errors_Detected > 0
8756
                or else Configurable_Run_Time_Violations > 0
8757
                or else Subunits_Missing
8758
                or else not Expander_Active);
8759
            return;
8760
 
8761
         --  Here for source entity
8762
 
8763
         else
8764
            --  Here if no body to post the error message, so we post the error
8765
            --  on the declaration that has no completion. This is not really
8766
            --  the right place to post it, think about this later ???
8767
 
8768
            if No (Body_Id) then
8769
               if Is_Type (E) then
8770
                  Error_Msg_NE
8771
                    ("missing full declaration for }", Parent (E), E);
8772
               else
8773
                  Error_Msg_NE
8774
                    ("missing body for &", Parent (E), E);
8775
               end if;
8776
 
8777
            --  Package body has no completion for a declaration that appears
8778
            --  in the corresponding spec. Post error on the body, with a
8779
            --  reference to the non-completed declaration.
8780
 
8781
            else
8782
               Error_Msg_Sloc := Sloc (E);
8783
 
8784
               if Is_Type (E) then
8785
                  Error_Msg_NE
8786
                    ("missing full declaration for }!", Body_Id, E);
8787
 
8788
               elsif Is_Overloadable (E)
8789
                 and then Current_Entity_In_Scope (E) /= E
8790
               then
8791
                  --  It may be that the completion is mistyped and appears as
8792
                  --  a distinct overloading of the entity.
8793
 
8794
                  declare
8795
                     Candidate : constant Entity_Id :=
8796
                                   Current_Entity_In_Scope (E);
8797
                     Decl      : constant Node_Id :=
8798
                                   Unit_Declaration_Node (Candidate);
8799
 
8800
                  begin
8801
                     if Is_Overloadable (Candidate)
8802
                       and then Ekind (Candidate) = Ekind (E)
8803
                       and then Nkind (Decl) = N_Subprogram_Body
8804
                       and then Acts_As_Spec (Decl)
8805
                     then
8806
                        Check_Type_Conformant (Candidate, E);
8807
 
8808
                     else
8809
                        Missing_Body;
8810
                     end if;
8811
                  end;
8812
 
8813
               else
8814
                  Missing_Body;
8815
               end if;
8816
            end if;
8817
         end if;
8818
      end Post_Error;
8819
 
8820
   --  Start of processing for Check_Completion
8821
 
8822
   begin
8823
      E := First_Entity (Current_Scope);
8824
      while Present (E) loop
8825
         if Is_Intrinsic_Subprogram (E) then
8826
            null;
8827
 
8828
         --  The following situation requires special handling: a child unit
8829
         --  that appears in the context clause of the body of its parent:
8830
 
8831
         --    procedure Parent.Child (...);
8832
 
8833
         --    with Parent.Child;
8834
         --    package body Parent is
8835
 
8836
         --  Here Parent.Child appears as a local entity, but should not be
8837
         --  flagged as requiring completion, because it is a compilation
8838
         --  unit.
8839
 
8840
         --  Ignore missing completion for a subprogram that does not come from
8841
         --  source (including the _Call primitive operation of RAS types,
8842
         --  which has to have the flag Comes_From_Source for other purposes):
8843
         --  we assume that the expander will provide the missing completion.
8844
         --  In case of previous errors, other expansion actions that provide
8845
         --  bodies for null procedures with not be invoked, so inhibit message
8846
         --  in those cases.
8847
         --  Note that E_Operator is not in the list that follows, because
8848
         --  this kind is reserved for predefined operators, that are
8849
         --  intrinsic and do not need completion.
8850
 
8851
         elsif     Ekind (E) = E_Function
8852
           or else Ekind (E) = E_Procedure
8853
           or else Ekind (E) = E_Generic_Function
8854
           or else Ekind (E) = E_Generic_Procedure
8855
         then
8856
            if Has_Completion (E) then
8857
               null;
8858
 
8859
            elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
8860
               null;
8861
 
8862
            elsif Is_Subprogram (E)
8863
              and then (not Comes_From_Source (E)
8864
                          or else Chars (E) = Name_uCall)
8865
            then
8866
               null;
8867
 
8868
            elsif
8869
               Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
8870
            then
8871
               null;
8872
 
8873
            elsif Nkind (Parent (E)) = N_Procedure_Specification
8874
              and then Null_Present (Parent (E))
8875
              and then Serious_Errors_Detected > 0
8876
            then
8877
               null;
8878
 
8879
            else
8880
               Post_Error;
8881
            end if;
8882
 
8883
         elsif Is_Entry (E) then
8884
            if not Has_Completion (E) and then
8885
              (Ekind (Scope (E)) = E_Protected_Object
8886
                or else Ekind (Scope (E)) = E_Protected_Type)
8887
            then
8888
               Post_Error;
8889
            end if;
8890
 
8891
         elsif Is_Package_Or_Generic_Package (E) then
8892
            if Unit_Requires_Body (E) then
8893
               if not Has_Completion (E)
8894
                 and then Nkind (Parent (Unit_Declaration_Node (E))) /=
8895
                                                       N_Compilation_Unit
8896
               then
8897
                  Post_Error;
8898
               end if;
8899
 
8900
            elsif not Is_Child_Unit (E) then
8901
               May_Need_Implicit_Body (E);
8902
            end if;
8903
 
8904
         elsif Ekind (E) = E_Incomplete_Type
8905
           and then No (Underlying_Type (E))
8906
         then
8907
            Post_Error;
8908
 
8909
         elsif (Ekind (E) = E_Task_Type or else
8910
                Ekind (E) = E_Protected_Type)
8911
           and then not Has_Completion (E)
8912
         then
8913
            Post_Error;
8914
 
8915
         --  A single task declared in the current scope is a constant, verify
8916
         --  that the body of its anonymous type is in the same scope. If the
8917
         --  task is defined elsewhere, this may be a renaming declaration for
8918
         --  which no completion is needed.
8919
 
8920
         elsif Ekind (E) = E_Constant
8921
           and then Ekind (Etype (E)) = E_Task_Type
8922
           and then not Has_Completion (Etype (E))
8923
           and then Scope (Etype (E)) = Current_Scope
8924
         then
8925
            Post_Error;
8926
 
8927
         elsif Ekind (E) = E_Protected_Object
8928
           and then not Has_Completion (Etype (E))
8929
         then
8930
            Post_Error;
8931
 
8932
         elsif Ekind (E) = E_Record_Type then
8933
            if Is_Tagged_Type (E) then
8934
               Check_Abstract_Overriding (E);
8935
               Check_Conventions (E);
8936
            end if;
8937
 
8938
            Check_Aliased_Component_Types (E);
8939
 
8940
         elsif Ekind (E) = E_Array_Type then
8941
            Check_Aliased_Component_Types (E);
8942
 
8943
         end if;
8944
 
8945
         Next_Entity (E);
8946
      end loop;
8947
   end Check_Completion;
8948
 
8949
   ----------------------------
8950
   -- Check_Delta_Expression --
8951
   ----------------------------
8952
 
8953
   procedure Check_Delta_Expression (E : Node_Id) is
8954
   begin
8955
      if not (Is_Real_Type (Etype (E))) then
8956
         Wrong_Type (E, Any_Real);
8957
 
8958
      elsif not Is_OK_Static_Expression (E) then
8959
         Flag_Non_Static_Expr
8960
           ("non-static expression used for delta value!", E);
8961
 
8962
      elsif not UR_Is_Positive (Expr_Value_R (E)) then
8963
         Error_Msg_N ("delta expression must be positive", E);
8964
 
8965
      else
8966
         return;
8967
      end if;
8968
 
8969
      --  If any of above errors occurred, then replace the incorrect
8970
      --  expression by the real 0.1, which should prevent further errors.
8971
 
8972
      Rewrite (E,
8973
        Make_Real_Literal (Sloc (E), Ureal_Tenth));
8974
      Analyze_And_Resolve (E, Standard_Float);
8975
   end Check_Delta_Expression;
8976
 
8977
   -----------------------------
8978
   -- Check_Digits_Expression --
8979
   -----------------------------
8980
 
8981
   procedure Check_Digits_Expression (E : Node_Id) is
8982
   begin
8983
      if not (Is_Integer_Type (Etype (E))) then
8984
         Wrong_Type (E, Any_Integer);
8985
 
8986
      elsif not Is_OK_Static_Expression (E) then
8987
         Flag_Non_Static_Expr
8988
           ("non-static expression used for digits value!", E);
8989
 
8990
      elsif Expr_Value (E) <= 0 then
8991
         Error_Msg_N ("digits value must be greater than zero", E);
8992
 
8993
      else
8994
         return;
8995
      end if;
8996
 
8997
      --  If any of above errors occurred, then replace the incorrect
8998
      --  expression by the integer 1, which should prevent further errors.
8999
 
9000
      Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
9001
      Analyze_And_Resolve (E, Standard_Integer);
9002
 
9003
   end Check_Digits_Expression;
9004
 
9005
   --------------------------
9006
   -- Check_Initialization --
9007
   --------------------------
9008
 
9009
   procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
9010
   begin
9011
      if Is_Limited_Type (T)
9012
        and then not In_Instance
9013
        and then not In_Inlined_Body
9014
      then
9015
         if not OK_For_Limited_Init (T, Exp) then
9016
 
9017
            --  In GNAT mode, this is just a warning, to allow it to be evilly
9018
            --  turned off. Otherwise it is a real error.
9019
 
9020
            if GNAT_Mode then
9021
               Error_Msg_N
9022
                 ("?cannot initialize entities of limited type!", Exp);
9023
 
9024
            elsif Ada_Version < Ada_05 then
9025
               Error_Msg_N
9026
                 ("cannot initialize entities of limited type", Exp);
9027
               Explain_Limited_Type (T, Exp);
9028
 
9029
            else
9030
               --  Specialize error message according to kind of illegal
9031
               --  initial expression.
9032
 
9033
               if Nkind (Exp) = N_Type_Conversion
9034
                 and then Nkind (Expression (Exp)) = N_Function_Call
9035
               then
9036
                  Error_Msg_N
9037
                    ("illegal context for call"
9038
                      & " to function with limited result", Exp);
9039
 
9040
               else
9041
                  Error_Msg_N
9042
                    ("initialization of limited object requires aggregate "
9043
                      & "or function call",  Exp);
9044
               end if;
9045
            end if;
9046
         end if;
9047
      end if;
9048
   end Check_Initialization;
9049
 
9050
   ----------------------
9051
   -- Check_Interfaces --
9052
   ----------------------
9053
 
9054
   procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
9055
      Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
9056
 
9057
      Iface       : Node_Id;
9058
      Iface_Def   : Node_Id;
9059
      Iface_Typ   : Entity_Id;
9060
      Parent_Node : Node_Id;
9061
 
9062
      Is_Task : Boolean := False;
9063
      --  Set True if parent type or any progenitor is a task interface
9064
 
9065
      Is_Protected : Boolean := False;
9066
      --  Set True if parent type or any progenitor is a protected interface
9067
 
9068
      procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
9069
      --  Check that a progenitor is compatible with declaration.
9070
      --  Error is posted on Error_Node.
9071
 
9072
      ------------------
9073
      -- Check_Ifaces --
9074
      ------------------
9075
 
9076
      procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
9077
         Iface_Id : constant Entity_Id :=
9078
                      Defining_Identifier (Parent (Iface_Def));
9079
         Type_Def : Node_Id;
9080
 
9081
      begin
9082
         if Nkind (N) = N_Private_Extension_Declaration then
9083
            Type_Def := N;
9084
         else
9085
            Type_Def := Type_Definition (N);
9086
         end if;
9087
 
9088
         if Is_Task_Interface (Iface_Id) then
9089
            Is_Task := True;
9090
 
9091
         elsif Is_Protected_Interface (Iface_Id) then
9092
            Is_Protected := True;
9093
         end if;
9094
 
9095
         if Is_Synchronized_Interface (Iface_Id) then
9096
 
9097
            --  A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
9098
            --  extension derived from a synchronized interface must explicitly
9099
            --  be declared synchronized, because the full view will be a
9100
            --  synchronized type.
9101
 
9102
            if Nkind (N) = N_Private_Extension_Declaration then
9103
               if not Synchronized_Present (N) then
9104
                  Error_Msg_NE
9105
                    ("private extension of& must be explicitly synchronized",
9106
                      N, Iface_Id);
9107
               end if;
9108
 
9109
            --  However, by 3.9.4(16/2), a full type that is a record extension
9110
            --  is never allowed to derive from a synchronized interface (note
9111
            --  that interfaces must be excluded from this check, because those
9112
            --  are represented by derived type definitions in some cases).
9113
 
9114
            elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
9115
              and then not Interface_Present (Type_Definition (N))
9116
            then
9117
               Error_Msg_N ("record extension cannot derive from synchronized"
9118
                             & " interface", Error_Node);
9119
            end if;
9120
         end if;
9121
 
9122
         --  Check that the characteristics of the progenitor are compatible
9123
         --  with the explicit qualifier in the declaration.
9124
         --  The check only applies to qualifiers that come from source.
9125
         --  Limited_Present also appears in the declaration of corresponding
9126
         --  records, and the check does not apply to them.
9127
 
9128
         if Limited_Present (Type_Def)
9129
           and then not
9130
             Is_Concurrent_Record_Type (Defining_Identifier (N))
9131
         then
9132
            if Is_Limited_Interface (Parent_Type)
9133
              and then not Is_Limited_Interface (Iface_Id)
9134
            then
9135
               Error_Msg_NE
9136
                 ("progenitor& must be limited interface",
9137
                   Error_Node, Iface_Id);
9138
 
9139
            elsif
9140
              (Task_Present (Iface_Def)
9141
                or else Protected_Present (Iface_Def)
9142
                or else Synchronized_Present (Iface_Def))
9143
              and then Nkind (N) /= N_Private_Extension_Declaration
9144
              and then not Error_Posted (N)
9145
            then
9146
               Error_Msg_NE
9147
                 ("progenitor& must be limited interface",
9148
                   Error_Node, Iface_Id);
9149
            end if;
9150
 
9151
         --  Protected interfaces can only inherit from limited, synchronized
9152
         --  or protected interfaces.
9153
 
9154
         elsif Nkind (N) = N_Full_Type_Declaration
9155
           and then  Protected_Present (Type_Def)
9156
         then
9157
            if Limited_Present (Iface_Def)
9158
              or else Synchronized_Present (Iface_Def)
9159
              or else Protected_Present (Iface_Def)
9160
            then
9161
               null;
9162
 
9163
            elsif Task_Present (Iface_Def) then
9164
               Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
9165
                            & " from task interface", Error_Node);
9166
 
9167
            else
9168
               Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
9169
                            & " from non-limited interface", Error_Node);
9170
            end if;
9171
 
9172
         --  Ada 2005 (AI-345): Synchronized interfaces can only inherit from
9173
         --  limited and synchronized.
9174
 
9175
         elsif Synchronized_Present (Type_Def) then
9176
            if Limited_Present (Iface_Def)
9177
              or else Synchronized_Present (Iface_Def)
9178
            then
9179
               null;
9180
 
9181
            elsif Protected_Present (Iface_Def)
9182
              and then Nkind (N) /= N_Private_Extension_Declaration
9183
            then
9184
               Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
9185
                            & " from protected interface", Error_Node);
9186
 
9187
            elsif Task_Present (Iface_Def)
9188
              and then Nkind (N) /= N_Private_Extension_Declaration
9189
            then
9190
               Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
9191
                            & " from task interface", Error_Node);
9192
 
9193
            elsif not Is_Limited_Interface (Iface_Id) then
9194
               Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
9195
                            & " from non-limited interface", Error_Node);
9196
            end if;
9197
 
9198
         --  Ada 2005 (AI-345): Task interfaces can only inherit from limited,
9199
         --  synchronized or task interfaces.
9200
 
9201
         elsif Nkind (N) = N_Full_Type_Declaration
9202
           and then Task_Present (Type_Def)
9203
         then
9204
            if Limited_Present (Iface_Def)
9205
              or else Synchronized_Present (Iface_Def)
9206
              or else Task_Present (Iface_Def)
9207
            then
9208
               null;
9209
 
9210
            elsif Protected_Present (Iface_Def) then
9211
               Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
9212
                            & " protected interface", Error_Node);
9213
 
9214
            else
9215
               Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
9216
                            & " non-limited interface", Error_Node);
9217
            end if;
9218
         end if;
9219
      end Check_Ifaces;
9220
 
9221
   --  Start of processing for Check_Interfaces
9222
 
9223
   begin
9224
      if Is_Interface (Parent_Type) then
9225
         if Is_Task_Interface (Parent_Type) then
9226
            Is_Task := True;
9227
 
9228
         elsif Is_Protected_Interface (Parent_Type) then
9229
            Is_Protected := True;
9230
         end if;
9231
      end if;
9232
 
9233
      if Nkind (N) = N_Private_Extension_Declaration then
9234
 
9235
         --  Check that progenitors are compatible with declaration
9236
 
9237
         Iface := First (Interface_List (Def));
9238
         while Present (Iface) loop
9239
            Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
9240
 
9241
            Parent_Node := Parent (Base_Type (Iface_Typ));
9242
            Iface_Def   := Type_Definition (Parent_Node);
9243
 
9244
            if not Is_Interface (Iface_Typ) then
9245
               Diagnose_Interface (Iface, Iface_Typ);
9246
 
9247
            else
9248
               Check_Ifaces (Iface_Def, Iface);
9249
            end if;
9250
 
9251
            Next (Iface);
9252
         end loop;
9253
 
9254
         if Is_Task and Is_Protected then
9255
            Error_Msg_N
9256
              ("type cannot derive from task and protected interface", N);
9257
         end if;
9258
 
9259
         return;
9260
      end if;
9261
 
9262
      --  Full type declaration of derived type.
9263
      --  Check compatibility with parent if it is interface type
9264
 
9265
      if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
9266
        and then Is_Interface (Parent_Type)
9267
      then
9268
         Parent_Node := Parent (Parent_Type);
9269
 
9270
         --  More detailed checks for interface varieties
9271
 
9272
         Check_Ifaces
9273
           (Iface_Def  => Type_Definition (Parent_Node),
9274
            Error_Node => Subtype_Indication (Type_Definition (N)));
9275
      end if;
9276
 
9277
      Iface := First (Interface_List (Def));
9278
      while Present (Iface) loop
9279
         Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
9280
 
9281
         Parent_Node := Parent (Base_Type (Iface_Typ));
9282
         Iface_Def   := Type_Definition (Parent_Node);
9283
 
9284
         if not Is_Interface (Iface_Typ) then
9285
            Diagnose_Interface (Iface, Iface_Typ);
9286
 
9287
         else
9288
            --  "The declaration of a specific descendant of an interface
9289
            --   type freezes the interface type" RM 13.14
9290
 
9291
            Freeze_Before (N, Iface_Typ);
9292
            Check_Ifaces (Iface_Def, Error_Node => Iface);
9293
         end if;
9294
 
9295
         Next (Iface);
9296
      end loop;
9297
 
9298
      if Is_Task and Is_Protected then
9299
         Error_Msg_N
9300
           ("type cannot derive from task and protected interface", N);
9301
      end if;
9302
   end Check_Interfaces;
9303
 
9304
   ------------------------------------
9305
   -- Check_Or_Process_Discriminants --
9306
   ------------------------------------
9307
 
9308
   --  If an incomplete or private type declaration was already given for the
9309
   --  type, the discriminants may have already been processed if they were
9310
   --  present on the incomplete declaration. In this case a full conformance
9311
   --  check is performed otherwise just process them.
9312
 
9313
   procedure Check_Or_Process_Discriminants
9314
     (N    : Node_Id;
9315
      T    : Entity_Id;
9316
      Prev : Entity_Id := Empty)
9317
   is
9318
   begin
9319
      if Has_Discriminants (T) then
9320
 
9321
         --  Make the discriminants visible to component declarations
9322
 
9323
         declare
9324
            D    : Entity_Id;
9325
            Prev : Entity_Id;
9326
 
9327
         begin
9328
            D := First_Discriminant (T);
9329
            while Present (D) loop
9330
               Prev := Current_Entity (D);
9331
               Set_Current_Entity (D);
9332
               Set_Is_Immediately_Visible (D);
9333
               Set_Homonym (D, Prev);
9334
 
9335
               --  Ada 2005 (AI-230): Access discriminant allowed in
9336
               --  non-limited record types.
9337
 
9338
               if Ada_Version < Ada_05 then
9339
 
9340
                  --  This restriction gets applied to the full type here. It
9341
                  --  has already been applied earlier to the partial view.
9342
 
9343
                  Check_Access_Discriminant_Requires_Limited (Parent (D), N);
9344
               end if;
9345
 
9346
               Next_Discriminant (D);
9347
            end loop;
9348
         end;
9349
 
9350
      elsif Present (Discriminant_Specifications (N)) then
9351
         Process_Discriminants (N, Prev);
9352
      end if;
9353
   end Check_Or_Process_Discriminants;
9354
 
9355
   ----------------------
9356
   -- Check_Real_Bound --
9357
   ----------------------
9358
 
9359
   procedure Check_Real_Bound (Bound : Node_Id) is
9360
   begin
9361
      if not Is_Real_Type (Etype (Bound)) then
9362
         Error_Msg_N
9363
           ("bound in real type definition must be of real type", Bound);
9364
 
9365
      elsif not Is_OK_Static_Expression (Bound) then
9366
         Flag_Non_Static_Expr
9367
           ("non-static expression used for real type bound!", Bound);
9368
 
9369
      else
9370
         return;
9371
      end if;
9372
 
9373
      Rewrite
9374
        (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
9375
      Analyze (Bound);
9376
      Resolve (Bound, Standard_Float);
9377
   end Check_Real_Bound;
9378
 
9379
   ------------------------------
9380
   -- Complete_Private_Subtype --
9381
   ------------------------------
9382
 
9383
   procedure Complete_Private_Subtype
9384
     (Priv        : Entity_Id;
9385
      Full        : Entity_Id;
9386
      Full_Base   : Entity_Id;
9387
      Related_Nod : Node_Id)
9388
   is
9389
      Save_Next_Entity : Entity_Id;
9390
      Save_Homonym     : Entity_Id;
9391
 
9392
   begin
9393
      --  Set semantic attributes for (implicit) private subtype completion.
9394
      --  If the full type has no discriminants, then it is a copy of the full
9395
      --  view of the base. Otherwise, it is a subtype of the base with a
9396
      --  possible discriminant constraint. Save and restore the original
9397
      --  Next_Entity field of full to ensure that the calls to Copy_Node
9398
      --  do not corrupt the entity chain.
9399
 
9400
      --  Note that the type of the full view is the same entity as the type of
9401
      --  the partial view. In this fashion, the subtype has access to the
9402
      --  correct view of the parent.
9403
 
9404
      Save_Next_Entity := Next_Entity (Full);
9405
      Save_Homonym     := Homonym (Priv);
9406
 
9407
      case Ekind (Full_Base) is
9408
         when E_Record_Type    |
9409
              E_Record_Subtype |
9410
              Class_Wide_Kind  |
9411
              Private_Kind     |
9412
              Task_Kind        |
9413
              Protected_Kind   =>
9414
            Copy_Node (Priv, Full);
9415
 
9416
            Set_Has_Discriminants  (Full, Has_Discriminants (Full_Base));
9417
            Set_First_Entity       (Full, First_Entity (Full_Base));
9418
            Set_Last_Entity        (Full, Last_Entity (Full_Base));
9419
 
9420
         when others =>
9421
            Copy_Node (Full_Base, Full);
9422
            Set_Chars          (Full, Chars (Priv));
9423
            Conditional_Delay  (Full, Priv);
9424
            Set_Sloc           (Full, Sloc (Priv));
9425
      end case;
9426
 
9427
      Set_Next_Entity (Full, Save_Next_Entity);
9428
      Set_Homonym     (Full, Save_Homonym);
9429
      Set_Associated_Node_For_Itype (Full, Related_Nod);
9430
 
9431
      --  Set common attributes for all subtypes
9432
 
9433
      Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
9434
 
9435
      --  The Etype of the full view is inconsistent. Gigi needs to see the
9436
      --  structural full view,  which is what the current scheme gives:
9437
      --  the Etype of the full view is the etype of the full base. However,
9438
      --  if the full base is a derived type, the full view then looks like
9439
      --  a subtype of the parent, not a subtype of the full base. If instead
9440
      --  we write:
9441
 
9442
      --       Set_Etype (Full, Full_Base);
9443
 
9444
      --  then we get inconsistencies in the front-end (confusion between
9445
      --  views). Several outstanding bugs are related to this ???
9446
 
9447
      Set_Is_First_Subtype (Full, False);
9448
      Set_Scope            (Full, Scope (Priv));
9449
      Set_Size_Info        (Full, Full_Base);
9450
      Set_RM_Size          (Full, RM_Size (Full_Base));
9451
      Set_Is_Itype         (Full);
9452
 
9453
      --  A subtype of a private-type-without-discriminants, whose full-view
9454
      --  has discriminants with default expressions, is not constrained!
9455
 
9456
      if not Has_Discriminants (Priv) then
9457
         Set_Is_Constrained (Full, Is_Constrained (Full_Base));
9458
 
9459
         if Has_Discriminants (Full_Base) then
9460
            Set_Discriminant_Constraint
9461
              (Full, Discriminant_Constraint (Full_Base));
9462
 
9463
            --  The partial view may have been indefinite, the full view
9464
            --  might not be.
9465
 
9466
            Set_Has_Unknown_Discriminants
9467
              (Full, Has_Unknown_Discriminants (Full_Base));
9468
         end if;
9469
      end if;
9470
 
9471
      Set_First_Rep_Item     (Full, First_Rep_Item (Full_Base));
9472
      Set_Depends_On_Private (Full, Has_Private_Component (Full));
9473
 
9474
      --  Freeze the private subtype entity if its parent is delayed, and not
9475
      --  already frozen. We skip this processing if the type is an anonymous
9476
      --  subtype of a record component, or is the corresponding record of a
9477
      --  protected type, since ???
9478
 
9479
      if not Is_Type (Scope (Full)) then
9480
         Set_Has_Delayed_Freeze (Full,
9481
           Has_Delayed_Freeze (Full_Base)
9482
             and then (not Is_Frozen (Full_Base)));
9483
      end if;
9484
 
9485
      Set_Freeze_Node (Full, Empty);
9486
      Set_Is_Frozen (Full, False);
9487
      Set_Full_View (Priv, Full);
9488
 
9489
      if Has_Discriminants (Full) then
9490
         Set_Stored_Constraint_From_Discriminant_Constraint (Full);
9491
         Set_Stored_Constraint (Priv, Stored_Constraint (Full));
9492
 
9493
         if Has_Unknown_Discriminants (Full) then
9494
            Set_Discriminant_Constraint (Full, No_Elist);
9495
         end if;
9496
      end if;
9497
 
9498
      if Ekind (Full_Base) = E_Record_Type
9499
        and then Has_Discriminants (Full_Base)
9500
        and then Has_Discriminants (Priv) -- might not, if errors
9501
        and then not Has_Unknown_Discriminants (Priv)
9502
        and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
9503
      then
9504
         Create_Constrained_Components
9505
           (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
9506
 
9507
      --  If the full base is itself derived from private, build a congruent
9508
      --  subtype of its underlying type, for use by the back end. For a
9509
      --  constrained record component, the declaration cannot be placed on
9510
      --  the component list, but it must nevertheless be built an analyzed, to
9511
      --  supply enough information for Gigi to compute the size of component.
9512
 
9513
      elsif Ekind (Full_Base) in Private_Kind
9514
        and then Is_Derived_Type (Full_Base)
9515
        and then Has_Discriminants (Full_Base)
9516
        and then (Ekind (Current_Scope) /= E_Record_Subtype)
9517
      then
9518
         if not Is_Itype (Priv)
9519
           and then
9520
             Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
9521
         then
9522
            Build_Underlying_Full_View
9523
              (Parent (Priv), Full, Etype (Full_Base));
9524
 
9525
         elsif Nkind (Related_Nod) = N_Component_Declaration then
9526
            Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
9527
         end if;
9528
 
9529
      elsif Is_Record_Type (Full_Base) then
9530
 
9531
         --  Show Full is simply a renaming of Full_Base
9532
 
9533
         Set_Cloned_Subtype (Full, Full_Base);
9534
      end if;
9535
 
9536
      --  It is unsafe to share to bounds of a scalar type, because the Itype
9537
      --  is elaborated on demand, and if a bound is non-static then different
9538
      --  orders of elaboration in different units will lead to different
9539
      --  external symbols.
9540
 
9541
      if Is_Scalar_Type (Full_Base) then
9542
         Set_Scalar_Range (Full,
9543
           Make_Range (Sloc (Related_Nod),
9544
             Low_Bound  =>
9545
               Duplicate_Subexpr_No_Checks (Type_Low_Bound  (Full_Base)),
9546
             High_Bound =>
9547
               Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
9548
 
9549
         --  This completion inherits the bounds of the full parent, but if
9550
         --  the parent is an unconstrained floating point type, so is the
9551
         --  completion.
9552
 
9553
         if Is_Floating_Point_Type (Full_Base) then
9554
            Set_Includes_Infinities
9555
             (Scalar_Range (Full), Has_Infinities (Full_Base));
9556
         end if;
9557
      end if;
9558
 
9559
      --  ??? It seems that a lot of fields are missing that should be copied
9560
      --  from Full_Base to Full. Here are some that are introduced in a
9561
      --  non-disruptive way but a cleanup is necessary.
9562
 
9563
      if Is_Tagged_Type (Full_Base) then
9564
         Set_Is_Tagged_Type (Full);
9565
         Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
9566
         Set_Class_Wide_Type      (Full, Class_Wide_Type (Full_Base));
9567
 
9568
      --  If this is a subtype of a protected or task type, constrain its
9569
      --  corresponding record, unless this is a subtype without constraints,
9570
      --  i.e. a simple renaming as with an actual subtype in an instance.
9571
 
9572
      elsif Is_Concurrent_Type (Full_Base) then
9573
         if Has_Discriminants (Full)
9574
           and then Present (Corresponding_Record_Type (Full_Base))
9575
           and then
9576
             not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
9577
         then
9578
            Set_Corresponding_Record_Type (Full,
9579
              Constrain_Corresponding_Record
9580
                (Full, Corresponding_Record_Type (Full_Base),
9581
                  Related_Nod, Full_Base));
9582
 
9583
         else
9584
            Set_Corresponding_Record_Type (Full,
9585
              Corresponding_Record_Type (Full_Base));
9586
         end if;
9587
      end if;
9588
   end Complete_Private_Subtype;
9589
 
9590
   ----------------------------
9591
   -- Constant_Redeclaration --
9592
   ----------------------------
9593
 
9594
   procedure Constant_Redeclaration
9595
     (Id : Entity_Id;
9596
      N  : Node_Id;
9597
      T  : out Entity_Id)
9598
   is
9599
      Prev    : constant Entity_Id := Current_Entity_In_Scope (Id);
9600
      Obj_Def : constant Node_Id := Object_Definition (N);
9601
      New_T   : Entity_Id;
9602
 
9603
      procedure Check_Possible_Deferred_Completion
9604
        (Prev_Id      : Entity_Id;
9605
         Prev_Obj_Def : Node_Id;
9606
         Curr_Obj_Def : Node_Id);
9607
      --  Determine whether the two object definitions describe the partial
9608
      --  and the full view of a constrained deferred constant. Generate
9609
      --  a subtype for the full view and verify that it statically matches
9610
      --  the subtype of the partial view.
9611
 
9612
      procedure Check_Recursive_Declaration (Typ : Entity_Id);
9613
      --  If deferred constant is an access type initialized with an allocator,
9614
      --  check whether there is an illegal recursion in the definition,
9615
      --  through a default value of some record subcomponent. This is normally
9616
      --  detected when generating init procs, but requires this additional
9617
      --  mechanism when expansion is disabled.
9618
 
9619
      ----------------------------------------
9620
      -- Check_Possible_Deferred_Completion --
9621
      ----------------------------------------
9622
 
9623
      procedure Check_Possible_Deferred_Completion
9624
        (Prev_Id      : Entity_Id;
9625
         Prev_Obj_Def : Node_Id;
9626
         Curr_Obj_Def : Node_Id)
9627
      is
9628
      begin
9629
         if Nkind (Prev_Obj_Def) = N_Subtype_Indication
9630
           and then Present (Constraint (Prev_Obj_Def))
9631
           and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
9632
           and then Present (Constraint (Curr_Obj_Def))
9633
         then
9634
            declare
9635
               Loc    : constant Source_Ptr := Sloc (N);
9636
               Def_Id : constant Entity_Id :=
9637
                          Make_Defining_Identifier (Loc,
9638
                            New_Internal_Name ('S'));
9639
               Decl   : constant Node_Id :=
9640
                          Make_Subtype_Declaration (Loc,
9641
                            Defining_Identifier =>
9642
                              Def_Id,
9643
                            Subtype_Indication =>
9644
                              Relocate_Node (Curr_Obj_Def));
9645
 
9646
            begin
9647
               Insert_Before_And_Analyze (N, Decl);
9648
               Set_Etype (Id, Def_Id);
9649
 
9650
               if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
9651
                  Error_Msg_Sloc := Sloc (Prev_Id);
9652
                  Error_Msg_N ("subtype does not statically match deferred " &
9653
                               "declaration#", N);
9654
               end if;
9655
            end;
9656
         end if;
9657
      end Check_Possible_Deferred_Completion;
9658
 
9659
      ---------------------------------
9660
      -- Check_Recursive_Declaration --
9661
      ---------------------------------
9662
 
9663
      procedure Check_Recursive_Declaration (Typ : Entity_Id) is
9664
         Comp : Entity_Id;
9665
 
9666
      begin
9667
         if Is_Record_Type (Typ) then
9668
            Comp := First_Component (Typ);
9669
            while Present (Comp) loop
9670
               if Comes_From_Source (Comp) then
9671
                  if Present (Expression (Parent (Comp)))
9672
                    and then Is_Entity_Name (Expression (Parent (Comp)))
9673
                    and then Entity (Expression (Parent (Comp))) = Prev
9674
                  then
9675
                     Error_Msg_Sloc := Sloc (Parent (Comp));
9676
                     Error_Msg_NE
9677
                       ("illegal circularity with declaration for&#",
9678
                         N, Comp);
9679
                     return;
9680
 
9681
                  elsif Is_Record_Type (Etype (Comp)) then
9682
                     Check_Recursive_Declaration (Etype (Comp));
9683
                  end if;
9684
               end if;
9685
 
9686
               Next_Component (Comp);
9687
            end loop;
9688
         end if;
9689
      end Check_Recursive_Declaration;
9690
 
9691
   --  Start of processing for Constant_Redeclaration
9692
 
9693
   begin
9694
      if Nkind (Parent (Prev)) = N_Object_Declaration then
9695
         if Nkind (Object_Definition
9696
                     (Parent (Prev))) = N_Subtype_Indication
9697
         then
9698
            --  Find type of new declaration. The constraints of the two
9699
            --  views must match statically, but there is no point in
9700
            --  creating an itype for the full view.
9701
 
9702
            if Nkind (Obj_Def) = N_Subtype_Indication then
9703
               Find_Type (Subtype_Mark (Obj_Def));
9704
               New_T := Entity (Subtype_Mark (Obj_Def));
9705
 
9706
            else
9707
               Find_Type (Obj_Def);
9708
               New_T := Entity (Obj_Def);
9709
            end if;
9710
 
9711
            T := Etype (Prev);
9712
 
9713
         else
9714
            --  The full view may impose a constraint, even if the partial
9715
            --  view does not, so construct the subtype.
9716
 
9717
            New_T := Find_Type_Of_Object (Obj_Def, N);
9718
            T     := New_T;
9719
         end if;
9720
 
9721
      else
9722
         --  Current declaration is illegal, diagnosed below in Enter_Name
9723
 
9724
         T := Empty;
9725
         New_T := Any_Type;
9726
      end if;
9727
 
9728
      --  If previous full declaration or a renaming declaration exists, or if
9729
      --  a homograph is present, let Enter_Name handle it, either with an
9730
      --  error or with the removal of an overridden implicit subprogram.
9731
 
9732
      if Ekind (Prev) /= E_Constant
9733
        or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
9734
        or else Present (Expression (Parent (Prev)))
9735
        or else Present (Full_View (Prev))
9736
      then
9737
         Enter_Name (Id);
9738
 
9739
      --  Verify that types of both declarations match, or else that both types
9740
      --  are anonymous access types whose designated subtypes statically match
9741
      --  (as allowed in Ada 2005 by AI-385).
9742
 
9743
      elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
9744
        and then
9745
          (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
9746
             or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
9747
             or else Is_Access_Constant (Etype (New_T)) /=
9748
                     Is_Access_Constant (Etype (Prev))
9749
             or else Can_Never_Be_Null (Etype (New_T)) /=
9750
                     Can_Never_Be_Null (Etype (Prev))
9751
             or else Null_Exclusion_Present (Parent (Prev)) /=
9752
                     Null_Exclusion_Present (Parent (Id))
9753
             or else not Subtypes_Statically_Match
9754
                           (Designated_Type (Etype (Prev)),
9755
                            Designated_Type (Etype (New_T))))
9756
      then
9757
         Error_Msg_Sloc := Sloc (Prev);
9758
         Error_Msg_N ("type does not match declaration#", N);
9759
         Set_Full_View (Prev, Id);
9760
         Set_Etype (Id, Any_Type);
9761
 
9762
      elsif
9763
        Null_Exclusion_Present (Parent (Prev))
9764
          and then not Null_Exclusion_Present (N)
9765
      then
9766
         Error_Msg_Sloc := Sloc (Prev);
9767
         Error_Msg_N ("null-exclusion does not match declaration#", N);
9768
         Set_Full_View (Prev, Id);
9769
         Set_Etype (Id, Any_Type);
9770
 
9771
      --  If so, process the full constant declaration
9772
 
9773
      else
9774
         --  RM 7.4 (6): If the subtype defined by the subtype_indication in
9775
         --  the deferred declaration is constrained, then the subtype defined
9776
         --  by the subtype_indication in the full declaration shall match it
9777
         --  statically.
9778
 
9779
         Check_Possible_Deferred_Completion
9780
           (Prev_Id      => Prev,
9781
            Prev_Obj_Def => Object_Definition (Parent (Prev)),
9782
            Curr_Obj_Def => Obj_Def);
9783
 
9784
         Set_Full_View (Prev, Id);
9785
         Set_Is_Public (Id, Is_Public (Prev));
9786
         Set_Is_Internal (Id);
9787
         Append_Entity (Id, Current_Scope);
9788
 
9789
         --  Check ALIASED present if present before (RM 7.4(7))
9790
 
9791
         if Is_Aliased (Prev)
9792
           and then not Aliased_Present (N)
9793
         then
9794
            Error_Msg_Sloc := Sloc (Prev);
9795
            Error_Msg_N ("ALIASED required (see declaration#)", N);
9796
         end if;
9797
 
9798
         --  Check that placement is in private part and that the incomplete
9799
         --  declaration appeared in the visible part.
9800
 
9801
         if Ekind (Current_Scope) = E_Package
9802
           and then not In_Private_Part (Current_Scope)
9803
         then
9804
            Error_Msg_Sloc := Sloc (Prev);
9805
            Error_Msg_N ("full constant for declaration#"
9806
                         & " must be in private part", N);
9807
 
9808
         elsif Ekind (Current_Scope) = E_Package
9809
           and then List_Containing (Parent (Prev))
9810
           /= Visible_Declarations
9811
             (Specification (Unit_Declaration_Node (Current_Scope)))
9812
         then
9813
            Error_Msg_N
9814
              ("deferred constant must be declared in visible part",
9815
                 Parent (Prev));
9816
         end if;
9817
 
9818
         if Is_Access_Type (T)
9819
           and then Nkind (Expression (N)) = N_Allocator
9820
         then
9821
            Check_Recursive_Declaration (Designated_Type (T));
9822
         end if;
9823
      end if;
9824
   end Constant_Redeclaration;
9825
 
9826
   ----------------------
9827
   -- Constrain_Access --
9828
   ----------------------
9829
 
9830
   procedure Constrain_Access
9831
     (Def_Id      : in out Entity_Id;
9832
      S           : Node_Id;
9833
      Related_Nod : Node_Id)
9834
   is
9835
      T             : constant Entity_Id := Entity (Subtype_Mark (S));
9836
      Desig_Type    : constant Entity_Id := Designated_Type (T);
9837
      Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
9838
      Constraint_OK : Boolean := True;
9839
 
9840
      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean;
9841
      --  Simple predicate to test for defaulted discriminants
9842
      --  Shouldn't this be in sem_util???
9843
 
9844
      ---------------------------------
9845
      -- Has_Defaulted_Discriminants --
9846
      ---------------------------------
9847
 
9848
      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
9849
      begin
9850
         return Has_Discriminants (Typ)
9851
          and then Present (First_Discriminant (Typ))
9852
          and then Present
9853
            (Discriminant_Default_Value (First_Discriminant (Typ)));
9854
      end Has_Defaulted_Discriminants;
9855
 
9856
   --  Start of processing for Constrain_Access
9857
 
9858
   begin
9859
      if Is_Array_Type (Desig_Type) then
9860
         Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
9861
 
9862
      elsif (Is_Record_Type (Desig_Type)
9863
              or else Is_Incomplete_Or_Private_Type (Desig_Type))
9864
        and then not Is_Constrained (Desig_Type)
9865
      then
9866
         --  ??? The following code is a temporary kludge to ignore a
9867
         --  discriminant constraint on access type if it is constraining
9868
         --  the current record. Avoid creating the implicit subtype of the
9869
         --  record we are currently compiling since right now, we cannot
9870
         --  handle these. For now, just return the access type itself.
9871
 
9872
         if Desig_Type = Current_Scope
9873
           and then No (Def_Id)
9874
         then
9875
            Set_Ekind (Desig_Subtype, E_Record_Subtype);
9876
            Def_Id := Entity (Subtype_Mark (S));
9877
 
9878
            --  This call added to ensure that the constraint is analyzed
9879
            --  (needed for a B test). Note that we still return early from
9880
            --  this procedure to avoid recursive processing. ???
9881
 
9882
            Constrain_Discriminated_Type
9883
              (Desig_Subtype, S, Related_Nod, For_Access => True);
9884
            return;
9885
         end if;
9886
 
9887
         if (Ekind (T) = E_General_Access_Type
9888
              or else Ada_Version >= Ada_05)
9889
           and then Has_Private_Declaration (Desig_Type)
9890
           and then In_Open_Scopes (Scope (Desig_Type))
9891
           and then Has_Discriminants (Desig_Type)
9892
         then
9893
            --  Enforce rule that the constraint is illegal if there is
9894
            --  an unconstrained view of the designated type. This means
9895
            --  that the partial view (either a private type declaration or
9896
            --  a derivation from a private type) has no discriminants.
9897
            --  (Defect Report 8652/0008, Technical Corrigendum 1, checked
9898
            --  by ACATS B371001).
9899
 
9900
            --  Rule updated for Ada 2005: the private type is said to have
9901
            --  a constrained partial view, given that objects of the type
9902
            --  can be declared. Furthermore, the rule applies to all access
9903
            --  types, unlike the rule concerning default discriminants.
9904
 
9905
            declare
9906
               Pack  : constant Node_Id :=
9907
                         Unit_Declaration_Node (Scope (Desig_Type));
9908
               Decls : List_Id;
9909
               Decl  : Node_Id;
9910
 
9911
            begin
9912
               if Nkind (Pack) = N_Package_Declaration then
9913
                  Decls := Visible_Declarations (Specification (Pack));
9914
                  Decl := First (Decls);
9915
                  while Present (Decl) loop
9916
                     if (Nkind (Decl) = N_Private_Type_Declaration
9917
                          and then
9918
                            Chars (Defining_Identifier (Decl)) =
9919
                                                     Chars (Desig_Type))
9920
 
9921
                       or else
9922
                        (Nkind (Decl) = N_Full_Type_Declaration
9923
                          and then
9924
                            Chars (Defining_Identifier (Decl)) =
9925
                                                     Chars (Desig_Type)
9926
                          and then Is_Derived_Type (Desig_Type)
9927
                          and then
9928
                            Has_Private_Declaration (Etype (Desig_Type)))
9929
                     then
9930
                        if No (Discriminant_Specifications (Decl)) then
9931
                           Error_Msg_N
9932
                            ("cannot constrain general access type if " &
9933
                               "designated type has constrained partial view",
9934
                                S);
9935
                        end if;
9936
 
9937
                        exit;
9938
                     end if;
9939
 
9940
                     Next (Decl);
9941
                  end loop;
9942
               end if;
9943
            end;
9944
         end if;
9945
 
9946
         Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
9947
           For_Access => True);
9948
 
9949
      elsif (Is_Task_Type (Desig_Type)
9950
              or else Is_Protected_Type (Desig_Type))
9951
        and then not Is_Constrained (Desig_Type)
9952
      then
9953
         Constrain_Concurrent
9954
           (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
9955
 
9956
      else
9957
         Error_Msg_N ("invalid constraint on access type", S);
9958
         Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
9959
         Constraint_OK := False;
9960
      end if;
9961
 
9962
      if No (Def_Id) then
9963
         Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
9964
      else
9965
         Set_Ekind (Def_Id, E_Access_Subtype);
9966
      end if;
9967
 
9968
      if Constraint_OK then
9969
         Set_Etype (Def_Id, Base_Type (T));
9970
 
9971
         if Is_Private_Type (Desig_Type) then
9972
            Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
9973
         end if;
9974
      else
9975
         Set_Etype (Def_Id, Any_Type);
9976
      end if;
9977
 
9978
      Set_Size_Info                (Def_Id, T);
9979
      Set_Is_Constrained           (Def_Id, Constraint_OK);
9980
      Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
9981
      Set_Depends_On_Private       (Def_Id, Has_Private_Component (Def_Id));
9982
      Set_Is_Access_Constant       (Def_Id, Is_Access_Constant (T));
9983
 
9984
      Conditional_Delay (Def_Id, T);
9985
 
9986
      --  AI-363 : Subtypes of general access types whose designated types have
9987
      --  default discriminants are disallowed. In instances, the rule has to
9988
      --  be checked against the actual, of which T is the subtype. In a
9989
      --  generic body, the rule is checked assuming that the actual type has
9990
      --  defaulted discriminants.
9991
 
9992
      if Ada_Version >= Ada_05 or else Warn_On_Ada_2005_Compatibility then
9993
         if Ekind (Base_Type (T)) = E_General_Access_Type
9994
           and then Has_Defaulted_Discriminants (Desig_Type)
9995
         then
9996
            if Ada_Version < Ada_05 then
9997
               Error_Msg_N
9998
                 ("access subtype of general access type would not " &
9999
                  "be allowed in Ada 2005?", S);
10000
            else
10001
               Error_Msg_N
10002
                 ("access subype of general access type not allowed", S);
10003
            end if;
10004
 
10005
            Error_Msg_N ("\discriminants have defaults", S);
10006
 
10007
         elsif Is_Access_Type (T)
10008
           and then Is_Generic_Type (Desig_Type)
10009
           and then Has_Discriminants (Desig_Type)
10010
           and then In_Package_Body (Current_Scope)
10011
         then
10012
            if Ada_Version < Ada_05 then
10013
               Error_Msg_N
10014
                 ("access subtype would not be allowed in generic body " &
10015
                  "in Ada 2005?", S);
10016
            else
10017
               Error_Msg_N
10018
                 ("access subtype not allowed in generic body", S);
10019
            end if;
10020
 
10021
            Error_Msg_N
10022
              ("\designated type is a discriminated formal", S);
10023
         end if;
10024
      end if;
10025
   end Constrain_Access;
10026
 
10027
   ---------------------
10028
   -- Constrain_Array --
10029
   ---------------------
10030
 
10031
   procedure Constrain_Array
10032
     (Def_Id      : in out Entity_Id;
10033
      SI          : Node_Id;
10034
      Related_Nod : Node_Id;
10035
      Related_Id  : Entity_Id;
10036
      Suffix      : Character)
10037
   is
10038
      C                     : constant Node_Id := Constraint (SI);
10039
      Number_Of_Constraints : Nat := 0;
10040
      Index                 : Node_Id;
10041
      S, T                  : Entity_Id;
10042
      Constraint_OK         : Boolean := True;
10043
 
10044
   begin
10045
      T := Entity (Subtype_Mark (SI));
10046
 
10047
      if Ekind (T) in Access_Kind then
10048
         T := Designated_Type (T);
10049
      end if;
10050
 
10051
      --  If an index constraint follows a subtype mark in a subtype indication
10052
      --  then the type or subtype denoted by the subtype mark must not already
10053
      --  impose an index constraint. The subtype mark must denote either an
10054
      --  unconstrained array type or an access type whose designated type
10055
      --  is such an array type... (RM 3.6.1)
10056
 
10057
      if Is_Constrained (T) then
10058
         Error_Msg_N
10059
           ("array type is already constrained", Subtype_Mark (SI));
10060
         Constraint_OK := False;
10061
 
10062
      else
10063
         S := First (Constraints (C));
10064
         while Present (S) loop
10065
            Number_Of_Constraints := Number_Of_Constraints + 1;
10066
            Next (S);
10067
         end loop;
10068
 
10069
         --  In either case, the index constraint must provide a discrete
10070
         --  range for each index of the array type and the type of each
10071
         --  discrete range must be the same as that of the corresponding
10072
         --  index. (RM 3.6.1)
10073
 
10074
         if Number_Of_Constraints /= Number_Dimensions (T) then
10075
            Error_Msg_NE ("incorrect number of index constraints for }", C, T);
10076
            Constraint_OK := False;
10077
 
10078
         else
10079
            S := First (Constraints (C));
10080
            Index := First_Index (T);
10081
            Analyze (Index);
10082
 
10083
            --  Apply constraints to each index type
10084
 
10085
            for J in 1 .. Number_Of_Constraints loop
10086
               Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
10087
               Next (Index);
10088
               Next (S);
10089
            end loop;
10090
 
10091
         end if;
10092
      end if;
10093
 
10094
      if No (Def_Id) then
10095
         Def_Id :=
10096
           Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
10097
         Set_Parent (Def_Id, Related_Nod);
10098
 
10099
      else
10100
         Set_Ekind (Def_Id, E_Array_Subtype);
10101
      end if;
10102
 
10103
      Set_Size_Info      (Def_Id,                (T));
10104
      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
10105
      Set_Etype          (Def_Id, Base_Type      (T));
10106
 
10107
      if Constraint_OK then
10108
         Set_First_Index (Def_Id, First (Constraints (C)));
10109
      else
10110
         Set_First_Index (Def_Id, First_Index (T));
10111
      end if;
10112
 
10113
      Set_Is_Constrained     (Def_Id, True);
10114
      Set_Is_Aliased         (Def_Id, Is_Aliased (T));
10115
      Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
10116
 
10117
      Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
10118
      Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
10119
 
10120
      --  A subtype does not inherit the packed_array_type of is parent. We
10121
      --  need to initialize the attribute because if Def_Id is previously
10122
      --  analyzed through a limited_with clause, it will have the attributes
10123
      --  of an incomplete type, one of which is an Elist that overlaps the
10124
      --  Packed_Array_Type field.
10125
 
10126
      Set_Packed_Array_Type (Def_Id, Empty);
10127
 
10128
      --  Build a freeze node if parent still needs one. Also make sure that
10129
      --  the Depends_On_Private status is set because the subtype will need
10130
      --  reprocessing at the time the base type does, and also we must set a
10131
      --  conditional delay.
10132
 
10133
      Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
10134
      Conditional_Delay (Def_Id, T);
10135
   end Constrain_Array;
10136
 
10137
   ------------------------------
10138
   -- Constrain_Component_Type --
10139
   ------------------------------
10140
 
10141
   function Constrain_Component_Type
10142
     (Comp            : Entity_Id;
10143
      Constrained_Typ : Entity_Id;
10144
      Related_Node    : Node_Id;
10145
      Typ             : Entity_Id;
10146
      Constraints     : Elist_Id) return Entity_Id
10147
   is
10148
      Loc         : constant Source_Ptr := Sloc (Constrained_Typ);
10149
      Compon_Type : constant Entity_Id := Etype (Comp);
10150
 
10151
      function Build_Constrained_Array_Type
10152
        (Old_Type : Entity_Id) return Entity_Id;
10153
      --  If Old_Type is an array type, one of whose indices is constrained
10154
      --  by a discriminant, build an Itype whose constraint replaces the
10155
      --  discriminant with its value in the constraint.
10156
 
10157
      function Build_Constrained_Discriminated_Type
10158
        (Old_Type : Entity_Id) return Entity_Id;
10159
      --  Ditto for record components
10160
 
10161
      function Build_Constrained_Access_Type
10162
        (Old_Type : Entity_Id) return Entity_Id;
10163
      --  Ditto for access types. Makes use of previous two functions, to
10164
      --  constrain designated type.
10165
 
10166
      function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
10167
      --  T is an array or discriminated type, C is a list of constraints
10168
      --  that apply to T. This routine builds the constrained subtype.
10169
 
10170
      function Is_Discriminant (Expr : Node_Id) return Boolean;
10171
      --  Returns True if Expr is a discriminant
10172
 
10173
      function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
10174
      --  Find the value of discriminant Discrim in Constraint
10175
 
10176
      -----------------------------------
10177
      -- Build_Constrained_Access_Type --
10178
      -----------------------------------
10179
 
10180
      function Build_Constrained_Access_Type
10181
        (Old_Type : Entity_Id) return Entity_Id
10182
      is
10183
         Desig_Type    : constant Entity_Id := Designated_Type (Old_Type);
10184
         Itype         : Entity_Id;
10185
         Desig_Subtype : Entity_Id;
10186
         Scop          : Entity_Id;
10187
 
10188
      begin
10189
         --  if the original access type was not embedded in the enclosing
10190
         --  type definition, there is no need to produce a new access
10191
         --  subtype. In fact every access type with an explicit constraint
10192
         --  generates an itype whose scope is the enclosing record.
10193
 
10194
         if not Is_Type (Scope (Old_Type)) then
10195
            return Old_Type;
10196
 
10197
         elsif Is_Array_Type (Desig_Type) then
10198
            Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
10199
 
10200
         elsif Has_Discriminants (Desig_Type) then
10201
 
10202
            --  This may be an access type to an enclosing record type for
10203
            --  which we are constructing the constrained components. Return
10204
            --  the enclosing record subtype. This is not always correct,
10205
            --  but avoids infinite recursion. ???
10206
 
10207
            Desig_Subtype := Any_Type;
10208
 
10209
            for J in reverse 0 .. Scope_Stack.Last loop
10210
               Scop := Scope_Stack.Table (J).Entity;
10211
 
10212
               if Is_Type (Scop)
10213
                 and then Base_Type (Scop) = Base_Type (Desig_Type)
10214
               then
10215
                  Desig_Subtype := Scop;
10216
               end if;
10217
 
10218
               exit when not Is_Type (Scop);
10219
            end loop;
10220
 
10221
            if Desig_Subtype = Any_Type then
10222
               Desig_Subtype :=
10223
                 Build_Constrained_Discriminated_Type (Desig_Type);
10224
            end if;
10225
 
10226
         else
10227
            return Old_Type;
10228
         end if;
10229
 
10230
         if Desig_Subtype /= Desig_Type then
10231
 
10232
            --  The Related_Node better be here or else we won't be able
10233
            --  to attach new itypes to a node in the tree.
10234
 
10235
            pragma Assert (Present (Related_Node));
10236
 
10237
            Itype := Create_Itype (E_Access_Subtype, Related_Node);
10238
 
10239
            Set_Etype                    (Itype, Base_Type      (Old_Type));
10240
            Set_Size_Info                (Itype,                (Old_Type));
10241
            Set_Directly_Designated_Type (Itype, Desig_Subtype);
10242
            Set_Depends_On_Private       (Itype, Has_Private_Component
10243
                                                                (Old_Type));
10244
            Set_Is_Access_Constant       (Itype, Is_Access_Constant
10245
                                                                (Old_Type));
10246
 
10247
            --  The new itype needs freezing when it depends on a not frozen
10248
            --  type and the enclosing subtype needs freezing.
10249
 
10250
            if Has_Delayed_Freeze (Constrained_Typ)
10251
              and then not Is_Frozen (Constrained_Typ)
10252
            then
10253
               Conditional_Delay (Itype, Base_Type (Old_Type));
10254
            end if;
10255
 
10256
            return Itype;
10257
 
10258
         else
10259
            return Old_Type;
10260
         end if;
10261
      end Build_Constrained_Access_Type;
10262
 
10263
      ----------------------------------
10264
      -- Build_Constrained_Array_Type --
10265
      ----------------------------------
10266
 
10267
      function Build_Constrained_Array_Type
10268
        (Old_Type : Entity_Id) return Entity_Id
10269
      is
10270
         Lo_Expr     : Node_Id;
10271
         Hi_Expr     : Node_Id;
10272
         Old_Index   : Node_Id;
10273
         Range_Node  : Node_Id;
10274
         Constr_List : List_Id;
10275
 
10276
         Need_To_Create_Itype : Boolean := False;
10277
 
10278
      begin
10279
         Old_Index := First_Index (Old_Type);
10280
         while Present (Old_Index) loop
10281
            Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
10282
 
10283
            if Is_Discriminant (Lo_Expr)
10284
              or else Is_Discriminant (Hi_Expr)
10285
            then
10286
               Need_To_Create_Itype := True;
10287
            end if;
10288
 
10289
            Next_Index (Old_Index);
10290
         end loop;
10291
 
10292
         if Need_To_Create_Itype then
10293
            Constr_List := New_List;
10294
 
10295
            Old_Index := First_Index (Old_Type);
10296
            while Present (Old_Index) loop
10297
               Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
10298
 
10299
               if Is_Discriminant (Lo_Expr) then
10300
                  Lo_Expr := Get_Discr_Value (Lo_Expr);
10301
               end if;
10302
 
10303
               if Is_Discriminant (Hi_Expr) then
10304
                  Hi_Expr := Get_Discr_Value (Hi_Expr);
10305
               end if;
10306
 
10307
               Range_Node :=
10308
                 Make_Range
10309
                   (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
10310
 
10311
               Append (Range_Node, To => Constr_List);
10312
 
10313
               Next_Index (Old_Index);
10314
            end loop;
10315
 
10316
            return Build_Subtype (Old_Type, Constr_List);
10317
 
10318
         else
10319
            return Old_Type;
10320
         end if;
10321
      end Build_Constrained_Array_Type;
10322
 
10323
      ------------------------------------------
10324
      -- Build_Constrained_Discriminated_Type --
10325
      ------------------------------------------
10326
 
10327
      function Build_Constrained_Discriminated_Type
10328
        (Old_Type : Entity_Id) return Entity_Id
10329
      is
10330
         Expr           : Node_Id;
10331
         Constr_List    : List_Id;
10332
         Old_Constraint : Elmt_Id;
10333
 
10334
         Need_To_Create_Itype : Boolean := False;
10335
 
10336
      begin
10337
         Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
10338
         while Present (Old_Constraint) loop
10339
            Expr := Node (Old_Constraint);
10340
 
10341
            if Is_Discriminant (Expr) then
10342
               Need_To_Create_Itype := True;
10343
            end if;
10344
 
10345
            Next_Elmt (Old_Constraint);
10346
         end loop;
10347
 
10348
         if Need_To_Create_Itype then
10349
            Constr_List := New_List;
10350
 
10351
            Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
10352
            while Present (Old_Constraint) loop
10353
               Expr := Node (Old_Constraint);
10354
 
10355
               if Is_Discriminant (Expr) then
10356
                  Expr := Get_Discr_Value (Expr);
10357
               end if;
10358
 
10359
               Append (New_Copy_Tree (Expr), To => Constr_List);
10360
 
10361
               Next_Elmt (Old_Constraint);
10362
            end loop;
10363
 
10364
            return Build_Subtype (Old_Type, Constr_List);
10365
 
10366
         else
10367
            return Old_Type;
10368
         end if;
10369
      end Build_Constrained_Discriminated_Type;
10370
 
10371
      -------------------
10372
      -- Build_Subtype --
10373
      -------------------
10374
 
10375
      function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
10376
         Indic       : Node_Id;
10377
         Subtyp_Decl : Node_Id;
10378
         Def_Id      : Entity_Id;
10379
         Btyp        : Entity_Id := Base_Type (T);
10380
 
10381
      begin
10382
         --  The Related_Node better be here or else we won't be able to
10383
         --  attach new itypes to a node in the tree.
10384
 
10385
         pragma Assert (Present (Related_Node));
10386
 
10387
         --  If the view of the component's type is incomplete or private
10388
         --  with unknown discriminants, then the constraint must be applied
10389
         --  to the full type.
10390
 
10391
         if Has_Unknown_Discriminants (Btyp)
10392
           and then Present (Underlying_Type (Btyp))
10393
         then
10394
            Btyp := Underlying_Type (Btyp);
10395
         end if;
10396
 
10397
         Indic :=
10398
           Make_Subtype_Indication (Loc,
10399
             Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
10400
             Constraint   => Make_Index_Or_Discriminant_Constraint (Loc, C));
10401
 
10402
         Def_Id := Create_Itype (Ekind (T), Related_Node);
10403
 
10404
         Subtyp_Decl :=
10405
           Make_Subtype_Declaration (Loc,
10406
             Defining_Identifier => Def_Id,
10407
             Subtype_Indication  => Indic);
10408
 
10409
         Set_Parent (Subtyp_Decl, Parent (Related_Node));
10410
 
10411
         --  Itypes must be analyzed with checks off (see package Itypes)
10412
 
10413
         Analyze (Subtyp_Decl, Suppress => All_Checks);
10414
 
10415
         return Def_Id;
10416
      end Build_Subtype;
10417
 
10418
      ---------------------
10419
      -- Get_Discr_Value --
10420
      ---------------------
10421
 
10422
      function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
10423
         D : Entity_Id;
10424
         E : Elmt_Id;
10425
 
10426
      begin
10427
         --  The discriminant may be declared for the type, in which case we
10428
         --  find it by iterating over the list of discriminants. If the
10429
         --  discriminant is inherited from a parent type, it appears as the
10430
         --  corresponding discriminant of the current type. This will be the
10431
         --  case when constraining an inherited component whose constraint is
10432
         --  given by a discriminant of the parent.
10433
 
10434
         D := First_Discriminant (Typ);
10435
         E := First_Elmt (Constraints);
10436
 
10437
         while Present (D) loop
10438
            if D = Entity (Discrim)
10439
              or else D = CR_Discriminant (Entity (Discrim))
10440
              or else Corresponding_Discriminant (D) = Entity (Discrim)
10441
            then
10442
               return Node (E);
10443
            end if;
10444
 
10445
            Next_Discriminant (D);
10446
            Next_Elmt (E);
10447
         end loop;
10448
 
10449
         --  The corresponding_Discriminant mechanism is incomplete, because
10450
         --  the correspondence between new and old discriminants is not one
10451
         --  to one: one new discriminant can constrain several old ones. In
10452
         --  that case, scan sequentially the stored_constraint, the list of
10453
         --  discriminants of the parents, and the constraints.
10454
         --  Previous code checked for the present of the Stored_Constraint
10455
         --  list for the derived type, but did not use it at all. Should it
10456
         --  be present when the component is a discriminated task type?
10457
 
10458
         if Is_Derived_Type (Typ)
10459
           and then Scope (Entity (Discrim)) = Etype (Typ)
10460
         then
10461
            D := First_Discriminant (Etype (Typ));
10462
            E := First_Elmt (Constraints);
10463
            while Present (D) loop
10464
               if D = Entity (Discrim) then
10465
                  return Node (E);
10466
               end if;
10467
 
10468
               Next_Discriminant (D);
10469
               Next_Elmt (E);
10470
            end loop;
10471
         end if;
10472
 
10473
         --  Something is wrong if we did not find the value
10474
 
10475
         raise Program_Error;
10476
      end Get_Discr_Value;
10477
 
10478
      ---------------------
10479
      -- Is_Discriminant --
10480
      ---------------------
10481
 
10482
      function Is_Discriminant (Expr : Node_Id) return Boolean is
10483
         Discrim_Scope : Entity_Id;
10484
 
10485
      begin
10486
         if Denotes_Discriminant (Expr) then
10487
            Discrim_Scope := Scope (Entity (Expr));
10488
 
10489
            --  Either we have a reference to one of Typ's discriminants,
10490
 
10491
            pragma Assert (Discrim_Scope = Typ
10492
 
10493
               --  or to the discriminants of the parent type, in the case
10494
               --  of a derivation of a tagged type with variants.
10495
 
10496
               or else Discrim_Scope = Etype (Typ)
10497
               or else Full_View (Discrim_Scope) = Etype (Typ)
10498
 
10499
               --  or same as above for the case where the discriminants
10500
               --  were declared in Typ's private view.
10501
 
10502
               or else (Is_Private_Type (Discrim_Scope)
10503
                        and then Chars (Discrim_Scope) = Chars (Typ))
10504
 
10505
               --  or else we are deriving from the full view and the
10506
               --  discriminant is declared in the private entity.
10507
 
10508
               or else (Is_Private_Type (Typ)
10509
                         and then Chars (Discrim_Scope) = Chars (Typ))
10510
 
10511
               --  Or we are constrained the corresponding record of a
10512
               --  synchronized type that completes a private declaration.
10513
 
10514
               or else (Is_Concurrent_Record_Type (Typ)
10515
                         and then
10516
                           Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
10517
 
10518
               --  or we have a class-wide type, in which case make sure the
10519
               --  discriminant found belongs to the root type.
10520
 
10521
               or else (Is_Class_Wide_Type (Typ)
10522
                         and then Etype (Typ) = Discrim_Scope));
10523
 
10524
            return True;
10525
         end if;
10526
 
10527
         --  In all other cases we have something wrong
10528
 
10529
         return False;
10530
      end Is_Discriminant;
10531
 
10532
   --  Start of processing for Constrain_Component_Type
10533
 
10534
   begin
10535
      if Nkind (Parent (Comp)) = N_Component_Declaration
10536
        and then Comes_From_Source (Parent (Comp))
10537
        and then Comes_From_Source
10538
          (Subtype_Indication (Component_Definition (Parent (Comp))))
10539
        and then
10540
          Is_Entity_Name
10541
            (Subtype_Indication (Component_Definition (Parent (Comp))))
10542
      then
10543
         return Compon_Type;
10544
 
10545
      elsif Is_Array_Type (Compon_Type) then
10546
         return Build_Constrained_Array_Type (Compon_Type);
10547
 
10548
      elsif Has_Discriminants (Compon_Type) then
10549
         return Build_Constrained_Discriminated_Type (Compon_Type);
10550
 
10551
      elsif Is_Access_Type (Compon_Type) then
10552
         return Build_Constrained_Access_Type (Compon_Type);
10553
 
10554
      else
10555
         return Compon_Type;
10556
      end if;
10557
   end Constrain_Component_Type;
10558
 
10559
   --------------------------
10560
   -- Constrain_Concurrent --
10561
   --------------------------
10562
 
10563
   --  For concurrent types, the associated record value type carries the same
10564
   --  discriminants, so when we constrain a concurrent type, we must constrain
10565
   --  the corresponding record type as well.
10566
 
10567
   procedure Constrain_Concurrent
10568
     (Def_Id      : in out Entity_Id;
10569
      SI          : Node_Id;
10570
      Related_Nod : Node_Id;
10571
      Related_Id  : Entity_Id;
10572
      Suffix      : Character)
10573
   is
10574
      T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
10575
      T_Val : Entity_Id;
10576
 
10577
   begin
10578
      if Ekind (T_Ent) in Access_Kind then
10579
         T_Ent := Designated_Type (T_Ent);
10580
      end if;
10581
 
10582
      T_Val := Corresponding_Record_Type (T_Ent);
10583
 
10584
      if Present (T_Val) then
10585
 
10586
         if No (Def_Id) then
10587
            Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
10588
         end if;
10589
 
10590
         Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
10591
 
10592
         Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
10593
         Set_Corresponding_Record_Type (Def_Id,
10594
           Constrain_Corresponding_Record
10595
             (Def_Id, T_Val, Related_Nod, Related_Id));
10596
 
10597
      else
10598
         --  If there is no associated record, expansion is disabled and this
10599
         --  is a generic context. Create a subtype in any case, so that
10600
         --  semantic analysis can proceed.
10601
 
10602
         if No (Def_Id) then
10603
            Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
10604
         end if;
10605
 
10606
         Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
10607
      end if;
10608
   end Constrain_Concurrent;
10609
 
10610
   ------------------------------------
10611
   -- Constrain_Corresponding_Record --
10612
   ------------------------------------
10613
 
10614
   function Constrain_Corresponding_Record
10615
     (Prot_Subt   : Entity_Id;
10616
      Corr_Rec    : Entity_Id;
10617
      Related_Nod : Node_Id;
10618
      Related_Id  : Entity_Id) return Entity_Id
10619
   is
10620
      T_Sub : constant Entity_Id :=
10621
                Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
10622
 
10623
   begin
10624
      Set_Etype             (T_Sub, Corr_Rec);
10625
      Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
10626
      Set_Is_Constrained    (T_Sub, True);
10627
      Set_First_Entity      (T_Sub, First_Entity (Corr_Rec));
10628
      Set_Last_Entity       (T_Sub, Last_Entity  (Corr_Rec));
10629
 
10630
      --  As elsewhere, we do not want to create a freeze node for this itype
10631
      --  if it is created for a constrained component of an enclosing record
10632
      --  because references to outer discriminants will appear out of scope.
10633
 
10634
      if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
10635
         Conditional_Delay (T_Sub, Corr_Rec);
10636
      else
10637
         Set_Is_Frozen (T_Sub);
10638
      end if;
10639
 
10640
      if Has_Discriminants (Prot_Subt) then -- False only if errors.
10641
         Set_Discriminant_Constraint
10642
           (T_Sub, Discriminant_Constraint (Prot_Subt));
10643
         Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
10644
         Create_Constrained_Components
10645
           (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
10646
      end if;
10647
 
10648
      Set_Depends_On_Private      (T_Sub, Has_Private_Component (T_Sub));
10649
 
10650
      return T_Sub;
10651
   end Constrain_Corresponding_Record;
10652
 
10653
   -----------------------
10654
   -- Constrain_Decimal --
10655
   -----------------------
10656
 
10657
   procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is
10658
      T           : constant Entity_Id  := Entity (Subtype_Mark (S));
10659
      C           : constant Node_Id    := Constraint (S);
10660
      Loc         : constant Source_Ptr := Sloc (C);
10661
      Range_Expr  : Node_Id;
10662
      Digits_Expr : Node_Id;
10663
      Digits_Val  : Uint;
10664
      Bound_Val   : Ureal;
10665
 
10666
   begin
10667
      Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
10668
 
10669
      if Nkind (C) = N_Range_Constraint then
10670
         Range_Expr := Range_Expression (C);
10671
         Digits_Val := Digits_Value (T);
10672
 
10673
      else
10674
         pragma Assert (Nkind (C) = N_Digits_Constraint);
10675
         Digits_Expr := Digits_Expression (C);
10676
         Analyze_And_Resolve (Digits_Expr, Any_Integer);
10677
 
10678
         Check_Digits_Expression (Digits_Expr);
10679
         Digits_Val := Expr_Value (Digits_Expr);
10680
 
10681
         if Digits_Val > Digits_Value (T) then
10682
            Error_Msg_N
10683
               ("digits expression is incompatible with subtype", C);
10684
            Digits_Val := Digits_Value (T);
10685
         end if;
10686
 
10687
         if Present (Range_Constraint (C)) then
10688
            Range_Expr := Range_Expression (Range_Constraint (C));
10689
         else
10690
            Range_Expr := Empty;
10691
         end if;
10692
      end if;
10693
 
10694
      Set_Etype            (Def_Id, Base_Type        (T));
10695
      Set_Size_Info        (Def_Id,                  (T));
10696
      Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
10697
      Set_Delta_Value      (Def_Id, Delta_Value      (T));
10698
      Set_Scale_Value      (Def_Id, Scale_Value      (T));
10699
      Set_Small_Value      (Def_Id, Small_Value      (T));
10700
      Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
10701
      Set_Digits_Value     (Def_Id, Digits_Val);
10702
 
10703
      --  Manufacture range from given digits value if no range present
10704
 
10705
      if No (Range_Expr) then
10706
         Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
10707
         Range_Expr :=
10708
           Make_Range (Loc,
10709
             Low_Bound =>
10710
               Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
10711
             High_Bound =>
10712
               Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
10713
      end if;
10714
 
10715
      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
10716
      Set_Discrete_RM_Size (Def_Id);
10717
 
10718
      --  Unconditionally delay the freeze, since we cannot set size
10719
      --  information in all cases correctly until the freeze point.
10720
 
10721
      Set_Has_Delayed_Freeze (Def_Id);
10722
   end Constrain_Decimal;
10723
 
10724
   ----------------------------------
10725
   -- Constrain_Discriminated_Type --
10726
   ----------------------------------
10727
 
10728
   procedure Constrain_Discriminated_Type
10729
     (Def_Id      : Entity_Id;
10730
      S           : Node_Id;
10731
      Related_Nod : Node_Id;
10732
      For_Access  : Boolean := False)
10733
   is
10734
      E     : constant Entity_Id := Entity (Subtype_Mark (S));
10735
      T     : Entity_Id;
10736
      C     : Node_Id;
10737
      Elist : Elist_Id := New_Elmt_List;
10738
 
10739
      procedure Fixup_Bad_Constraint;
10740
      --  This is called after finding a bad constraint, and after having
10741
      --  posted an appropriate error message. The mission is to leave the
10742
      --  entity T in as reasonable state as possible!
10743
 
10744
      --------------------------
10745
      -- Fixup_Bad_Constraint --
10746
      --------------------------
10747
 
10748
      procedure Fixup_Bad_Constraint is
10749
      begin
10750
         --  Set a reasonable Ekind for the entity. For an incomplete type,
10751
         --  we can't do much, but for other types, we can set the proper
10752
         --  corresponding subtype kind.
10753
 
10754
         if Ekind (T) = E_Incomplete_Type then
10755
            Set_Ekind (Def_Id, Ekind (T));
10756
         else
10757
            Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
10758
         end if;
10759
 
10760
         --  Set Etype to the known type, to reduce chances of cascaded errors
10761
 
10762
         Set_Etype (Def_Id, E);
10763
         Set_Error_Posted (Def_Id);
10764
      end Fixup_Bad_Constraint;
10765
 
10766
   --  Start of processing for Constrain_Discriminated_Type
10767
 
10768
   begin
10769
      C := Constraint (S);
10770
 
10771
      --  A discriminant constraint is only allowed in a subtype indication,
10772
      --  after a subtype mark. This subtype mark must denote either a type
10773
      --  with discriminants, or an access type whose designated type is a
10774
      --  type with discriminants. A discriminant constraint specifies the
10775
      --  values of these discriminants (RM 3.7.2(5)).
10776
 
10777
      T := Base_Type (Entity (Subtype_Mark (S)));
10778
 
10779
      if Ekind (T) in Access_Kind then
10780
         T := Designated_Type (T);
10781
      end if;
10782
 
10783
      --  Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
10784
      --  Avoid generating an error for access-to-incomplete subtypes.
10785
 
10786
      if Ada_Version >= Ada_05
10787
        and then Ekind (T) = E_Incomplete_Type
10788
        and then Nkind (Parent (S)) = N_Subtype_Declaration
10789
        and then not Is_Itype (Def_Id)
10790
      then
10791
         --  A little sanity check, emit an error message if the type
10792
         --  has discriminants to begin with. Type T may be a regular
10793
         --  incomplete type or imported via a limited with clause.
10794
 
10795
         if Has_Discriminants (T)
10796
           or else
10797
             (From_With_Type (T)
10798
                and then Present (Non_Limited_View (T))
10799
                and then Nkind (Parent (Non_Limited_View (T))) =
10800
                           N_Full_Type_Declaration
10801
                and then Present (Discriminant_Specifications
10802
                          (Parent (Non_Limited_View (T)))))
10803
         then
10804
            Error_Msg_N
10805
              ("(Ada 2005) incomplete subtype may not be constrained", C);
10806
         else
10807
            Error_Msg_N
10808
              ("invalid constraint: type has no discriminant", C);
10809
         end if;
10810
 
10811
         Fixup_Bad_Constraint;
10812
         return;
10813
 
10814
      --  Check that the type has visible discriminants. The type may be
10815
      --  a private type with unknown discriminants whose full view has
10816
      --  discriminants which are invisible.
10817
 
10818
      elsif not Has_Discriminants (T)
10819
        or else
10820
          (Has_Unknown_Discriminants (T)
10821
             and then Is_Private_Type (T))
10822
      then
10823
         Error_Msg_N ("invalid constraint: type has no discriminant", C);
10824
         Fixup_Bad_Constraint;
10825
         return;
10826
 
10827
      elsif Is_Constrained (E)
10828
        or else (Ekind (E) = E_Class_Wide_Subtype
10829
                  and then Present (Discriminant_Constraint (E)))
10830
      then
10831
         Error_Msg_N ("type is already constrained", Subtype_Mark (S));
10832
         Fixup_Bad_Constraint;
10833
         return;
10834
      end if;
10835
 
10836
      --  T may be an unconstrained subtype (e.g. a generic actual).
10837
      --  Constraint applies to the base type.
10838
 
10839
      T := Base_Type (T);
10840
 
10841
      Elist := Build_Discriminant_Constraints (T, S);
10842
 
10843
      --  If the list returned was empty we had an error in building the
10844
      --  discriminant constraint. We have also already signalled an error
10845
      --  in the incomplete type case
10846
 
10847
      if Is_Empty_Elmt_List (Elist) then
10848
         Fixup_Bad_Constraint;
10849
         return;
10850
      end if;
10851
 
10852
      Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
10853
   end Constrain_Discriminated_Type;
10854
 
10855
   ---------------------------
10856
   -- Constrain_Enumeration --
10857
   ---------------------------
10858
 
10859
   procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is
10860
      T : constant Entity_Id := Entity (Subtype_Mark (S));
10861
      C : constant Node_Id   := Constraint (S);
10862
 
10863
   begin
10864
      Set_Ekind (Def_Id, E_Enumeration_Subtype);
10865
 
10866
      Set_First_Literal     (Def_Id, First_Literal (Base_Type (T)));
10867
 
10868
      Set_Etype             (Def_Id, Base_Type         (T));
10869
      Set_Size_Info         (Def_Id,                   (T));
10870
      Set_First_Rep_Item    (Def_Id, First_Rep_Item    (T));
10871
      Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
10872
 
10873
      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
10874
 
10875
      Set_Discrete_RM_Size (Def_Id);
10876
   end Constrain_Enumeration;
10877
 
10878
   ----------------------
10879
   -- Constrain_Float --
10880
   ----------------------
10881
 
10882
   procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is
10883
      T    : constant Entity_Id := Entity (Subtype_Mark (S));
10884
      C    : Node_Id;
10885
      D    : Node_Id;
10886
      Rais : Node_Id;
10887
 
10888
   begin
10889
      Set_Ekind (Def_Id, E_Floating_Point_Subtype);
10890
 
10891
      Set_Etype          (Def_Id, Base_Type      (T));
10892
      Set_Size_Info      (Def_Id,                (T));
10893
      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
10894
 
10895
      --  Process the constraint
10896
 
10897
      C := Constraint (S);
10898
 
10899
      --  Digits constraint present
10900
 
10901
      if Nkind (C) = N_Digits_Constraint then
10902
         Check_Restriction (No_Obsolescent_Features, C);
10903
 
10904
         if Warn_On_Obsolescent_Feature then
10905
            Error_Msg_N
10906
              ("subtype digits constraint is an " &
10907
               "obsolescent feature (RM J.3(8))?", C);
10908
         end if;
10909
 
10910
         D := Digits_Expression (C);
10911
         Analyze_And_Resolve (D, Any_Integer);
10912
         Check_Digits_Expression (D);
10913
         Set_Digits_Value (Def_Id, Expr_Value (D));
10914
 
10915
         --  Check that digits value is in range. Obviously we can do this
10916
         --  at compile time, but it is strictly a runtime check, and of
10917
         --  course there is an ACVC test that checks this!
10918
 
10919
         if Digits_Value (Def_Id) > Digits_Value (T) then
10920
            Error_Msg_Uint_1 := Digits_Value (T);
10921
            Error_Msg_N ("?digits value is too large, maximum is ^", D);
10922
            Rais :=
10923
              Make_Raise_Constraint_Error (Sloc (D),
10924
                Reason => CE_Range_Check_Failed);
10925
            Insert_Action (Declaration_Node (Def_Id), Rais);
10926
         end if;
10927
 
10928
         C := Range_Constraint (C);
10929
 
10930
      --  No digits constraint present
10931
 
10932
      else
10933
         Set_Digits_Value (Def_Id, Digits_Value (T));
10934
      end if;
10935
 
10936
      --  Range constraint present
10937
 
10938
      if Nkind (C) = N_Range_Constraint then
10939
         Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
10940
 
10941
      --  No range constraint present
10942
 
10943
      else
10944
         pragma Assert (No (C));
10945
         Set_Scalar_Range (Def_Id, Scalar_Range (T));
10946
      end if;
10947
 
10948
      Set_Is_Constrained (Def_Id);
10949
   end Constrain_Float;
10950
 
10951
   ---------------------
10952
   -- Constrain_Index --
10953
   ---------------------
10954
 
10955
   procedure Constrain_Index
10956
     (Index        : Node_Id;
10957
      S            : Node_Id;
10958
      Related_Nod  : Node_Id;
10959
      Related_Id   : Entity_Id;
10960
      Suffix       : Character;
10961
      Suffix_Index : Nat)
10962
   is
10963
      Def_Id : Entity_Id;
10964
      R      : Node_Id := Empty;
10965
      T      : constant Entity_Id := Etype (Index);
10966
 
10967
   begin
10968
      if Nkind (S) = N_Range
10969
        or else
10970
          (Nkind (S) = N_Attribute_Reference
10971
            and then Attribute_Name (S) = Name_Range)
10972
      then
10973
         --  A Range attribute will transformed into N_Range by Resolve
10974
 
10975
         Analyze (S);
10976
         Set_Etype (S, T);
10977
         R := S;
10978
 
10979
         Process_Range_Expr_In_Decl (R, T, Empty_List);
10980
 
10981
         if not Error_Posted (S)
10982
           and then
10983
             (Nkind (S) /= N_Range
10984
               or else not Covers (T, (Etype (Low_Bound (S))))
10985
               or else not Covers (T, (Etype (High_Bound (S)))))
10986
         then
10987
            if Base_Type (T) /= Any_Type
10988
              and then Etype (Low_Bound (S)) /= Any_Type
10989
              and then Etype (High_Bound (S)) /= Any_Type
10990
            then
10991
               Error_Msg_N ("range expected", S);
10992
            end if;
10993
         end if;
10994
 
10995
      elsif Nkind (S) = N_Subtype_Indication then
10996
 
10997
         --  The parser has verified that this is a discrete indication
10998
 
10999
         Resolve_Discrete_Subtype_Indication (S, T);
11000
         R := Range_Expression (Constraint (S));
11001
 
11002
      elsif Nkind (S) = N_Discriminant_Association then
11003
 
11004
         --  Syntactically valid in subtype indication
11005
 
11006
         Error_Msg_N ("invalid index constraint", S);
11007
         Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
11008
         return;
11009
 
11010
      --  Subtype_Mark case, no anonymous subtypes to construct
11011
 
11012
      else
11013
         Analyze (S);
11014
 
11015
         if Is_Entity_Name (S) then
11016
            if not Is_Type (Entity (S)) then
11017
               Error_Msg_N ("expect subtype mark for index constraint", S);
11018
 
11019
            elsif Base_Type (Entity (S)) /= Base_Type (T) then
11020
               Wrong_Type (S, Base_Type (T));
11021
            end if;
11022
 
11023
            return;
11024
 
11025
         else
11026
            Error_Msg_N ("invalid index constraint", S);
11027
            Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
11028
            return;
11029
         end if;
11030
      end if;
11031
 
11032
      Def_Id :=
11033
        Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
11034
 
11035
      Set_Etype (Def_Id, Base_Type (T));
11036
 
11037
      if Is_Modular_Integer_Type (T) then
11038
         Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
11039
 
11040
      elsif Is_Integer_Type (T) then
11041
         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
11042
 
11043
      else
11044
         Set_Ekind (Def_Id, E_Enumeration_Subtype);
11045
         Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
11046
      end if;
11047
 
11048
      Set_Size_Info      (Def_Id,                (T));
11049
      Set_RM_Size        (Def_Id, RM_Size        (T));
11050
      Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
11051
 
11052
      Set_Scalar_Range   (Def_Id, R);
11053
 
11054
      Set_Etype (S, Def_Id);
11055
      Set_Discrete_RM_Size (Def_Id);
11056
   end Constrain_Index;
11057
 
11058
   -----------------------
11059
   -- Constrain_Integer --
11060
   -----------------------
11061
 
11062
   procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is
11063
      T : constant Entity_Id := Entity (Subtype_Mark (S));
11064
      C : constant Node_Id   := Constraint (S);
11065
 
11066
   begin
11067
      Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
11068
 
11069
      if Is_Modular_Integer_Type (T) then
11070
         Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
11071
      else
11072
         Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
11073
      end if;
11074
 
11075
      Set_Etype            (Def_Id, Base_Type        (T));
11076
      Set_Size_Info        (Def_Id,                  (T));
11077
      Set_First_Rep_Item   (Def_Id, First_Rep_Item   (T));
11078
      Set_Discrete_RM_Size (Def_Id);
11079
   end Constrain_Integer;
11080
 
11081
   ------------------------------
11082
   -- Constrain_Ordinary_Fixed --
11083
   ------------------------------
11084
 
11085
   procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is
11086
      T    : constant Entity_Id := Entity (Subtype_Mark (S));
11087
      C    : Node_Id;
11088
      D    : Node_Id;
11089
      Rais : Node_Id;
11090
 
11091
   begin
11092
      Set_Ekind          (Def_Id, E_Ordinary_Fixed_Point_Subtype);
11093
      Set_Etype          (Def_Id, Base_Type        (T));
11094
      Set_Size_Info      (Def_Id,                  (T));
11095
      Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
11096
      Set_Small_Value    (Def_Id, Small_Value      (T));
11097
 
11098
      --  Process the constraint
11099
 
11100
      C := Constraint (S);
11101
 
11102
      --  Delta constraint present
11103
 
11104
      if Nkind (C) = N_Delta_Constraint then
11105
         Check_Restriction (No_Obsolescent_Features, C);
11106
 
11107
         if Warn_On_Obsolescent_Feature then
11108
            Error_Msg_S
11109
              ("subtype delta constraint is an " &
11110
               "obsolescent feature (RM J.3(7))?");
11111
         end if;
11112
 
11113
         D := Delta_Expression (C);
11114
         Analyze_And_Resolve (D, Any_Real);
11115
         Check_Delta_Expression (D);
11116
         Set_Delta_Value (Def_Id, Expr_Value_R (D));
11117
 
11118
         --  Check that delta value is in range. Obviously we can do this
11119
         --  at compile time, but it is strictly a runtime check, and of
11120
         --  course there is an ACVC test that checks this!
11121
 
11122
         if Delta_Value (Def_Id) < Delta_Value (T) then
11123
            Error_Msg_N ("?delta value is too small", D);
11124
            Rais :=
11125
              Make_Raise_Constraint_Error (Sloc (D),
11126
                Reason => CE_Range_Check_Failed);
11127
            Insert_Action (Declaration_Node (Def_Id), Rais);
11128
         end if;
11129
 
11130
         C := Range_Constraint (C);
11131
 
11132
      --  No delta constraint present
11133
 
11134
      else
11135
         Set_Delta_Value (Def_Id, Delta_Value (T));
11136
      end if;
11137
 
11138
      --  Range constraint present
11139
 
11140
      if Nkind (C) = N_Range_Constraint then
11141
         Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
11142
 
11143
      --  No range constraint present
11144
 
11145
      else
11146
         pragma Assert (No (C));
11147
         Set_Scalar_Range (Def_Id, Scalar_Range (T));
11148
 
11149
      end if;
11150
 
11151
      Set_Discrete_RM_Size (Def_Id);
11152
 
11153
      --  Unconditionally delay the freeze, since we cannot set size
11154
      --  information in all cases correctly until the freeze point.
11155
 
11156
      Set_Has_Delayed_Freeze (Def_Id);
11157
   end Constrain_Ordinary_Fixed;
11158
 
11159
   -----------------------
11160
   -- Contain_Interface --
11161
   -----------------------
11162
 
11163
   function Contain_Interface
11164
     (Iface  : Entity_Id;
11165
      Ifaces : Elist_Id) return Boolean
11166
   is
11167
      Iface_Elmt : Elmt_Id;
11168
 
11169
   begin
11170
      if Present (Ifaces) then
11171
         Iface_Elmt := First_Elmt (Ifaces);
11172
         while Present (Iface_Elmt) loop
11173
            if Node (Iface_Elmt) = Iface then
11174
               return True;
11175
            end if;
11176
 
11177
            Next_Elmt (Iface_Elmt);
11178
         end loop;
11179
      end if;
11180
 
11181
      return False;
11182
   end Contain_Interface;
11183
 
11184
   ---------------------------
11185
   -- Convert_Scalar_Bounds --
11186
   ---------------------------
11187
 
11188
   procedure Convert_Scalar_Bounds
11189
     (N            : Node_Id;
11190
      Parent_Type  : Entity_Id;
11191
      Derived_Type : Entity_Id;
11192
      Loc          : Source_Ptr)
11193
   is
11194
      Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
11195
 
11196
      Lo  : Node_Id;
11197
      Hi  : Node_Id;
11198
      Rng : Node_Id;
11199
 
11200
   begin
11201
      Lo := Build_Scalar_Bound
11202
              (Type_Low_Bound (Derived_Type),
11203
               Parent_Type, Implicit_Base);
11204
 
11205
      Hi := Build_Scalar_Bound
11206
              (Type_High_Bound (Derived_Type),
11207
               Parent_Type, Implicit_Base);
11208
 
11209
      Rng :=
11210
        Make_Range (Loc,
11211
          Low_Bound  => Lo,
11212
          High_Bound => Hi);
11213
 
11214
      Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
11215
 
11216
      Set_Parent (Rng, N);
11217
      Set_Scalar_Range (Derived_Type, Rng);
11218
 
11219
      --  Analyze the bounds
11220
 
11221
      Analyze_And_Resolve (Lo, Implicit_Base);
11222
      Analyze_And_Resolve (Hi, Implicit_Base);
11223
 
11224
      --  Analyze the range itself, except that we do not analyze it if
11225
      --  the bounds are real literals, and we have a fixed-point type.
11226
      --  The reason for this is that we delay setting the bounds in this
11227
      --  case till we know the final Small and Size values (see circuit
11228
      --  in Freeze.Freeze_Fixed_Point_Type for further details).
11229
 
11230
      if Is_Fixed_Point_Type (Parent_Type)
11231
        and then Nkind (Lo) = N_Real_Literal
11232
        and then Nkind (Hi) = N_Real_Literal
11233
      then
11234
         return;
11235
 
11236
      --  Here we do the analysis of the range
11237
 
11238
      --  Note: we do this manually, since if we do a normal Analyze and
11239
      --  Resolve call, there are problems with the conversions used for
11240
      --  the derived type range.
11241
 
11242
      else
11243
         Set_Etype    (Rng, Implicit_Base);
11244
         Set_Analyzed (Rng, True);
11245
      end if;
11246
   end Convert_Scalar_Bounds;
11247
 
11248
   -------------------
11249
   -- Copy_And_Swap --
11250
   -------------------
11251
 
11252
   procedure Copy_And_Swap (Priv, Full : Entity_Id) is
11253
   begin
11254
      --  Initialize new full declaration entity by copying the pertinent
11255
      --  fields of the corresponding private declaration entity.
11256
 
11257
      --  We temporarily set Ekind to a value appropriate for a type to
11258
      --  avoid assert failures in Einfo from checking for setting type
11259
      --  attributes on something that is not a type. Ekind (Priv) is an
11260
      --  appropriate choice, since it allowed the attributes to be set
11261
      --  in the first place. This Ekind value will be modified later.
11262
 
11263
      Set_Ekind (Full, Ekind (Priv));
11264
 
11265
      --  Also set Etype temporarily to Any_Type, again, in the absence
11266
      --  of errors, it will be properly reset, and if there are errors,
11267
      --  then we want a value of Any_Type to remain.
11268
 
11269
      Set_Etype (Full, Any_Type);
11270
 
11271
      --  Now start copying attributes
11272
 
11273
      Set_Has_Discriminants          (Full, Has_Discriminants       (Priv));
11274
 
11275
      if Has_Discriminants (Full) then
11276
         Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
11277
         Set_Stored_Constraint       (Full, Stored_Constraint       (Priv));
11278
      end if;
11279
 
11280
      Set_First_Rep_Item             (Full, First_Rep_Item          (Priv));
11281
      Set_Homonym                    (Full, Homonym                 (Priv));
11282
      Set_Is_Immediately_Visible     (Full, Is_Immediately_Visible  (Priv));
11283
      Set_Is_Public                  (Full, Is_Public               (Priv));
11284
      Set_Is_Pure                    (Full, Is_Pure                 (Priv));
11285
      Set_Is_Tagged_Type             (Full, Is_Tagged_Type          (Priv));
11286
      Set_Has_Pragma_Unreferenced    (Full, Has_Pragma_Unreferenced (Priv));
11287
      Set_Has_Pragma_Unreferenced_Objects
11288
                                     (Full, Has_Pragma_Unreferenced_Objects
11289
                                                                    (Priv));
11290
 
11291
      Conditional_Delay              (Full,                          Priv);
11292
 
11293
      if Is_Tagged_Type (Full) then
11294
         Set_Primitive_Operations    (Full, Primitive_Operations    (Priv));
11295
 
11296
         if Priv = Base_Type (Priv) then
11297
            Set_Class_Wide_Type      (Full, Class_Wide_Type         (Priv));
11298
         end if;
11299
      end if;
11300
 
11301
      Set_Is_Volatile                (Full, Is_Volatile             (Priv));
11302
      Set_Treat_As_Volatile          (Full, Treat_As_Volatile       (Priv));
11303
      Set_Scope                      (Full, Scope                   (Priv));
11304
      Set_Next_Entity                (Full, Next_Entity             (Priv));
11305
      Set_First_Entity               (Full, First_Entity            (Priv));
11306
      Set_Last_Entity                (Full, Last_Entity             (Priv));
11307
 
11308
      --  If access types have been recorded for later handling, keep them in
11309
      --  the full view so that they get handled when the full view freeze
11310
      --  node is expanded.
11311
 
11312
      if Present (Freeze_Node (Priv))
11313
        and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
11314
      then
11315
         Ensure_Freeze_Node (Full);
11316
         Set_Access_Types_To_Process
11317
           (Freeze_Node (Full),
11318
            Access_Types_To_Process (Freeze_Node (Priv)));
11319
      end if;
11320
 
11321
      --  Swap the two entities. Now Privat is the full type entity and
11322
      --  Full is the private one. They will be swapped back at the end
11323
      --  of the private part. This swapping ensures that the entity that
11324
      --  is visible in the private part is the full declaration.
11325
 
11326
      Exchange_Entities (Priv, Full);
11327
      Append_Entity (Full, Scope (Full));
11328
   end Copy_And_Swap;
11329
 
11330
   -------------------------------------
11331
   -- Copy_Array_Base_Type_Attributes --
11332
   -------------------------------------
11333
 
11334
   procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
11335
   begin
11336
      Set_Component_Alignment      (T1, Component_Alignment      (T2));
11337
      Set_Component_Type           (T1, Component_Type           (T2));
11338
      Set_Component_Size           (T1, Component_Size           (T2));
11339
      Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
11340
      Set_Finalize_Storage_Only    (T1, Finalize_Storage_Only    (T2));
11341
      Set_Has_Non_Standard_Rep     (T1, Has_Non_Standard_Rep     (T2));
11342
      Set_Has_Task                 (T1, Has_Task                 (T2));
11343
      Set_Is_Packed                (T1, Is_Packed                (T2));
11344
      Set_Has_Aliased_Components   (T1, Has_Aliased_Components   (T2));
11345
      Set_Has_Atomic_Components    (T1, Has_Atomic_Components    (T2));
11346
      Set_Has_Volatile_Components  (T1, Has_Volatile_Components  (T2));
11347
   end Copy_Array_Base_Type_Attributes;
11348
 
11349
   -----------------------------------
11350
   -- Copy_Array_Subtype_Attributes --
11351
   -----------------------------------
11352
 
11353
   procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
11354
   begin
11355
      Set_Size_Info (T1, T2);
11356
 
11357
      Set_First_Index          (T1, First_Index           (T2));
11358
      Set_Is_Aliased           (T1, Is_Aliased            (T2));
11359
      Set_Is_Atomic            (T1, Is_Atomic             (T2));
11360
      Set_Is_Volatile          (T1, Is_Volatile           (T2));
11361
      Set_Treat_As_Volatile    (T1, Treat_As_Volatile     (T2));
11362
      Set_Is_Constrained       (T1, Is_Constrained        (T2));
11363
      Set_Depends_On_Private   (T1, Has_Private_Component (T2));
11364
      Set_First_Rep_Item       (T1, First_Rep_Item        (T2));
11365
      Set_Convention           (T1, Convention            (T2));
11366
      Set_Is_Limited_Composite (T1, Is_Limited_Composite  (T2));
11367
      Set_Is_Private_Composite (T1, Is_Private_Composite  (T2));
11368
      Set_Packed_Array_Type    (T1, Packed_Array_Type     (T2));
11369
   end Copy_Array_Subtype_Attributes;
11370
 
11371
   -----------------------------------
11372
   -- Create_Constrained_Components --
11373
   -----------------------------------
11374
 
11375
   procedure Create_Constrained_Components
11376
     (Subt        : Entity_Id;
11377
      Decl_Node   : Node_Id;
11378
      Typ         : Entity_Id;
11379
      Constraints : Elist_Id)
11380
   is
11381
      Loc         : constant Source_Ptr := Sloc (Subt);
11382
      Comp_List   : constant Elist_Id   := New_Elmt_List;
11383
      Parent_Type : constant Entity_Id  := Etype (Typ);
11384
      Assoc_List  : constant List_Id    := New_List;
11385
      Discr_Val   : Elmt_Id;
11386
      Errors      : Boolean;
11387
      New_C       : Entity_Id;
11388
      Old_C       : Entity_Id;
11389
      Is_Static   : Boolean := True;
11390
 
11391
      procedure Collect_Fixed_Components (Typ : Entity_Id);
11392
      --  Collect parent type components that do not appear in a variant part
11393
 
11394
      procedure Create_All_Components;
11395
      --  Iterate over Comp_List to create the components of the subtype
11396
 
11397
      function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
11398
      --  Creates a new component from Old_Compon, copying all the fields from
11399
      --  it, including its Etype, inserts the new component in the Subt entity
11400
      --  chain and returns the new component.
11401
 
11402
      function Is_Variant_Record (T : Entity_Id) return Boolean;
11403
      --  If true, and discriminants are static, collect only components from
11404
      --  variants selected by discriminant values.
11405
 
11406
      ------------------------------
11407
      -- Collect_Fixed_Components --
11408
      ------------------------------
11409
 
11410
      procedure Collect_Fixed_Components (Typ : Entity_Id) is
11411
      begin
11412
      --  Build association list for discriminants, and find components of the
11413
      --  variant part selected by the values of the discriminants.
11414
 
11415
         Old_C := First_Discriminant (Typ);
11416
         Discr_Val := First_Elmt (Constraints);
11417
         while Present (Old_C) loop
11418
            Append_To (Assoc_List,
11419
              Make_Component_Association (Loc,
11420
                 Choices    => New_List (New_Occurrence_Of (Old_C, Loc)),
11421
                 Expression => New_Copy (Node (Discr_Val))));
11422
 
11423
            Next_Elmt (Discr_Val);
11424
            Next_Discriminant (Old_C);
11425
         end loop;
11426
 
11427
         --  The tag, and the possible parent and controller components
11428
         --  are unconditionally in the subtype.
11429
 
11430
         if Is_Tagged_Type (Typ)
11431
           or else Has_Controlled_Component (Typ)
11432
         then
11433
            Old_C := First_Component (Typ);
11434
            while Present (Old_C) loop
11435
               if Chars ((Old_C)) = Name_uTag
11436
                 or else Chars ((Old_C)) = Name_uParent
11437
                 or else Chars ((Old_C)) = Name_uController
11438
               then
11439
                  Append_Elmt (Old_C, Comp_List);
11440
               end if;
11441
 
11442
               Next_Component (Old_C);
11443
            end loop;
11444
         end if;
11445
      end Collect_Fixed_Components;
11446
 
11447
      ---------------------------
11448
      -- Create_All_Components --
11449
      ---------------------------
11450
 
11451
      procedure Create_All_Components is
11452
         Comp : Elmt_Id;
11453
 
11454
      begin
11455
         Comp := First_Elmt (Comp_List);
11456
         while Present (Comp) loop
11457
            Old_C := Node (Comp);
11458
            New_C := Create_Component (Old_C);
11459
 
11460
            Set_Etype
11461
              (New_C,
11462
               Constrain_Component_Type
11463
                 (Old_C, Subt, Decl_Node, Typ, Constraints));
11464
            Set_Is_Public (New_C, Is_Public (Subt));
11465
 
11466
            Next_Elmt (Comp);
11467
         end loop;
11468
      end Create_All_Components;
11469
 
11470
      ----------------------
11471
      -- Create_Component --
11472
      ----------------------
11473
 
11474
      function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
11475
         New_Compon : constant Entity_Id := New_Copy (Old_Compon);
11476
 
11477
      begin
11478
         if Ekind (Old_Compon) = E_Discriminant
11479
           and then Is_Completely_Hidden (Old_Compon)
11480
         then
11481
            --  This is a shadow discriminant created for a discriminant of
11482
            --  the parent type, which needs to be present in the subtype.
11483
            --  Give the shadow discriminant an internal name that cannot
11484
            --  conflict with that of visible components.
11485
 
11486
            Set_Chars (New_Compon, New_Internal_Name ('C'));
11487
         end if;
11488
 
11489
         --  Set the parent so we have a proper link for freezing etc. This is
11490
         --  not a real parent pointer, since of course our parent does not own
11491
         --  up to us and reference us, we are an illegitimate child of the
11492
         --  original parent!
11493
 
11494
         Set_Parent (New_Compon, Parent (Old_Compon));
11495
 
11496
         --  If the old component's Esize was already determined and is a
11497
         --  static value, then the new component simply inherits it. Otherwise
11498
         --  the old component's size may require run-time determination, but
11499
         --  the new component's size still might be statically determinable
11500
         --  (if, for example it has a static constraint). In that case we want
11501
         --  Layout_Type to recompute the component's size, so we reset its
11502
         --  size and positional fields.
11503
 
11504
         if Frontend_Layout_On_Target
11505
           and then not Known_Static_Esize (Old_Compon)
11506
         then
11507
            Set_Esize (New_Compon, Uint_0);
11508
            Init_Normalized_First_Bit    (New_Compon);
11509
            Init_Normalized_Position     (New_Compon);
11510
            Init_Normalized_Position_Max (New_Compon);
11511
         end if;
11512
 
11513
         --  We do not want this node marked as Comes_From_Source, since
11514
         --  otherwise it would get first class status and a separate cross-
11515
         --  reference line would be generated. Illegitimate children do not
11516
         --  rate such recognition.
11517
 
11518
         Set_Comes_From_Source (New_Compon, False);
11519
 
11520
         --  But it is a real entity, and a birth certificate must be properly
11521
         --  registered by entering it into the entity list.
11522
 
11523
         Enter_Name (New_Compon);
11524
 
11525
         return New_Compon;
11526
      end Create_Component;
11527
 
11528
      -----------------------
11529
      -- Is_Variant_Record --
11530
      -----------------------
11531
 
11532
      function Is_Variant_Record (T : Entity_Id) return Boolean is
11533
      begin
11534
         return Nkind (Parent (T)) = N_Full_Type_Declaration
11535
           and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
11536
           and then Present (Component_List (Type_Definition (Parent (T))))
11537
           and then
11538
             Present
11539
               (Variant_Part (Component_List (Type_Definition (Parent (T)))));
11540
      end Is_Variant_Record;
11541
 
11542
   --  Start of processing for Create_Constrained_Components
11543
 
11544
   begin
11545
      pragma Assert (Subt /= Base_Type (Subt));
11546
      pragma Assert (Typ = Base_Type (Typ));
11547
 
11548
      Set_First_Entity (Subt, Empty);
11549
      Set_Last_Entity  (Subt, Empty);
11550
 
11551
      --  Check whether constraint is fully static, in which case we can
11552
      --  optimize the list of components.
11553
 
11554
      Discr_Val := First_Elmt (Constraints);
11555
      while Present (Discr_Val) loop
11556
         if not Is_OK_Static_Expression (Node (Discr_Val)) then
11557
            Is_Static := False;
11558
            exit;
11559
         end if;
11560
 
11561
         Next_Elmt (Discr_Val);
11562
      end loop;
11563
 
11564
      Set_Has_Static_Discriminants (Subt, Is_Static);
11565
 
11566
      Push_Scope (Subt);
11567
 
11568
      --  Inherit the discriminants of the parent type
11569
 
11570
      Add_Discriminants : declare
11571
         Num_Disc : Int;
11572
         Num_Gird : Int;
11573
 
11574
      begin
11575
         Num_Disc := 0;
11576
         Old_C := First_Discriminant (Typ);
11577
 
11578
         while Present (Old_C) loop
11579
            Num_Disc := Num_Disc + 1;
11580
            New_C := Create_Component (Old_C);
11581
            Set_Is_Public (New_C, Is_Public (Subt));
11582
            Next_Discriminant (Old_C);
11583
         end loop;
11584
 
11585
         --  For an untagged derived subtype, the number of discriminants may
11586
         --  be smaller than the number of inherited discriminants, because
11587
         --  several of them may be renamed by a single new discriminant or
11588
         --  constrained. In this case, add the hidden discriminants back into
11589
         --  the subtype, because they need to be present if the optimizer of
11590
         --  the GCC 4.x back-end decides to break apart assignments between
11591
         --  objects using the parent view into member-wise assignments.
11592
 
11593
         Num_Gird := 0;
11594
 
11595
         if Is_Derived_Type (Typ)
11596
           and then not Is_Tagged_Type (Typ)
11597
         then
11598
            Old_C := First_Stored_Discriminant (Typ);
11599
 
11600
            while Present (Old_C) loop
11601
               Num_Gird := Num_Gird + 1;
11602
               Next_Stored_Discriminant (Old_C);
11603
            end loop;
11604
         end if;
11605
 
11606
         if Num_Gird > Num_Disc then
11607
 
11608
            --  Find out multiple uses of new discriminants, and add hidden
11609
            --  components for the extra renamed discriminants. We recognize
11610
            --  multiple uses through the Corresponding_Discriminant of a
11611
            --  new discriminant: if it constrains several old discriminants,
11612
            --  this field points to the last one in the parent type. The
11613
            --  stored discriminants of the derived type have the same name
11614
            --  as those of the parent.
11615
 
11616
            declare
11617
               Constr    : Elmt_Id;
11618
               New_Discr : Entity_Id;
11619
               Old_Discr : Entity_Id;
11620
 
11621
            begin
11622
               Constr    := First_Elmt (Stored_Constraint (Typ));
11623
               Old_Discr := First_Stored_Discriminant (Typ);
11624
               while Present (Constr) loop
11625
                  if Is_Entity_Name (Node (Constr))
11626
                    and then Ekind (Entity (Node (Constr))) = E_Discriminant
11627
                  then
11628
                     New_Discr := Entity (Node (Constr));
11629
 
11630
                     if Chars (Corresponding_Discriminant (New_Discr)) /=
11631
                        Chars (Old_Discr)
11632
                     then
11633
                        --  The new discriminant has been used to rename a
11634
                        --  subsequent old discriminant. Introduce a shadow
11635
                        --  component for the current old discriminant.
11636
 
11637
                        New_C := Create_Component (Old_Discr);
11638
                        Set_Original_Record_Component (New_C, Old_Discr);
11639
                     end if;
11640
 
11641
                  else
11642
                     --  The constraint has eliminated the old discriminant.
11643
                     --  Introduce a shadow component.
11644
 
11645
                     New_C := Create_Component (Old_Discr);
11646
                     Set_Original_Record_Component (New_C, Old_Discr);
11647
                  end if;
11648
 
11649
                  Next_Elmt (Constr);
11650
                  Next_Stored_Discriminant (Old_Discr);
11651
               end loop;
11652
            end;
11653
         end if;
11654
      end Add_Discriminants;
11655
 
11656
      if Is_Static
11657
        and then Is_Variant_Record (Typ)
11658
      then
11659
         Collect_Fixed_Components (Typ);
11660
 
11661
         Gather_Components (
11662
           Typ,
11663
           Component_List (Type_Definition (Parent (Typ))),
11664
           Governed_By   => Assoc_List,
11665
           Into          => Comp_List,
11666
           Report_Errors => Errors);
11667
         pragma Assert (not Errors);
11668
 
11669
         Create_All_Components;
11670
 
11671
      --  If the subtype declaration is created for a tagged type derivation
11672
      --  with constraints, we retrieve the record definition of the parent
11673
      --  type to select the components of the proper variant.
11674
 
11675
      elsif Is_Static
11676
        and then Is_Tagged_Type (Typ)
11677
        and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
11678
        and then
11679
          Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
11680
        and then Is_Variant_Record (Parent_Type)
11681
      then
11682
         Collect_Fixed_Components (Typ);
11683
 
11684
         Gather_Components (
11685
           Typ,
11686
           Component_List (Type_Definition (Parent (Parent_Type))),
11687
           Governed_By   => Assoc_List,
11688
           Into          => Comp_List,
11689
           Report_Errors => Errors);
11690
         pragma Assert (not Errors);
11691
 
11692
         --  If the tagged derivation has a type extension, collect all the
11693
         --  new components therein.
11694
 
11695
         if Present
11696
              (Record_Extension_Part (Type_Definition (Parent (Typ))))
11697
         then
11698
            Old_C := First_Component (Typ);
11699
            while Present (Old_C) loop
11700
               if Original_Record_Component (Old_C) = Old_C
11701
                and then Chars (Old_C) /= Name_uTag
11702
                and then Chars (Old_C) /= Name_uParent
11703
                and then Chars (Old_C) /= Name_uController
11704
               then
11705
                  Append_Elmt (Old_C, Comp_List);
11706
               end if;
11707
 
11708
               Next_Component (Old_C);
11709
            end loop;
11710
         end if;
11711
 
11712
         Create_All_Components;
11713
 
11714
      else
11715
         --  If discriminants are not static, or if this is a multi-level type
11716
         --  extension, we have to include all components of the parent type.
11717
 
11718
         Old_C := First_Component (Typ);
11719
         while Present (Old_C) loop
11720
            New_C := Create_Component (Old_C);
11721
 
11722
            Set_Etype
11723
              (New_C,
11724
               Constrain_Component_Type
11725
                 (Old_C, Subt, Decl_Node, Typ, Constraints));
11726
            Set_Is_Public (New_C, Is_Public (Subt));
11727
 
11728
            Next_Component (Old_C);
11729
         end loop;
11730
      end if;
11731
 
11732
      End_Scope;
11733
   end Create_Constrained_Components;
11734
 
11735
   ------------------------------------------
11736
   -- Decimal_Fixed_Point_Type_Declaration --
11737
   ------------------------------------------
11738
 
11739
   procedure Decimal_Fixed_Point_Type_Declaration
11740
     (T   : Entity_Id;
11741
      Def : Node_Id)
11742
   is
11743
      Loc           : constant Source_Ptr := Sloc (Def);
11744
      Digs_Expr     : constant Node_Id    := Digits_Expression (Def);
11745
      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
11746
      Implicit_Base : Entity_Id;
11747
      Digs_Val      : Uint;
11748
      Delta_Val     : Ureal;
11749
      Scale_Val     : Uint;
11750
      Bound_Val     : Ureal;
11751
 
11752
   begin
11753
      Check_Restriction (No_Fixed_Point, Def);
11754
 
11755
      --  Create implicit base type
11756
 
11757
      Implicit_Base :=
11758
        Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
11759
      Set_Etype (Implicit_Base, Implicit_Base);
11760
 
11761
      --  Analyze and process delta expression
11762
 
11763
      Analyze_And_Resolve (Delta_Expr, Universal_Real);
11764
 
11765
      Check_Delta_Expression (Delta_Expr);
11766
      Delta_Val := Expr_Value_R (Delta_Expr);
11767
 
11768
      --  Check delta is power of 10, and determine scale value from it
11769
 
11770
      declare
11771
         Val : Ureal;
11772
 
11773
      begin
11774
         Scale_Val := Uint_0;
11775
         Val := Delta_Val;
11776
 
11777
         if Val < Ureal_1 then
11778
            while Val < Ureal_1 loop
11779
               Val := Val * Ureal_10;
11780
               Scale_Val := Scale_Val + 1;
11781
            end loop;
11782
 
11783
            if Scale_Val > 18 then
11784
               Error_Msg_N ("scale exceeds maximum value of 18", Def);
11785
               Scale_Val := UI_From_Int (+18);
11786
            end if;
11787
 
11788
         else
11789
            while Val > Ureal_1 loop
11790
               Val := Val / Ureal_10;
11791
               Scale_Val := Scale_Val - 1;
11792
            end loop;
11793
 
11794
            if Scale_Val < -18 then
11795
               Error_Msg_N ("scale is less than minimum value of -18", Def);
11796
               Scale_Val := UI_From_Int (-18);
11797
            end if;
11798
         end if;
11799
 
11800
         if Val /= Ureal_1 then
11801
            Error_Msg_N ("delta expression must be a power of 10", Def);
11802
            Delta_Val := Ureal_10 ** (-Scale_Val);
11803
         end if;
11804
      end;
11805
 
11806
      --  Set delta, scale and small (small = delta for decimal type)
11807
 
11808
      Set_Delta_Value (Implicit_Base, Delta_Val);
11809
      Set_Scale_Value (Implicit_Base, Scale_Val);
11810
      Set_Small_Value (Implicit_Base, Delta_Val);
11811
 
11812
      --  Analyze and process digits expression
11813
 
11814
      Analyze_And_Resolve (Digs_Expr, Any_Integer);
11815
      Check_Digits_Expression (Digs_Expr);
11816
      Digs_Val := Expr_Value (Digs_Expr);
11817
 
11818
      if Digs_Val > 18 then
11819
         Digs_Val := UI_From_Int (+18);
11820
         Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
11821
      end if;
11822
 
11823
      Set_Digits_Value (Implicit_Base, Digs_Val);
11824
      Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
11825
 
11826
      --  Set range of base type from digits value for now. This will be
11827
      --  expanded to represent the true underlying base range by Freeze.
11828
 
11829
      Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
11830
 
11831
      --  Note: We leave size as zero for now, size will be set at freeze
11832
      --  time. We have to do this for ordinary fixed-point, because the size
11833
      --  depends on the specified small, and we might as well do the same for
11834
      --  decimal fixed-point.
11835
 
11836
      pragma Assert (Esize (Implicit_Base) = Uint_0);
11837
 
11838
      --  If there are bounds given in the declaration use them as the
11839
      --  bounds of the first named subtype.
11840
 
11841
      if Present (Real_Range_Specification (Def)) then
11842
         declare
11843
            RRS      : constant Node_Id := Real_Range_Specification (Def);
11844
            Low      : constant Node_Id := Low_Bound (RRS);
11845
            High     : constant Node_Id := High_Bound (RRS);
11846
            Low_Val  : Ureal;
11847
            High_Val : Ureal;
11848
 
11849
         begin
11850
            Analyze_And_Resolve (Low, Any_Real);
11851
            Analyze_And_Resolve (High, Any_Real);
11852
            Check_Real_Bound (Low);
11853
            Check_Real_Bound (High);
11854
            Low_Val := Expr_Value_R (Low);
11855
            High_Val := Expr_Value_R (High);
11856
 
11857
            if Low_Val < (-Bound_Val) then
11858
               Error_Msg_N
11859
                 ("range low bound too small for digits value", Low);
11860
               Low_Val := -Bound_Val;
11861
            end if;
11862
 
11863
            if High_Val > Bound_Val then
11864
               Error_Msg_N
11865
                 ("range high bound too large for digits value", High);
11866
               High_Val := Bound_Val;
11867
            end if;
11868
 
11869
            Set_Fixed_Range (T, Loc, Low_Val, High_Val);
11870
         end;
11871
 
11872
      --  If no explicit range, use range that corresponds to given
11873
      --  digits value. This will end up as the final range for the
11874
      --  first subtype.
11875
 
11876
      else
11877
         Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
11878
      end if;
11879
 
11880
      --  Complete entity for first subtype
11881
 
11882
      Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
11883
      Set_Etype          (T, Implicit_Base);
11884
      Set_Size_Info      (T, Implicit_Base);
11885
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
11886
      Set_Digits_Value   (T, Digs_Val);
11887
      Set_Delta_Value    (T, Delta_Val);
11888
      Set_Small_Value    (T, Delta_Val);
11889
      Set_Scale_Value    (T, Scale_Val);
11890
      Set_Is_Constrained (T);
11891
   end Decimal_Fixed_Point_Type_Declaration;
11892
 
11893
   -----------------------------------
11894
   -- Derive_Progenitor_Subprograms --
11895
   -----------------------------------
11896
 
11897
   procedure Derive_Progenitor_Subprograms
11898
     (Parent_Type : Entity_Id;
11899
      Tagged_Type : Entity_Id)
11900
   is
11901
      E          : Entity_Id;
11902
      Elmt       : Elmt_Id;
11903
      Iface      : Entity_Id;
11904
      Iface_Elmt : Elmt_Id;
11905
      Iface_Subp : Entity_Id;
11906
      New_Subp   : Entity_Id := Empty;
11907
      Prim_Elmt  : Elmt_Id;
11908
      Subp       : Entity_Id;
11909
      Typ        : Entity_Id;
11910
 
11911
   begin
11912
      pragma Assert (Ada_Version >= Ada_05
11913
        and then Is_Record_Type (Tagged_Type)
11914
        and then Is_Tagged_Type (Tagged_Type)
11915
        and then Has_Interfaces (Tagged_Type));
11916
 
11917
      --  Step 1: Transfer to the full-view primitives associated with the
11918
      --  partial-view that cover interface primitives. Conceptually this
11919
      --  work should be done later by Process_Full_View; done here to
11920
      --  simplify its implementation at later stages. It can be safely
11921
      --  done here because interfaces must be visible in the partial and
11922
      --  private view (RM 7.3(7.3/2)).
11923
 
11924
      --  Small optimization: This work is only required if the parent is
11925
      --  abstract. If the tagged type is not abstract, it cannot have
11926
      --  abstract primitives (the only entities in the list of primitives of
11927
      --  non-abstract tagged types that can reference abstract primitives
11928
      --  through its Alias attribute are the internal entities that have
11929
      --  attribute Interface_Alias, and these entities are generated later
11930
      --  by Freeze_Record_Type).
11931
 
11932
      if In_Private_Part (Current_Scope)
11933
        and then Is_Abstract_Type (Parent_Type)
11934
      then
11935
         Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
11936
         while Present (Elmt) loop
11937
            Subp := Node (Elmt);
11938
 
11939
            --  At this stage it is not possible to have entities in the list
11940
            --  of primitives that have attribute Interface_Alias
11941
 
11942
            pragma Assert (No (Interface_Alias (Subp)));
11943
 
11944
            Typ := Find_Dispatching_Type (Ultimate_Alias (Subp));
11945
 
11946
            if Is_Interface (Typ) then
11947
               E := Find_Primitive_Covering_Interface
11948
                      (Tagged_Type => Tagged_Type,
11949
                       Iface_Prim  => Subp);
11950
 
11951
               if Present (E)
11952
                 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ
11953
               then
11954
                  Replace_Elmt (Elmt, E);
11955
                  Remove_Homonym (Subp);
11956
               end if;
11957
            end if;
11958
 
11959
            Next_Elmt (Elmt);
11960
         end loop;
11961
      end if;
11962
 
11963
      --  Step 2: Add primitives of progenitors that are not implemented by
11964
      --  parents of Tagged_Type
11965
 
11966
      if Present (Interfaces (Base_Type (Tagged_Type))) then
11967
         Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
11968
         while Present (Iface_Elmt) loop
11969
            Iface := Node (Iface_Elmt);
11970
 
11971
            Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
11972
            while Present (Prim_Elmt) loop
11973
               Iface_Subp := Node (Prim_Elmt);
11974
 
11975
               --  Exclude derivation of predefined primitives except those
11976
               --  that come from source. Required to catch declarations of
11977
               --  equality operators of interfaces. For example:
11978
 
11979
               --     type Iface is interface;
11980
               --     function "=" (Left, Right : Iface) return Boolean;
11981
 
11982
               if not Is_Predefined_Dispatching_Operation (Iface_Subp)
11983
                 or else Comes_From_Source (Iface_Subp)
11984
               then
11985
                  E := Find_Primitive_Covering_Interface
11986
                         (Tagged_Type => Tagged_Type,
11987
                          Iface_Prim  => Iface_Subp);
11988
 
11989
                  --  If not found we derive a new primitive leaving its alias
11990
                  --  attribute referencing the interface primitive
11991
 
11992
                  if No (E) then
11993
                     Derive_Subprogram
11994
                       (New_Subp, Iface_Subp, Tagged_Type, Iface);
11995
 
11996
                  --  Propagate to the full view interface entities associated
11997
                  --  with the partial view
11998
 
11999
                  elsif In_Private_Part (Current_Scope)
12000
                    and then Present (Alias (E))
12001
                    and then Alias (E) = Iface_Subp
12002
                    and then
12003
                      List_Containing (Parent (E)) /=
12004
                        Private_Declarations
12005
                          (Specification
12006
                            (Unit_Declaration_Node (Current_Scope)))
12007
                  then
12008
                     Append_Elmt (E, Primitive_Operations (Tagged_Type));
12009
                  end if;
12010
               end if;
12011
 
12012
               Next_Elmt (Prim_Elmt);
12013
            end loop;
12014
 
12015
            Next_Elmt (Iface_Elmt);
12016
         end loop;
12017
      end if;
12018
   end Derive_Progenitor_Subprograms;
12019
 
12020
   -----------------------
12021
   -- Derive_Subprogram --
12022
   -----------------------
12023
 
12024
   procedure Derive_Subprogram
12025
     (New_Subp     : in out Entity_Id;
12026
      Parent_Subp  : Entity_Id;
12027
      Derived_Type : Entity_Id;
12028
      Parent_Type  : Entity_Id;
12029
      Actual_Subp  : Entity_Id := Empty)
12030
   is
12031
      Formal : Entity_Id;
12032
      --  Formal parameter of parent primitive operation
12033
 
12034
      Formal_Of_Actual : Entity_Id;
12035
      --  Formal parameter of actual operation, when the derivation is to
12036
      --  create a renaming for a primitive operation of an actual in an
12037
      --  instantiation.
12038
 
12039
      New_Formal : Entity_Id;
12040
      --  Formal of inherited operation
12041
 
12042
      Visible_Subp : Entity_Id := Parent_Subp;
12043
 
12044
      function Is_Private_Overriding return Boolean;
12045
      --  If Subp is a private overriding of a visible operation, the inherited
12046
      --  operation derives from the overridden op (even though its body is the
12047
      --  overriding one) and the inherited operation is visible now. See
12048
      --  sem_disp to see the full details of the handling of the overridden
12049
      --  subprogram, which is removed from the list of primitive operations of
12050
      --  the type. The overridden subprogram is saved locally in Visible_Subp,
12051
      --  and used to diagnose abstract operations that need overriding in the
12052
      --  derived type.
12053
 
12054
      procedure Replace_Type (Id, New_Id : Entity_Id);
12055
      --  When the type is an anonymous access type, create a new access type
12056
      --  designating the derived type.
12057
 
12058
      procedure Set_Derived_Name;
12059
      --  This procedure sets the appropriate Chars name for New_Subp. This
12060
      --  is normally just a copy of the parent name. An exception arises for
12061
      --  type support subprograms, where the name is changed to reflect the
12062
      --  name of the derived type, e.g. if type foo is derived from type bar,
12063
      --  then a procedure barDA is derived with a name fooDA.
12064
 
12065
      ---------------------------
12066
      -- Is_Private_Overriding --
12067
      ---------------------------
12068
 
12069
      function Is_Private_Overriding return Boolean is
12070
         Prev : Entity_Id;
12071
 
12072
      begin
12073
         --  If the parent is not a dispatching operation there is no
12074
         --  need to investigate overridings
12075
 
12076
         if not Is_Dispatching_Operation (Parent_Subp) then
12077
            return False;
12078
         end if;
12079
 
12080
         --  The visible operation that is overridden is a homonym of the
12081
         --  parent subprogram. We scan the homonym chain to find the one
12082
         --  whose alias is the subprogram we are deriving.
12083
 
12084
         Prev := Current_Entity (Parent_Subp);
12085
         while Present (Prev) loop
12086
            if Ekind (Prev) = Ekind (Parent_Subp)
12087
              and then Alias (Prev) = Parent_Subp
12088
              and then Scope (Parent_Subp) = Scope (Prev)
12089
              and then not Is_Hidden (Prev)
12090
            then
12091
               Visible_Subp := Prev;
12092
               return True;
12093
            end if;
12094
 
12095
            Prev := Homonym (Prev);
12096
         end loop;
12097
 
12098
         return False;
12099
      end Is_Private_Overriding;
12100
 
12101
      ------------------
12102
      -- Replace_Type --
12103
      ------------------
12104
 
12105
      procedure Replace_Type (Id, New_Id : Entity_Id) is
12106
         Acc_Type : Entity_Id;
12107
         Par      : constant Node_Id := Parent (Derived_Type);
12108
 
12109
      begin
12110
         --  When the type is an anonymous access type, create a new access
12111
         --  type designating the derived type. This itype must be elaborated
12112
         --  at the point of the derivation, not on subsequent calls that may
12113
         --  be out of the proper scope for Gigi, so we insert a reference to
12114
         --  it after the derivation.
12115
 
12116
         if Ekind (Etype (Id)) = E_Anonymous_Access_Type then
12117
            declare
12118
               Desig_Typ : Entity_Id := Designated_Type (Etype (Id));
12119
 
12120
            begin
12121
               if Ekind (Desig_Typ) = E_Record_Type_With_Private
12122
                 and then Present (Full_View (Desig_Typ))
12123
                 and then not Is_Private_Type (Parent_Type)
12124
               then
12125
                  Desig_Typ := Full_View (Desig_Typ);
12126
               end if;
12127
 
12128
               if Base_Type (Desig_Typ) = Base_Type (Parent_Type)
12129
 
12130
                  --  Ada 2005 (AI-251): Handle also derivations of abstract
12131
                  --  interface primitives.
12132
 
12133
                 or else (Is_Interface (Desig_Typ)
12134
                          and then not Is_Class_Wide_Type (Desig_Typ))
12135
               then
12136
                  Acc_Type := New_Copy (Etype (Id));
12137
                  Set_Etype (Acc_Type, Acc_Type);
12138
                  Set_Scope (Acc_Type, New_Subp);
12139
 
12140
                  --  Compute size of anonymous access type
12141
 
12142
                  if Is_Array_Type (Desig_Typ)
12143
                    and then not Is_Constrained (Desig_Typ)
12144
                  then
12145
                     Init_Size (Acc_Type, 2 * System_Address_Size);
12146
                  else
12147
                     Init_Size (Acc_Type, System_Address_Size);
12148
                  end if;
12149
 
12150
                  Init_Alignment (Acc_Type);
12151
                  Set_Directly_Designated_Type (Acc_Type, Derived_Type);
12152
 
12153
                  Set_Etype (New_Id, Acc_Type);
12154
                  Set_Scope (New_Id, New_Subp);
12155
 
12156
                  --  Create a reference to it
12157
                  Build_Itype_Reference (Acc_Type, Parent (Derived_Type));
12158
 
12159
               else
12160
                  Set_Etype (New_Id, Etype (Id));
12161
               end if;
12162
            end;
12163
 
12164
         elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
12165
           or else
12166
             (Ekind (Etype (Id)) = E_Record_Type_With_Private
12167
               and then Present (Full_View (Etype (Id)))
12168
               and then
12169
                 Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type))
12170
         then
12171
            --  Constraint checks on formals are generated during expansion,
12172
            --  based on the signature of the original subprogram. The bounds
12173
            --  of the derived type are not relevant, and thus we can use
12174
            --  the base type for the formals. However, the return type may be
12175
            --  used in a context that requires that the proper static bounds
12176
            --  be used (a case statement, for example)  and for those cases
12177
            --  we must use the derived type (first subtype), not its base.
12178
 
12179
            --  If the derived_type_definition has no constraints, we know that
12180
            --  the derived type has the same constraints as the first subtype
12181
            --  of the parent, and we can also use it rather than its base,
12182
            --  which can lead to more efficient code.
12183
 
12184
            if Etype (Id) = Parent_Type then
12185
               if Is_Scalar_Type (Parent_Type)
12186
                 and then
12187
                   Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
12188
               then
12189
                  Set_Etype (New_Id, Derived_Type);
12190
 
12191
               elsif Nkind (Par) = N_Full_Type_Declaration
12192
                 and then
12193
                   Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
12194
                 and then
12195
                   Is_Entity_Name
12196
                     (Subtype_Indication (Type_Definition (Par)))
12197
               then
12198
                  Set_Etype (New_Id, Derived_Type);
12199
 
12200
               else
12201
                  Set_Etype (New_Id, Base_Type (Derived_Type));
12202
               end if;
12203
 
12204
            else
12205
               Set_Etype (New_Id, Base_Type (Derived_Type));
12206
            end if;
12207
 
12208
         --  Ada 2005 (AI-251): Handle derivations of abstract interface
12209
         --  primitives.
12210
 
12211
         elsif Is_Interface (Etype (Id))
12212
           and then not Is_Class_Wide_Type (Etype (Id))
12213
           and then Is_Progenitor (Etype (Id), Derived_Type)
12214
         then
12215
            Set_Etype (New_Id, Derived_Type);
12216
 
12217
         else
12218
            Set_Etype (New_Id, Etype (Id));
12219
         end if;
12220
      end Replace_Type;
12221
 
12222
      ----------------------
12223
      -- Set_Derived_Name --
12224
      ----------------------
12225
 
12226
      procedure Set_Derived_Name is
12227
         Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp);
12228
      begin
12229
         if Nm = TSS_Null then
12230
            Set_Chars (New_Subp, Chars (Parent_Subp));
12231
         else
12232
            Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm));
12233
         end if;
12234
      end Set_Derived_Name;
12235
 
12236
      --  Local variables
12237
 
12238
      Parent_Overrides_Interface_Primitive : Boolean := False;
12239
 
12240
   --  Start of processing for Derive_Subprogram
12241
 
12242
   begin
12243
      New_Subp :=
12244
         New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
12245
      Set_Ekind (New_Subp, Ekind (Parent_Subp));
12246
 
12247
      --  Check whether the parent overrides an interface primitive
12248
 
12249
      if Is_Overriding_Operation (Parent_Subp) then
12250
         declare
12251
            E : Entity_Id := Parent_Subp;
12252
         begin
12253
            while Present (Overridden_Operation (E)) loop
12254
               E := Ultimate_Alias (Overridden_Operation (E));
12255
            end loop;
12256
 
12257
            Parent_Overrides_Interface_Primitive :=
12258
              Is_Dispatching_Operation (E)
12259
                and then Present (Find_Dispatching_Type (E))
12260
                and then Is_Interface (Find_Dispatching_Type (E));
12261
         end;
12262
      end if;
12263
 
12264
      --  Check whether the inherited subprogram is a private operation that
12265
      --  should be inherited but not yet made visible. Such subprograms can
12266
      --  become visible at a later point (e.g., the private part of a public
12267
      --  child unit) via Declare_Inherited_Private_Subprograms. If the
12268
      --  following predicate is true, then this is not such a private
12269
      --  operation and the subprogram simply inherits the name of the parent
12270
      --  subprogram. Note the special check for the names of controlled
12271
      --  operations, which are currently exempted from being inherited with
12272
      --  a hidden name because they must be findable for generation of
12273
      --  implicit run-time calls.
12274
 
12275
      if not Is_Hidden (Parent_Subp)
12276
        or else Is_Internal (Parent_Subp)
12277
        or else Is_Private_Overriding
12278
        or else Is_Internal_Name (Chars (Parent_Subp))
12279
        or else Chars (Parent_Subp) = Name_Initialize
12280
        or else Chars (Parent_Subp) = Name_Adjust
12281
        or else Chars (Parent_Subp) = Name_Finalize
12282
      then
12283
         Set_Derived_Name;
12284
 
12285
      --  An inherited dispatching equality will be overridden by an internally
12286
      --  generated one, or by an explicit one, so preserve its name and thus
12287
      --  its entry in the dispatch table. Otherwise, if Parent_Subp is a
12288
      --  private operation it may become invisible if the full view has
12289
      --  progenitors, and the dispatch table will be malformed.
12290
      --  We check that the type is limited to handle the anomalous declaration
12291
      --  of Limited_Controlled, which is derived from a non-limited type, and
12292
      --  which is handled specially elsewhere as well.
12293
 
12294
      elsif Chars (Parent_Subp) = Name_Op_Eq
12295
        and then Is_Dispatching_Operation (Parent_Subp)
12296
        and then Etype (Parent_Subp) = Standard_Boolean
12297
        and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
12298
        and then
12299
          Etype (First_Formal (Parent_Subp)) =
12300
            Etype (Next_Formal (First_Formal (Parent_Subp)))
12301
      then
12302
         Set_Derived_Name;
12303
 
12304
      --  If parent is hidden, this can be a regular derivation if the
12305
      --  parent is immediately visible in a non-instantiating context,
12306
      --  or if we are in the private part of an instance. This test
12307
      --  should still be refined ???
12308
 
12309
      --  The test for In_Instance_Not_Visible avoids inheriting the derived
12310
      --  operation as a non-visible operation in cases where the parent
12311
      --  subprogram might not be visible now, but was visible within the
12312
      --  original generic, so it would be wrong to make the inherited
12313
      --  subprogram non-visible now. (Not clear if this test is fully
12314
      --  correct; are there any cases where we should declare the inherited
12315
      --  operation as not visible to avoid it being overridden, e.g., when
12316
      --  the parent type is a generic actual with private primitives ???)
12317
 
12318
      --  (they should be treated the same as other private inherited
12319
      --  subprograms, but it's not clear how to do this cleanly). ???
12320
 
12321
      elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
12322
              and then Is_Immediately_Visible (Parent_Subp)
12323
              and then not In_Instance)
12324
        or else In_Instance_Not_Visible
12325
      then
12326
         Set_Derived_Name;
12327
 
12328
      --  Ada 2005 (AI-251): Regular derivation if the parent subprogram
12329
      --  overrides an interface primitive because interface primitives
12330
      --  must be visible in the partial view of the parent (RM 7.3 (7.3/2))
12331
 
12332
      elsif Parent_Overrides_Interface_Primitive then
12333
         Set_Derived_Name;
12334
 
12335
      --  Otherwise, the type is inheriting a private operation, so enter
12336
      --  it with a special name so it can't be overridden.
12337
 
12338
      else
12339
         Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
12340
      end if;
12341
 
12342
      Set_Parent (New_Subp, Parent (Derived_Type));
12343
 
12344
      if Present (Actual_Subp) then
12345
         Replace_Type (Actual_Subp, New_Subp);
12346
      else
12347
         Replace_Type (Parent_Subp, New_Subp);
12348
      end if;
12349
 
12350
      Conditional_Delay (New_Subp, Parent_Subp);
12351
 
12352
      --  If we are creating a renaming for a primitive operation of an
12353
      --  actual of a generic derived type, we must examine the signature
12354
      --  of the actual primitive, not that of the generic formal, which for
12355
      --  example may be an interface. However the name and initial value
12356
      --  of the inherited operation are those of the formal primitive.
12357
 
12358
      Formal := First_Formal (Parent_Subp);
12359
 
12360
      if Present (Actual_Subp) then
12361
         Formal_Of_Actual := First_Formal (Actual_Subp);
12362
      else
12363
         Formal_Of_Actual := Empty;
12364
      end if;
12365
 
12366
      while Present (Formal) loop
12367
         New_Formal := New_Copy (Formal);
12368
 
12369
         --  Normally we do not go copying parents, but in the case of
12370
         --  formals, we need to link up to the declaration (which is the
12371
         --  parameter specification), and it is fine to link up to the
12372
         --  original formal's parameter specification in this case.
12373
 
12374
         Set_Parent (New_Formal, Parent (Formal));
12375
         Append_Entity (New_Formal, New_Subp);
12376
 
12377
         if Present (Formal_Of_Actual) then
12378
            Replace_Type (Formal_Of_Actual, New_Formal);
12379
            Next_Formal (Formal_Of_Actual);
12380
         else
12381
            Replace_Type (Formal, New_Formal);
12382
         end if;
12383
 
12384
         Next_Formal (Formal);
12385
      end loop;
12386
 
12387
      --  If this derivation corresponds to a tagged generic actual, then
12388
      --  primitive operations rename those of the actual. Otherwise the
12389
      --  primitive operations rename those of the parent type, If the parent
12390
      --  renames an intrinsic operator, so does the new subprogram. We except
12391
      --  concatenation, which is always properly typed, and does not get
12392
      --  expanded as other intrinsic operations.
12393
 
12394
      if No (Actual_Subp) then
12395
         if Is_Intrinsic_Subprogram (Parent_Subp) then
12396
            Set_Is_Intrinsic_Subprogram (New_Subp);
12397
 
12398
            if Present (Alias (Parent_Subp))
12399
              and then Chars (Parent_Subp) /= Name_Op_Concat
12400
            then
12401
               Set_Alias (New_Subp, Alias (Parent_Subp));
12402
            else
12403
               Set_Alias (New_Subp, Parent_Subp);
12404
            end if;
12405
 
12406
         else
12407
            Set_Alias (New_Subp, Parent_Subp);
12408
         end if;
12409
 
12410
      else
12411
         Set_Alias (New_Subp, Actual_Subp);
12412
      end if;
12413
 
12414
      --  Derived subprograms of a tagged type must inherit the convention
12415
      --  of the parent subprogram (a requirement of AI-117). Derived
12416
      --  subprograms of untagged types simply get convention Ada by default.
12417
 
12418
      if Is_Tagged_Type (Derived_Type) then
12419
         Set_Convention (New_Subp, Convention (Parent_Subp));
12420
      end if;
12421
 
12422
      --  Predefined controlled operations retain their name even if the parent
12423
      --  is hidden (see above), but they are not primitive operations if the
12424
      --  ancestor is not visible, for example if the parent is a private
12425
      --  extension completed with a controlled extension. Note that a full
12426
      --  type that is controlled can break privacy: the flag Is_Controlled is
12427
      --  set on both views of the type.
12428
 
12429
      if Is_Controlled (Parent_Type)
12430
        and then
12431
          (Chars (Parent_Subp) = Name_Initialize
12432
            or else Chars (Parent_Subp) = Name_Adjust
12433
            or else Chars (Parent_Subp) = Name_Finalize)
12434
        and then Is_Hidden (Parent_Subp)
12435
        and then not Is_Visibly_Controlled (Parent_Type)
12436
      then
12437
         Set_Is_Hidden (New_Subp);
12438
      end if;
12439
 
12440
      Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
12441
      Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
12442
 
12443
      if Ekind (Parent_Subp) = E_Procedure then
12444
         Set_Is_Valued_Procedure
12445
           (New_Subp, Is_Valued_Procedure (Parent_Subp));
12446
      end if;
12447
 
12448
      --  No_Return must be inherited properly. If this is overridden in the
12449
      --  case of a dispatching operation, then a check is made in Sem_Disp
12450
      --  that the overriding operation is also No_Return (no such check is
12451
      --  required for the case of non-dispatching operation.
12452
 
12453
      Set_No_Return (New_Subp, No_Return (Parent_Subp));
12454
 
12455
      --  A derived function with a controlling result is abstract. If the
12456
      --  Derived_Type is a nonabstract formal generic derived type, then
12457
      --  inherited operations are not abstract: the required check is done at
12458
      --  instantiation time. If the derivation is for a generic actual, the
12459
      --  function is not abstract unless the actual is.
12460
 
12461
      if Is_Generic_Type (Derived_Type)
12462
        and then not Is_Abstract_Type (Derived_Type)
12463
      then
12464
         null;
12465
 
12466
      --  Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
12467
      --  properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
12468
 
12469
      elsif Ada_Version >= Ada_05
12470
        and then (Is_Abstract_Subprogram (Alias (New_Subp))
12471
                   or else (Is_Tagged_Type (Derived_Type)
12472
                            and then Etype (New_Subp) = Derived_Type
12473
                            and then not Is_Null_Extension (Derived_Type))
12474
                   or else (Is_Tagged_Type (Derived_Type)
12475
                            and then Ekind (Etype (New_Subp)) =
12476
                                                       E_Anonymous_Access_Type
12477
                            and then Designated_Type (Etype (New_Subp)) =
12478
                                                       Derived_Type
12479
                            and then not Is_Null_Extension (Derived_Type)))
12480
        and then No (Actual_Subp)
12481
      then
12482
         if not Is_Tagged_Type (Derived_Type)
12483
           or else Is_Abstract_Type (Derived_Type)
12484
           or else Is_Abstract_Subprogram (Alias (New_Subp))
12485
         then
12486
            Set_Is_Abstract_Subprogram (New_Subp);
12487
         else
12488
            Set_Requires_Overriding (New_Subp);
12489
         end if;
12490
 
12491
      elsif Ada_Version < Ada_05
12492
        and then (Is_Abstract_Subprogram (Alias (New_Subp))
12493
                   or else (Is_Tagged_Type (Derived_Type)
12494
                             and then Etype (New_Subp) = Derived_Type
12495
                             and then No (Actual_Subp)))
12496
      then
12497
         Set_Is_Abstract_Subprogram (New_Subp);
12498
 
12499
      --  Finally, if the parent type is abstract we must verify that all
12500
      --  inherited operations are either non-abstract or overridden, or that
12501
      --  the derived type itself is abstract (this check is performed at the
12502
      --  end of a package declaration, in Check_Abstract_Overriding). A
12503
      --  private overriding in the parent type will not be visible in the
12504
      --  derivation if we are not in an inner package or in a child unit of
12505
      --  the parent type, in which case the abstractness of the inherited
12506
      --  operation is carried to the new subprogram.
12507
 
12508
      elsif Is_Abstract_Type (Parent_Type)
12509
        and then not In_Open_Scopes (Scope (Parent_Type))
12510
        and then Is_Private_Overriding
12511
        and then Is_Abstract_Subprogram (Visible_Subp)
12512
      then
12513
         if No (Actual_Subp) then
12514
            Set_Alias (New_Subp, Visible_Subp);
12515
            Set_Is_Abstract_Subprogram (New_Subp, True);
12516
 
12517
         else
12518
            --  If this is a derivation for an instance of a formal derived
12519
            --  type, abstractness comes from the primitive operation of the
12520
            --  actual, not from the operation inherited from the ancestor.
12521
 
12522
            Set_Is_Abstract_Subprogram
12523
              (New_Subp, Is_Abstract_Subprogram (Actual_Subp));
12524
         end if;
12525
      end if;
12526
 
12527
      New_Overloaded_Entity (New_Subp, Derived_Type);
12528
 
12529
      --  Check for case of a derived subprogram for the instantiation of a
12530
      --  formal derived tagged type, if so mark the subprogram as dispatching
12531
      --  and inherit the dispatching attributes of the parent subprogram. The
12532
      --  derived subprogram is effectively renaming of the actual subprogram,
12533
      --  so it needs to have the same attributes as the actual.
12534
 
12535
      if Present (Actual_Subp)
12536
        and then Is_Dispatching_Operation (Parent_Subp)
12537
      then
12538
         Set_Is_Dispatching_Operation (New_Subp);
12539
 
12540
         if Present (DTC_Entity (Parent_Subp)) then
12541
            Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
12542
            Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
12543
         end if;
12544
      end if;
12545
 
12546
      --  Indicate that a derived subprogram does not require a body and that
12547
      --  it does not require processing of default expressions.
12548
 
12549
      Set_Has_Completion (New_Subp);
12550
      Set_Default_Expressions_Processed (New_Subp);
12551
 
12552
      if Ekind (New_Subp) = E_Function then
12553
         Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
12554
      end if;
12555
   end Derive_Subprogram;
12556
 
12557
   ------------------------
12558
   -- Derive_Subprograms --
12559
   ------------------------
12560
 
12561
   procedure Derive_Subprograms
12562
     (Parent_Type    : Entity_Id;
12563
      Derived_Type   : Entity_Id;
12564
      Generic_Actual : Entity_Id := Empty)
12565
   is
12566
      Op_List : constant Elist_Id :=
12567
                  Collect_Primitive_Operations (Parent_Type);
12568
 
12569
      function Check_Derived_Type return Boolean;
12570
      --  Check that all primitive inherited from Parent_Type are found in
12571
      --  the list of primitives of Derived_Type exactly in the same order.
12572
 
12573
      function Check_Derived_Type return Boolean is
12574
         E        : Entity_Id;
12575
         Elmt     : Elmt_Id;
12576
         List     : Elist_Id;
12577
         New_Subp : Entity_Id;
12578
         Op_Elmt  : Elmt_Id;
12579
         Subp     : Entity_Id;
12580
 
12581
      begin
12582
         --  Traverse list of entities in the current scope searching for
12583
         --  an incomplete type whose full-view is derived type
12584
 
12585
         E := First_Entity (Scope (Derived_Type));
12586
         while Present (E)
12587
           and then E /= Derived_Type
12588
         loop
12589
            if Ekind (E) = E_Incomplete_Type
12590
              and then Present (Full_View (E))
12591
              and then Full_View (E) = Derived_Type
12592
            then
12593
               --  Disable this test if Derived_Type completes an incomplete
12594
               --  type because in such case more primitives can be added
12595
               --  later to the list of primitives of Derived_Type by routine
12596
               --  Process_Incomplete_Dependents
12597
 
12598
               return True;
12599
            end if;
12600
 
12601
            E := Next_Entity (E);
12602
         end loop;
12603
 
12604
         List := Collect_Primitive_Operations (Derived_Type);
12605
         Elmt := First_Elmt (List);
12606
 
12607
         Op_Elmt := First_Elmt (Op_List);
12608
         while Present (Op_Elmt) loop
12609
            Subp     := Node (Op_Elmt);
12610
            New_Subp := Node (Elmt);
12611
 
12612
            --  At this early stage Derived_Type has no entities with attribute
12613
            --  Interface_Alias. In addition, such primitives are always
12614
            --  located at the end of the list of primitives of Parent_Type.
12615
            --  Therefore, if found we can safely stop processing pending
12616
            --  entities.
12617
 
12618
            exit when Present (Interface_Alias (Subp));
12619
 
12620
            --  Handle hidden entities
12621
 
12622
            if not Is_Predefined_Dispatching_Operation (Subp)
12623
              and then Is_Hidden (Subp)
12624
            then
12625
               if Present (New_Subp)
12626
                 and then Primitive_Names_Match (Subp, New_Subp)
12627
               then
12628
                  Next_Elmt (Elmt);
12629
               end if;
12630
 
12631
            else
12632
               if not Present (New_Subp)
12633
                 or else Ekind (Subp) /= Ekind (New_Subp)
12634
                 or else not Primitive_Names_Match (Subp, New_Subp)
12635
               then
12636
                  return False;
12637
               end if;
12638
 
12639
               Next_Elmt (Elmt);
12640
            end if;
12641
 
12642
            Next_Elmt (Op_Elmt);
12643
         end loop;
12644
 
12645
         return True;
12646
      end Check_Derived_Type;
12647
 
12648
      --  Local variables
12649
 
12650
      Alias_Subp   : Entity_Id;
12651
      Act_List     : Elist_Id;
12652
      Act_Elmt     : Elmt_Id   := No_Elmt;
12653
      Act_Subp     : Entity_Id := Empty;
12654
      Elmt         : Elmt_Id;
12655
      Need_Search  : Boolean   := False;
12656
      New_Subp     : Entity_Id := Empty;
12657
      Parent_Base  : Entity_Id;
12658
      Subp         : Entity_Id;
12659
 
12660
   --  Start of processing for Derive_Subprograms
12661
 
12662
   begin
12663
      if Ekind (Parent_Type) = E_Record_Type_With_Private
12664
        and then Has_Discriminants (Parent_Type)
12665
        and then Present (Full_View (Parent_Type))
12666
      then
12667
         Parent_Base := Full_View (Parent_Type);
12668
      else
12669
         Parent_Base := Parent_Type;
12670
      end if;
12671
 
12672
      if Present (Generic_Actual) then
12673
         Act_List := Collect_Primitive_Operations (Generic_Actual);
12674
         Act_Elmt := First_Elmt (Act_List);
12675
      end if;
12676
 
12677
      --  Derive primitives inherited from the parent. Note that if the generic
12678
      --  actual is present, this is not really a type derivation, it is a
12679
      --  completion within an instance.
12680
 
12681
      --  Case 1: Derived_Type does not implement interfaces
12682
 
12683
      if not Is_Tagged_Type (Derived_Type)
12684
        or else (not Has_Interfaces (Derived_Type)
12685
                  and then not (Present (Generic_Actual)
12686
                                  and then
12687
                                Has_Interfaces (Generic_Actual)))
12688
      then
12689
         Elmt := First_Elmt (Op_List);
12690
         while Present (Elmt) loop
12691
            Subp := Node (Elmt);
12692
 
12693
            --  Literals are derived earlier in the process of building the
12694
            --  derived type, and are skipped here.
12695
 
12696
            if Ekind (Subp) = E_Enumeration_Literal then
12697
               null;
12698
 
12699
            --  The actual is a direct descendant and the common primitive
12700
            --  operations appear in the same order.
12701
 
12702
            --  If the generic parent type is present, the derived type is an
12703
            --  instance of a formal derived type, and within the instance its
12704
            --  operations are those of the actual. We derive from the formal
12705
            --  type but make the inherited operations aliases of the
12706
            --  corresponding operations of the actual.
12707
 
12708
            else
12709
               Derive_Subprogram
12710
                 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
12711
 
12712
               if Present (Act_Elmt) then
12713
                  Next_Elmt (Act_Elmt);
12714
               end if;
12715
            end if;
12716
 
12717
            Next_Elmt (Elmt);
12718
         end loop;
12719
 
12720
      --  Case 2: Derived_Type implements interfaces
12721
 
12722
      else
12723
         --  If the parent type has no predefined primitives we remove
12724
         --  predefined primitives from the list of primitives of generic
12725
         --  actual to simplify the complexity of this algorithm.
12726
 
12727
         if Present (Generic_Actual) then
12728
            declare
12729
               Has_Predefined_Primitives : Boolean := False;
12730
 
12731
            begin
12732
               --  Check if the parent type has predefined primitives
12733
 
12734
               Elmt := First_Elmt (Op_List);
12735
               while Present (Elmt) loop
12736
                  Subp := Node (Elmt);
12737
 
12738
                  if Is_Predefined_Dispatching_Operation (Subp)
12739
                    and then not Comes_From_Source (Ultimate_Alias (Subp))
12740
                  then
12741
                     Has_Predefined_Primitives := True;
12742
                     exit;
12743
                  end if;
12744
 
12745
                  Next_Elmt (Elmt);
12746
               end loop;
12747
 
12748
               --  Remove predefined primitives of Generic_Actual. We must use
12749
               --  an auxiliary list because in case of tagged types the value
12750
               --  returned by Collect_Primitive_Operations is the value stored
12751
               --  in its Primitive_Operations attribute (and we don't want to
12752
               --  modify its current contents).
12753
 
12754
               if not Has_Predefined_Primitives then
12755
                  declare
12756
                     Aux_List : constant Elist_Id := New_Elmt_List;
12757
 
12758
                  begin
12759
                     Elmt := First_Elmt (Act_List);
12760
                     while Present (Elmt) loop
12761
                        Subp := Node (Elmt);
12762
 
12763
                        if not Is_Predefined_Dispatching_Operation (Subp)
12764
                          or else Comes_From_Source (Subp)
12765
                        then
12766
                           Append_Elmt (Subp, Aux_List);
12767
                        end if;
12768
 
12769
                        Next_Elmt (Elmt);
12770
                     end loop;
12771
 
12772
                     Act_List := Aux_List;
12773
                  end;
12774
               end if;
12775
 
12776
               Act_Elmt := First_Elmt (Act_List);
12777
               Act_Subp := Node (Act_Elmt);
12778
            end;
12779
         end if;
12780
 
12781
         --  Stage 1: If the generic actual is not present we derive the
12782
         --  primitives inherited from the parent type. If the generic parent
12783
         --  type is present, the derived type is an instance of a formal
12784
         --  derived type, and within the instance its operations are those of
12785
         --  the actual. We derive from the formal type but make the inherited
12786
         --  operations aliases of the corresponding operations of the actual.
12787
 
12788
         Elmt := First_Elmt (Op_List);
12789
         while Present (Elmt) loop
12790
            Subp       := Node (Elmt);
12791
            Alias_Subp := Ultimate_Alias (Subp);
12792
 
12793
            --  At this early stage Derived_Type has no entities with attribute
12794
            --  Interface_Alias. In addition, such primitives are always
12795
            --  located at the end of the list of primitives of Parent_Type.
12796
            --  Therefore, if found we can safely stop processing pending
12797
            --  entities.
12798
 
12799
            exit when Present (Interface_Alias (Subp));
12800
 
12801
            --  If the generic actual is present find the corresponding
12802
            --  operation in the generic actual. If the parent type is a
12803
            --  direct ancestor of the derived type then, even if it is an
12804
            --  interface, the operations are inherited from the primary
12805
            --  dispatch table and are in the proper order. If we detect here
12806
            --  that primitives are not in the same order we traverse the list
12807
            --  of primitive operations of the actual to find the one that
12808
            --  implements the interface primitive.
12809
 
12810
            if Need_Search
12811
              or else
12812
                (Present (Generic_Actual)
12813
                   and then Present (Act_Subp)
12814
                   and then not Primitive_Names_Match (Subp, Act_Subp))
12815
            then
12816
               pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
12817
               pragma Assert (Is_Interface (Parent_Base));
12818
 
12819
               --  Remember that we need searching for all the pending
12820
               --  primitives
12821
 
12822
               Need_Search := True;
12823
 
12824
               --  Handle entities associated with interface primitives
12825
 
12826
               if Present (Alias (Subp))
12827
                 and then Is_Interface (Find_Dispatching_Type (Alias (Subp)))
12828
                 and then not Is_Predefined_Dispatching_Operation (Subp)
12829
               then
12830
                  Act_Subp :=
12831
                    Find_Primitive_Covering_Interface
12832
                      (Tagged_Type => Generic_Actual,
12833
                       Iface_Prim  => Subp);
12834
 
12835
               --  Handle predefined primitives plus the rest of user-defined
12836
               --  primitives
12837
 
12838
               else
12839
                  Act_Elmt := First_Elmt (Act_List);
12840
                  while Present (Act_Elmt) loop
12841
                     Act_Subp := Node (Act_Elmt);
12842
 
12843
                     exit when Primitive_Names_Match (Subp, Act_Subp)
12844
                       and then Type_Conformant (Subp, Act_Subp,
12845
                                  Skip_Controlling_Formals => True)
12846
                       and then No (Interface_Alias (Act_Subp));
12847
 
12848
                     Next_Elmt (Act_Elmt);
12849
                  end loop;
12850
               end if;
12851
            end if;
12852
 
12853
            --   Case 1: If the parent is a limited interface then it has the
12854
            --   predefined primitives of synchronized interfaces. However, the
12855
            --   actual type may be a non-limited type and hence it does not
12856
            --   have such primitives.
12857
 
12858
            if Present (Generic_Actual)
12859
              and then not Present (Act_Subp)
12860
              and then Is_Limited_Interface (Parent_Base)
12861
              and then Is_Predefined_Interface_Primitive (Subp)
12862
            then
12863
               null;
12864
 
12865
            --  Case 2: Inherit entities associated with interfaces that
12866
            --  were not covered by the parent type. We exclude here null
12867
            --  interface primitives because they do not need special
12868
            --  management.
12869
 
12870
            elsif Present (Alias (Subp))
12871
              and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
12872
              and then not
12873
                (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
12874
                   and then Null_Present (Parent (Alias_Subp)))
12875
            then
12876
               Derive_Subprogram
12877
                 (New_Subp     => New_Subp,
12878
                  Parent_Subp  => Alias_Subp,
12879
                  Derived_Type => Derived_Type,
12880
                  Parent_Type  => Find_Dispatching_Type (Alias_Subp),
12881
                  Actual_Subp  => Act_Subp);
12882
 
12883
               if No (Generic_Actual) then
12884
                  Set_Alias (New_Subp, Subp);
12885
               end if;
12886
 
12887
            --  Case 3: Common derivation
12888
 
12889
            else
12890
               Derive_Subprogram
12891
                 (New_Subp     => New_Subp,
12892
                  Parent_Subp  => Subp,
12893
                  Derived_Type => Derived_Type,
12894
                  Parent_Type  => Parent_Base,
12895
                  Actual_Subp  => Act_Subp);
12896
            end if;
12897
 
12898
            --  No need to update Act_Elm if we must search for the
12899
            --  corresponding operation in the generic actual
12900
 
12901
            if not Need_Search
12902
              and then Present (Act_Elmt)
12903
            then
12904
               Next_Elmt (Act_Elmt);
12905
               Act_Subp := Node (Act_Elmt);
12906
            end if;
12907
 
12908
            Next_Elmt (Elmt);
12909
         end loop;
12910
 
12911
         --  Inherit additional operations from progenitors. If the derived
12912
         --  type is a generic actual, there are not new primitive operations
12913
         --  for the type because it has those of the actual, and therefore
12914
         --  nothing needs to be done. The renamings generated above are not
12915
         --  primitive operations, and their purpose is simply to make the
12916
         --  proper operations visible within an instantiation.
12917
 
12918
         if No (Generic_Actual) then
12919
            Derive_Progenitor_Subprograms (Parent_Base, Derived_Type);
12920
         end if;
12921
      end if;
12922
 
12923
      --  Final check: Direct descendants must have their primitives in the
12924
      --  same order. We exclude from this test non-tagged types and instances
12925
      --  of formal derived types. We skip this test if we have already
12926
      --  reported serious errors in the sources.
12927
 
12928
      pragma Assert (not Is_Tagged_Type (Derived_Type)
12929
        or else Present (Generic_Actual)
12930
        or else Serious_Errors_Detected > 0
12931
        or else Check_Derived_Type);
12932
   end Derive_Subprograms;
12933
 
12934
   --------------------------------
12935
   -- Derived_Standard_Character --
12936
   --------------------------------
12937
 
12938
   procedure Derived_Standard_Character
12939
     (N            : Node_Id;
12940
      Parent_Type  : Entity_Id;
12941
      Derived_Type : Entity_Id)
12942
   is
12943
      Loc           : constant Source_Ptr := Sloc (N);
12944
      Def           : constant Node_Id    := Type_Definition (N);
12945
      Indic         : constant Node_Id    := Subtype_Indication (Def);
12946
      Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
12947
      Implicit_Base : constant Entity_Id  :=
12948
                        Create_Itype
12949
                          (E_Enumeration_Type, N, Derived_Type, 'B');
12950
 
12951
      Lo : Node_Id;
12952
      Hi : Node_Id;
12953
 
12954
   begin
12955
      Discard_Node (Process_Subtype (Indic, N));
12956
 
12957
      Set_Etype     (Implicit_Base, Parent_Base);
12958
      Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
12959
      Set_RM_Size   (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
12960
 
12961
      Set_Is_Character_Type  (Implicit_Base, True);
12962
      Set_Has_Delayed_Freeze (Implicit_Base);
12963
 
12964
      --  The bounds of the implicit base are the bounds of the parent base.
12965
      --  Note that their type is the parent base.
12966
 
12967
      Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Base));
12968
      Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
12969
 
12970
      Set_Scalar_Range (Implicit_Base,
12971
        Make_Range (Loc,
12972
          Low_Bound  => Lo,
12973
          High_Bound => Hi));
12974
 
12975
      Conditional_Delay (Derived_Type, Parent_Type);
12976
 
12977
      Set_Ekind (Derived_Type, E_Enumeration_Subtype);
12978
      Set_Etype (Derived_Type, Implicit_Base);
12979
      Set_Size_Info         (Derived_Type, Parent_Type);
12980
 
12981
      if Unknown_RM_Size (Derived_Type) then
12982
         Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
12983
      end if;
12984
 
12985
      Set_Is_Character_Type (Derived_Type, True);
12986
 
12987
      if Nkind (Indic) /= N_Subtype_Indication then
12988
 
12989
         --  If no explicit constraint, the bounds are those
12990
         --  of the parent type.
12991
 
12992
         Lo := New_Copy_Tree (Type_Low_Bound  (Parent_Type));
12993
         Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
12994
         Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi));
12995
      end if;
12996
 
12997
      Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
12998
 
12999
      --  Because the implicit base is used in the conversion of the bounds, we
13000
      --  have to freeze it now. This is similar to what is done for numeric
13001
      --  types, and it equally suspicious, but otherwise a non-static bound
13002
      --  will have a reference to an unfrozen type, which is rejected by Gigi
13003
      --  (???). This requires specific care for definition of stream
13004
      --  attributes. For details, see comments at the end of
13005
      --  Build_Derived_Numeric_Type.
13006
 
13007
      Freeze_Before (N, Implicit_Base);
13008
   end Derived_Standard_Character;
13009
 
13010
   ------------------------------
13011
   -- Derived_Type_Declaration --
13012
   ------------------------------
13013
 
13014
   procedure Derived_Type_Declaration
13015
     (T             : Entity_Id;
13016
      N             : Node_Id;
13017
      Is_Completion : Boolean)
13018
   is
13019
      Parent_Type  : Entity_Id;
13020
 
13021
      function Comes_From_Generic (Typ : Entity_Id) return Boolean;
13022
      --  Check whether the parent type is a generic formal, or derives
13023
      --  directly or indirectly from one.
13024
 
13025
      ------------------------
13026
      -- Comes_From_Generic --
13027
      ------------------------
13028
 
13029
      function Comes_From_Generic (Typ : Entity_Id) return Boolean is
13030
      begin
13031
         if Is_Generic_Type (Typ) then
13032
            return True;
13033
 
13034
         elsif Is_Generic_Type (Root_Type (Parent_Type)) then
13035
            return True;
13036
 
13037
         elsif Is_Private_Type (Typ)
13038
           and then Present (Full_View (Typ))
13039
           and then Is_Generic_Type (Root_Type (Full_View (Typ)))
13040
         then
13041
            return True;
13042
 
13043
         elsif Is_Generic_Actual_Type (Typ) then
13044
            return True;
13045
 
13046
         else
13047
            return False;
13048
         end if;
13049
      end Comes_From_Generic;
13050
 
13051
      --  Local variables
13052
 
13053
      Def          : constant Node_Id := Type_Definition (N);
13054
      Iface_Def    : Node_Id;
13055
      Indic        : constant Node_Id := Subtype_Indication (Def);
13056
      Extension    : constant Node_Id := Record_Extension_Part (Def);
13057
      Parent_Node  : Node_Id;
13058
      Parent_Scope : Entity_Id;
13059
      Taggd        : Boolean;
13060
 
13061
   --  Start of processing for Derived_Type_Declaration
13062
 
13063
   begin
13064
      Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
13065
 
13066
      --  Ada 2005 (AI-251): In case of interface derivation check that the
13067
      --  parent is also an interface.
13068
 
13069
      if Interface_Present (Def) then
13070
         if not Is_Interface (Parent_Type) then
13071
            Diagnose_Interface (Indic, Parent_Type);
13072
 
13073
         else
13074
            Parent_Node := Parent (Base_Type (Parent_Type));
13075
            Iface_Def   := Type_Definition (Parent_Node);
13076
 
13077
            --  Ada 2005 (AI-251): Limited interfaces can only inherit from
13078
            --  other limited interfaces.
13079
 
13080
            if Limited_Present (Def) then
13081
               if Limited_Present (Iface_Def) then
13082
                  null;
13083
 
13084
               elsif Protected_Present (Iface_Def) then
13085
                  Error_Msg_NE
13086
                    ("descendant of& must be declared"
13087
                       & " as a protected interface",
13088
                         N, Parent_Type);
13089
 
13090
               elsif Synchronized_Present (Iface_Def) then
13091
                  Error_Msg_NE
13092
                    ("descendant of& must be declared"
13093
                       & " as a synchronized interface",
13094
                         N, Parent_Type);
13095
 
13096
               elsif Task_Present (Iface_Def) then
13097
                  Error_Msg_NE
13098
                    ("descendant of& must be declared as a task interface",
13099
                       N, Parent_Type);
13100
 
13101
               else
13102
                  Error_Msg_N
13103
                    ("(Ada 2005) limited interface cannot "
13104
                     & "inherit from non-limited interface", Indic);
13105
               end if;
13106
 
13107
            --  Ada 2005 (AI-345): Non-limited interfaces can only inherit
13108
            --  from non-limited or limited interfaces.
13109
 
13110
            elsif not Protected_Present (Def)
13111
              and then not Synchronized_Present (Def)
13112
              and then not Task_Present (Def)
13113
            then
13114
               if Limited_Present (Iface_Def) then
13115
                  null;
13116
 
13117
               elsif Protected_Present (Iface_Def) then
13118
                  Error_Msg_NE
13119
                    ("descendant of& must be declared"
13120
                       & " as a protected interface",
13121
                         N, Parent_Type);
13122
 
13123
               elsif Synchronized_Present (Iface_Def) then
13124
                  Error_Msg_NE
13125
                    ("descendant of& must be declared"
13126
                       & " as a synchronized interface",
13127
                         N, Parent_Type);
13128
 
13129
               elsif Task_Present (Iface_Def) then
13130
                  Error_Msg_NE
13131
                    ("descendant of& must be declared as a task interface",
13132
                       N, Parent_Type);
13133
               else
13134
                  null;
13135
               end if;
13136
            end if;
13137
         end if;
13138
      end if;
13139
 
13140
      if Is_Tagged_Type (Parent_Type)
13141
        and then Is_Concurrent_Type (Parent_Type)
13142
        and then not Is_Interface (Parent_Type)
13143
      then
13144
         Error_Msg_N
13145
           ("parent type of a record extension cannot be "
13146
            & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
13147
         Set_Etype (T, Any_Type);
13148
         return;
13149
      end if;
13150
 
13151
      --  Ada 2005 (AI-251): Decorate all the names in the list of ancestor
13152
      --  interfaces
13153
 
13154
      if Is_Tagged_Type (Parent_Type)
13155
        and then Is_Non_Empty_List (Interface_List (Def))
13156
      then
13157
         declare
13158
            Intf : Node_Id;
13159
            T    : Entity_Id;
13160
 
13161
         begin
13162
            Intf := First (Interface_List (Def));
13163
            while Present (Intf) loop
13164
               T := Find_Type_Of_Subtype_Indic (Intf);
13165
 
13166
               if not Is_Interface (T) then
13167
                  Diagnose_Interface (Intf, T);
13168
 
13169
               --  Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow
13170
               --  a limited type from having a nonlimited progenitor.
13171
 
13172
               elsif (Limited_Present (Def)
13173
                       or else (not Is_Interface (Parent_Type)
13174
                                 and then Is_Limited_Type (Parent_Type)))
13175
                 and then not Is_Limited_Interface (T)
13176
               then
13177
                  Error_Msg_NE
13178
                   ("progenitor interface& of limited type must be limited",
13179
                     N, T);
13180
               end if;
13181
 
13182
               Next (Intf);
13183
            end loop;
13184
         end;
13185
      end if;
13186
 
13187
      if Parent_Type = Any_Type
13188
        or else Etype (Parent_Type) = Any_Type
13189
        or else (Is_Class_Wide_Type (Parent_Type)
13190
                   and then Etype (Parent_Type) = T)
13191
      then
13192
         --  If Parent_Type is undefined or illegal, make new type into a
13193
         --  subtype of Any_Type, and set a few attributes to prevent cascaded
13194
         --  errors. If this is a self-definition, emit error now.
13195
 
13196
         if T = Parent_Type
13197
           or else T = Etype (Parent_Type)
13198
         then
13199
            Error_Msg_N ("type cannot be used in its own definition", Indic);
13200
         end if;
13201
 
13202
         Set_Ekind        (T, Ekind (Parent_Type));
13203
         Set_Etype        (T, Any_Type);
13204
         Set_Scalar_Range (T, Scalar_Range (Any_Type));
13205
 
13206
         if Is_Tagged_Type (T) then
13207
            Set_Primitive_Operations (T, New_Elmt_List);
13208
         end if;
13209
 
13210
         return;
13211
      end if;
13212
 
13213
      --  Ada 2005 (AI-251): The case in which the parent of the full-view is
13214
      --  an interface is special because the list of interfaces in the full
13215
      --  view can be given in any order. For example:
13216
 
13217
      --     type A is interface;
13218
      --     type B is interface and A;
13219
      --     type D is new B with private;
13220
      --   private
13221
      --     type D is new A and B with null record; -- 1 --
13222
 
13223
      --  In this case we perform the following transformation of -1-:
13224
 
13225
      --     type D is new B and A with null record;
13226
 
13227
      --  If the parent of the full-view covers the parent of the partial-view
13228
      --  we have two possible cases:
13229
 
13230
      --     1) They have the same parent
13231
      --     2) The parent of the full-view implements some further interfaces
13232
 
13233
      --  In both cases we do not need to perform the transformation. In the
13234
      --  first case the source program is correct and the transformation is
13235
      --  not needed; in the second case the source program does not fulfill
13236
      --  the no-hidden interfaces rule (AI-396) and the error will be reported
13237
      --  later.
13238
 
13239
      --  This transformation not only simplifies the rest of the analysis of
13240
      --  this type declaration but also simplifies the correct generation of
13241
      --  the object layout to the expander.
13242
 
13243
      if In_Private_Part (Current_Scope)
13244
        and then Is_Interface (Parent_Type)
13245
      then
13246
         declare
13247
            Iface               : Node_Id;
13248
            Partial_View        : Entity_Id;
13249
            Partial_View_Parent : Entity_Id;
13250
            New_Iface           : Node_Id;
13251
 
13252
         begin
13253
            --  Look for the associated private type declaration
13254
 
13255
            Partial_View := First_Entity (Current_Scope);
13256
            loop
13257
               exit when No (Partial_View)
13258
                 or else (Has_Private_Declaration (Partial_View)
13259
                           and then Full_View (Partial_View) = T);
13260
 
13261
               Next_Entity (Partial_View);
13262
            end loop;
13263
 
13264
            --  If the partial view was not found then the source code has
13265
            --  errors and the transformation is not needed.
13266
 
13267
            if Present (Partial_View) then
13268
               Partial_View_Parent := Etype (Partial_View);
13269
 
13270
               --  If the parent of the full-view covers the parent of the
13271
               --  partial-view we have nothing else to do.
13272
 
13273
               if Interface_Present_In_Ancestor
13274
                    (Parent_Type, Partial_View_Parent)
13275
               then
13276
                  null;
13277
 
13278
               --  Traverse the list of interfaces of the full-view to look
13279
               --  for the parent of the partial-view and perform the tree
13280
               --  transformation.
13281
 
13282
               else
13283
                  Iface := First (Interface_List (Def));
13284
                  while Present (Iface) loop
13285
                     if Etype (Iface) = Etype (Partial_View) then
13286
                        Rewrite (Subtype_Indication (Def),
13287
                          New_Copy (Subtype_Indication
13288
                                     (Parent (Partial_View))));
13289
 
13290
                        New_Iface := Make_Identifier (Sloc (N),
13291
                                       Chars (Parent_Type));
13292
                        Append (New_Iface, Interface_List (Def));
13293
 
13294
                        --  Analyze the transformed code
13295
 
13296
                        Derived_Type_Declaration (T, N, Is_Completion);
13297
                        return;
13298
                     end if;
13299
 
13300
                     Next (Iface);
13301
                  end loop;
13302
               end if;
13303
            end if;
13304
         end;
13305
      end if;
13306
 
13307
      --  Only composite types other than array types are allowed to have
13308
      --  discriminants.
13309
 
13310
      if Present (Discriminant_Specifications (N))
13311
        and then (Is_Elementary_Type (Parent_Type)
13312
                  or else Is_Array_Type (Parent_Type))
13313
        and then not Error_Posted (N)
13314
      then
13315
         Error_Msg_N
13316
           ("elementary or array type cannot have discriminants",
13317
            Defining_Identifier (First (Discriminant_Specifications (N))));
13318
         Set_Has_Discriminants (T, False);
13319
      end if;
13320
 
13321
      --  In Ada 83, a derived type defined in a package specification cannot
13322
      --  be used for further derivation until the end of its visible part.
13323
      --  Note that derivation in the private part of the package is allowed.
13324
 
13325
      if Ada_Version = Ada_83
13326
        and then Is_Derived_Type (Parent_Type)
13327
        and then In_Visible_Part (Scope (Parent_Type))
13328
      then
13329
         if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
13330
            Error_Msg_N
13331
              ("(Ada 83): premature use of type for derivation", Indic);
13332
         end if;
13333
      end if;
13334
 
13335
      --  Check for early use of incomplete or private type
13336
 
13337
      if Ekind (Parent_Type) = E_Void
13338
        or else Ekind (Parent_Type) = E_Incomplete_Type
13339
      then
13340
         Error_Msg_N ("premature derivation of incomplete type", Indic);
13341
         return;
13342
 
13343
      elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
13344
              and then not Comes_From_Generic (Parent_Type))
13345
        or else Has_Private_Component (Parent_Type)
13346
      then
13347
         --  The ancestor type of a formal type can be incomplete, in which
13348
         --  case only the operations of the partial view are available in
13349
         --  the generic. Subsequent checks may be required when the full
13350
         --  view is analyzed, to verify that derivation from a tagged type
13351
         --  has an extension.
13352
 
13353
         if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
13354
            null;
13355
 
13356
         elsif No (Underlying_Type (Parent_Type))
13357
           or else Has_Private_Component (Parent_Type)
13358
         then
13359
            Error_Msg_N
13360
              ("premature derivation of derived or private type", Indic);
13361
 
13362
            --  Flag the type itself as being in error, this prevents some
13363
            --  nasty problems with subsequent uses of the malformed type.
13364
 
13365
            Set_Error_Posted (T);
13366
 
13367
         --  Check that within the immediate scope of an untagged partial
13368
         --  view it's illegal to derive from the partial view if the
13369
         --  full view is tagged. (7.3(7))
13370
 
13371
         --  We verify that the Parent_Type is a partial view by checking
13372
         --  that it is not a Full_Type_Declaration (i.e. a private type or
13373
         --  private extension declaration), to distinguish a partial view
13374
         --  from  a derivation from a private type which also appears as
13375
         --  E_Private_Type.
13376
 
13377
         elsif Present (Full_View (Parent_Type))
13378
           and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
13379
           and then not Is_Tagged_Type (Parent_Type)
13380
           and then Is_Tagged_Type (Full_View (Parent_Type))
13381
         then
13382
            Parent_Scope := Scope (T);
13383
            while Present (Parent_Scope)
13384
              and then Parent_Scope /= Standard_Standard
13385
            loop
13386
               if Parent_Scope = Scope (Parent_Type) then
13387
                  Error_Msg_N
13388
                    ("premature derivation from type with tagged full view",
13389
                     Indic);
13390
               end if;
13391
 
13392
               Parent_Scope := Scope (Parent_Scope);
13393
            end loop;
13394
         end if;
13395
      end if;
13396
 
13397
      --  Check that form of derivation is appropriate
13398
 
13399
      Taggd := Is_Tagged_Type (Parent_Type);
13400
 
13401
      --  Perhaps the parent type should be changed to the class-wide type's
13402
      --  specific type in this case to prevent cascading errors ???
13403
 
13404
      if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
13405
         Error_Msg_N ("parent type must not be a class-wide type", Indic);
13406
         return;
13407
      end if;
13408
 
13409
      if Present (Extension) and then not Taggd then
13410
         Error_Msg_N
13411
           ("type derived from untagged type cannot have extension", Indic);
13412
 
13413
      elsif No (Extension) and then Taggd then
13414
 
13415
         --  If this declaration is within a private part (or body) of a
13416
         --  generic instantiation then the derivation is allowed (the parent
13417
         --  type can only appear tagged in this case if it's a generic actual
13418
         --  type, since it would otherwise have been rejected in the analysis
13419
         --  of the generic template).
13420
 
13421
         if not Is_Generic_Actual_Type (Parent_Type)
13422
           or else In_Visible_Part (Scope (Parent_Type))
13423
         then
13424
            Error_Msg_N
13425
              ("type derived from tagged type must have extension", Indic);
13426
         end if;
13427
      end if;
13428
 
13429
      --  AI-443: Synchronized formal derived types require a private
13430
      --  extension. There is no point in checking the ancestor type or
13431
      --  the progenitors since the construct is wrong to begin with.
13432
 
13433
      if Ada_Version >= Ada_05
13434
        and then Is_Generic_Type (T)
13435
        and then Present (Original_Node (N))
13436
      then
13437
         declare
13438
            Decl : constant Node_Id := Original_Node (N);
13439
 
13440
         begin
13441
            if Nkind (Decl) = N_Formal_Type_Declaration
13442
              and then Nkind (Formal_Type_Definition (Decl)) =
13443
                         N_Formal_Derived_Type_Definition
13444
              and then Synchronized_Present (Formal_Type_Definition (Decl))
13445
              and then No (Extension)
13446
 
13447
               --  Avoid emitting a duplicate error message
13448
 
13449
              and then not Error_Posted (Indic)
13450
            then
13451
               Error_Msg_N
13452
                 ("synchronized derived type must have extension", N);
13453
            end if;
13454
         end;
13455
      end if;
13456
 
13457
      if Null_Exclusion_Present (Def)
13458
        and then not Is_Access_Type (Parent_Type)
13459
      then
13460
         Error_Msg_N ("null exclusion can only apply to an access type", N);
13461
      end if;
13462
 
13463
      --  Avoid deriving parent primitives of underlying record views
13464
 
13465
      Build_Derived_Type (N, Parent_Type, T, Is_Completion,
13466
        Derive_Subps => not Is_Underlying_Record_View (T));
13467
 
13468
      --  AI-419: The parent type of an explicitly limited derived type must
13469
      --  be a limited type or a limited interface.
13470
 
13471
      if Limited_Present (Def) then
13472
         Set_Is_Limited_Record (T);
13473
 
13474
         if Is_Interface (T) then
13475
            Set_Is_Limited_Interface (T);
13476
         end if;
13477
 
13478
         if not Is_Limited_Type (Parent_Type)
13479
           and then
13480
             (not Is_Interface (Parent_Type)
13481
               or else not Is_Limited_Interface (Parent_Type))
13482
         then
13483
            Error_Msg_NE ("parent type& of limited type must be limited",
13484
              N, Parent_Type);
13485
         end if;
13486
      end if;
13487
   end Derived_Type_Declaration;
13488
 
13489
   ------------------------
13490
   -- Diagnose_Interface --
13491
   ------------------------
13492
 
13493
   procedure Diagnose_Interface (N : Node_Id;  E : Entity_Id) is
13494
   begin
13495
      if not Is_Interface (E)
13496
        and then  E /= Any_Type
13497
      then
13498
         Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
13499
      end if;
13500
   end Diagnose_Interface;
13501
 
13502
   ----------------------------------
13503
   -- Enumeration_Type_Declaration --
13504
   ----------------------------------
13505
 
13506
   procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
13507
      Ev     : Uint;
13508
      L      : Node_Id;
13509
      R_Node : Node_Id;
13510
      B_Node : Node_Id;
13511
 
13512
   begin
13513
      --  Create identifier node representing lower bound
13514
 
13515
      B_Node := New_Node (N_Identifier, Sloc (Def));
13516
      L := First (Literals (Def));
13517
      Set_Chars (B_Node, Chars (L));
13518
      Set_Entity (B_Node,  L);
13519
      Set_Etype (B_Node, T);
13520
      Set_Is_Static_Expression (B_Node, True);
13521
 
13522
      R_Node := New_Node (N_Range, Sloc (Def));
13523
      Set_Low_Bound  (R_Node, B_Node);
13524
 
13525
      Set_Ekind (T, E_Enumeration_Type);
13526
      Set_First_Literal (T, L);
13527
      Set_Etype (T, T);
13528
      Set_Is_Constrained (T);
13529
 
13530
      Ev := Uint_0;
13531
 
13532
      --  Loop through literals of enumeration type setting pos and rep values
13533
      --  except that if the Ekind is already set, then it means the literal
13534
      --  was already constructed (case of a derived type declaration and we
13535
      --  should not disturb the Pos and Rep values.
13536
 
13537
      while Present (L) loop
13538
         if Ekind (L) /= E_Enumeration_Literal then
13539
            Set_Ekind (L, E_Enumeration_Literal);
13540
            Set_Enumeration_Pos (L, Ev);
13541
            Set_Enumeration_Rep (L, Ev);
13542
            Set_Is_Known_Valid  (L, True);
13543
         end if;
13544
 
13545
         Set_Etype (L, T);
13546
         New_Overloaded_Entity (L);
13547
         Generate_Definition (L);
13548
         Set_Convention (L, Convention_Intrinsic);
13549
 
13550
         if Nkind (L) = N_Defining_Character_Literal then
13551
            Set_Is_Character_Type (T, True);
13552
         end if;
13553
 
13554
         Ev := Ev + 1;
13555
         Next (L);
13556
      end loop;
13557
 
13558
      --  Now create a node representing upper bound
13559
 
13560
      B_Node := New_Node (N_Identifier, Sloc (Def));
13561
      Set_Chars (B_Node, Chars (Last (Literals (Def))));
13562
      Set_Entity (B_Node,  Last (Literals (Def)));
13563
      Set_Etype (B_Node, T);
13564
      Set_Is_Static_Expression (B_Node, True);
13565
 
13566
      Set_High_Bound (R_Node, B_Node);
13567
 
13568
      --  Initialize various fields of the type. Some of this information
13569
      --  may be overwritten later through rep.clauses.
13570
 
13571
      Set_Scalar_Range    (T, R_Node);
13572
      Set_RM_Size         (T, UI_From_Int (Minimum_Size (T)));
13573
      Set_Enum_Esize      (T);
13574
      Set_Enum_Pos_To_Rep (T, Empty);
13575
 
13576
      --  Set Discard_Names if configuration pragma set, or if there is
13577
      --  a parameterless pragma in the current declarative region
13578
 
13579
      if Global_Discard_Names
13580
        or else Discard_Names (Scope (T))
13581
      then
13582
         Set_Discard_Names (T);
13583
      end if;
13584
 
13585
      --  Process end label if there is one
13586
 
13587
      if Present (Def) then
13588
         Process_End_Label (Def, 'e', T);
13589
      end if;
13590
   end Enumeration_Type_Declaration;
13591
 
13592
   ---------------------------------
13593
   -- Expand_To_Stored_Constraint --
13594
   ---------------------------------
13595
 
13596
   function Expand_To_Stored_Constraint
13597
     (Typ        : Entity_Id;
13598
      Constraint : Elist_Id) return Elist_Id
13599
   is
13600
      Explicitly_Discriminated_Type : Entity_Id;
13601
      Expansion    : Elist_Id;
13602
      Discriminant : Entity_Id;
13603
 
13604
      function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
13605
      --  Find the nearest type that actually specifies discriminants
13606
 
13607
      ---------------------------------
13608
      -- Type_With_Explicit_Discrims --
13609
      ---------------------------------
13610
 
13611
      function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
13612
         Typ : constant E := Base_Type (Id);
13613
 
13614
      begin
13615
         if Ekind (Typ) in Incomplete_Or_Private_Kind then
13616
            if Present (Full_View (Typ)) then
13617
               return Type_With_Explicit_Discrims (Full_View (Typ));
13618
            end if;
13619
 
13620
         else
13621
            if Has_Discriminants (Typ) then
13622
               return Typ;
13623
            end if;
13624
         end if;
13625
 
13626
         if Etype (Typ) = Typ then
13627
            return Empty;
13628
         elsif Has_Discriminants (Typ) then
13629
            return Typ;
13630
         else
13631
            return Type_With_Explicit_Discrims (Etype (Typ));
13632
         end if;
13633
 
13634
      end Type_With_Explicit_Discrims;
13635
 
13636
   --  Start of processing for Expand_To_Stored_Constraint
13637
 
13638
   begin
13639
      if No (Constraint)
13640
        or else Is_Empty_Elmt_List (Constraint)
13641
      then
13642
         return No_Elist;
13643
      end if;
13644
 
13645
      Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
13646
 
13647
      if No (Explicitly_Discriminated_Type) then
13648
         return No_Elist;
13649
      end if;
13650
 
13651
      Expansion := New_Elmt_List;
13652
 
13653
      Discriminant :=
13654
         First_Stored_Discriminant (Explicitly_Discriminated_Type);
13655
      while Present (Discriminant) loop
13656
         Append_Elmt (
13657
           Get_Discriminant_Value (
13658
             Discriminant, Explicitly_Discriminated_Type, Constraint),
13659
           Expansion);
13660
         Next_Stored_Discriminant (Discriminant);
13661
      end loop;
13662
 
13663
      return Expansion;
13664
   end Expand_To_Stored_Constraint;
13665
 
13666
   ---------------------------
13667
   -- Find_Hidden_Interface --
13668
   ---------------------------
13669
 
13670
   function Find_Hidden_Interface
13671
     (Src  : Elist_Id;
13672
      Dest : Elist_Id) return Entity_Id
13673
   is
13674
      Iface      : Entity_Id;
13675
      Iface_Elmt : Elmt_Id;
13676
 
13677
   begin
13678
      if Present (Src) and then Present (Dest) then
13679
         Iface_Elmt := First_Elmt (Src);
13680
         while Present (Iface_Elmt) loop
13681
            Iface := Node (Iface_Elmt);
13682
 
13683
            if Is_Interface (Iface)
13684
              and then not Contain_Interface (Iface, Dest)
13685
            then
13686
               return Iface;
13687
            end if;
13688
 
13689
            Next_Elmt (Iface_Elmt);
13690
         end loop;
13691
      end if;
13692
 
13693
      return Empty;
13694
   end Find_Hidden_Interface;
13695
 
13696
   --------------------
13697
   -- Find_Type_Name --
13698
   --------------------
13699
 
13700
   function Find_Type_Name (N : Node_Id) return Entity_Id is
13701
      Id       : constant Entity_Id := Defining_Identifier (N);
13702
      Prev     : Entity_Id;
13703
      New_Id   : Entity_Id;
13704
      Prev_Par : Node_Id;
13705
 
13706
      procedure Tag_Mismatch;
13707
      --  Diagnose a tagged partial view whose full view is untagged.
13708
      --  We post the message on the full view, with a reference to
13709
      --  the previous partial view. The partial view can be private
13710
      --  or incomplete, and these are handled in a different manner,
13711
      --  so we determine the position of the error message from the
13712
      --  respective slocs of both.
13713
 
13714
      ------------------
13715
      -- Tag_Mismatch --
13716
      ------------------
13717
 
13718
      procedure Tag_Mismatch is
13719
      begin
13720
         if Sloc (Prev) < Sloc (Id) then
13721
            Error_Msg_NE
13722
              ("full declaration of } must be a tagged type ", Id, Prev);
13723
         else
13724
            Error_Msg_NE
13725
              ("full declaration of } must be a tagged type ", Prev, Id);
13726
         end if;
13727
      end Tag_Mismatch;
13728
 
13729
   --  Start of processing for Find_Type_Name
13730
 
13731
   begin
13732
      --  Find incomplete declaration, if one was given
13733
 
13734
      Prev := Current_Entity_In_Scope (Id);
13735
 
13736
      if Present (Prev) then
13737
 
13738
         --  Previous declaration exists. Error if not incomplete/private case
13739
         --  except if previous declaration is implicit, etc. Enter_Name will
13740
         --  emit error if appropriate.
13741
 
13742
         Prev_Par := Parent (Prev);
13743
 
13744
         if not Is_Incomplete_Or_Private_Type (Prev) then
13745
            Enter_Name (Id);
13746
            New_Id := Id;
13747
 
13748
         elsif not Nkind_In (N, N_Full_Type_Declaration,
13749
                                N_Task_Type_Declaration,
13750
                                N_Protected_Type_Declaration)
13751
         then
13752
            --  Completion must be a full type declarations (RM 7.3(4))
13753
 
13754
            Error_Msg_Sloc := Sloc (Prev);
13755
            Error_Msg_NE ("invalid completion of }", Id, Prev);
13756
 
13757
            --  Set scope of Id to avoid cascaded errors. Entity is never
13758
            --  examined again, except when saving globals in generics.
13759
 
13760
            Set_Scope (Id, Current_Scope);
13761
            New_Id := Id;
13762
 
13763
            --  If this is a repeated incomplete declaration, no further
13764
            --  checks are possible.
13765
 
13766
            if Nkind (N) = N_Incomplete_Type_Declaration then
13767
               return Prev;
13768
            end if;
13769
 
13770
         --  Case of full declaration of incomplete type
13771
 
13772
         elsif Ekind (Prev) = E_Incomplete_Type then
13773
 
13774
            --  Indicate that the incomplete declaration has a matching full
13775
            --  declaration. The defining occurrence of the incomplete
13776
            --  declaration remains the visible one, and the procedure
13777
            --  Get_Full_View dereferences it whenever the type is used.
13778
 
13779
            if Present (Full_View (Prev)) then
13780
               Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
13781
            end if;
13782
 
13783
            Set_Full_View (Prev,  Id);
13784
            Append_Entity (Id, Current_Scope);
13785
            Set_Is_Public (Id, Is_Public (Prev));
13786
            Set_Is_Internal (Id);
13787
            New_Id := Prev;
13788
 
13789
         --  Case of full declaration of private type
13790
 
13791
         else
13792
            if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
13793
               if Etype (Prev) /= Prev then
13794
 
13795
                  --  Prev is a private subtype or a derived type, and needs
13796
                  --  no completion.
13797
 
13798
                  Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
13799
                  New_Id := Id;
13800
 
13801
               elsif Ekind (Prev) = E_Private_Type
13802
                 and then Nkind_In (N, N_Task_Type_Declaration,
13803
                                       N_Protected_Type_Declaration)
13804
               then
13805
                  Error_Msg_N
13806
                   ("completion of nonlimited type cannot be limited", N);
13807
 
13808
               elsif Ekind (Prev) = E_Record_Type_With_Private
13809
                 and then Nkind_In (N, N_Task_Type_Declaration,
13810
                                       N_Protected_Type_Declaration)
13811
               then
13812
                  if not Is_Limited_Record (Prev) then
13813
                     Error_Msg_N
13814
                        ("completion of nonlimited type cannot be limited", N);
13815
 
13816
                  elsif No (Interface_List (N)) then
13817
                     Error_Msg_N
13818
                        ("completion of tagged private type must be tagged",
13819
                         N);
13820
                  end if;
13821
 
13822
               elsif Nkind (N) = N_Full_Type_Declaration
13823
                 and then
13824
                   Nkind (Type_Definition (N)) = N_Record_Definition
13825
                 and then Interface_Present (Type_Definition (N))
13826
               then
13827
                  Error_Msg_N
13828
                    ("completion of private type cannot be an interface", N);
13829
               end if;
13830
 
13831
            --  Ada 2005 (AI-251): Private extension declaration of a task
13832
            --  type or a protected type. This case arises when covering
13833
            --  interface types.
13834
 
13835
            elsif Nkind_In (N, N_Task_Type_Declaration,
13836
                               N_Protected_Type_Declaration)
13837
            then
13838
               null;
13839
 
13840
            elsif Nkind (N) /= N_Full_Type_Declaration
13841
              or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
13842
            then
13843
               Error_Msg_N
13844
                 ("full view of private extension must be an extension", N);
13845
 
13846
            elsif not (Abstract_Present (Parent (Prev)))
13847
              and then Abstract_Present (Type_Definition (N))
13848
            then
13849
               Error_Msg_N
13850
                 ("full view of non-abstract extension cannot be abstract", N);
13851
            end if;
13852
 
13853
            if not In_Private_Part (Current_Scope) then
13854
               Error_Msg_N
13855
                 ("declaration of full view must appear in private part", N);
13856
            end if;
13857
 
13858
            Copy_And_Swap (Prev, Id);
13859
            Set_Has_Private_Declaration (Prev);
13860
            Set_Has_Private_Declaration (Id);
13861
 
13862
            --  If no error, propagate freeze_node from private to full view.
13863
            --  It may have been generated for an early operational item.
13864
 
13865
            if Present (Freeze_Node (Id))
13866
              and then Serious_Errors_Detected = 0
13867
              and then No (Full_View (Id))
13868
            then
13869
               Set_Freeze_Node (Prev, Freeze_Node (Id));
13870
               Set_Freeze_Node (Id, Empty);
13871
               Set_First_Rep_Item (Prev, First_Rep_Item (Id));
13872
            end if;
13873
 
13874
            Set_Full_View (Id, Prev);
13875
            New_Id := Prev;
13876
         end if;
13877
 
13878
         --  Verify that full declaration conforms to partial one
13879
 
13880
         if Is_Incomplete_Or_Private_Type (Prev)
13881
           and then Present (Discriminant_Specifications (Prev_Par))
13882
         then
13883
            if Present (Discriminant_Specifications (N)) then
13884
               if Ekind (Prev) = E_Incomplete_Type then
13885
                  Check_Discriminant_Conformance (N, Prev, Prev);
13886
               else
13887
                  Check_Discriminant_Conformance (N, Prev, Id);
13888
               end if;
13889
 
13890
            else
13891
               Error_Msg_N
13892
                 ("missing discriminants in full type declaration", N);
13893
 
13894
               --  To avoid cascaded errors on subsequent use, share the
13895
               --  discriminants of the partial view.
13896
 
13897
               Set_Discriminant_Specifications (N,
13898
                 Discriminant_Specifications (Prev_Par));
13899
            end if;
13900
         end if;
13901
 
13902
         --  A prior untagged partial view can have an associated class-wide
13903
         --  type due to use of the class attribute, and in this case the full
13904
         --  type must also be tagged. This Ada 95 usage is deprecated in favor
13905
         --  of incomplete tagged declarations, but we check for it.
13906
 
13907
         if Is_Type (Prev)
13908
           and then (Is_Tagged_Type (Prev)
13909
                      or else Present (Class_Wide_Type (Prev)))
13910
         then
13911
            --  The full declaration is either a tagged type (including
13912
            --  a synchronized type that implements interfaces) or a
13913
            --  type extension, otherwise this is an error.
13914
 
13915
            if Nkind_In (N, N_Task_Type_Declaration,
13916
                            N_Protected_Type_Declaration)
13917
            then
13918
               if No (Interface_List (N))
13919
                 and then not Error_Posted (N)
13920
               then
13921
                  Tag_Mismatch;
13922
               end if;
13923
 
13924
            elsif Nkind (Type_Definition (N)) = N_Record_Definition then
13925
 
13926
               --  Indicate that the previous declaration (tagged incomplete
13927
               --  or private declaration) requires the same on the full one.
13928
 
13929
               if not Tagged_Present (Type_Definition (N)) then
13930
                  Tag_Mismatch;
13931
                  Set_Is_Tagged_Type (Id);
13932
                  Set_Primitive_Operations (Id, New_Elmt_List);
13933
               end if;
13934
 
13935
            elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
13936
               if No (Record_Extension_Part (Type_Definition (N))) then
13937
                  Error_Msg_NE (
13938
                    "full declaration of } must be a record extension",
13939
                    Prev, Id);
13940
 
13941
                  --  Set some attributes to produce a usable full view
13942
 
13943
                  Set_Is_Tagged_Type (Id);
13944
                  Set_Primitive_Operations (Id, New_Elmt_List);
13945
               end if;
13946
 
13947
            else
13948
               Tag_Mismatch;
13949
            end if;
13950
         end if;
13951
 
13952
         return New_Id;
13953
 
13954
      else
13955
         --  New type declaration
13956
 
13957
         Enter_Name (Id);
13958
         return Id;
13959
      end if;
13960
   end Find_Type_Name;
13961
 
13962
   -------------------------
13963
   -- Find_Type_Of_Object --
13964
   -------------------------
13965
 
13966
   function Find_Type_Of_Object
13967
     (Obj_Def     : Node_Id;
13968
      Related_Nod : Node_Id) return Entity_Id
13969
   is
13970
      Def_Kind : constant Node_Kind := Nkind (Obj_Def);
13971
      P        : Node_Id := Parent (Obj_Def);
13972
      T        : Entity_Id;
13973
      Nam      : Name_Id;
13974
 
13975
   begin
13976
      --  If the parent is a component_definition node we climb to the
13977
      --  component_declaration node
13978
 
13979
      if Nkind (P) = N_Component_Definition then
13980
         P := Parent (P);
13981
      end if;
13982
 
13983
      --  Case of an anonymous array subtype
13984
 
13985
      if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
13986
                             N_Unconstrained_Array_Definition)
13987
      then
13988
         T := Empty;
13989
         Array_Type_Declaration (T, Obj_Def);
13990
 
13991
      --  Create an explicit subtype whenever possible
13992
 
13993
      elsif Nkind (P) /= N_Component_Declaration
13994
        and then Def_Kind = N_Subtype_Indication
13995
      then
13996
         --  Base name of subtype on object name, which will be unique in
13997
         --  the current scope.
13998
 
13999
         --  If this is a duplicate declaration, return base type, to avoid
14000
         --  generating duplicate anonymous types.
14001
 
14002
         if Error_Posted (P) then
14003
            Analyze (Subtype_Mark (Obj_Def));
14004
            return Entity (Subtype_Mark (Obj_Def));
14005
         end if;
14006
 
14007
         Nam :=
14008
            New_External_Name
14009
             (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
14010
 
14011
         T := Make_Defining_Identifier (Sloc (P), Nam);
14012
 
14013
         Insert_Action (Obj_Def,
14014
           Make_Subtype_Declaration (Sloc (P),
14015
             Defining_Identifier => T,
14016
             Subtype_Indication  => Relocate_Node (Obj_Def)));
14017
 
14018
         --  This subtype may need freezing, and this will not be done
14019
         --  automatically if the object declaration is not in declarative
14020
         --  part. Since this is an object declaration, the type cannot always
14021
         --  be frozen here. Deferred constants do not freeze their type
14022
         --  (which often enough will be private).
14023
 
14024
         if Nkind (P) = N_Object_Declaration
14025
           and then Constant_Present (P)
14026
           and then No (Expression (P))
14027
         then
14028
            null;
14029
         else
14030
            Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P)));
14031
         end if;
14032
 
14033
      --  Ada 2005 AI-406: the object definition in an object declaration
14034
      --  can be an access definition.
14035
 
14036
      elsif Def_Kind = N_Access_Definition then
14037
         T := Access_Definition (Related_Nod, Obj_Def);
14038
         Set_Is_Local_Anonymous_Access (T);
14039
 
14040
      --  Otherwise, the object definition is just a subtype_mark
14041
 
14042
      else
14043
         T := Process_Subtype (Obj_Def, Related_Nod);
14044
      end if;
14045
 
14046
      return T;
14047
   end Find_Type_Of_Object;
14048
 
14049
   --------------------------------
14050
   -- Find_Type_Of_Subtype_Indic --
14051
   --------------------------------
14052
 
14053
   function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
14054
      Typ : Entity_Id;
14055
 
14056
   begin
14057
      --  Case of subtype mark with a constraint
14058
 
14059
      if Nkind (S) = N_Subtype_Indication then
14060
         Find_Type (Subtype_Mark (S));
14061
         Typ := Entity (Subtype_Mark (S));
14062
 
14063
         if not
14064
           Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
14065
         then
14066
            Error_Msg_N
14067
              ("incorrect constraint for this kind of type", Constraint (S));
14068
            Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
14069
         end if;
14070
 
14071
      --  Otherwise we have a subtype mark without a constraint
14072
 
14073
      elsif Error_Posted (S) then
14074
         Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
14075
         return Any_Type;
14076
 
14077
      else
14078
         Find_Type (S);
14079
         Typ := Entity (S);
14080
      end if;
14081
 
14082
      --  Check No_Wide_Characters restriction
14083
 
14084
      if Typ = Standard_Wide_Character
14085
        or else Typ = Standard_Wide_Wide_Character
14086
        or else Typ = Standard_Wide_String
14087
        or else Typ = Standard_Wide_Wide_String
14088
      then
14089
         Check_Restriction (No_Wide_Characters, S);
14090
      end if;
14091
 
14092
      return Typ;
14093
   end Find_Type_Of_Subtype_Indic;
14094
 
14095
   -------------------------------------
14096
   -- Floating_Point_Type_Declaration --
14097
   -------------------------------------
14098
 
14099
   procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
14100
      Digs          : constant Node_Id := Digits_Expression (Def);
14101
      Digs_Val      : Uint;
14102
      Base_Typ      : Entity_Id;
14103
      Implicit_Base : Entity_Id;
14104
      Bound         : Node_Id;
14105
 
14106
      function Can_Derive_From (E : Entity_Id) return Boolean;
14107
      --  Find if given digits value allows derivation from specified type
14108
 
14109
      ---------------------
14110
      -- Can_Derive_From --
14111
      ---------------------
14112
 
14113
      function Can_Derive_From (E : Entity_Id) return Boolean is
14114
         Spec : constant Entity_Id := Real_Range_Specification (Def);
14115
 
14116
      begin
14117
         if Digs_Val > Digits_Value (E) then
14118
            return False;
14119
         end if;
14120
 
14121
         if Present (Spec) then
14122
            if Expr_Value_R (Type_Low_Bound (E)) >
14123
               Expr_Value_R (Low_Bound (Spec))
14124
            then
14125
               return False;
14126
            end if;
14127
 
14128
            if Expr_Value_R (Type_High_Bound (E)) <
14129
               Expr_Value_R (High_Bound (Spec))
14130
            then
14131
               return False;
14132
            end if;
14133
         end if;
14134
 
14135
         return True;
14136
      end Can_Derive_From;
14137
 
14138
   --  Start of processing for Floating_Point_Type_Declaration
14139
 
14140
   begin
14141
      Check_Restriction (No_Floating_Point, Def);
14142
 
14143
      --  Create an implicit base type
14144
 
14145
      Implicit_Base :=
14146
        Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
14147
 
14148
      --  Analyze and verify digits value
14149
 
14150
      Analyze_And_Resolve (Digs, Any_Integer);
14151
      Check_Digits_Expression (Digs);
14152
      Digs_Val := Expr_Value (Digs);
14153
 
14154
      --  Process possible range spec and find correct type to derive from
14155
 
14156
      Process_Real_Range_Specification (Def);
14157
 
14158
      if Can_Derive_From (Standard_Short_Float) then
14159
         Base_Typ := Standard_Short_Float;
14160
      elsif Can_Derive_From (Standard_Float) then
14161
         Base_Typ := Standard_Float;
14162
      elsif Can_Derive_From (Standard_Long_Float) then
14163
         Base_Typ := Standard_Long_Float;
14164
      elsif Can_Derive_From (Standard_Long_Long_Float) then
14165
         Base_Typ := Standard_Long_Long_Float;
14166
 
14167
      --  If we can't derive from any existing type, use long_long_float
14168
      --  and give appropriate message explaining the problem.
14169
 
14170
      else
14171
         Base_Typ := Standard_Long_Long_Float;
14172
 
14173
         if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
14174
            Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float);
14175
            Error_Msg_N ("digits value out of range, maximum is ^", Digs);
14176
 
14177
         else
14178
            Error_Msg_N
14179
              ("range too large for any predefined type",
14180
               Real_Range_Specification (Def));
14181
         end if;
14182
      end if;
14183
 
14184
      --  If there are bounds given in the declaration use them as the bounds
14185
      --  of the type, otherwise use the bounds of the predefined base type
14186
      --  that was chosen based on the Digits value.
14187
 
14188
      if Present (Real_Range_Specification (Def)) then
14189
         Set_Scalar_Range (T, Real_Range_Specification (Def));
14190
         Set_Is_Constrained (T);
14191
 
14192
         --  The bounds of this range must be converted to machine numbers
14193
         --  in accordance with RM 4.9(38).
14194
 
14195
         Bound := Type_Low_Bound (T);
14196
 
14197
         if Nkind (Bound) = N_Real_Literal then
14198
            Set_Realval
14199
              (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
14200
            Set_Is_Machine_Number (Bound);
14201
         end if;
14202
 
14203
         Bound := Type_High_Bound (T);
14204
 
14205
         if Nkind (Bound) = N_Real_Literal then
14206
            Set_Realval
14207
              (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
14208
            Set_Is_Machine_Number (Bound);
14209
         end if;
14210
 
14211
      else
14212
         Set_Scalar_Range (T, Scalar_Range (Base_Typ));
14213
      end if;
14214
 
14215
      --  Complete definition of implicit base and declared first subtype
14216
 
14217
      Set_Etype          (Implicit_Base, Base_Typ);
14218
 
14219
      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
14220
      Set_Size_Info      (Implicit_Base,                (Base_Typ));
14221
      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
14222
      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
14223
      Set_Digits_Value   (Implicit_Base, Digits_Value   (Base_Typ));
14224
      Set_Vax_Float      (Implicit_Base, Vax_Float      (Base_Typ));
14225
 
14226
      Set_Ekind          (T, E_Floating_Point_Subtype);
14227
      Set_Etype          (T, Implicit_Base);
14228
 
14229
      Set_Size_Info      (T,                (Implicit_Base));
14230
      Set_RM_Size        (T, RM_Size        (Implicit_Base));
14231
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
14232
      Set_Digits_Value   (T, Digs_Val);
14233
   end Floating_Point_Type_Declaration;
14234
 
14235
   ----------------------------
14236
   -- Get_Discriminant_Value --
14237
   ----------------------------
14238
 
14239
   --  This is the situation:
14240
 
14241
   --  There is a non-derived type
14242
 
14243
   --       type T0 (Dx, Dy, Dz...)
14244
 
14245
   --  There are zero or more levels of derivation, with each derivation
14246
   --  either purely inheriting the discriminants, or defining its own.
14247
 
14248
   --       type Ti      is new Ti-1
14249
   --  or
14250
   --       type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
14251
   --  or
14252
   --       subtype Ti is ...
14253
 
14254
   --  The subtype issue is avoided by the use of Original_Record_Component,
14255
   --  and the fact that derived subtypes also derive the constraints.
14256
 
14257
   --  This chain leads back from
14258
 
14259
   --       Typ_For_Constraint
14260
 
14261
   --  Typ_For_Constraint has discriminants, and the value for each
14262
   --  discriminant is given by its corresponding Elmt of Constraints.
14263
 
14264
   --  Discriminant is some discriminant in this hierarchy
14265
 
14266
   --  We need to return its value
14267
 
14268
   --  We do this by recursively searching each level, and looking for
14269
   --  Discriminant. Once we get to the bottom, we start backing up
14270
   --  returning the value for it which may in turn be a discriminant
14271
   --  further up, so on the backup we continue the substitution.
14272
 
14273
   function Get_Discriminant_Value
14274
     (Discriminant       : Entity_Id;
14275
      Typ_For_Constraint : Entity_Id;
14276
      Constraint         : Elist_Id) return Node_Id
14277
   is
14278
      function Search_Derivation_Levels
14279
        (Ti                    : Entity_Id;
14280
         Discrim_Values        : Elist_Id;
14281
         Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
14282
      --  This is the routine that performs the recursive search of levels
14283
      --  as described above.
14284
 
14285
      ------------------------------
14286
      -- Search_Derivation_Levels --
14287
      ------------------------------
14288
 
14289
      function Search_Derivation_Levels
14290
        (Ti                    : Entity_Id;
14291
         Discrim_Values        : Elist_Id;
14292
         Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
14293
      is
14294
         Assoc          : Elmt_Id;
14295
         Disc           : Entity_Id;
14296
         Result         : Node_Or_Entity_Id;
14297
         Result_Entity  : Node_Id;
14298
 
14299
      begin
14300
         --  If inappropriate type, return Error, this happens only in
14301
         --  cascaded error situations, and we want to avoid a blow up.
14302
 
14303
         if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
14304
            return Error;
14305
         end if;
14306
 
14307
         --  Look deeper if possible. Use Stored_Constraints only for
14308
         --  untagged types. For tagged types use the given constraint.
14309
         --  This asymmetry needs explanation???
14310
 
14311
         if not Stored_Discrim_Values
14312
           and then Present (Stored_Constraint (Ti))
14313
           and then not Is_Tagged_Type (Ti)
14314
         then
14315
            Result :=
14316
              Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
14317
         else
14318
            declare
14319
               Td : constant Entity_Id := Etype (Ti);
14320
 
14321
            begin
14322
               if Td = Ti then
14323
                  Result := Discriminant;
14324
 
14325
               else
14326
                  if Present (Stored_Constraint (Ti)) then
14327
                     Result :=
14328
                        Search_Derivation_Levels
14329
                          (Td, Stored_Constraint (Ti), True);
14330
                  else
14331
                     Result :=
14332
                        Search_Derivation_Levels
14333
                          (Td, Discrim_Values, Stored_Discrim_Values);
14334
                  end if;
14335
               end if;
14336
            end;
14337
         end if;
14338
 
14339
         --  Extra underlying places to search, if not found above. For
14340
         --  concurrent types, the relevant discriminant appears in the
14341
         --  corresponding record. For a type derived from a private type
14342
         --  without discriminant, the full view inherits the discriminants
14343
         --  of the full view of the parent.
14344
 
14345
         if Result = Discriminant then
14346
            if Is_Concurrent_Type (Ti)
14347
              and then Present (Corresponding_Record_Type (Ti))
14348
            then
14349
               Result :=
14350
                 Search_Derivation_Levels (
14351
                   Corresponding_Record_Type (Ti),
14352
                   Discrim_Values,
14353
                   Stored_Discrim_Values);
14354
 
14355
            elsif Is_Private_Type (Ti)
14356
              and then not Has_Discriminants (Ti)
14357
              and then Present (Full_View (Ti))
14358
              and then Etype (Full_View (Ti)) /= Ti
14359
            then
14360
               Result :=
14361
                 Search_Derivation_Levels (
14362
                   Full_View (Ti),
14363
                   Discrim_Values,
14364
                   Stored_Discrim_Values);
14365
            end if;
14366
         end if;
14367
 
14368
         --  If Result is not a (reference to a) discriminant, return it,
14369
         --  otherwise set Result_Entity to the discriminant.
14370
 
14371
         if Nkind (Result) = N_Defining_Identifier then
14372
            pragma Assert (Result = Discriminant);
14373
            Result_Entity := Result;
14374
 
14375
         else
14376
            if not Denotes_Discriminant (Result) then
14377
               return Result;
14378
            end if;
14379
 
14380
            Result_Entity := Entity (Result);
14381
         end if;
14382
 
14383
         --  See if this level of derivation actually has discriminants
14384
         --  because tagged derivations can add them, hence the lower
14385
         --  levels need not have any.
14386
 
14387
         if not Has_Discriminants (Ti) then
14388
            return Result;
14389
         end if;
14390
 
14391
         --  Scan Ti's discriminants for Result_Entity,
14392
         --  and return its corresponding value, if any.
14393
 
14394
         Result_Entity := Original_Record_Component (Result_Entity);
14395
 
14396
         Assoc := First_Elmt (Discrim_Values);
14397
 
14398
         if Stored_Discrim_Values then
14399
            Disc := First_Stored_Discriminant (Ti);
14400
         else
14401
            Disc := First_Discriminant (Ti);
14402
         end if;
14403
 
14404
         while Present (Disc) loop
14405
            pragma Assert (Present (Assoc));
14406
 
14407
            if Original_Record_Component (Disc) = Result_Entity then
14408
               return Node (Assoc);
14409
            end if;
14410
 
14411
            Next_Elmt (Assoc);
14412
 
14413
            if Stored_Discrim_Values then
14414
               Next_Stored_Discriminant (Disc);
14415
            else
14416
               Next_Discriminant (Disc);
14417
            end if;
14418
         end loop;
14419
 
14420
         --  Could not find it
14421
         --
14422
         return Result;
14423
      end Search_Derivation_Levels;
14424
 
14425
      --  Local Variables
14426
 
14427
      Result : Node_Or_Entity_Id;
14428
 
14429
   --  Start of processing for Get_Discriminant_Value
14430
 
14431
   begin
14432
      --  ??? This routine is a gigantic mess and will be deleted. For the
14433
      --  time being just test for the trivial case before calling recurse.
14434
 
14435
      if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
14436
         declare
14437
            D : Entity_Id;
14438
            E : Elmt_Id;
14439
 
14440
         begin
14441
            D := First_Discriminant (Typ_For_Constraint);
14442
            E := First_Elmt (Constraint);
14443
            while Present (D) loop
14444
               if Chars (D) = Chars (Discriminant) then
14445
                  return Node (E);
14446
               end if;
14447
 
14448
               Next_Discriminant (D);
14449
               Next_Elmt (E);
14450
            end loop;
14451
         end;
14452
      end if;
14453
 
14454
      Result := Search_Derivation_Levels
14455
        (Typ_For_Constraint, Constraint, False);
14456
 
14457
      --  ??? hack to disappear when this routine is gone
14458
 
14459
      if  Nkind (Result) = N_Defining_Identifier then
14460
         declare
14461
            D : Entity_Id;
14462
            E : Elmt_Id;
14463
 
14464
         begin
14465
            D := First_Discriminant (Typ_For_Constraint);
14466
            E := First_Elmt (Constraint);
14467
            while Present (D) loop
14468
               if Corresponding_Discriminant (D) = Discriminant then
14469
                  return Node (E);
14470
               end if;
14471
 
14472
               Next_Discriminant (D);
14473
               Next_Elmt (E);
14474
            end loop;
14475
         end;
14476
      end if;
14477
 
14478
      pragma Assert (Nkind (Result) /= N_Defining_Identifier);
14479
      return Result;
14480
   end Get_Discriminant_Value;
14481
 
14482
   --------------------------
14483
   -- Has_Range_Constraint --
14484
   --------------------------
14485
 
14486
   function Has_Range_Constraint (N : Node_Id) return Boolean is
14487
      C : constant Node_Id := Constraint (N);
14488
 
14489
   begin
14490
      if Nkind (C) = N_Range_Constraint then
14491
         return True;
14492
 
14493
      elsif Nkind (C) = N_Digits_Constraint then
14494
         return
14495
            Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
14496
              or else
14497
            Present (Range_Constraint (C));
14498
 
14499
      elsif Nkind (C) = N_Delta_Constraint then
14500
         return Present (Range_Constraint (C));
14501
 
14502
      else
14503
         return False;
14504
      end if;
14505
   end Has_Range_Constraint;
14506
 
14507
   ------------------------
14508
   -- Inherit_Components --
14509
   ------------------------
14510
 
14511
   function Inherit_Components
14512
     (N             : Node_Id;
14513
      Parent_Base   : Entity_Id;
14514
      Derived_Base  : Entity_Id;
14515
      Is_Tagged     : Boolean;
14516
      Inherit_Discr : Boolean;
14517
      Discs         : Elist_Id) return Elist_Id
14518
   is
14519
      Assoc_List : constant Elist_Id := New_Elmt_List;
14520
 
14521
      procedure Inherit_Component
14522
        (Old_C          : Entity_Id;
14523
         Plain_Discrim  : Boolean := False;
14524
         Stored_Discrim : Boolean := False);
14525
      --  Inherits component Old_C from Parent_Base to the Derived_Base. If
14526
      --  Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
14527
      --  True, Old_C is a stored discriminant. If they are both false then
14528
      --  Old_C is a regular component.
14529
 
14530
      -----------------------
14531
      -- Inherit_Component --
14532
      -----------------------
14533
 
14534
      procedure Inherit_Component
14535
        (Old_C          : Entity_Id;
14536
         Plain_Discrim  : Boolean := False;
14537
         Stored_Discrim : Boolean := False)
14538
      is
14539
         New_C : constant Entity_Id := New_Copy (Old_C);
14540
 
14541
         Discrim      : Entity_Id;
14542
         Corr_Discrim : Entity_Id;
14543
 
14544
      begin
14545
         pragma Assert (not Is_Tagged or else not Stored_Discrim);
14546
 
14547
         Set_Parent (New_C, Parent (Old_C));
14548
 
14549
         --  Regular discriminants and components must be inserted in the scope
14550
         --  of the Derived_Base. Do it here.
14551
 
14552
         if not Stored_Discrim then
14553
            Enter_Name (New_C);
14554
         end if;
14555
 
14556
         --  For tagged types the Original_Record_Component must point to
14557
         --  whatever this field was pointing to in the parent type. This has
14558
         --  already been achieved by the call to New_Copy above.
14559
 
14560
         if not Is_Tagged then
14561
            Set_Original_Record_Component (New_C, New_C);
14562
         end if;
14563
 
14564
         --  If we have inherited a component then see if its Etype contains
14565
         --  references to Parent_Base discriminants. In this case, replace
14566
         --  these references with the constraints given in Discs. We do not
14567
         --  do this for the partial view of private types because this is
14568
         --  not needed (only the components of the full view will be used
14569
         --  for code generation) and cause problem. We also avoid this
14570
         --  transformation in some error situations.
14571
 
14572
         if Ekind (New_C) = E_Component then
14573
            if (Is_Private_Type (Derived_Base)
14574
                 and then not Is_Generic_Type (Derived_Base))
14575
              or else (Is_Empty_Elmt_List (Discs)
14576
                        and then  not Expander_Active)
14577
            then
14578
               Set_Etype (New_C, Etype (Old_C));
14579
 
14580
            else
14581
               --  The current component introduces a circularity of the
14582
               --  following kind:
14583
 
14584
               --     limited with Pack_2;
14585
               --     package Pack_1 is
14586
               --        type T_1 is tagged record
14587
               --           Comp : access Pack_2.T_2;
14588
               --           ...
14589
               --        end record;
14590
               --     end Pack_1;
14591
 
14592
               --     with Pack_1;
14593
               --     package Pack_2 is
14594
               --        type T_2 is new Pack_1.T_1 with ...;
14595
               --     end Pack_2;
14596
 
14597
               Set_Etype
14598
                 (New_C,
14599
                  Constrain_Component_Type
14600
                  (Old_C, Derived_Base, N, Parent_Base, Discs));
14601
            end if;
14602
         end if;
14603
 
14604
         --  In derived tagged types it is illegal to reference a non
14605
         --  discriminant component in the parent type. To catch this, mark
14606
         --  these components with an Ekind of E_Void. This will be reset in
14607
         --  Record_Type_Definition after processing the record extension of
14608
         --  the derived type.
14609
 
14610
         --  If the declaration is a private extension, there is no further
14611
         --  record extension to process, and the components retain their
14612
         --  current kind, because they are visible at this point.
14613
 
14614
         if Is_Tagged and then Ekind (New_C) = E_Component
14615
           and then Nkind (N) /= N_Private_Extension_Declaration
14616
         then
14617
            Set_Ekind (New_C, E_Void);
14618
         end if;
14619
 
14620
         if Plain_Discrim then
14621
            Set_Corresponding_Discriminant (New_C, Old_C);
14622
            Build_Discriminal (New_C);
14623
 
14624
         --  If we are explicitly inheriting a stored discriminant it will be
14625
         --  completely hidden.
14626
 
14627
         elsif Stored_Discrim then
14628
            Set_Corresponding_Discriminant (New_C, Empty);
14629
            Set_Discriminal (New_C, Empty);
14630
            Set_Is_Completely_Hidden (New_C);
14631
 
14632
            --  Set the Original_Record_Component of each discriminant in the
14633
            --  derived base to point to the corresponding stored that we just
14634
            --  created.
14635
 
14636
            Discrim := First_Discriminant (Derived_Base);
14637
            while Present (Discrim) loop
14638
               Corr_Discrim := Corresponding_Discriminant (Discrim);
14639
 
14640
               --  Corr_Discrim could be missing in an error situation
14641
 
14642
               if Present (Corr_Discrim)
14643
                 and then Original_Record_Component (Corr_Discrim) = Old_C
14644
               then
14645
                  Set_Original_Record_Component (Discrim, New_C);
14646
               end if;
14647
 
14648
               Next_Discriminant (Discrim);
14649
            end loop;
14650
 
14651
            Append_Entity (New_C, Derived_Base);
14652
         end if;
14653
 
14654
         if not Is_Tagged then
14655
            Append_Elmt (Old_C, Assoc_List);
14656
            Append_Elmt (New_C, Assoc_List);
14657
         end if;
14658
      end Inherit_Component;
14659
 
14660
      --  Variables local to Inherit_Component
14661
 
14662
      Loc : constant Source_Ptr := Sloc (N);
14663
 
14664
      Parent_Discrim : Entity_Id;
14665
      Stored_Discrim : Entity_Id;
14666
      D              : Entity_Id;
14667
      Component      : Entity_Id;
14668
 
14669
   --  Start of processing for Inherit_Components
14670
 
14671
   begin
14672
      if not Is_Tagged then
14673
         Append_Elmt (Parent_Base,  Assoc_List);
14674
         Append_Elmt (Derived_Base, Assoc_List);
14675
      end if;
14676
 
14677
      --  Inherit parent discriminants if needed
14678
 
14679
      if Inherit_Discr then
14680
         Parent_Discrim := First_Discriminant (Parent_Base);
14681
         while Present (Parent_Discrim) loop
14682
            Inherit_Component (Parent_Discrim, Plain_Discrim => True);
14683
            Next_Discriminant (Parent_Discrim);
14684
         end loop;
14685
      end if;
14686
 
14687
      --  Create explicit stored discrims for untagged types when necessary
14688
 
14689
      if not Has_Unknown_Discriminants (Derived_Base)
14690
        and then Has_Discriminants (Parent_Base)
14691
        and then not Is_Tagged
14692
        and then
14693
          (not Inherit_Discr
14694
             or else First_Discriminant (Parent_Base) /=
14695
                     First_Stored_Discriminant (Parent_Base))
14696
      then
14697
         Stored_Discrim := First_Stored_Discriminant (Parent_Base);
14698
         while Present (Stored_Discrim) loop
14699
            Inherit_Component (Stored_Discrim, Stored_Discrim => True);
14700
            Next_Stored_Discriminant (Stored_Discrim);
14701
         end loop;
14702
      end if;
14703
 
14704
      --  See if we can apply the second transformation for derived types, as
14705
      --  explained in point 6. in the comments above Build_Derived_Record_Type
14706
      --  This is achieved by appending Derived_Base discriminants into Discs,
14707
      --  which has the side effect of returning a non empty Discs list to the
14708
      --  caller of Inherit_Components, which is what we want. This must be
14709
      --  done for private derived types if there are explicit stored
14710
      --  discriminants, to ensure that we can retrieve the values of the
14711
      --  constraints provided in the ancestors.
14712
 
14713
      if Inherit_Discr
14714
        and then Is_Empty_Elmt_List (Discs)
14715
        and then Present (First_Discriminant (Derived_Base))
14716
        and then
14717
          (not Is_Private_Type (Derived_Base)
14718
             or else Is_Completely_Hidden
14719
               (First_Stored_Discriminant (Derived_Base))
14720
             or else Is_Generic_Type (Derived_Base))
14721
      then
14722
         D := First_Discriminant (Derived_Base);
14723
         while Present (D) loop
14724
            Append_Elmt (New_Reference_To (D, Loc), Discs);
14725
            Next_Discriminant (D);
14726
         end loop;
14727
      end if;
14728
 
14729
      --  Finally, inherit non-discriminant components unless they are not
14730
      --  visible because defined or inherited from the full view of the
14731
      --  parent. Don't inherit the _parent field of the parent type.
14732
 
14733
      Component := First_Entity (Parent_Base);
14734
      while Present (Component) loop
14735
 
14736
         --  Ada 2005 (AI-251): Do not inherit components associated with
14737
         --  secondary tags of the parent.
14738
 
14739
         if Ekind (Component) = E_Component
14740
           and then Present (Related_Type (Component))
14741
         then
14742
            null;
14743
 
14744
         elsif Ekind (Component) /= E_Component
14745
           or else Chars (Component) = Name_uParent
14746
         then
14747
            null;
14748
 
14749
         --  If the derived type is within the parent type's declarative
14750
         --  region, then the components can still be inherited even though
14751
         --  they aren't visible at this point. This can occur for cases
14752
         --  such as within public child units where the components must
14753
         --  become visible upon entering the child unit's private part.
14754
 
14755
         elsif not Is_Visible_Component (Component)
14756
           and then not In_Open_Scopes (Scope (Parent_Base))
14757
         then
14758
            null;
14759
 
14760
         elsif Ekind (Derived_Base) = E_Private_Type
14761
           or else Ekind (Derived_Base) = E_Limited_Private_Type
14762
         then
14763
            null;
14764
 
14765
         else
14766
            Inherit_Component (Component);
14767
         end if;
14768
 
14769
         Next_Entity (Component);
14770
      end loop;
14771
 
14772
      --  For tagged derived types, inherited discriminants cannot be used in
14773
      --  component declarations of the record extension part. To achieve this
14774
      --  we mark the inherited discriminants as not visible.
14775
 
14776
      if Is_Tagged and then Inherit_Discr then
14777
         D := First_Discriminant (Derived_Base);
14778
         while Present (D) loop
14779
            Set_Is_Immediately_Visible (D, False);
14780
            Next_Discriminant (D);
14781
         end loop;
14782
      end if;
14783
 
14784
      return Assoc_List;
14785
   end Inherit_Components;
14786
 
14787
   -----------------------
14788
   -- Is_Null_Extension --
14789
   -----------------------
14790
 
14791
   function Is_Null_Extension (T : Entity_Id) return Boolean is
14792
      Type_Decl : constant Node_Id := Parent (Base_Type (T));
14793
      Comp_List : Node_Id;
14794
      Comp      : Node_Id;
14795
 
14796
   begin
14797
      if Nkind (Type_Decl) /= N_Full_Type_Declaration
14798
        or else not Is_Tagged_Type (T)
14799
        or else Nkind (Type_Definition (Type_Decl)) /=
14800
                                              N_Derived_Type_Definition
14801
        or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
14802
      then
14803
         return False;
14804
      end if;
14805
 
14806
      Comp_List :=
14807
        Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
14808
 
14809
      if Present (Discriminant_Specifications (Type_Decl)) then
14810
         return False;
14811
 
14812
      elsif Present (Comp_List)
14813
        and then Is_Non_Empty_List (Component_Items (Comp_List))
14814
      then
14815
         Comp := First (Component_Items (Comp_List));
14816
 
14817
         --  Only user-defined components are relevant. The component list
14818
         --  may also contain a parent component and internal components
14819
         --  corresponding to secondary tags, but these do not determine
14820
         --  whether this is a null extension.
14821
 
14822
         while Present (Comp) loop
14823
            if Comes_From_Source (Comp) then
14824
               return False;
14825
            end if;
14826
 
14827
            Next (Comp);
14828
         end loop;
14829
 
14830
         return True;
14831
      else
14832
         return True;
14833
      end if;
14834
   end Is_Null_Extension;
14835
 
14836
   --------------------
14837
   --  Is_Progenitor --
14838
   --------------------
14839
 
14840
   function Is_Progenitor
14841
     (Iface : Entity_Id;
14842
      Typ   : Entity_Id) return Boolean
14843
   is
14844
   begin
14845
      return Implements_Interface (Typ, Iface,
14846
               Exclude_Parents => True);
14847
   end Is_Progenitor;
14848
 
14849
   ------------------------------
14850
   -- Is_Valid_Constraint_Kind --
14851
   ------------------------------
14852
 
14853
   function Is_Valid_Constraint_Kind
14854
     (T_Kind          : Type_Kind;
14855
      Constraint_Kind : Node_Kind) return Boolean
14856
   is
14857
   begin
14858
      case T_Kind is
14859
         when Enumeration_Kind |
14860
              Integer_Kind =>
14861
            return Constraint_Kind = N_Range_Constraint;
14862
 
14863
         when Decimal_Fixed_Point_Kind =>
14864
            return Nkind_In (Constraint_Kind, N_Digits_Constraint,
14865
                                              N_Range_Constraint);
14866
 
14867
         when Ordinary_Fixed_Point_Kind =>
14868
            return Nkind_In (Constraint_Kind, N_Delta_Constraint,
14869
                                              N_Range_Constraint);
14870
 
14871
         when Float_Kind =>
14872
            return Nkind_In (Constraint_Kind, N_Digits_Constraint,
14873
                                              N_Range_Constraint);
14874
 
14875
         when Access_Kind       |
14876
              Array_Kind        |
14877
              E_Record_Type     |
14878
              E_Record_Subtype  |
14879
              Class_Wide_Kind   |
14880
              E_Incomplete_Type |
14881
              Private_Kind      |
14882
              Concurrent_Kind  =>
14883
            return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
14884
 
14885
         when others =>
14886
            return True; -- Error will be detected later
14887
      end case;
14888
   end Is_Valid_Constraint_Kind;
14889
 
14890
   --------------------------
14891
   -- Is_Visible_Component --
14892
   --------------------------
14893
 
14894
   function Is_Visible_Component (C : Entity_Id) return Boolean is
14895
      Original_Comp  : Entity_Id := Empty;
14896
      Original_Scope : Entity_Id;
14897
      Type_Scope     : Entity_Id;
14898
 
14899
      function Is_Local_Type (Typ : Entity_Id) return Boolean;
14900
      --  Check whether parent type of inherited component is declared locally,
14901
      --  possibly within a nested package or instance. The current scope is
14902
      --  the derived record itself.
14903
 
14904
      -------------------
14905
      -- Is_Local_Type --
14906
      -------------------
14907
 
14908
      function Is_Local_Type (Typ : Entity_Id) return Boolean is
14909
         Scop : Entity_Id;
14910
 
14911
      begin
14912
         Scop := Scope (Typ);
14913
         while Present (Scop)
14914
           and then Scop /= Standard_Standard
14915
         loop
14916
            if Scop = Scope (Current_Scope) then
14917
               return True;
14918
            end if;
14919
 
14920
            Scop := Scope (Scop);
14921
         end loop;
14922
 
14923
         return False;
14924
      end Is_Local_Type;
14925
 
14926
   --  Start of processing for Is_Visible_Component
14927
 
14928
   begin
14929
      if Ekind (C) = E_Component
14930
        or else Ekind (C) = E_Discriminant
14931
      then
14932
         Original_Comp := Original_Record_Component (C);
14933
      end if;
14934
 
14935
      if No (Original_Comp) then
14936
 
14937
         --  Premature usage, or previous error
14938
 
14939
         return False;
14940
 
14941
      else
14942
         Original_Scope := Scope (Original_Comp);
14943
         Type_Scope     := Scope (Base_Type (Scope (C)));
14944
      end if;
14945
 
14946
      --  This test only concerns tagged types
14947
 
14948
      if not Is_Tagged_Type (Original_Scope) then
14949
         return True;
14950
 
14951
      --  If it is _Parent or _Tag, there is no visibility issue
14952
 
14953
      elsif not Comes_From_Source (Original_Comp) then
14954
         return True;
14955
 
14956
      --  If we are in the body of an instantiation, the component is visible
14957
      --  even when the parent type (possibly defined in an enclosing unit or
14958
      --  in a parent unit) might not.
14959
 
14960
      elsif In_Instance_Body then
14961
         return True;
14962
 
14963
      --  Discriminants are always visible
14964
 
14965
      elsif Ekind (Original_Comp) = E_Discriminant
14966
        and then not Has_Unknown_Discriminants (Original_Scope)
14967
      then
14968
         return True;
14969
 
14970
      --  If the component has been declared in an ancestor which is currently
14971
      --  a private type, then it is not visible. The same applies if the
14972
      --  component's containing type is not in an open scope and the original
14973
      --  component's enclosing type is a visible full view of a private type
14974
      --  (which can occur in cases where an attempt is being made to reference
14975
      --  a component in a sibling package that is inherited from a visible
14976
      --  component of a type in an ancestor package; the component in the
14977
      --  sibling package should not be visible even though the component it
14978
      --  inherited from is visible). This does not apply however in the case
14979
      --  where the scope of the type is a private child unit, or when the
14980
      --  parent comes from a local package in which the ancestor is currently
14981
      --  visible. The latter suppression of visibility is needed for cases
14982
      --  that are tested in B730006.
14983
 
14984
      elsif Is_Private_Type (Original_Scope)
14985
        or else
14986
          (not Is_Private_Descendant (Type_Scope)
14987
            and then not In_Open_Scopes (Type_Scope)
14988
            and then Has_Private_Declaration (Original_Scope))
14989
      then
14990
         --  If the type derives from an entity in a formal package, there
14991
         --  are no additional visible components.
14992
 
14993
         if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) =
14994
            N_Formal_Package_Declaration
14995
         then
14996
            return False;
14997
 
14998
         --  if we are not in the private part of the current package, there
14999
         --  are no additional visible components.
15000
 
15001
         elsif Ekind (Scope (Current_Scope)) = E_Package
15002
           and then not In_Private_Part (Scope (Current_Scope))
15003
         then
15004
            return False;
15005
         else
15006
            return
15007
              Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
15008
                and then In_Open_Scopes (Scope (Original_Scope))
15009
                and then Is_Local_Type (Type_Scope);
15010
         end if;
15011
 
15012
      --  There is another weird way in which a component may be invisible
15013
      --  when the private and the full view are not derived from the same
15014
      --  ancestor. Here is an example :
15015
 
15016
      --       type A1 is tagged      record F1 : integer; end record;
15017
      --       type A2 is new A1 with record F2 : integer; end record;
15018
      --       type T is new A1 with private;
15019
      --     private
15020
      --       type T is new A2 with null record;
15021
 
15022
      --  In this case, the full view of T inherits F1 and F2 but the private
15023
      --  view inherits only F1
15024
 
15025
      else
15026
         declare
15027
            Ancestor : Entity_Id := Scope (C);
15028
 
15029
         begin
15030
            loop
15031
               if Ancestor = Original_Scope then
15032
                  return True;
15033
               elsif Ancestor = Etype (Ancestor) then
15034
                  return False;
15035
               end if;
15036
 
15037
               Ancestor := Etype (Ancestor);
15038
            end loop;
15039
         end;
15040
      end if;
15041
   end Is_Visible_Component;
15042
 
15043
   --------------------------
15044
   -- Make_Class_Wide_Type --
15045
   --------------------------
15046
 
15047
   procedure Make_Class_Wide_Type (T : Entity_Id) is
15048
      CW_Type : Entity_Id;
15049
      CW_Name : Name_Id;
15050
      Next_E  : Entity_Id;
15051
 
15052
   begin
15053
      --  The class wide type can have been defined by the partial view, in
15054
      --  which case everything is already done.
15055
 
15056
      if Present (Class_Wide_Type (T)) then
15057
         return;
15058
      end if;
15059
 
15060
      CW_Type :=
15061
        New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
15062
 
15063
      --  Inherit root type characteristics
15064
 
15065
      CW_Name := Chars (CW_Type);
15066
      Next_E  := Next_Entity (CW_Type);
15067
      Copy_Node (T, CW_Type);
15068
      Set_Comes_From_Source (CW_Type, False);
15069
      Set_Chars (CW_Type, CW_Name);
15070
      Set_Parent (CW_Type, Parent (T));
15071
      Set_Next_Entity (CW_Type, Next_E);
15072
 
15073
      --  Ensure we have a new freeze node for the class-wide type. The partial
15074
      --  view may have freeze action of its own, requiring a proper freeze
15075
      --  node, and the same freeze node cannot be shared between the two
15076
      --  types.
15077
 
15078
      Set_Has_Delayed_Freeze (CW_Type);
15079
      Set_Freeze_Node (CW_Type, Empty);
15080
 
15081
      --  Customize the class-wide type: It has no prim. op., it cannot be
15082
      --  abstract and its Etype points back to the specific root type.
15083
 
15084
      Set_Ekind                (CW_Type, E_Class_Wide_Type);
15085
      Set_Is_Tagged_Type       (CW_Type, True);
15086
      Set_Primitive_Operations (CW_Type, New_Elmt_List);
15087
      Set_Is_Abstract_Type     (CW_Type, False);
15088
      Set_Is_Constrained       (CW_Type, False);
15089
      Set_Is_First_Subtype     (CW_Type, Is_First_Subtype (T));
15090
 
15091
      if Ekind (T) = E_Class_Wide_Subtype then
15092
         Set_Etype             (CW_Type, Etype (Base_Type (T)));
15093
      else
15094
         Set_Etype             (CW_Type, T);
15095
      end if;
15096
 
15097
      --  If this is the class_wide type of a constrained subtype, it does
15098
      --  not have discriminants.
15099
 
15100
      Set_Has_Discriminants (CW_Type,
15101
        Has_Discriminants (T) and then not Is_Constrained (T));
15102
 
15103
      Set_Has_Unknown_Discriminants (CW_Type, True);
15104
      Set_Class_Wide_Type (T, CW_Type);
15105
      Set_Equivalent_Type (CW_Type, Empty);
15106
 
15107
      --  The class-wide type of a class-wide type is itself (RM 3.9(14))
15108
 
15109
      Set_Class_Wide_Type (CW_Type, CW_Type);
15110
   end Make_Class_Wide_Type;
15111
 
15112
   ----------------
15113
   -- Make_Index --
15114
   ----------------
15115
 
15116
   procedure Make_Index
15117
     (I            : Node_Id;
15118
      Related_Nod  : Node_Id;
15119
      Related_Id   : Entity_Id := Empty;
15120
      Suffix_Index : Nat := 1)
15121
   is
15122
      R      : Node_Id;
15123
      T      : Entity_Id;
15124
      Def_Id : Entity_Id := Empty;
15125
      Found  : Boolean := False;
15126
 
15127
   begin
15128
      --  For a discrete range used in a constrained array definition and
15129
      --  defined by a range, an implicit conversion to the predefined type
15130
      --  INTEGER is assumed if each bound is either a numeric literal, a named
15131
      --  number, or an attribute, and the type of both bounds (prior to the
15132
      --  implicit conversion) is the type universal_integer. Otherwise, both
15133
      --  bounds must be of the same discrete type, other than universal
15134
      --  integer; this type must be determinable independently of the
15135
      --  context, but using the fact that the type must be discrete and that
15136
      --  both bounds must have the same type.
15137
 
15138
      --  Character literals also have a universal type in the absence of
15139
      --  of additional context,  and are resolved to Standard_Character.
15140
 
15141
      if Nkind (I) = N_Range then
15142
 
15143
         --  The index is given by a range constraint. The bounds are known
15144
         --  to be of a consistent type.
15145
 
15146
         if not Is_Overloaded (I) then
15147
            T := Etype (I);
15148
 
15149
            --  For universal bounds, choose the specific predefined type
15150
 
15151
            if T = Universal_Integer then
15152
               T := Standard_Integer;
15153
 
15154
            elsif T = Any_Character then
15155
               Ambiguous_Character (Low_Bound (I));
15156
 
15157
               T := Standard_Character;
15158
            end if;
15159
 
15160
         --  The node may be overloaded because some user-defined operators
15161
         --  are available, but if a universal interpretation exists it is
15162
         --  also the selected one.
15163
 
15164
         elsif Universal_Interpretation (I) = Universal_Integer then
15165
            T := Standard_Integer;
15166
 
15167
         else
15168
            T := Any_Type;
15169
 
15170
            declare
15171
               Ind : Interp_Index;
15172
               It  : Interp;
15173
 
15174
            begin
15175
               Get_First_Interp (I, Ind, It);
15176
               while Present (It.Typ) loop
15177
                  if Is_Discrete_Type (It.Typ) then
15178
 
15179
                     if Found
15180
                       and then not Covers (It.Typ, T)
15181
                       and then not Covers (T, It.Typ)
15182
                     then
15183
                        Error_Msg_N ("ambiguous bounds in discrete range", I);
15184
                        exit;
15185
                     else
15186
                        T := It.Typ;
15187
                        Found := True;
15188
                     end if;
15189
                  end if;
15190
 
15191
                  Get_Next_Interp (Ind, It);
15192
               end loop;
15193
 
15194
               if T = Any_Type then
15195
                  Error_Msg_N ("discrete type required for range", I);
15196
                  Set_Etype (I, Any_Type);
15197
                  return;
15198
 
15199
               elsif T = Universal_Integer then
15200
                  T := Standard_Integer;
15201
               end if;
15202
            end;
15203
         end if;
15204
 
15205
         if not Is_Discrete_Type (T) then
15206
            Error_Msg_N ("discrete type required for range", I);
15207
            Set_Etype (I, Any_Type);
15208
            return;
15209
         end if;
15210
 
15211
         if Nkind (Low_Bound (I)) = N_Attribute_Reference
15212
           and then Attribute_Name (Low_Bound (I)) = Name_First
15213
           and then Is_Entity_Name (Prefix (Low_Bound (I)))
15214
           and then Is_Type (Entity (Prefix (Low_Bound (I))))
15215
           and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I))))
15216
         then
15217
            --  The type of the index will be the type of the prefix, as long
15218
            --  as the upper bound is 'Last of the same type.
15219
 
15220
            Def_Id := Entity (Prefix (Low_Bound (I)));
15221
 
15222
            if Nkind (High_Bound (I)) /= N_Attribute_Reference
15223
              or else Attribute_Name (High_Bound (I)) /= Name_Last
15224
              or else not Is_Entity_Name (Prefix (High_Bound (I)))
15225
              or else Entity (Prefix (High_Bound (I))) /= Def_Id
15226
            then
15227
               Def_Id := Empty;
15228
            end if;
15229
         end if;
15230
 
15231
         R := I;
15232
         Process_Range_Expr_In_Decl (R, T);
15233
 
15234
      elsif Nkind (I) = N_Subtype_Indication then
15235
 
15236
         --  The index is given by a subtype with a range constraint
15237
 
15238
         T :=  Base_Type (Entity (Subtype_Mark (I)));
15239
 
15240
         if not Is_Discrete_Type (T) then
15241
            Error_Msg_N ("discrete type required for range", I);
15242
            Set_Etype (I, Any_Type);
15243
            return;
15244
         end if;
15245
 
15246
         R := Range_Expression (Constraint (I));
15247
 
15248
         Resolve (R, T);
15249
         Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (I)));
15250
 
15251
      elsif Nkind (I) = N_Attribute_Reference then
15252
 
15253
         --  The parser guarantees that the attribute is a RANGE attribute
15254
 
15255
         --  If the node denotes the range of a type mark, that is also the
15256
         --  resulting type, and we do no need to create an Itype for it.
15257
 
15258
         if Is_Entity_Name (Prefix (I))
15259
           and then Comes_From_Source (I)
15260
           and then Is_Type (Entity (Prefix (I)))
15261
           and then Is_Discrete_Type (Entity (Prefix (I)))
15262
         then
15263
            Def_Id := Entity (Prefix (I));
15264
         end if;
15265
 
15266
         Analyze_And_Resolve (I);
15267
         T := Etype (I);
15268
         R := I;
15269
 
15270
      --  If none of the above, must be a subtype. We convert this to a
15271
      --  range attribute reference because in the case of declared first
15272
      --  named subtypes, the types in the range reference can be different
15273
      --  from the type of the entity. A range attribute normalizes the
15274
      --  reference and obtains the correct types for the bounds.
15275
 
15276
      --  This transformation is in the nature of an expansion, is only
15277
      --  done if expansion is active. In particular, it is not done on
15278
      --  formal generic types,  because we need to retain the name of the
15279
      --  original index for instantiation purposes.
15280
 
15281
      else
15282
         if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
15283
            Error_Msg_N ("invalid subtype mark in discrete range ", I);
15284
            Set_Etype (I, Any_Integer);
15285
            return;
15286
 
15287
         else
15288
            --  The type mark may be that of an incomplete type. It is only
15289
            --  now that we can get the full view, previous analysis does
15290
            --  not look specifically for a type mark.
15291
 
15292
            Set_Entity (I, Get_Full_View (Entity (I)));
15293
            Set_Etype  (I, Entity (I));
15294
            Def_Id := Entity (I);
15295
 
15296
            if not Is_Discrete_Type (Def_Id) then
15297
               Error_Msg_N ("discrete type required for index", I);
15298
               Set_Etype (I, Any_Type);
15299
               return;
15300
            end if;
15301
         end if;
15302
 
15303
         if Expander_Active then
15304
            Rewrite (I,
15305
              Make_Attribute_Reference (Sloc (I),
15306
                Attribute_Name => Name_Range,
15307
                Prefix         => Relocate_Node (I)));
15308
 
15309
            --  The original was a subtype mark that does not freeze. This
15310
            --  means that the rewritten version must not freeze either.
15311
 
15312
            Set_Must_Not_Freeze (I);
15313
            Set_Must_Not_Freeze (Prefix (I));
15314
 
15315
            --  Is order critical??? if so, document why, if not
15316
            --  use Analyze_And_Resolve
15317
 
15318
            Analyze_And_Resolve (I);
15319
            T := Etype (I);
15320
            R := I;
15321
 
15322
         --  If expander is inactive, type is legal, nothing else to construct
15323
 
15324
         else
15325
            return;
15326
         end if;
15327
      end if;
15328
 
15329
      if not Is_Discrete_Type (T) then
15330
         Error_Msg_N ("discrete type required for range", I);
15331
         Set_Etype (I, Any_Type);
15332
         return;
15333
 
15334
      elsif T = Any_Type then
15335
         Set_Etype (I, Any_Type);
15336
         return;
15337
      end if;
15338
 
15339
      --  We will now create the appropriate Itype to describe the range, but
15340
      --  first a check. If we originally had a subtype, then we just label
15341
      --  the range with this subtype. Not only is there no need to construct
15342
      --  a new subtype, but it is wrong to do so for two reasons:
15343
 
15344
      --    1. A legality concern, if we have a subtype, it must not freeze,
15345
      --       and the Itype would cause freezing incorrectly
15346
 
15347
      --    2. An efficiency concern, if we created an Itype, it would not be
15348
      --       recognized as the same type for the purposes of eliminating
15349
      --       checks in some circumstances.
15350
 
15351
      --  We signal this case by setting the subtype entity in Def_Id
15352
 
15353
      if No (Def_Id) then
15354
         Def_Id :=
15355
           Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
15356
         Set_Etype (Def_Id, Base_Type (T));
15357
 
15358
         if Is_Signed_Integer_Type (T) then
15359
            Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
15360
 
15361
         elsif Is_Modular_Integer_Type (T) then
15362
            Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
15363
 
15364
         else
15365
            Set_Ekind             (Def_Id, E_Enumeration_Subtype);
15366
            Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
15367
            Set_First_Literal     (Def_Id, First_Literal (T));
15368
         end if;
15369
 
15370
         Set_Size_Info      (Def_Id,                  (T));
15371
         Set_RM_Size        (Def_Id, RM_Size          (T));
15372
         Set_First_Rep_Item (Def_Id, First_Rep_Item   (T));
15373
 
15374
         Set_Scalar_Range   (Def_Id, R);
15375
         Conditional_Delay  (Def_Id, T);
15376
 
15377
         --  In the subtype indication case, if the immediate parent of the
15378
         --  new subtype is non-static, then the subtype we create is non-
15379
         --  static, even if its bounds are static.
15380
 
15381
         if Nkind (I) = N_Subtype_Indication
15382
           and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
15383
         then
15384
            Set_Is_Non_Static_Subtype (Def_Id);
15385
         end if;
15386
      end if;
15387
 
15388
      --  Final step is to label the index with this constructed type
15389
 
15390
      Set_Etype (I, Def_Id);
15391
   end Make_Index;
15392
 
15393
   ------------------------------
15394
   -- Modular_Type_Declaration --
15395
   ------------------------------
15396
 
15397
   procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
15398
      Mod_Expr : constant Node_Id := Expression (Def);
15399
      M_Val    : Uint;
15400
 
15401
      procedure Set_Modular_Size (Bits : Int);
15402
      --  Sets RM_Size to Bits, and Esize to normal word size above this
15403
 
15404
      ----------------------
15405
      -- Set_Modular_Size --
15406
      ----------------------
15407
 
15408
      procedure Set_Modular_Size (Bits : Int) is
15409
      begin
15410
         Set_RM_Size (T, UI_From_Int (Bits));
15411
 
15412
         if Bits <= 8 then
15413
            Init_Esize (T, 8);
15414
 
15415
         elsif Bits <= 16 then
15416
            Init_Esize (T, 16);
15417
 
15418
         elsif Bits <= 32 then
15419
            Init_Esize (T, 32);
15420
 
15421
         else
15422
            Init_Esize (T, System_Max_Binary_Modulus_Power);
15423
         end if;
15424
 
15425
         if not Non_Binary_Modulus (T)
15426
           and then Esize (T) = RM_Size (T)
15427
         then
15428
            Set_Is_Known_Valid (T);
15429
         end if;
15430
      end Set_Modular_Size;
15431
 
15432
   --  Start of processing for Modular_Type_Declaration
15433
 
15434
   begin
15435
      Analyze_And_Resolve (Mod_Expr, Any_Integer);
15436
      Set_Etype (T, T);
15437
      Set_Ekind (T, E_Modular_Integer_Type);
15438
      Init_Alignment (T);
15439
      Set_Is_Constrained (T);
15440
 
15441
      if not Is_OK_Static_Expression (Mod_Expr) then
15442
         Flag_Non_Static_Expr
15443
           ("non-static expression used for modular type bound!", Mod_Expr);
15444
         M_Val := 2 ** System_Max_Binary_Modulus_Power;
15445
      else
15446
         M_Val := Expr_Value (Mod_Expr);
15447
      end if;
15448
 
15449
      if M_Val < 1 then
15450
         Error_Msg_N ("modulus value must be positive", Mod_Expr);
15451
         M_Val := 2 ** System_Max_Binary_Modulus_Power;
15452
      end if;
15453
 
15454
      Set_Modulus (T, M_Val);
15455
 
15456
      --   Create bounds for the modular type based on the modulus given in
15457
      --   the type declaration and then analyze and resolve those bounds.
15458
 
15459
      Set_Scalar_Range (T,
15460
        Make_Range (Sloc (Mod_Expr),
15461
          Low_Bound  =>
15462
            Make_Integer_Literal (Sloc (Mod_Expr), 0),
15463
          High_Bound =>
15464
            Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
15465
 
15466
      --  Properly analyze the literals for the range. We do this manually
15467
      --  because we can't go calling Resolve, since we are resolving these
15468
      --  bounds with the type, and this type is certainly not complete yet!
15469
 
15470
      Set_Etype (Low_Bound  (Scalar_Range (T)), T);
15471
      Set_Etype (High_Bound (Scalar_Range (T)), T);
15472
      Set_Is_Static_Expression (Low_Bound  (Scalar_Range (T)));
15473
      Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
15474
 
15475
      --  Loop through powers of two to find number of bits required
15476
 
15477
      for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
15478
 
15479
         --  Binary case
15480
 
15481
         if M_Val = 2 ** Bits then
15482
            Set_Modular_Size (Bits);
15483
            return;
15484
 
15485
         --  Non-binary case
15486
 
15487
         elsif M_Val < 2 ** Bits then
15488
            Set_Non_Binary_Modulus (T);
15489
 
15490
            if Bits > System_Max_Nonbinary_Modulus_Power then
15491
               Error_Msg_Uint_1 :=
15492
                 UI_From_Int (System_Max_Nonbinary_Modulus_Power);
15493
               Error_Msg_F
15494
                 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
15495
               Set_Modular_Size (System_Max_Binary_Modulus_Power);
15496
               return;
15497
 
15498
            else
15499
               --  In the non-binary case, set size as per RM 13.3(55)
15500
 
15501
               Set_Modular_Size (Bits);
15502
               return;
15503
            end if;
15504
         end if;
15505
 
15506
      end loop;
15507
 
15508
      --  If we fall through, then the size exceed System.Max_Binary_Modulus
15509
      --  so we just signal an error and set the maximum size.
15510
 
15511
      Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
15512
      Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
15513
 
15514
      Set_Modular_Size (System_Max_Binary_Modulus_Power);
15515
      Init_Alignment (T);
15516
 
15517
   end Modular_Type_Declaration;
15518
 
15519
   --------------------------
15520
   -- New_Concatenation_Op --
15521
   --------------------------
15522
 
15523
   procedure New_Concatenation_Op (Typ : Entity_Id) is
15524
      Loc : constant Source_Ptr := Sloc (Typ);
15525
      Op  : Entity_Id;
15526
 
15527
      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
15528
      --  Create abbreviated declaration for the formal of a predefined
15529
      --  Operator 'Op' of type 'Typ'
15530
 
15531
      --------------------
15532
      -- Make_Op_Formal --
15533
      --------------------
15534
 
15535
      function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
15536
         Formal : Entity_Id;
15537
      begin
15538
         Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
15539
         Set_Etype (Formal, Typ);
15540
         Set_Mechanism (Formal, Default_Mechanism);
15541
         return Formal;
15542
      end Make_Op_Formal;
15543
 
15544
   --  Start of processing for New_Concatenation_Op
15545
 
15546
   begin
15547
      Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
15548
 
15549
      Set_Ekind                   (Op, E_Operator);
15550
      Set_Scope                   (Op, Current_Scope);
15551
      Set_Etype                   (Op, Typ);
15552
      Set_Homonym                 (Op, Get_Name_Entity_Id (Name_Op_Concat));
15553
      Set_Is_Immediately_Visible  (Op);
15554
      Set_Is_Intrinsic_Subprogram (Op);
15555
      Set_Has_Completion          (Op);
15556
      Append_Entity               (Op, Current_Scope);
15557
 
15558
      Set_Name_Entity_Id (Name_Op_Concat, Op);
15559
 
15560
      Append_Entity (Make_Op_Formal (Typ, Op), Op);
15561
      Append_Entity (Make_Op_Formal (Typ, Op), Op);
15562
   end New_Concatenation_Op;
15563
 
15564
   -------------------------
15565
   -- OK_For_Limited_Init --
15566
   -------------------------
15567
 
15568
   --  ???Check all calls of this, and compare the conditions under which it's
15569
   --  called.
15570
 
15571
   function OK_For_Limited_Init
15572
     (Typ : Entity_Id;
15573
      Exp : Node_Id) return Boolean
15574
   is
15575
   begin
15576
      return Is_CPP_Constructor_Call (Exp)
15577
        or else (Ada_Version >= Ada_05
15578
                  and then not Debug_Flag_Dot_L
15579
                  and then OK_For_Limited_Init_In_05 (Typ, Exp));
15580
   end OK_For_Limited_Init;
15581
 
15582
   -------------------------------
15583
   -- OK_For_Limited_Init_In_05 --
15584
   -------------------------------
15585
 
15586
   function OK_For_Limited_Init_In_05
15587
     (Typ : Entity_Id;
15588
      Exp : Node_Id) return Boolean
15589
   is
15590
   begin
15591
      --  An object of a limited interface type can be initialized with any
15592
      --  expression of a nonlimited descendant type.
15593
 
15594
      if Is_Class_Wide_Type (Typ)
15595
        and then Is_Limited_Interface (Typ)
15596
        and then not Is_Limited_Type (Etype (Exp))
15597
      then
15598
         return True;
15599
      end if;
15600
 
15601
      --  Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
15602
      --  case of limited aggregates (including extension aggregates), and
15603
      --  function calls. The function call may have been give in prefixed
15604
      --  notation, in which case the original node is an indexed component.
15605
 
15606
      case Nkind (Original_Node (Exp)) is
15607
         when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
15608
            return True;
15609
 
15610
         when N_Qualified_Expression =>
15611
            return
15612
              OK_For_Limited_Init_In_05
15613
                (Typ, Expression (Original_Node (Exp)));
15614
 
15615
         --  Ada 2005 (AI-251): If a class-wide interface object is initialized
15616
         --  with a function call, the expander has rewritten the call into an
15617
         --  N_Type_Conversion node to force displacement of the pointer to
15618
         --  reference the component containing the secondary dispatch table.
15619
         --  Otherwise a type conversion is not a legal context.
15620
         --  A return statement for a build-in-place function returning a
15621
         --  synchronized type also introduces an unchecked conversion.
15622
 
15623
         when N_Type_Conversion | N_Unchecked_Type_Conversion =>
15624
            return not Comes_From_Source (Exp)
15625
              and then
15626
                OK_For_Limited_Init_In_05
15627
                  (Typ, Expression (Original_Node (Exp)));
15628
 
15629
         when N_Indexed_Component | N_Selected_Component  =>
15630
            return Nkind (Exp) = N_Function_Call;
15631
 
15632
         --  A use of 'Input is a function call, hence allowed. Normally the
15633
         --  attribute will be changed to a call, but the attribute by itself
15634
         --  can occur with -gnatc.
15635
 
15636
         when N_Attribute_Reference =>
15637
            return Attribute_Name (Original_Node (Exp)) = Name_Input;
15638
 
15639
         when others =>
15640
            return False;
15641
      end case;
15642
   end OK_For_Limited_Init_In_05;
15643
 
15644
   -------------------------------------------
15645
   -- Ordinary_Fixed_Point_Type_Declaration --
15646
   -------------------------------------------
15647
 
15648
   procedure Ordinary_Fixed_Point_Type_Declaration
15649
     (T   : Entity_Id;
15650
      Def : Node_Id)
15651
   is
15652
      Loc           : constant Source_Ptr := Sloc (Def);
15653
      Delta_Expr    : constant Node_Id    := Delta_Expression (Def);
15654
      RRS           : constant Node_Id    := Real_Range_Specification (Def);
15655
      Implicit_Base : Entity_Id;
15656
      Delta_Val     : Ureal;
15657
      Small_Val     : Ureal;
15658
      Low_Val       : Ureal;
15659
      High_Val      : Ureal;
15660
 
15661
   begin
15662
      Check_Restriction (No_Fixed_Point, Def);
15663
 
15664
      --  Create implicit base type
15665
 
15666
      Implicit_Base :=
15667
        Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
15668
      Set_Etype (Implicit_Base, Implicit_Base);
15669
 
15670
      --  Analyze and process delta expression
15671
 
15672
      Analyze_And_Resolve (Delta_Expr, Any_Real);
15673
 
15674
      Check_Delta_Expression (Delta_Expr);
15675
      Delta_Val := Expr_Value_R (Delta_Expr);
15676
 
15677
      Set_Delta_Value (Implicit_Base, Delta_Val);
15678
 
15679
      --  Compute default small from given delta, which is the largest power
15680
      --  of two that does not exceed the given delta value.
15681
 
15682
      declare
15683
         Tmp   : Ureal;
15684
         Scale : Int;
15685
 
15686
      begin
15687
         Tmp := Ureal_1;
15688
         Scale := 0;
15689
 
15690
         if Delta_Val < Ureal_1 then
15691
            while Delta_Val < Tmp loop
15692
               Tmp := Tmp / Ureal_2;
15693
               Scale := Scale + 1;
15694
            end loop;
15695
 
15696
         else
15697
            loop
15698
               Tmp := Tmp * Ureal_2;
15699
               exit when Tmp > Delta_Val;
15700
               Scale := Scale - 1;
15701
            end loop;
15702
         end if;
15703
 
15704
         Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
15705
      end;
15706
 
15707
      Set_Small_Value (Implicit_Base, Small_Val);
15708
 
15709
      --  If no range was given, set a dummy range
15710
 
15711
      if RRS <= Empty_Or_Error then
15712
         Low_Val  := -Small_Val;
15713
         High_Val := Small_Val;
15714
 
15715
      --  Otherwise analyze and process given range
15716
 
15717
      else
15718
         declare
15719
            Low  : constant Node_Id := Low_Bound  (RRS);
15720
            High : constant Node_Id := High_Bound (RRS);
15721
 
15722
         begin
15723
            Analyze_And_Resolve (Low, Any_Real);
15724
            Analyze_And_Resolve (High, Any_Real);
15725
            Check_Real_Bound (Low);
15726
            Check_Real_Bound (High);
15727
 
15728
            --  Obtain and set the range
15729
 
15730
            Low_Val  := Expr_Value_R (Low);
15731
            High_Val := Expr_Value_R (High);
15732
 
15733
            if Low_Val > High_Val then
15734
               Error_Msg_NE ("?fixed point type& has null range", Def, T);
15735
            end if;
15736
         end;
15737
      end if;
15738
 
15739
      --  The range for both the implicit base and the declared first subtype
15740
      --  cannot be set yet, so we use the special routine Set_Fixed_Range to
15741
      --  set a temporary range in place. Note that the bounds of the base
15742
      --  type will be widened to be symmetrical and to fill the available
15743
      --  bits when the type is frozen.
15744
 
15745
      --  We could do this with all discrete types, and probably should, but
15746
      --  we absolutely have to do it for fixed-point, since the end-points
15747
      --  of the range and the size are determined by the small value, which
15748
      --  could be reset before the freeze point.
15749
 
15750
      Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
15751
      Set_Fixed_Range (T, Loc, Low_Val, High_Val);
15752
 
15753
      --  Complete definition of first subtype
15754
 
15755
      Set_Ekind          (T, E_Ordinary_Fixed_Point_Subtype);
15756
      Set_Etype          (T, Implicit_Base);
15757
      Init_Size_Align    (T);
15758
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
15759
      Set_Small_Value    (T, Small_Val);
15760
      Set_Delta_Value    (T, Delta_Val);
15761
      Set_Is_Constrained (T);
15762
 
15763
   end Ordinary_Fixed_Point_Type_Declaration;
15764
 
15765
   ----------------------------------------
15766
   -- Prepare_Private_Subtype_Completion --
15767
   ----------------------------------------
15768
 
15769
   procedure Prepare_Private_Subtype_Completion
15770
     (Id          : Entity_Id;
15771
      Related_Nod : Node_Id)
15772
   is
15773
      Id_B   : constant Entity_Id := Base_Type (Id);
15774
      Full_B : constant Entity_Id := Full_View (Id_B);
15775
      Full   : Entity_Id;
15776
 
15777
   begin
15778
      if Present (Full_B) then
15779
 
15780
         --  The Base_Type is already completed, we can complete the subtype
15781
         --  now. We have to create a new entity with the same name, Thus we
15782
         --  can't use Create_Itype.
15783
 
15784
         --  This is messy, should be fixed ???
15785
 
15786
         Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
15787
         Set_Is_Itype (Full);
15788
         Set_Associated_Node_For_Itype (Full, Related_Nod);
15789
         Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
15790
      end if;
15791
 
15792
      --  The parent subtype may be private, but the base might not, in some
15793
      --  nested instances. In that case, the subtype does not need to be
15794
      --  exchanged. It would still be nice to make private subtypes and their
15795
      --  bases consistent at all times ???
15796
 
15797
      if Is_Private_Type (Id_B) then
15798
         Append_Elmt (Id, Private_Dependents (Id_B));
15799
      end if;
15800
 
15801
   end Prepare_Private_Subtype_Completion;
15802
 
15803
   ---------------------------
15804
   -- Process_Discriminants --
15805
   ---------------------------
15806
 
15807
   procedure Process_Discriminants
15808
     (N    : Node_Id;
15809
      Prev : Entity_Id := Empty)
15810
   is
15811
      Elist               : constant Elist_Id := New_Elmt_List;
15812
      Id                  : Node_Id;
15813
      Discr               : Node_Id;
15814
      Discr_Number        : Uint;
15815
      Discr_Type          : Entity_Id;
15816
      Default_Present     : Boolean := False;
15817
      Default_Not_Present : Boolean := False;
15818
 
15819
   begin
15820
      --  A composite type other than an array type can have discriminants.
15821
      --  On entry, the current scope is the composite type.
15822
 
15823
      --  The discriminants are initially entered into the scope of the type
15824
      --  via Enter_Name with the default Ekind of E_Void to prevent premature
15825
      --  use, as explained at the end of this procedure.
15826
 
15827
      Discr := First (Discriminant_Specifications (N));
15828
      while Present (Discr) loop
15829
         Enter_Name (Defining_Identifier (Discr));
15830
 
15831
         --  For navigation purposes we add a reference to the discriminant
15832
         --  in the entity for the type. If the current declaration is a
15833
         --  completion, place references on the partial view. Otherwise the
15834
         --  type is the current scope.
15835
 
15836
         if Present (Prev) then
15837
 
15838
            --  The references go on the partial view, if present. If the
15839
            --  partial view has discriminants, the references have been
15840
            --  generated already.
15841
 
15842
            if not Has_Discriminants (Prev) then
15843
               Generate_Reference (Prev, Defining_Identifier (Discr), 'd');
15844
            end if;
15845
         else
15846
            Generate_Reference
15847
              (Current_Scope, Defining_Identifier (Discr), 'd');
15848
         end if;
15849
 
15850
         if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
15851
            Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
15852
 
15853
            --  Ada 2005 (AI-254)
15854
 
15855
            if Present (Access_To_Subprogram_Definition
15856
                         (Discriminant_Type (Discr)))
15857
              and then Protected_Present (Access_To_Subprogram_Definition
15858
                                           (Discriminant_Type (Discr)))
15859
            then
15860
               Discr_Type :=
15861
                 Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
15862
            end if;
15863
 
15864
         else
15865
            Find_Type (Discriminant_Type (Discr));
15866
            Discr_Type := Etype (Discriminant_Type (Discr));
15867
 
15868
            if Error_Posted (Discriminant_Type (Discr)) then
15869
               Discr_Type := Any_Type;
15870
            end if;
15871
         end if;
15872
 
15873
         if Is_Access_Type (Discr_Type) then
15874
 
15875
            --  Ada 2005 (AI-230): Access discriminant allowed in non-limited
15876
            --  record types
15877
 
15878
            if Ada_Version < Ada_05 then
15879
               Check_Access_Discriminant_Requires_Limited
15880
                 (Discr, Discriminant_Type (Discr));
15881
            end if;
15882
 
15883
            if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
15884
               Error_Msg_N
15885
                 ("(Ada 83) access discriminant not allowed", Discr);
15886
            end if;
15887
 
15888
         elsif not Is_Discrete_Type (Discr_Type) then
15889
            Error_Msg_N ("discriminants must have a discrete or access type",
15890
              Discriminant_Type (Discr));
15891
         end if;
15892
 
15893
         Set_Etype (Defining_Identifier (Discr), Discr_Type);
15894
 
15895
         --  If a discriminant specification includes the assignment compound
15896
         --  delimiter followed by an expression, the expression is the default
15897
         --  expression of the discriminant; the default expression must be of
15898
         --  the type of the discriminant. (RM 3.7.1) Since this expression is
15899
         --  a default expression, we do the special preanalysis, since this
15900
         --  expression does not freeze (see "Handling of Default and Per-
15901
         --  Object Expressions" in spec of package Sem).
15902
 
15903
         if Present (Expression (Discr)) then
15904
            Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
15905
 
15906
            if Nkind (N) = N_Formal_Type_Declaration then
15907
               Error_Msg_N
15908
                 ("discriminant defaults not allowed for formal type",
15909
                  Expression (Discr));
15910
 
15911
            --  Tagged types cannot have defaulted discriminants, but a
15912
            --  non-tagged private type with defaulted discriminants
15913
            --   can have a tagged completion.
15914
 
15915
            elsif Is_Tagged_Type (Current_Scope)
15916
              and then Comes_From_Source (N)
15917
            then
15918
               Error_Msg_N
15919
                 ("discriminants of tagged type cannot have defaults",
15920
                  Expression (Discr));
15921
 
15922
            else
15923
               Default_Present := True;
15924
               Append_Elmt (Expression (Discr), Elist);
15925
 
15926
               --  Tag the defining identifiers for the discriminants with
15927
               --  their corresponding default expressions from the tree.
15928
 
15929
               Set_Discriminant_Default_Value
15930
                 (Defining_Identifier (Discr), Expression (Discr));
15931
            end if;
15932
 
15933
         else
15934
            Default_Not_Present := True;
15935
         end if;
15936
 
15937
         --  Ada 2005 (AI-231): Create an Itype that is a duplicate of
15938
         --  Discr_Type but with the null-exclusion attribute
15939
 
15940
         if Ada_Version >= Ada_05 then
15941
 
15942
            --  Ada 2005 (AI-231): Static checks
15943
 
15944
            if Can_Never_Be_Null (Discr_Type) then
15945
               Null_Exclusion_Static_Checks (Discr);
15946
 
15947
            elsif Is_Access_Type (Discr_Type)
15948
              and then Null_Exclusion_Present (Discr)
15949
 
15950
               --  No need to check itypes because in their case this check
15951
               --  was done at their point of creation
15952
 
15953
              and then not Is_Itype (Discr_Type)
15954
            then
15955
               if Can_Never_Be_Null (Discr_Type) then
15956
                  Error_Msg_NE
15957
                    ("`NOT NULL` not allowed (& already excludes null)",
15958
                     Discr,
15959
                     Discr_Type);
15960
               end if;
15961
 
15962
               Set_Etype (Defining_Identifier (Discr),
15963
                 Create_Null_Excluding_Itype
15964
                   (T           => Discr_Type,
15965
                    Related_Nod => Discr));
15966
 
15967
            --  Check for improper null exclusion if the type is otherwise
15968
            --  legal for a discriminant.
15969
 
15970
            elsif Null_Exclusion_Present (Discr)
15971
              and then Is_Discrete_Type (Discr_Type)
15972
            then
15973
               Error_Msg_N
15974
                 ("null exclusion can only apply to an access type", Discr);
15975
            end if;
15976
 
15977
            --  Ada 2005 (AI-402): access discriminants of nonlimited types
15978
            --  can't have defaults. Synchronized types, or types that are
15979
            --  explicitly limited are fine, but special tests apply to derived
15980
            --  types in generics: in a generic body we have to assume the
15981
            --  worst, and therefore defaults are not allowed if the parent is
15982
            --  a generic formal private type (see ACATS B370001).
15983
 
15984
            if Is_Access_Type (Discr_Type) then
15985
               if Ekind (Discr_Type) /= E_Anonymous_Access_Type
15986
                 or else not Default_Present
15987
                 or else Is_Limited_Record (Current_Scope)
15988
                 or else Is_Concurrent_Type (Current_Scope)
15989
                 or else Is_Concurrent_Record_Type (Current_Scope)
15990
                 or else Ekind (Current_Scope) = E_Limited_Private_Type
15991
               then
15992
                  if not Is_Derived_Type (Current_Scope)
15993
                    or else not Is_Generic_Type (Etype (Current_Scope))
15994
                    or else not In_Package_Body (Scope (Etype (Current_Scope)))
15995
                    or else Limited_Present
15996
                              (Type_Definition (Parent (Current_Scope)))
15997
                  then
15998
                     null;
15999
 
16000
                  else
16001
                     Error_Msg_N ("access discriminants of nonlimited types",
16002
                         Expression (Discr));
16003
                     Error_Msg_N ("\cannot have defaults", Expression (Discr));
16004
                  end if;
16005
 
16006
               elsif Present (Expression (Discr)) then
16007
                  Error_Msg_N
16008
                    ("(Ada 2005) access discriminants of nonlimited types",
16009
                     Expression (Discr));
16010
                  Error_Msg_N ("\cannot have defaults", Expression (Discr));
16011
               end if;
16012
            end if;
16013
         end if;
16014
 
16015
         Next (Discr);
16016
      end loop;
16017
 
16018
      --  An element list consisting of the default expressions of the
16019
      --  discriminants is constructed in the above loop and used to set
16020
      --  the Discriminant_Constraint attribute for the type. If an object
16021
      --  is declared of this (record or task) type without any explicit
16022
      --  discriminant constraint given, this element list will form the
16023
      --  actual parameters for the corresponding initialization procedure
16024
      --  for the type.
16025
 
16026
      Set_Discriminant_Constraint (Current_Scope, Elist);
16027
      Set_Stored_Constraint (Current_Scope, No_Elist);
16028
 
16029
      --  Default expressions must be provided either for all or for none
16030
      --  of the discriminants of a discriminant part. (RM 3.7.1)
16031
 
16032
      if Default_Present and then Default_Not_Present then
16033
         Error_Msg_N
16034
           ("incomplete specification of defaults for discriminants", N);
16035
      end if;
16036
 
16037
      --  The use of the name of a discriminant is not allowed in default
16038
      --  expressions of a discriminant part if the specification of the
16039
      --  discriminant is itself given in the discriminant part. (RM 3.7.1)
16040
 
16041
      --  To detect this, the discriminant names are entered initially with an
16042
      --  Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
16043
      --  attempt to use a void entity (for example in an expression that is
16044
      --  type-checked) produces the error message: premature usage. Now after
16045
      --  completing the semantic analysis of the discriminant part, we can set
16046
      --  the Ekind of all the discriminants appropriately.
16047
 
16048
      Discr := First (Discriminant_Specifications (N));
16049
      Discr_Number := Uint_1;
16050
      while Present (Discr) loop
16051
         Id := Defining_Identifier (Discr);
16052
         Set_Ekind (Id, E_Discriminant);
16053
         Init_Component_Location (Id);
16054
         Init_Esize (Id);
16055
         Set_Discriminant_Number (Id, Discr_Number);
16056
 
16057
         --  Make sure this is always set, even in illegal programs
16058
 
16059
         Set_Corresponding_Discriminant (Id, Empty);
16060
 
16061
         --  Initialize the Original_Record_Component to the entity itself.
16062
         --  Inherit_Components will propagate the right value to
16063
         --  discriminants in derived record types.
16064
 
16065
         Set_Original_Record_Component (Id, Id);
16066
 
16067
         --  Create the discriminal for the discriminant
16068
 
16069
         Build_Discriminal (Id);
16070
 
16071
         Next (Discr);
16072
         Discr_Number := Discr_Number + 1;
16073
      end loop;
16074
 
16075
      Set_Has_Discriminants (Current_Scope);
16076
   end Process_Discriminants;
16077
 
16078
   -----------------------
16079
   -- Process_Full_View --
16080
   -----------------------
16081
 
16082
   procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
16083
      Priv_Parent : Entity_Id;
16084
      Full_Parent : Entity_Id;
16085
      Full_Indic  : Node_Id;
16086
 
16087
      procedure Collect_Implemented_Interfaces
16088
        (Typ    : Entity_Id;
16089
         Ifaces : Elist_Id);
16090
      --  Ada 2005: Gather all the interfaces that Typ directly or
16091
      --  inherently implements. Duplicate entries are not added to
16092
      --  the list Ifaces.
16093
 
16094
      ------------------------------------
16095
      -- Collect_Implemented_Interfaces --
16096
      ------------------------------------
16097
 
16098
      procedure Collect_Implemented_Interfaces
16099
        (Typ    : Entity_Id;
16100
         Ifaces : Elist_Id)
16101
      is
16102
         Iface      : Entity_Id;
16103
         Iface_Elmt : Elmt_Id;
16104
 
16105
      begin
16106
         --  Abstract interfaces are only associated with tagged record types
16107
 
16108
         if not Is_Tagged_Type (Typ)
16109
           or else not Is_Record_Type (Typ)
16110
         then
16111
            return;
16112
         end if;
16113
 
16114
         --  Recursively climb to the ancestors
16115
 
16116
         if Etype (Typ) /= Typ
16117
 
16118
            --  Protect the frontend against wrong cyclic declarations like:
16119
 
16120
            --     type B is new A with private;
16121
            --     type C is new A with private;
16122
            --  private
16123
            --     type B is new C with null record;
16124
            --     type C is new B with null record;
16125
 
16126
           and then Etype (Typ) /= Priv_T
16127
           and then Etype (Typ) /= Full_T
16128
         then
16129
            --  Keep separate the management of private type declarations
16130
 
16131
            if Ekind (Typ) = E_Record_Type_With_Private then
16132
 
16133
               --  Handle the following erronous case:
16134
               --      type Private_Type is tagged private;
16135
               --   private
16136
               --      type Private_Type is new Type_Implementing_Iface;
16137
 
16138
               if Present (Full_View (Typ))
16139
                 and then Etype (Typ) /= Full_View (Typ)
16140
               then
16141
                  if Is_Interface (Etype (Typ)) then
16142
                     Append_Unique_Elmt (Etype (Typ), Ifaces);
16143
                  end if;
16144
 
16145
                  Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
16146
               end if;
16147
 
16148
            --  Non-private types
16149
 
16150
            else
16151
               if Is_Interface (Etype (Typ)) then
16152
                  Append_Unique_Elmt (Etype (Typ), Ifaces);
16153
               end if;
16154
 
16155
               Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
16156
            end if;
16157
         end if;
16158
 
16159
         --  Handle entities in the list of abstract interfaces
16160
 
16161
         if Present (Interfaces (Typ)) then
16162
            Iface_Elmt := First_Elmt (Interfaces (Typ));
16163
            while Present (Iface_Elmt) loop
16164
               Iface := Node (Iface_Elmt);
16165
 
16166
               pragma Assert (Is_Interface (Iface));
16167
 
16168
               if not Contain_Interface (Iface, Ifaces) then
16169
                  Append_Elmt (Iface, Ifaces);
16170
                  Collect_Implemented_Interfaces (Iface, Ifaces);
16171
               end if;
16172
 
16173
               Next_Elmt (Iface_Elmt);
16174
            end loop;
16175
         end if;
16176
      end Collect_Implemented_Interfaces;
16177
 
16178
   --  Start of processing for Process_Full_View
16179
 
16180
   begin
16181
      --  First some sanity checks that must be done after semantic
16182
      --  decoration of the full view and thus cannot be placed with other
16183
      --  similar checks in Find_Type_Name
16184
 
16185
      if not Is_Limited_Type (Priv_T)
16186
        and then (Is_Limited_Type (Full_T)
16187
                   or else Is_Limited_Composite (Full_T))
16188
      then
16189
         Error_Msg_N
16190
           ("completion of nonlimited type cannot be limited", Full_T);
16191
         Explain_Limited_Type (Full_T, Full_T);
16192
 
16193
      elsif Is_Abstract_Type (Full_T)
16194
        and then not Is_Abstract_Type (Priv_T)
16195
      then
16196
         Error_Msg_N
16197
           ("completion of nonabstract type cannot be abstract", Full_T);
16198
 
16199
      elsif Is_Tagged_Type (Priv_T)
16200
        and then Is_Limited_Type (Priv_T)
16201
        and then not Is_Limited_Type (Full_T)
16202
      then
16203
         --  If pragma CPP_Class was applied to the private declaration
16204
         --  propagate the limitedness to the full-view
16205
 
16206
         if Is_CPP_Class (Priv_T) then
16207
            Set_Is_Limited_Record (Full_T);
16208
 
16209
         --  GNAT allow its own definition of Limited_Controlled to disobey
16210
         --  this rule in order in ease the implementation. The next test is
16211
         --  safe because Root_Controlled is defined in a private system child
16212
 
16213
         elsif Etype (Full_T) = Full_View (RTE (RE_Root_Controlled)) then
16214
            Set_Is_Limited_Composite (Full_T);
16215
         else
16216
            Error_Msg_N
16217
              ("completion of limited tagged type must be limited", Full_T);
16218
         end if;
16219
 
16220
      elsif Is_Generic_Type (Priv_T) then
16221
         Error_Msg_N ("generic type cannot have a completion", Full_T);
16222
      end if;
16223
 
16224
      --  Check that ancestor interfaces of private and full views are
16225
      --  consistent. We omit this check for synchronized types because
16226
      --  they are performed on the corresponding record type when frozen.
16227
 
16228
      if Ada_Version >= Ada_05
16229
        and then Is_Tagged_Type (Priv_T)
16230
        and then Is_Tagged_Type (Full_T)
16231
        and then not Is_Concurrent_Type (Full_T)
16232
      then
16233
         declare
16234
            Iface         : Entity_Id;
16235
            Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
16236
            Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
16237
 
16238
         begin
16239
            Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
16240
            Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
16241
 
16242
            --  Ada 2005 (AI-251): The partial view shall be a descendant of
16243
            --  an interface type if and only if the full type is descendant
16244
            --  of the interface type (AARM 7.3 (7.3/2).
16245
 
16246
            Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
16247
 
16248
            if Present (Iface) then
16249
               Error_Msg_NE ("interface & not implemented by full type " &
16250
                             "(RM-2005 7.3 (7.3/2))", Priv_T, Iface);
16251
            end if;
16252
 
16253
            Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
16254
 
16255
            if Present (Iface) then
16256
               Error_Msg_NE ("interface & not implemented by partial view " &
16257
                             "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
16258
            end if;
16259
         end;
16260
      end if;
16261
 
16262
      if Is_Tagged_Type (Priv_T)
16263
        and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
16264
        and then Is_Derived_Type (Full_T)
16265
      then
16266
         Priv_Parent := Etype (Priv_T);
16267
 
16268
         --  The full view of a private extension may have been transformed
16269
         --  into an unconstrained derived type declaration and a subtype
16270
         --  declaration (see build_derived_record_type for details).
16271
 
16272
         if Nkind (N) = N_Subtype_Declaration then
16273
            Full_Indic  := Subtype_Indication (N);
16274
            Full_Parent := Etype (Base_Type (Full_T));
16275
         else
16276
            Full_Indic  := Subtype_Indication (Type_Definition (N));
16277
            Full_Parent := Etype (Full_T);
16278
         end if;
16279
 
16280
         --  Check that the parent type of the full type is a descendant of
16281
         --  the ancestor subtype given in the private extension. If either
16282
         --  entity has an Etype equal to Any_Type then we had some previous
16283
         --  error situation [7.3(8)].
16284
 
16285
         if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
16286
            return;
16287
 
16288
         --  Ada 2005 (AI-251): Interfaces in the full-typ can be given in
16289
         --  any order. Therefore we don't have to check that its parent must
16290
         --  be a descendant of the parent of the private type declaration.
16291
 
16292
         elsif Is_Interface (Priv_Parent)
16293
           and then Is_Interface (Full_Parent)
16294
         then
16295
            null;
16296
 
16297
         --  Ada 2005 (AI-251): If the parent of the private type declaration
16298
         --  is an interface there is no need to check that it is an ancestor
16299
         --  of the associated full type declaration. The required tests for
16300
         --  this case are performed by Build_Derived_Record_Type.
16301
 
16302
         elsif not Is_Interface (Base_Type (Priv_Parent))
16303
           and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
16304
         then
16305
            Error_Msg_N
16306
              ("parent of full type must descend from parent"
16307
                  & " of private extension", Full_Indic);
16308
 
16309
         --  Check the rules of 7.3(10): if the private extension inherits
16310
         --  known discriminants, then the full type must also inherit those
16311
         --  discriminants from the same (ancestor) type, and the parent
16312
         --  subtype of the full type must be constrained if and only if
16313
         --  the ancestor subtype of the private extension is constrained.
16314
 
16315
         elsif No (Discriminant_Specifications (Parent (Priv_T)))
16316
           and then not Has_Unknown_Discriminants (Priv_T)
16317
           and then Has_Discriminants (Base_Type (Priv_Parent))
16318
         then
16319
            declare
16320
               Priv_Indic  : constant Node_Id :=
16321
                               Subtype_Indication (Parent (Priv_T));
16322
 
16323
               Priv_Constr : constant Boolean :=
16324
                               Is_Constrained (Priv_Parent)
16325
                                 or else
16326
                                   Nkind (Priv_Indic) = N_Subtype_Indication
16327
                                 or else Is_Constrained (Entity (Priv_Indic));
16328
 
16329
               Full_Constr : constant Boolean :=
16330
                               Is_Constrained (Full_Parent)
16331
                                 or else
16332
                                   Nkind (Full_Indic) = N_Subtype_Indication
16333
                                 or else Is_Constrained (Entity (Full_Indic));
16334
 
16335
               Priv_Discr : Entity_Id;
16336
               Full_Discr : Entity_Id;
16337
 
16338
            begin
16339
               Priv_Discr := First_Discriminant (Priv_Parent);
16340
               Full_Discr := First_Discriminant (Full_Parent);
16341
               while Present (Priv_Discr) and then Present (Full_Discr) loop
16342
                  if Original_Record_Component (Priv_Discr) =
16343
                     Original_Record_Component (Full_Discr)
16344
                    or else
16345
                     Corresponding_Discriminant (Priv_Discr) =
16346
                     Corresponding_Discriminant (Full_Discr)
16347
                  then
16348
                     null;
16349
                  else
16350
                     exit;
16351
                  end if;
16352
 
16353
                  Next_Discriminant (Priv_Discr);
16354
                  Next_Discriminant (Full_Discr);
16355
               end loop;
16356
 
16357
               if Present (Priv_Discr) or else Present (Full_Discr) then
16358
                  Error_Msg_N
16359
                    ("full view must inherit discriminants of the parent type"
16360
                     & " used in the private extension", Full_Indic);
16361
 
16362
               elsif Priv_Constr and then not Full_Constr then
16363
                  Error_Msg_N
16364
                    ("parent subtype of full type must be constrained",
16365
                     Full_Indic);
16366
 
16367
               elsif Full_Constr and then not Priv_Constr then
16368
                  Error_Msg_N
16369
                    ("parent subtype of full type must be unconstrained",
16370
                     Full_Indic);
16371
               end if;
16372
            end;
16373
 
16374
         --  Check the rules of 7.3(12): if a partial view has neither known
16375
         --  or unknown discriminants, then the full type declaration shall
16376
         --  define a definite subtype.
16377
 
16378
         elsif      not Has_Unknown_Discriminants (Priv_T)
16379
           and then not Has_Discriminants (Priv_T)
16380
           and then not Is_Constrained (Full_T)
16381
         then
16382
            Error_Msg_N
16383
              ("full view must define a constrained type if partial view"
16384
                & " has no discriminants", Full_T);
16385
         end if;
16386
 
16387
         --  ??????? Do we implement the following properly ?????
16388
         --  If the ancestor subtype of a private extension has constrained
16389
         --  discriminants, then the parent subtype of the full view shall
16390
         --  impose a statically matching constraint on those discriminants
16391
         --  [7.3(13)].
16392
 
16393
      else
16394
         --  For untagged types, verify that a type without discriminants
16395
         --  is not completed with an unconstrained type.
16396
 
16397
         if not Is_Indefinite_Subtype (Priv_T)
16398
           and then Is_Indefinite_Subtype (Full_T)
16399
         then
16400
            Error_Msg_N ("full view of type must be definite subtype", Full_T);
16401
         end if;
16402
      end if;
16403
 
16404
      --  AI-419: verify that the use of "limited" is consistent
16405
 
16406
      declare
16407
         Orig_Decl : constant Node_Id := Original_Node (N);
16408
 
16409
      begin
16410
         if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
16411
           and then not Limited_Present (Parent (Priv_T))
16412
           and then not Synchronized_Present (Parent (Priv_T))
16413
           and then Nkind (Orig_Decl) = N_Full_Type_Declaration
16414
           and then Nkind
16415
             (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
16416
           and then Limited_Present (Type_Definition (Orig_Decl))
16417
         then
16418
            Error_Msg_N
16419
              ("full view of non-limited extension cannot be limited", N);
16420
         end if;
16421
      end;
16422
 
16423
      --  Ada 2005 (AI-443): A synchronized private extension must be
16424
      --  completed by a task or protected type.
16425
 
16426
      if Ada_Version >= Ada_05
16427
        and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
16428
        and then Synchronized_Present (Parent (Priv_T))
16429
        and then not Is_Concurrent_Type (Full_T)
16430
      then
16431
         Error_Msg_N ("full view of synchronized extension must " &
16432
                      "be synchronized type", N);
16433
      end if;
16434
 
16435
      --  Ada 2005 AI-363: if the full view has discriminants with
16436
      --  defaults, it is illegal to declare constrained access subtypes
16437
      --  whose designated type is the current type. This allows objects
16438
      --  of the type that are declared in the heap to be unconstrained.
16439
 
16440
      if not Has_Unknown_Discriminants (Priv_T)
16441
        and then not Has_Discriminants (Priv_T)
16442
        and then Has_Discriminants (Full_T)
16443
        and then
16444
          Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
16445
      then
16446
         Set_Has_Constrained_Partial_View (Full_T);
16447
         Set_Has_Constrained_Partial_View (Priv_T);
16448
      end if;
16449
 
16450
      --  Create a full declaration for all its subtypes recorded in
16451
      --  Private_Dependents and swap them similarly to the base type. These
16452
      --  are subtypes that have been define before the full declaration of
16453
      --  the private type. We also swap the entry in Private_Dependents list
16454
      --  so we can properly restore the private view on exit from the scope.
16455
 
16456
      declare
16457
         Priv_Elmt : Elmt_Id;
16458
         Priv      : Entity_Id;
16459
         Full      : Entity_Id;
16460
 
16461
      begin
16462
         Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
16463
         while Present (Priv_Elmt) loop
16464
            Priv := Node (Priv_Elmt);
16465
 
16466
            if Ekind (Priv) = E_Private_Subtype
16467
              or else Ekind (Priv) = E_Limited_Private_Subtype
16468
              or else Ekind (Priv) = E_Record_Subtype_With_Private
16469
            then
16470
               Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
16471
               Set_Is_Itype (Full);
16472
               Set_Parent (Full, Parent (Priv));
16473
               Set_Associated_Node_For_Itype (Full, N);
16474
 
16475
               --  Now we need to complete the private subtype, but since the
16476
               --  base type has already been swapped, we must also swap the
16477
               --  subtypes (and thus, reverse the arguments in the call to
16478
               --  Complete_Private_Subtype).
16479
 
16480
               Copy_And_Swap (Priv, Full);
16481
               Complete_Private_Subtype (Full, Priv, Full_T, N);
16482
               Replace_Elmt (Priv_Elmt, Full);
16483
            end if;
16484
 
16485
            Next_Elmt (Priv_Elmt);
16486
         end loop;
16487
      end;
16488
 
16489
      --  If the private view was tagged, copy the new primitive operations
16490
      --  from the private view to the full view.
16491
 
16492
      if Is_Tagged_Type (Full_T) then
16493
         declare
16494
            Disp_Typ  : Entity_Id;
16495
            Full_List : Elist_Id;
16496
            Prim      : Entity_Id;
16497
            Prim_Elmt : Elmt_Id;
16498
            Priv_List : Elist_Id;
16499
 
16500
            function Contains
16501
              (E : Entity_Id;
16502
               L : Elist_Id) return Boolean;
16503
            --  Determine whether list L contains element E
16504
 
16505
            --------------
16506
            -- Contains --
16507
            --------------
16508
 
16509
            function Contains
16510
              (E : Entity_Id;
16511
               L : Elist_Id) return Boolean
16512
            is
16513
               List_Elmt : Elmt_Id;
16514
 
16515
            begin
16516
               List_Elmt := First_Elmt (L);
16517
               while Present (List_Elmt) loop
16518
                  if Node (List_Elmt) = E then
16519
                     return True;
16520
                  end if;
16521
 
16522
                  Next_Elmt (List_Elmt);
16523
               end loop;
16524
 
16525
               return False;
16526
            end Contains;
16527
 
16528
         --  Start of processing
16529
 
16530
         begin
16531
            if Is_Tagged_Type (Priv_T) then
16532
               Priv_List := Primitive_Operations (Priv_T);
16533
               Prim_Elmt := First_Elmt (Priv_List);
16534
 
16535
               --  In the case of a concurrent type completing a private tagged
16536
               --  type, primitives may have been declared in between the two
16537
               --  views. These subprograms need to be wrapped the same way
16538
               --  entries and protected procedures are handled because they
16539
               --  cannot be directly shared by the two views.
16540
 
16541
               if Is_Concurrent_Type (Full_T) then
16542
                  declare
16543
                     Conc_Typ  : constant Entity_Id :=
16544
                                   Corresponding_Record_Type (Full_T);
16545
                     Curr_Nod  : Node_Id := Parent (Conc_Typ);
16546
                     Wrap_Spec : Node_Id;
16547
 
16548
                  begin
16549
                     while Present (Prim_Elmt) loop
16550
                        Prim := Node (Prim_Elmt);
16551
 
16552
                        if Comes_From_Source (Prim)
16553
                          and then not Is_Abstract_Subprogram (Prim)
16554
                        then
16555
                           Wrap_Spec :=
16556
                             Make_Subprogram_Declaration (Sloc (Prim),
16557
                               Specification =>
16558
                                 Build_Wrapper_Spec
16559
                                   (Subp_Id => Prim,
16560
                                    Obj_Typ => Conc_Typ,
16561
                                    Formals =>
16562
                                      Parameter_Specifications (
16563
                                        Parent (Prim))));
16564
 
16565
                           Insert_After (Curr_Nod, Wrap_Spec);
16566
                           Curr_Nod := Wrap_Spec;
16567
 
16568
                           Analyze (Wrap_Spec);
16569
                        end if;
16570
 
16571
                        Next_Elmt (Prim_Elmt);
16572
                     end loop;
16573
 
16574
                     return;
16575
                  end;
16576
 
16577
               --  For non-concurrent types, transfer explicit primitives, but
16578
               --  omit those inherited from the parent of the private view
16579
               --  since they will be re-inherited later on.
16580
 
16581
               else
16582
                  Full_List := Primitive_Operations (Full_T);
16583
 
16584
                  while Present (Prim_Elmt) loop
16585
                     Prim := Node (Prim_Elmt);
16586
 
16587
                     if Comes_From_Source (Prim)
16588
                       and then not Contains (Prim, Full_List)
16589
                     then
16590
                        Append_Elmt (Prim, Full_List);
16591
                     end if;
16592
 
16593
                     Next_Elmt (Prim_Elmt);
16594
                  end loop;
16595
               end if;
16596
 
16597
            --  Untagged private view
16598
 
16599
            else
16600
               Full_List := Primitive_Operations (Full_T);
16601
 
16602
               --  In this case the partial view is untagged, so here we locate
16603
               --  all of the earlier primitives that need to be treated as
16604
               --  dispatching (those that appear between the two views). Note
16605
               --  that these additional operations must all be new operations
16606
               --  (any earlier operations that override inherited operations
16607
               --  of the full view will already have been inserted in the
16608
               --  primitives list, marked by Check_Operation_From_Private_View
16609
               --  as dispatching. Note that implicit "/=" operators are
16610
               --  excluded from being added to the primitives list since they
16611
               --  shouldn't be treated as dispatching (tagged "/=" is handled
16612
               --  specially).
16613
 
16614
               Prim := Next_Entity (Full_T);
16615
               while Present (Prim) and then Prim /= Priv_T loop
16616
                  if Ekind (Prim) = E_Procedure
16617
                       or else
16618
                     Ekind (Prim) = E_Function
16619
                  then
16620
                     Disp_Typ := Find_Dispatching_Type (Prim);
16621
 
16622
                     if Disp_Typ = Full_T
16623
                       and then (Chars (Prim) /= Name_Op_Ne
16624
                                  or else Comes_From_Source (Prim))
16625
                     then
16626
                        Check_Controlling_Formals (Full_T, Prim);
16627
 
16628
                        if not Is_Dispatching_Operation (Prim) then
16629
                           Append_Elmt (Prim, Full_List);
16630
                           Set_Is_Dispatching_Operation (Prim, True);
16631
                           Set_DT_Position (Prim, No_Uint);
16632
                        end if;
16633
 
16634
                     elsif Is_Dispatching_Operation (Prim)
16635
                       and then Disp_Typ  /= Full_T
16636
                     then
16637
 
16638
                        --  Verify that it is not otherwise controlled by a
16639
                        --  formal or a return value of type T.
16640
 
16641
                        Check_Controlling_Formals (Disp_Typ, Prim);
16642
                     end if;
16643
                  end if;
16644
 
16645
                  Next_Entity (Prim);
16646
               end loop;
16647
            end if;
16648
 
16649
            --  For the tagged case, the two views can share the same
16650
            --  Primitive Operation list and the same class wide type.
16651
            --  Update attributes of the class-wide type which depend on
16652
            --  the full declaration.
16653
 
16654
            if Is_Tagged_Type (Priv_T) then
16655
               Set_Primitive_Operations (Priv_T, Full_List);
16656
               Set_Class_Wide_Type
16657
                 (Base_Type (Full_T), Class_Wide_Type (Priv_T));
16658
 
16659
               Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
16660
            end if;
16661
         end;
16662
      end if;
16663
 
16664
      --  Ada 2005 AI 161: Check preelaboratable initialization consistency
16665
 
16666
      if Known_To_Have_Preelab_Init (Priv_T) then
16667
 
16668
         --  Case where there is a pragma Preelaborable_Initialization. We
16669
         --  always allow this in predefined units, which is a bit of a kludge,
16670
         --  but it means we don't have to struggle to meet the requirements in
16671
         --  the RM for having Preelaborable Initialization. Otherwise we
16672
         --  require that the type meets the RM rules. But we can't check that
16673
         --  yet, because of the rule about overriding Ininitialize, so we
16674
         --  simply set a flag that will be checked at freeze time.
16675
 
16676
         if not In_Predefined_Unit (Full_T) then
16677
            Set_Must_Have_Preelab_Init (Full_T);
16678
         end if;
16679
      end if;
16680
 
16681
      --  If pragma CPP_Class was applied to the private type declaration,
16682
      --  propagate it now to the full type declaration.
16683
 
16684
      if Is_CPP_Class (Priv_T) then
16685
         Set_Is_CPP_Class (Full_T);
16686
         Set_Convention   (Full_T, Convention_CPP);
16687
      end if;
16688
 
16689
      --  If the private view has user specified stream attributes, then so has
16690
      --  the full view.
16691
 
16692
      if Has_Specified_Stream_Read (Priv_T) then
16693
         Set_Has_Specified_Stream_Read (Full_T);
16694
      end if;
16695
      if Has_Specified_Stream_Write (Priv_T) then
16696
         Set_Has_Specified_Stream_Write (Full_T);
16697
      end if;
16698
      if Has_Specified_Stream_Input (Priv_T) then
16699
         Set_Has_Specified_Stream_Input (Full_T);
16700
      end if;
16701
      if Has_Specified_Stream_Output (Priv_T) then
16702
         Set_Has_Specified_Stream_Output (Full_T);
16703
      end if;
16704
   end Process_Full_View;
16705
 
16706
   -----------------------------------
16707
   -- Process_Incomplete_Dependents --
16708
   -----------------------------------
16709
 
16710
   procedure Process_Incomplete_Dependents
16711
     (N      : Node_Id;
16712
      Full_T : Entity_Id;
16713
      Inc_T  : Entity_Id)
16714
   is
16715
      Inc_Elmt : Elmt_Id;
16716
      Priv_Dep : Entity_Id;
16717
      New_Subt : Entity_Id;
16718
 
16719
      Disc_Constraint : Elist_Id;
16720
 
16721
   begin
16722
      if No (Private_Dependents (Inc_T)) then
16723
         return;
16724
      end if;
16725
 
16726
      --  Itypes that may be generated by the completion of an incomplete
16727
      --  subtype are not used by the back-end and not attached to the tree.
16728
      --  They are created only for constraint-checking purposes.
16729
 
16730
      Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
16731
      while Present (Inc_Elmt) loop
16732
         Priv_Dep := Node (Inc_Elmt);
16733
 
16734
         if Ekind (Priv_Dep) = E_Subprogram_Type then
16735
 
16736
            --  An Access_To_Subprogram type may have a return type or a
16737
            --  parameter type that is incomplete. Replace with the full view.
16738
 
16739
            if Etype (Priv_Dep) = Inc_T then
16740
               Set_Etype (Priv_Dep, Full_T);
16741
            end if;
16742
 
16743
            declare
16744
               Formal : Entity_Id;
16745
 
16746
            begin
16747
               Formal := First_Formal (Priv_Dep);
16748
               while Present (Formal) loop
16749
                  if Etype (Formal) = Inc_T then
16750
                     Set_Etype (Formal, Full_T);
16751
                  end if;
16752
 
16753
                  Next_Formal (Formal);
16754
               end loop;
16755
            end;
16756
 
16757
         elsif Is_Overloadable (Priv_Dep) then
16758
 
16759
            --  A protected operation is never dispatching: only its
16760
            --  wrapper operation (which has convention Ada) is.
16761
 
16762
            if Is_Tagged_Type (Full_T)
16763
              and then Convention (Priv_Dep) /= Convention_Protected
16764
            then
16765
 
16766
               --  Subprogram has an access parameter whose designated type
16767
               --  was incomplete. Reexamine declaration now, because it may
16768
               --  be a primitive operation of the full type.
16769
 
16770
               Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
16771
               Set_Is_Dispatching_Operation (Priv_Dep);
16772
               Check_Controlling_Formals (Full_T, Priv_Dep);
16773
            end if;
16774
 
16775
         elsif Ekind (Priv_Dep) = E_Subprogram_Body then
16776
 
16777
            --  Can happen during processing of a body before the completion
16778
            --  of a TA type. Ignore, because spec is also on dependent list.
16779
 
16780
            return;
16781
 
16782
         --  Ada 2005 (AI-412): Transform a regular incomplete subtype into a
16783
         --  corresponding subtype of the full view.
16784
 
16785
         elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
16786
            Set_Subtype_Indication
16787
              (Parent (Priv_Dep), New_Reference_To (Full_T, Sloc (Priv_Dep)));
16788
            Set_Etype (Priv_Dep, Full_T);
16789
            Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
16790
            Set_Analyzed (Parent (Priv_Dep), False);
16791
 
16792
            --  Reanalyze the declaration, suppressing the call to
16793
            --  Enter_Name to avoid duplicate names.
16794
 
16795
            Analyze_Subtype_Declaration
16796
              (N    => Parent (Priv_Dep),
16797
               Skip => True);
16798
 
16799
         --  Dependent is a subtype
16800
 
16801
         else
16802
            --  We build a new subtype indication using the full view of the
16803
            --  incomplete parent. The discriminant constraints have been
16804
            --  elaborated already at the point of the subtype declaration.
16805
 
16806
            New_Subt := Create_Itype (E_Void, N);
16807
 
16808
            if Has_Discriminants (Full_T) then
16809
               Disc_Constraint := Discriminant_Constraint (Priv_Dep);
16810
            else
16811
               Disc_Constraint := No_Elist;
16812
            end if;
16813
 
16814
            Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
16815
            Set_Full_View (Priv_Dep, New_Subt);
16816
         end if;
16817
 
16818
         Next_Elmt (Inc_Elmt);
16819
      end loop;
16820
   end Process_Incomplete_Dependents;
16821
 
16822
   --------------------------------
16823
   -- Process_Range_Expr_In_Decl --
16824
   --------------------------------
16825
 
16826
   procedure Process_Range_Expr_In_Decl
16827
     (R           : Node_Id;
16828
      T           : Entity_Id;
16829
      Check_List  : List_Id := Empty_List;
16830
      R_Check_Off : Boolean := False)
16831
   is
16832
      Lo, Hi    : Node_Id;
16833
      R_Checks  : Check_Result;
16834
      Type_Decl : Node_Id;
16835
      Def_Id    : Entity_Id;
16836
 
16837
   begin
16838
      Analyze_And_Resolve (R, Base_Type (T));
16839
 
16840
      if Nkind (R) = N_Range then
16841
         Lo := Low_Bound (R);
16842
         Hi := High_Bound (R);
16843
 
16844
         --  We need to ensure validity of the bounds here, because if we
16845
         --  go ahead and do the expansion, then the expanded code will get
16846
         --  analyzed with range checks suppressed and we miss the check.
16847
 
16848
         Validity_Check_Range (R);
16849
 
16850
         --  If there were errors in the declaration, try and patch up some
16851
         --  common mistakes in the bounds. The cases handled are literals
16852
         --  which are Integer where the expected type is Real and vice versa.
16853
         --  These corrections allow the compilation process to proceed further
16854
         --  along since some basic assumptions of the format of the bounds
16855
         --  are guaranteed.
16856
 
16857
         if Etype (R) = Any_Type then
16858
 
16859
            if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
16860
               Rewrite (Lo,
16861
                 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
16862
 
16863
            elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
16864
               Rewrite (Hi,
16865
                 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
16866
 
16867
            elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
16868
               Rewrite (Lo,
16869
                 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
16870
 
16871
            elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
16872
               Rewrite (Hi,
16873
                 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
16874
            end if;
16875
 
16876
            Set_Etype (Lo, T);
16877
            Set_Etype (Hi, T);
16878
         end if;
16879
 
16880
         --  If the bounds of the range have been mistakenly given as string
16881
         --  literals (perhaps in place of character literals), then an error
16882
         --  has already been reported, but we rewrite the string literal as a
16883
         --  bound of the range's type to avoid blowups in later processing
16884
         --  that looks at static values.
16885
 
16886
         if Nkind (Lo) = N_String_Literal then
16887
            Rewrite (Lo,
16888
              Make_Attribute_Reference (Sloc (Lo),
16889
                Attribute_Name => Name_First,
16890
                Prefix => New_Reference_To (T, Sloc (Lo))));
16891
            Analyze_And_Resolve (Lo);
16892
         end if;
16893
 
16894
         if Nkind (Hi) = N_String_Literal then
16895
            Rewrite (Hi,
16896
              Make_Attribute_Reference (Sloc (Hi),
16897
                Attribute_Name => Name_First,
16898
                Prefix => New_Reference_To (T, Sloc (Hi))));
16899
            Analyze_And_Resolve (Hi);
16900
         end if;
16901
 
16902
         --  If bounds aren't scalar at this point then exit, avoiding
16903
         --  problems with further processing of the range in this procedure.
16904
 
16905
         if not Is_Scalar_Type (Etype (Lo)) then
16906
            return;
16907
         end if;
16908
 
16909
         --  Resolve (actually Sem_Eval) has checked that the bounds are in
16910
         --  then range of the base type. Here we check whether the bounds
16911
         --  are in the range of the subtype itself. Note that if the bounds
16912
         --  represent the null range the Constraint_Error exception should
16913
         --  not be raised.
16914
 
16915
         --  ??? The following code should be cleaned up as follows
16916
 
16917
         --  1. The Is_Null_Range (Lo, Hi) test should disappear since it
16918
         --     is done in the call to Range_Check (R, T); below
16919
 
16920
         --  2. The use of R_Check_Off should be investigated and possibly
16921
         --     removed, this would clean up things a bit.
16922
 
16923
         if Is_Null_Range (Lo, Hi) then
16924
            null;
16925
 
16926
         else
16927
            --  Capture values of bounds and generate temporaries for them
16928
            --  if needed, before applying checks, since checks may cause
16929
            --  duplication of the expression without forcing evaluation.
16930
 
16931
            if Expander_Active then
16932
               Force_Evaluation (Lo);
16933
               Force_Evaluation (Hi);
16934
            end if;
16935
 
16936
            --  We use a flag here instead of suppressing checks on the
16937
            --  type because the type we check against isn't necessarily
16938
            --  the place where we put the check.
16939
 
16940
            if not R_Check_Off then
16941
               R_Checks := Get_Range_Checks (R, T);
16942
 
16943
               --  Look up tree to find an appropriate insertion point.
16944
               --  This seems really junk code, and very brittle, couldn't
16945
               --  we just use an insert actions call of some kind ???
16946
 
16947
               Type_Decl := Parent (R);
16948
               while Present (Type_Decl) and then not
16949
                 (Nkind_In (Type_Decl, N_Full_Type_Declaration,
16950
                                       N_Subtype_Declaration,
16951
                                       N_Loop_Statement,
16952
                                       N_Task_Type_Declaration)
16953
                    or else
16954
                  Nkind_In (Type_Decl, N_Single_Task_Declaration,
16955
                                       N_Protected_Type_Declaration,
16956
                                       N_Single_Protected_Declaration))
16957
               loop
16958
                  Type_Decl := Parent (Type_Decl);
16959
               end loop;
16960
 
16961
               --  Why would Type_Decl not be present???  Without this test,
16962
               --  short regression tests fail.
16963
 
16964
               if Present (Type_Decl) then
16965
 
16966
                  --  Case of loop statement (more comments ???)
16967
 
16968
                  if Nkind (Type_Decl) = N_Loop_Statement then
16969
                     declare
16970
                        Indic : Node_Id;
16971
 
16972
                     begin
16973
                        Indic := Parent (R);
16974
                        while Present (Indic)
16975
                          and then Nkind (Indic) /= N_Subtype_Indication
16976
                        loop
16977
                           Indic := Parent (Indic);
16978
                        end loop;
16979
 
16980
                        if Present (Indic) then
16981
                           Def_Id := Etype (Subtype_Mark (Indic));
16982
 
16983
                           Insert_Range_Checks
16984
                             (R_Checks,
16985
                              Type_Decl,
16986
                              Def_Id,
16987
                              Sloc (Type_Decl),
16988
                              R,
16989
                              Do_Before => True);
16990
                        end if;
16991
                     end;
16992
 
16993
                  --  All other cases (more comments ???)
16994
 
16995
                  else
16996
                     Def_Id := Defining_Identifier (Type_Decl);
16997
 
16998
                     if (Ekind (Def_Id) = E_Record_Type
16999
                          and then Depends_On_Discriminant (R))
17000
                       or else
17001
                        (Ekind (Def_Id) = E_Protected_Type
17002
                          and then Has_Discriminants (Def_Id))
17003
                     then
17004
                        Append_Range_Checks
17005
                          (R_Checks, Check_List, Def_Id, Sloc (Type_Decl), R);
17006
 
17007
                     else
17008
                        Insert_Range_Checks
17009
                          (R_Checks, Type_Decl, Def_Id, Sloc (Type_Decl), R);
17010
 
17011
                     end if;
17012
                  end if;
17013
               end if;
17014
            end if;
17015
         end if;
17016
 
17017
      elsif Expander_Active then
17018
         Get_Index_Bounds (R, Lo, Hi);
17019
         Force_Evaluation (Lo);
17020
         Force_Evaluation (Hi);
17021
      end if;
17022
   end Process_Range_Expr_In_Decl;
17023
 
17024
   --------------------------------------
17025
   -- Process_Real_Range_Specification --
17026
   --------------------------------------
17027
 
17028
   procedure Process_Real_Range_Specification (Def : Node_Id) is
17029
      Spec : constant Node_Id := Real_Range_Specification (Def);
17030
      Lo   : Node_Id;
17031
      Hi   : Node_Id;
17032
      Err  : Boolean := False;
17033
 
17034
      procedure Analyze_Bound (N : Node_Id);
17035
      --  Analyze and check one bound
17036
 
17037
      -------------------
17038
      -- Analyze_Bound --
17039
      -------------------
17040
 
17041
      procedure Analyze_Bound (N : Node_Id) is
17042
      begin
17043
         Analyze_And_Resolve (N, Any_Real);
17044
 
17045
         if not Is_OK_Static_Expression (N) then
17046
            Flag_Non_Static_Expr
17047
              ("bound in real type definition is not static!", N);
17048
            Err := True;
17049
         end if;
17050
      end Analyze_Bound;
17051
 
17052
   --  Start of processing for Process_Real_Range_Specification
17053
 
17054
   begin
17055
      if Present (Spec) then
17056
         Lo := Low_Bound (Spec);
17057
         Hi := High_Bound (Spec);
17058
         Analyze_Bound (Lo);
17059
         Analyze_Bound (Hi);
17060
 
17061
         --  If error, clear away junk range specification
17062
 
17063
         if Err then
17064
            Set_Real_Range_Specification (Def, Empty);
17065
         end if;
17066
      end if;
17067
   end Process_Real_Range_Specification;
17068
 
17069
   ---------------------
17070
   -- Process_Subtype --
17071
   ---------------------
17072
 
17073
   function Process_Subtype
17074
     (S           : Node_Id;
17075
      Related_Nod : Node_Id;
17076
      Related_Id  : Entity_Id := Empty;
17077
      Suffix      : Character := ' ') return Entity_Id
17078
   is
17079
      P               : Node_Id;
17080
      Def_Id          : Entity_Id;
17081
      Error_Node      : Node_Id;
17082
      Full_View_Id    : Entity_Id;
17083
      Subtype_Mark_Id : Entity_Id;
17084
 
17085
      May_Have_Null_Exclusion : Boolean;
17086
 
17087
      procedure Check_Incomplete (T : Entity_Id);
17088
      --  Called to verify that an incomplete type is not used prematurely
17089
 
17090
      ----------------------
17091
      -- Check_Incomplete --
17092
      ----------------------
17093
 
17094
      procedure Check_Incomplete (T : Entity_Id) is
17095
      begin
17096
         --  Ada 2005 (AI-412): Incomplete subtypes are legal
17097
 
17098
         if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
17099
           and then
17100
             not (Ada_Version >= Ada_05
17101
                    and then
17102
                       (Nkind (Parent (T)) = N_Subtype_Declaration
17103
                          or else
17104
                            (Nkind (Parent (T)) = N_Subtype_Indication
17105
                               and then Nkind (Parent (Parent (T))) =
17106
                                          N_Subtype_Declaration)))
17107
         then
17108
            Error_Msg_N ("invalid use of type before its full declaration", T);
17109
         end if;
17110
      end Check_Incomplete;
17111
 
17112
   --  Start of processing for Process_Subtype
17113
 
17114
   begin
17115
      --  Case of no constraints present
17116
 
17117
      if Nkind (S) /= N_Subtype_Indication then
17118
         Find_Type (S);
17119
         Check_Incomplete (S);
17120
         P := Parent (S);
17121
 
17122
         --  Ada 2005 (AI-231): Static check
17123
 
17124
         if Ada_Version >= Ada_05
17125
           and then Present (P)
17126
           and then Null_Exclusion_Present (P)
17127
           and then Nkind (P) /= N_Access_To_Object_Definition
17128
           and then not Is_Access_Type (Entity (S))
17129
         then
17130
            Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
17131
         end if;
17132
 
17133
         --  The following is ugly, can't we have a range or even a flag???
17134
 
17135
         May_Have_Null_Exclusion :=
17136
           Nkind_In (P, N_Access_Definition,
17137
                        N_Access_Function_Definition,
17138
                        N_Access_Procedure_Definition,
17139
                        N_Access_To_Object_Definition,
17140
                        N_Allocator,
17141
                        N_Component_Definition)
17142
             or else
17143
           Nkind_In (P, N_Derived_Type_Definition,
17144
                        N_Discriminant_Specification,
17145
                        N_Formal_Object_Declaration,
17146
                        N_Object_Declaration,
17147
                        N_Object_Renaming_Declaration,
17148
                        N_Parameter_Specification,
17149
                        N_Subtype_Declaration);
17150
 
17151
         --  Create an Itype that is a duplicate of Entity (S) but with the
17152
         --  null-exclusion attribute
17153
 
17154
         if May_Have_Null_Exclusion
17155
           and then Is_Access_Type (Entity (S))
17156
           and then Null_Exclusion_Present (P)
17157
 
17158
            --  No need to check the case of an access to object definition.
17159
            --  It is correct to define double not-null pointers.
17160
 
17161
            --  Example:
17162
            --     type Not_Null_Int_Ptr is not null access Integer;
17163
            --     type Acc is not null access Not_Null_Int_Ptr;
17164
 
17165
           and then Nkind (P) /= N_Access_To_Object_Definition
17166
         then
17167
            if Can_Never_Be_Null (Entity (S)) then
17168
               case Nkind (Related_Nod) is
17169
                  when N_Full_Type_Declaration =>
17170
                     if Nkind (Type_Definition (Related_Nod))
17171
                       in N_Array_Type_Definition
17172
                     then
17173
                        Error_Node :=
17174
                          Subtype_Indication
17175
                            (Component_Definition
17176
                             (Type_Definition (Related_Nod)));
17177
                     else
17178
                        Error_Node :=
17179
                          Subtype_Indication (Type_Definition (Related_Nod));
17180
                     end if;
17181
 
17182
                  when N_Subtype_Declaration =>
17183
                     Error_Node := Subtype_Indication (Related_Nod);
17184
 
17185
                  when N_Object_Declaration =>
17186
                     Error_Node := Object_Definition (Related_Nod);
17187
 
17188
                  when N_Component_Declaration =>
17189
                     Error_Node :=
17190
                       Subtype_Indication (Component_Definition (Related_Nod));
17191
 
17192
                  when N_Allocator =>
17193
                     Error_Node := Expression (Related_Nod);
17194
 
17195
                  when others =>
17196
                     pragma Assert (False);
17197
                     Error_Node := Related_Nod;
17198
               end case;
17199
 
17200
               Error_Msg_NE
17201
                 ("`NOT NULL` not allowed (& already excludes null)",
17202
                  Error_Node,
17203
                  Entity (S));
17204
            end if;
17205
 
17206
            Set_Etype  (S,
17207
              Create_Null_Excluding_Itype
17208
                (T           => Entity (S),
17209
                 Related_Nod => P));
17210
            Set_Entity (S, Etype (S));
17211
         end if;
17212
 
17213
         return Entity (S);
17214
 
17215
      --  Case of constraint present, so that we have an N_Subtype_Indication
17216
      --  node (this node is created only if constraints are present).
17217
 
17218
      else
17219
         Find_Type (Subtype_Mark (S));
17220
 
17221
         if Nkind (Parent (S)) /= N_Access_To_Object_Definition
17222
           and then not
17223
            (Nkind (Parent (S)) = N_Subtype_Declaration
17224
              and then Is_Itype (Defining_Identifier (Parent (S))))
17225
         then
17226
            Check_Incomplete (Subtype_Mark (S));
17227
         end if;
17228
 
17229
         P := Parent (S);
17230
         Subtype_Mark_Id := Entity (Subtype_Mark (S));
17231
 
17232
         --  Explicit subtype declaration case
17233
 
17234
         if Nkind (P) = N_Subtype_Declaration then
17235
            Def_Id := Defining_Identifier (P);
17236
 
17237
         --  Explicit derived type definition case
17238
 
17239
         elsif Nkind (P) = N_Derived_Type_Definition then
17240
            Def_Id := Defining_Identifier (Parent (P));
17241
 
17242
         --  Implicit case, the Def_Id must be created as an implicit type.
17243
         --  The one exception arises in the case of concurrent types, array
17244
         --  and access types, where other subsidiary implicit types may be
17245
         --  created and must appear before the main implicit type. In these
17246
         --  cases we leave Def_Id set to Empty as a signal that Create_Itype
17247
         --  has not yet been called to create Def_Id.
17248
 
17249
         else
17250
            if Is_Array_Type (Subtype_Mark_Id)
17251
              or else Is_Concurrent_Type (Subtype_Mark_Id)
17252
              or else Is_Access_Type (Subtype_Mark_Id)
17253
            then
17254
               Def_Id := Empty;
17255
 
17256
            --  For the other cases, we create a new unattached Itype,
17257
            --  and set the indication to ensure it gets attached later.
17258
 
17259
            else
17260
               Def_Id :=
17261
                 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
17262
            end if;
17263
         end if;
17264
 
17265
         --  If the kind of constraint is invalid for this kind of type,
17266
         --  then give an error, and then pretend no constraint was given.
17267
 
17268
         if not Is_Valid_Constraint_Kind
17269
                   (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
17270
         then
17271
            Error_Msg_N
17272
              ("incorrect constraint for this kind of type", Constraint (S));
17273
 
17274
            Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
17275
 
17276
            --  Set Ekind of orphan itype, to prevent cascaded errors
17277
 
17278
            if Present (Def_Id) then
17279
               Set_Ekind (Def_Id, Ekind (Any_Type));
17280
            end if;
17281
 
17282
            --  Make recursive call, having got rid of the bogus constraint
17283
 
17284
            return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
17285
         end if;
17286
 
17287
         --  Remaining processing depends on type
17288
 
17289
         case Ekind (Subtype_Mark_Id) is
17290
            when Access_Kind =>
17291
               Constrain_Access (Def_Id, S, Related_Nod);
17292
 
17293
               if Expander_Active
17294
                 and then  Is_Itype (Designated_Type (Def_Id))
17295
                 and then Nkind (Related_Nod) = N_Subtype_Declaration
17296
                 and then not Is_Incomplete_Type (Designated_Type (Def_Id))
17297
               then
17298
                  Build_Itype_Reference
17299
                    (Designated_Type (Def_Id), Related_Nod);
17300
               end if;
17301
 
17302
            when Array_Kind =>
17303
               Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
17304
 
17305
            when Decimal_Fixed_Point_Kind =>
17306
               Constrain_Decimal (Def_Id, S);
17307
 
17308
            when Enumeration_Kind =>
17309
               Constrain_Enumeration (Def_Id, S);
17310
 
17311
            when Ordinary_Fixed_Point_Kind =>
17312
               Constrain_Ordinary_Fixed (Def_Id, S);
17313
 
17314
            when Float_Kind =>
17315
               Constrain_Float (Def_Id, S);
17316
 
17317
            when Integer_Kind =>
17318
               Constrain_Integer (Def_Id, S);
17319
 
17320
            when E_Record_Type     |
17321
                 E_Record_Subtype  |
17322
                 Class_Wide_Kind   |
17323
                 E_Incomplete_Type =>
17324
               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
17325
 
17326
               if Ekind (Def_Id) = E_Incomplete_Type then
17327
                  Set_Private_Dependents (Def_Id, New_Elmt_List);
17328
               end if;
17329
 
17330
            when Private_Kind =>
17331
               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
17332
               Set_Private_Dependents (Def_Id, New_Elmt_List);
17333
 
17334
               --  In case of an invalid constraint prevent further processing
17335
               --  since the type constructed is missing expected fields.
17336
 
17337
               if Etype (Def_Id) = Any_Type then
17338
                  return Def_Id;
17339
               end if;
17340
 
17341
               --  If the full view is that of a task with discriminants,
17342
               --  we must constrain both the concurrent type and its
17343
               --  corresponding record type. Otherwise we will just propagate
17344
               --  the constraint to the full view, if available.
17345
 
17346
               if Present (Full_View (Subtype_Mark_Id))
17347
                 and then Has_Discriminants (Subtype_Mark_Id)
17348
                 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
17349
               then
17350
                  Full_View_Id :=
17351
                    Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
17352
 
17353
                  Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
17354
                  Constrain_Concurrent (Full_View_Id, S,
17355
                    Related_Nod, Related_Id, Suffix);
17356
                  Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
17357
                  Set_Full_View (Def_Id, Full_View_Id);
17358
 
17359
                  --  Introduce an explicit reference to the private subtype,
17360
                  --  to prevent scope anomalies in gigi if first use appears
17361
                  --  in a nested context, e.g. a later function body.
17362
                  --  Should this be generated in other contexts than a full
17363
                  --  type declaration?
17364
 
17365
                  if Is_Itype (Def_Id)
17366
                    and then
17367
                      Nkind (Parent (P)) = N_Full_Type_Declaration
17368
                  then
17369
                     Build_Itype_Reference (Def_Id, Parent (P));
17370
                  end if;
17371
 
17372
               else
17373
                  Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
17374
               end if;
17375
 
17376
            when Concurrent_Kind  =>
17377
               Constrain_Concurrent (Def_Id, S,
17378
                 Related_Nod, Related_Id, Suffix);
17379
 
17380
            when others =>
17381
               Error_Msg_N ("invalid subtype mark in subtype indication", S);
17382
         end case;
17383
 
17384
         --  Size and Convention are always inherited from the base type
17385
 
17386
         Set_Size_Info  (Def_Id,            (Subtype_Mark_Id));
17387
         Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
17388
 
17389
         return Def_Id;
17390
      end if;
17391
   end Process_Subtype;
17392
 
17393
   ---------------------------------------
17394
   -- Check_Anonymous_Access_Components --
17395
   ---------------------------------------
17396
 
17397
   procedure Check_Anonymous_Access_Components
17398
      (Typ_Decl  : Node_Id;
17399
       Typ       : Entity_Id;
17400
       Prev      : Entity_Id;
17401
       Comp_List : Node_Id)
17402
   is
17403
      Loc         : constant Source_Ptr := Sloc (Typ_Decl);
17404
      Anon_Access : Entity_Id;
17405
      Acc_Def     : Node_Id;
17406
      Comp        : Node_Id;
17407
      Comp_Def    : Node_Id;
17408
      Decl        : Node_Id;
17409
      Type_Def    : Node_Id;
17410
 
17411
      procedure Build_Incomplete_Type_Declaration;
17412
      --  If the record type contains components that include an access to the
17413
      --  current record, then create an incomplete type declaration for the
17414
      --  record, to be used as the designated type of the anonymous access.
17415
      --  This is done only once, and only if there is no previous partial
17416
      --  view of the type.
17417
 
17418
      function Designates_T (Subt : Node_Id) return Boolean;
17419
      --  Check whether a node designates the enclosing record type, or 'Class
17420
      --  of that type
17421
 
17422
      function Mentions_T (Acc_Def : Node_Id) return Boolean;
17423
      --  Check whether an access definition includes a reference to
17424
      --  the enclosing record type. The reference can be a subtype mark
17425
      --  in the access definition itself, a 'Class attribute reference, or
17426
      --  recursively a reference appearing in a parameter specification
17427
      --  or result definition of an access_to_subprogram definition.
17428
 
17429
      --------------------------------------
17430
      -- Build_Incomplete_Type_Declaration --
17431
      --------------------------------------
17432
 
17433
      procedure Build_Incomplete_Type_Declaration is
17434
         Decl  : Node_Id;
17435
         Inc_T : Entity_Id;
17436
         H     : Entity_Id;
17437
 
17438
         --  Is_Tagged indicates whether the type is tagged. It is tagged if
17439
         --  it's "is new ... with record" or else "is tagged record ...".
17440
 
17441
         Is_Tagged : constant Boolean :=
17442
             (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
17443
                 and then
17444
                   Present
17445
                     (Record_Extension_Part (Type_Definition (Typ_Decl))))
17446
           or else
17447
             (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
17448
                 and then Tagged_Present (Type_Definition (Typ_Decl)));
17449
 
17450
      begin
17451
         --  If there is a previous partial view, no need to create a new one
17452
         --  If the partial view, given by Prev, is incomplete,  If Prev is
17453
         --  a private declaration, full declaration is flagged accordingly.
17454
 
17455
         if Prev /= Typ then
17456
            if Is_Tagged then
17457
               Make_Class_Wide_Type (Prev);
17458
               Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
17459
               Set_Etype (Class_Wide_Type (Typ), Typ);
17460
            end if;
17461
 
17462
            return;
17463
 
17464
         elsif Has_Private_Declaration (Typ) then
17465
 
17466
            --  If we refer to T'Class inside T, and T is the completion of a
17467
            --  private type, then we need to make sure the class-wide type
17468
            --  exists.
17469
 
17470
            if Is_Tagged then
17471
               Make_Class_Wide_Type (Typ);
17472
            end if;
17473
 
17474
            return;
17475
 
17476
         --  If there was a previous anonymous access type, the incomplete
17477
         --  type declaration will have been created already.
17478
 
17479
         elsif Present (Current_Entity (Typ))
17480
           and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
17481
           and then Full_View (Current_Entity (Typ)) = Typ
17482
         then
17483
            return;
17484
 
17485
         else
17486
            Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
17487
            Decl  := Make_Incomplete_Type_Declaration (Loc, Inc_T);
17488
 
17489
            --  Type has already been inserted into the current scope.
17490
            --  Remove it, and add incomplete declaration for type, so
17491
            --  that subsequent anonymous access types can use it.
17492
            --  The entity is unchained from the homonym list and from
17493
            --  immediate visibility. After analysis, the entity in the
17494
            --  incomplete declaration becomes immediately visible in the
17495
            --  record declaration that follows.
17496
 
17497
            H := Current_Entity (Typ);
17498
 
17499
            if H = Typ then
17500
               Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
17501
            else
17502
               while Present (H)
17503
                 and then Homonym (H) /= Typ
17504
               loop
17505
                  H := Homonym (Typ);
17506
               end loop;
17507
 
17508
               Set_Homonym (H, Homonym (Typ));
17509
            end if;
17510
 
17511
            Insert_Before (Typ_Decl, Decl);
17512
            Analyze (Decl);
17513
            Set_Full_View (Inc_T, Typ);
17514
 
17515
            if Is_Tagged then
17516
               --  Create a common class-wide type for both views, and set
17517
               --  the Etype of the class-wide type to the full view.
17518
 
17519
               Make_Class_Wide_Type (Inc_T);
17520
               Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
17521
               Set_Etype (Class_Wide_Type (Typ), Typ);
17522
            end if;
17523
         end if;
17524
      end Build_Incomplete_Type_Declaration;
17525
 
17526
      ------------------
17527
      -- Designates_T --
17528
      ------------------
17529
 
17530
      function Designates_T (Subt : Node_Id) return Boolean is
17531
         Type_Id : constant Name_Id := Chars (Typ);
17532
 
17533
         function Names_T (Nam : Node_Id) return Boolean;
17534
         --  The record type has not been introduced in the current scope
17535
         --  yet, so we must examine the name of the type itself, either
17536
         --  an identifier T, or an expanded name of the form P.T, where
17537
         --  P denotes the current scope.
17538
 
17539
         -------------
17540
         -- Names_T --
17541
         -------------
17542
 
17543
         function Names_T (Nam : Node_Id) return Boolean is
17544
         begin
17545
            if Nkind (Nam) = N_Identifier then
17546
               return Chars (Nam) = Type_Id;
17547
 
17548
            elsif Nkind (Nam) = N_Selected_Component then
17549
               if Chars (Selector_Name (Nam)) = Type_Id then
17550
                  if Nkind (Prefix (Nam)) = N_Identifier then
17551
                     return Chars (Prefix (Nam)) = Chars (Current_Scope);
17552
 
17553
                  elsif Nkind (Prefix (Nam)) = N_Selected_Component then
17554
                     return Chars (Selector_Name (Prefix (Nam))) =
17555
                            Chars (Current_Scope);
17556
                  else
17557
                     return False;
17558
                  end if;
17559
 
17560
               else
17561
                  return False;
17562
               end if;
17563
 
17564
            else
17565
               return False;
17566
            end if;
17567
         end Names_T;
17568
 
17569
      --  Start of processing for Designates_T
17570
 
17571
      begin
17572
         if Nkind (Subt) = N_Identifier then
17573
            return Chars (Subt) = Type_Id;
17574
 
17575
            --  Reference can be through an expanded name which has not been
17576
            --  analyzed yet, and which designates enclosing scopes.
17577
 
17578
         elsif Nkind (Subt) = N_Selected_Component then
17579
            if Names_T (Subt) then
17580
               return True;
17581
 
17582
            --  Otherwise it must denote an entity that is already visible.
17583
            --  The access definition may name a subtype of the enclosing
17584
            --  type, if there is a previous incomplete declaration for it.
17585
 
17586
            else
17587
               Find_Selected_Component (Subt);
17588
               return
17589
                 Is_Entity_Name (Subt)
17590
                   and then Scope (Entity (Subt)) = Current_Scope
17591
                   and then
17592
                     (Chars (Base_Type (Entity (Subt))) = Type_Id
17593
                       or else
17594
                         (Is_Class_Wide_Type (Entity (Subt))
17595
                           and then
17596
                           Chars (Etype (Base_Type (Entity (Subt)))) =
17597
                                                                  Type_Id));
17598
            end if;
17599
 
17600
         --  A reference to the current type may appear as the prefix of
17601
         --  a 'Class attribute.
17602
 
17603
         elsif Nkind (Subt) = N_Attribute_Reference
17604
           and then Attribute_Name (Subt) = Name_Class
17605
         then
17606
            return Names_T (Prefix (Subt));
17607
 
17608
         else
17609
            return False;
17610
         end if;
17611
      end Designates_T;
17612
 
17613
      ----------------
17614
      -- Mentions_T --
17615
      ----------------
17616
 
17617
      function Mentions_T (Acc_Def : Node_Id) return Boolean is
17618
         Param_Spec : Node_Id;
17619
 
17620
         Acc_Subprg : constant Node_Id :=
17621
                        Access_To_Subprogram_Definition (Acc_Def);
17622
 
17623
      begin
17624
         if No (Acc_Subprg) then
17625
            return Designates_T (Subtype_Mark (Acc_Def));
17626
         end if;
17627
 
17628
         --  Component is an access_to_subprogram: examine its formals,
17629
         --  and result definition in the case of an access_to_function.
17630
 
17631
         Param_Spec := First (Parameter_Specifications (Acc_Subprg));
17632
         while Present (Param_Spec) loop
17633
            if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
17634
              and then Mentions_T (Parameter_Type (Param_Spec))
17635
            then
17636
               return True;
17637
 
17638
            elsif Designates_T (Parameter_Type (Param_Spec)) then
17639
               return True;
17640
            end if;
17641
 
17642
            Next (Param_Spec);
17643
         end loop;
17644
 
17645
         if Nkind (Acc_Subprg) = N_Access_Function_Definition then
17646
            if Nkind (Result_Definition (Acc_Subprg)) =
17647
                 N_Access_Definition
17648
            then
17649
               return Mentions_T (Result_Definition (Acc_Subprg));
17650
            else
17651
               return Designates_T (Result_Definition (Acc_Subprg));
17652
            end if;
17653
         end if;
17654
 
17655
         return False;
17656
      end Mentions_T;
17657
 
17658
   --  Start of processing for Check_Anonymous_Access_Components
17659
 
17660
   begin
17661
      if No (Comp_List) then
17662
         return;
17663
      end if;
17664
 
17665
      Comp := First (Component_Items (Comp_List));
17666
      while Present (Comp) loop
17667
         if Nkind (Comp) = N_Component_Declaration
17668
           and then Present
17669
             (Access_Definition (Component_Definition (Comp)))
17670
           and then
17671
             Mentions_T (Access_Definition (Component_Definition (Comp)))
17672
         then
17673
            Comp_Def := Component_Definition (Comp);
17674
            Acc_Def :=
17675
              Access_To_Subprogram_Definition
17676
                (Access_Definition (Comp_Def));
17677
 
17678
            Build_Incomplete_Type_Declaration;
17679
            Anon_Access :=
17680
              Make_Defining_Identifier (Loc,
17681
                Chars => New_Internal_Name ('S'));
17682
 
17683
            --  Create a declaration for the anonymous access type: either
17684
            --  an access_to_object or an access_to_subprogram.
17685
 
17686
            if Present (Acc_Def) then
17687
               if Nkind  (Acc_Def) = N_Access_Function_Definition then
17688
                  Type_Def :=
17689
                    Make_Access_Function_Definition (Loc,
17690
                      Parameter_Specifications =>
17691
                        Parameter_Specifications (Acc_Def),
17692
                      Result_Definition => Result_Definition (Acc_Def));
17693
               else
17694
                  Type_Def :=
17695
                    Make_Access_Procedure_Definition (Loc,
17696
                      Parameter_Specifications =>
17697
                        Parameter_Specifications (Acc_Def));
17698
               end if;
17699
 
17700
            else
17701
               Type_Def :=
17702
                 Make_Access_To_Object_Definition (Loc,
17703
                   Subtype_Indication =>
17704
                      Relocate_Node
17705
                        (Subtype_Mark
17706
                          (Access_Definition (Comp_Def))));
17707
 
17708
               Set_Constant_Present
17709
                 (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
17710
               Set_All_Present
17711
                 (Type_Def, All_Present (Access_Definition (Comp_Def)));
17712
            end if;
17713
 
17714
            Set_Null_Exclusion_Present
17715
              (Type_Def,
17716
               Null_Exclusion_Present (Access_Definition (Comp_Def)));
17717
 
17718
            Decl :=
17719
              Make_Full_Type_Declaration (Loc,
17720
                Defining_Identifier => Anon_Access,
17721
                Type_Definition     => Type_Def);
17722
 
17723
            Insert_Before (Typ_Decl, Decl);
17724
            Analyze (Decl);
17725
 
17726
            --  If an access to object, Preserve entity of designated type,
17727
            --  for ASIS use, before rewriting the component definition.
17728
 
17729
            if No (Acc_Def) then
17730
               declare
17731
                  Desig : Entity_Id;
17732
 
17733
               begin
17734
                  Desig := Entity (Subtype_Indication (Type_Def));
17735
 
17736
                  --  If the access definition is to the current  record,
17737
                  --  the visible entity at this point is an  incomplete
17738
                  --  type. Retrieve the full view to simplify  ASIS queries
17739
 
17740
                  if Ekind (Desig) = E_Incomplete_Type then
17741
                     Desig := Full_View (Desig);
17742
                  end if;
17743
 
17744
                  Set_Entity
17745
                    (Subtype_Mark (Access_Definition  (Comp_Def)), Desig);
17746
               end;
17747
            end if;
17748
 
17749
            Rewrite (Comp_Def,
17750
              Make_Component_Definition (Loc,
17751
                Subtype_Indication =>
17752
               New_Occurrence_Of (Anon_Access, Loc)));
17753
 
17754
            if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
17755
               Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
17756
            else
17757
               Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
17758
            end if;
17759
 
17760
            Set_Is_Local_Anonymous_Access (Anon_Access);
17761
         end if;
17762
 
17763
         Next (Comp);
17764
      end loop;
17765
 
17766
      if Present (Variant_Part (Comp_List)) then
17767
         declare
17768
            V : Node_Id;
17769
         begin
17770
            V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
17771
            while Present (V) loop
17772
               Check_Anonymous_Access_Components
17773
                 (Typ_Decl, Typ, Prev, Component_List (V));
17774
               Next_Non_Pragma (V);
17775
            end loop;
17776
         end;
17777
      end if;
17778
   end Check_Anonymous_Access_Components;
17779
 
17780
   --------------------------------
17781
   -- Preanalyze_Spec_Expression --
17782
   --------------------------------
17783
 
17784
   procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
17785
      Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
17786
   begin
17787
      In_Spec_Expression := True;
17788
      Preanalyze_And_Resolve (N, T);
17789
      In_Spec_Expression := Save_In_Spec_Expression;
17790
   end Preanalyze_Spec_Expression;
17791
 
17792
   -----------------------------
17793
   -- Record_Type_Declaration --
17794
   -----------------------------
17795
 
17796
   procedure Record_Type_Declaration
17797
     (T    : Entity_Id;
17798
      N    : Node_Id;
17799
      Prev : Entity_Id)
17800
   is
17801
      Def       : constant Node_Id := Type_Definition (N);
17802
      Is_Tagged : Boolean;
17803
      Tag_Comp  : Entity_Id;
17804
 
17805
   begin
17806
      --  These flags must be initialized before calling Process_Discriminants
17807
      --  because this routine makes use of them.
17808
 
17809
      Set_Ekind             (T, E_Record_Type);
17810
      Set_Etype             (T, T);
17811
      Init_Size_Align       (T);
17812
      Set_Interfaces        (T, No_Elist);
17813
      Set_Stored_Constraint (T, No_Elist);
17814
 
17815
      --  Normal case
17816
 
17817
      if Ada_Version < Ada_05
17818
        or else not Interface_Present (Def)
17819
      then
17820
         --  The flag Is_Tagged_Type might have already been set by
17821
         --  Find_Type_Name if it detected an error for declaration T. This
17822
         --  arises in the case of private tagged types where the full view
17823
         --  omits the word tagged.
17824
 
17825
         Is_Tagged :=
17826
           Tagged_Present (Def)
17827
             or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
17828
 
17829
         Set_Is_Tagged_Type      (T, Is_Tagged);
17830
         Set_Is_Limited_Record   (T, Limited_Present (Def));
17831
 
17832
         --  Type is abstract if full declaration carries keyword, or if
17833
         --  previous partial view did.
17834
 
17835
         Set_Is_Abstract_Type    (T, Is_Abstract_Type (T)
17836
                                      or else Abstract_Present (Def));
17837
 
17838
      else
17839
         Is_Tagged := True;
17840
         Analyze_Interface_Declaration (T, Def);
17841
 
17842
         if Present (Discriminant_Specifications (N)) then
17843
            Error_Msg_N
17844
              ("interface types cannot have discriminants",
17845
                Defining_Identifier
17846
                  (First (Discriminant_Specifications (N))));
17847
         end if;
17848
      end if;
17849
 
17850
      --  First pass: if there are self-referential access components,
17851
      --  create the required anonymous access type declarations, and if
17852
      --  need be an incomplete type declaration for T itself.
17853
 
17854
      Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def));
17855
 
17856
      if Ada_Version >= Ada_05
17857
        and then Present (Interface_List (Def))
17858
      then
17859
         Check_Interfaces (N, Def);
17860
 
17861
         declare
17862
            Ifaces_List : Elist_Id;
17863
 
17864
         begin
17865
            --  Ada 2005 (AI-251): Collect the list of progenitors that are not
17866
            --  already in the parents.
17867
 
17868
            Collect_Interfaces
17869
              (T               => T,
17870
               Ifaces_List     => Ifaces_List,
17871
               Exclude_Parents => True);
17872
 
17873
            Set_Interfaces (T, Ifaces_List);
17874
         end;
17875
      end if;
17876
 
17877
      --  Records constitute a scope for the component declarations within.
17878
      --  The scope is created prior to the processing of these declarations.
17879
      --  Discriminants are processed first, so that they are visible when
17880
      --  processing the other components. The Ekind of the record type itself
17881
      --  is set to E_Record_Type (subtypes appear as E_Record_Subtype).
17882
 
17883
      --  Enter record scope
17884
 
17885
      Push_Scope (T);
17886
 
17887
      --  If an incomplete or private type declaration was already given for
17888
      --  the type, then this scope already exists, and the discriminants have
17889
      --  been declared within. We must verify that the full declaration
17890
      --  matches the incomplete one.
17891
 
17892
      Check_Or_Process_Discriminants (N, T, Prev);
17893
 
17894
      Set_Is_Constrained     (T, not Has_Discriminants (T));
17895
      Set_Has_Delayed_Freeze (T, True);
17896
 
17897
      --  For tagged types add a manually analyzed component corresponding
17898
      --  to the component _tag, the corresponding piece of tree will be
17899
      --  expanded as part of the freezing actions if it is not a CPP_Class.
17900
 
17901
      if Is_Tagged then
17902
 
17903
         --  Do not add the tag unless we are in expansion mode
17904
 
17905
         if Expander_Active then
17906
            Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
17907
            Enter_Name (Tag_Comp);
17908
 
17909
            Set_Ekind                     (Tag_Comp, E_Component);
17910
            Set_Is_Tag                    (Tag_Comp);
17911
            Set_Is_Aliased                (Tag_Comp);
17912
            Set_Etype                     (Tag_Comp, RTE (RE_Tag));
17913
            Set_DT_Entry_Count            (Tag_Comp, No_Uint);
17914
            Set_Original_Record_Component (Tag_Comp, Tag_Comp);
17915
            Init_Component_Location       (Tag_Comp);
17916
 
17917
            --  Ada 2005 (AI-251): Addition of the Tag corresponding to all the
17918
            --  implemented interfaces.
17919
 
17920
            if Has_Interfaces (T) then
17921
               Add_Interface_Tag_Components (N, T);
17922
            end if;
17923
         end if;
17924
 
17925
         Make_Class_Wide_Type (T);
17926
         Set_Primitive_Operations (T, New_Elmt_List);
17927
      end if;
17928
 
17929
      --  We must suppress range checks when processing the components
17930
      --  of a record in the presence of discriminants, since we don't
17931
      --  want spurious checks to be generated during their analysis, but
17932
      --  must reset the Suppress_Range_Checks flags after having processed
17933
      --  the record definition.
17934
 
17935
      --  Note: this is the only use of Kill_Range_Checks, and is a bit odd,
17936
      --  couldn't we just use the normal range check suppression method here.
17937
      --  That would seem cleaner ???
17938
 
17939
      if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then
17940
         Set_Kill_Range_Checks (T, True);
17941
         Record_Type_Definition (Def, Prev);
17942
         Set_Kill_Range_Checks (T, False);
17943
      else
17944
         Record_Type_Definition (Def, Prev);
17945
      end if;
17946
 
17947
      --  Exit from record scope
17948
 
17949
      End_Scope;
17950
 
17951
      --  Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all
17952
      --  the implemented interfaces and associate them an aliased entity.
17953
 
17954
      if Is_Tagged
17955
        and then not Is_Empty_List (Interface_List (Def))
17956
      then
17957
         Derive_Progenitor_Subprograms (T, T);
17958
      end if;
17959
   end Record_Type_Declaration;
17960
 
17961
   ----------------------------
17962
   -- Record_Type_Definition --
17963
   ----------------------------
17964
 
17965
   procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is
17966
      Component          : Entity_Id;
17967
      Ctrl_Components    : Boolean := False;
17968
      Final_Storage_Only : Boolean;
17969
      T                  : Entity_Id;
17970
 
17971
   begin
17972
      if Ekind (Prev_T) = E_Incomplete_Type then
17973
         T := Full_View (Prev_T);
17974
      else
17975
         T := Prev_T;
17976
      end if;
17977
 
17978
      Final_Storage_Only := not Is_Controlled (T);
17979
 
17980
      --  Ada 2005: check whether an explicit Limited is present in a derived
17981
      --  type declaration.
17982
 
17983
      if Nkind (Parent (Def)) = N_Derived_Type_Definition
17984
        and then Limited_Present (Parent (Def))
17985
      then
17986
         Set_Is_Limited_Record (T);
17987
      end if;
17988
 
17989
      --  If the component list of a record type is defined by the reserved
17990
      --  word null and there is no discriminant part, then the record type has
17991
      --  no components and all records of the type are null records (RM 3.7)
17992
      --  This procedure is also called to process the extension part of a
17993
      --  record extension, in which case the current scope may have inherited
17994
      --  components.
17995
 
17996
      if No (Def)
17997
        or else No (Component_List (Def))
17998
        or else Null_Present (Component_List (Def))
17999
      then
18000
         null;
18001
 
18002
      else
18003
         Analyze_Declarations (Component_Items (Component_List (Def)));
18004
 
18005
         if Present (Variant_Part (Component_List (Def))) then
18006
            Analyze (Variant_Part (Component_List (Def)));
18007
         end if;
18008
      end if;
18009
 
18010
      --  After completing the semantic analysis of the record definition,
18011
      --  record components, both new and inherited, are accessible. Set their
18012
      --  kind accordingly. Exclude malformed itypes from illegal declarations,
18013
      --  whose Ekind may be void.
18014
 
18015
      Component := First_Entity (Current_Scope);
18016
      while Present (Component) loop
18017
         if Ekind (Component) = E_Void
18018
           and then not Is_Itype (Component)
18019
         then
18020
            Set_Ekind (Component, E_Component);
18021
            Init_Component_Location (Component);
18022
         end if;
18023
 
18024
         if Has_Task (Etype (Component)) then
18025
            Set_Has_Task (T);
18026
         end if;
18027
 
18028
         if Ekind (Component) /= E_Component then
18029
            null;
18030
 
18031
         --  Do not set Has_Controlled_Component on a class-wide equivalent
18032
         --  type. See Make_CW_Equivalent_Type.
18033
 
18034
         elsif not Is_Class_Wide_Equivalent_Type (T)
18035
           and then (Has_Controlled_Component (Etype (Component))
18036
                      or else (Chars (Component) /= Name_uParent
18037
                                and then Is_Controlled (Etype (Component))))
18038
         then
18039
            Set_Has_Controlled_Component (T, True);
18040
            Final_Storage_Only :=
18041
              Final_Storage_Only
18042
                and then Finalize_Storage_Only (Etype (Component));
18043
            Ctrl_Components := True;
18044
         end if;
18045
 
18046
         Next_Entity (Component);
18047
      end loop;
18048
 
18049
      --  A Type is Finalize_Storage_Only only if all its controlled components
18050
      --  are also.
18051
 
18052
      if Ctrl_Components then
18053
         Set_Finalize_Storage_Only (T, Final_Storage_Only);
18054
      end if;
18055
 
18056
      --  Place reference to end record on the proper entity, which may
18057
      --  be a partial view.
18058
 
18059
      if Present (Def) then
18060
         Process_End_Label (Def, 'e', Prev_T);
18061
      end if;
18062
   end Record_Type_Definition;
18063
 
18064
   ------------------------
18065
   -- Replace_Components --
18066
   ------------------------
18067
 
18068
   procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
18069
      function Process (N : Node_Id) return Traverse_Result;
18070
 
18071
      -------------
18072
      -- Process --
18073
      -------------
18074
 
18075
      function Process (N : Node_Id) return Traverse_Result is
18076
         Comp : Entity_Id;
18077
 
18078
      begin
18079
         if Nkind (N) = N_Discriminant_Specification then
18080
            Comp := First_Discriminant (Typ);
18081
            while Present (Comp) loop
18082
               if Chars (Comp) = Chars (Defining_Identifier (N)) then
18083
                  Set_Defining_Identifier (N, Comp);
18084
                  exit;
18085
               end if;
18086
 
18087
               Next_Discriminant (Comp);
18088
            end loop;
18089
 
18090
         elsif Nkind (N) = N_Component_Declaration then
18091
            Comp := First_Component (Typ);
18092
            while Present (Comp) loop
18093
               if Chars (Comp) = Chars (Defining_Identifier (N)) then
18094
                  Set_Defining_Identifier (N, Comp);
18095
                  exit;
18096
               end if;
18097
 
18098
               Next_Component (Comp);
18099
            end loop;
18100
         end if;
18101
 
18102
         return OK;
18103
      end Process;
18104
 
18105
      procedure Replace is new Traverse_Proc (Process);
18106
 
18107
   --  Start of processing for Replace_Components
18108
 
18109
   begin
18110
      Replace (Decl);
18111
   end Replace_Components;
18112
 
18113
   -------------------------------
18114
   -- Set_Completion_Referenced --
18115
   -------------------------------
18116
 
18117
   procedure Set_Completion_Referenced (E : Entity_Id) is
18118
   begin
18119
      --  If in main unit, mark entity that is a completion as referenced,
18120
      --  warnings go on the partial view when needed.
18121
 
18122
      if In_Extended_Main_Source_Unit (E) then
18123
         Set_Referenced (E);
18124
      end if;
18125
   end Set_Completion_Referenced;
18126
 
18127
   ---------------------
18128
   -- Set_Fixed_Range --
18129
   ---------------------
18130
 
18131
   --  The range for fixed-point types is complicated by the fact that we
18132
   --  do not know the exact end points at the time of the declaration. This
18133
   --  is true for three reasons:
18134
 
18135
   --     A size clause may affect the fudging of the end-points
18136
   --     A small clause may affect the values of the end-points
18137
   --     We try to include the end-points if it does not affect the size
18138
 
18139
   --  This means that the actual end-points must be established at the point
18140
   --  when the type is frozen. Meanwhile, we first narrow the range as
18141
   --  permitted (so that it will fit if necessary in a small specified size),
18142
   --  and then build a range subtree with these narrowed bounds.
18143
 
18144
   --  Set_Fixed_Range constructs the range from real literal values, and sets
18145
   --  the range as the Scalar_Range of the given fixed-point type entity.
18146
 
18147
   --  The parent of this range is set to point to the entity so that it is
18148
   --  properly hooked into the tree (unlike normal Scalar_Range entries for
18149
   --  other scalar types, which are just pointers to the range in the
18150
   --  original tree, this would otherwise be an orphan).
18151
 
18152
   --  The tree is left unanalyzed. When the type is frozen, the processing
18153
   --  in Freeze.Freeze_Fixed_Point_Type notices that the range is not
18154
   --  analyzed, and uses this as an indication that it should complete
18155
   --  work on the range (it will know the final small and size values).
18156
 
18157
   procedure Set_Fixed_Range
18158
     (E   : Entity_Id;
18159
      Loc : Source_Ptr;
18160
      Lo  : Ureal;
18161
      Hi  : Ureal)
18162
   is
18163
      S : constant Node_Id :=
18164
            Make_Range (Loc,
18165
              Low_Bound  => Make_Real_Literal (Loc, Lo),
18166
              High_Bound => Make_Real_Literal (Loc, Hi));
18167
   begin
18168
      Set_Scalar_Range (E, S);
18169
      Set_Parent (S, E);
18170
   end Set_Fixed_Range;
18171
 
18172
   ----------------------------------
18173
   -- Set_Scalar_Range_For_Subtype --
18174
   ----------------------------------
18175
 
18176
   procedure Set_Scalar_Range_For_Subtype
18177
     (Def_Id : Entity_Id;
18178
      R      : Node_Id;
18179
      Subt   : Entity_Id)
18180
   is
18181
      Kind : constant Entity_Kind :=  Ekind (Def_Id);
18182
 
18183
   begin
18184
      Set_Scalar_Range (Def_Id, R);
18185
 
18186
      --  We need to link the range into the tree before resolving it so
18187
      --  that types that are referenced, including importantly the subtype
18188
      --  itself, are properly frozen (Freeze_Expression requires that the
18189
      --  expression be properly linked into the tree). Of course if it is
18190
      --  already linked in, then we do not disturb the current link.
18191
 
18192
      if No (Parent (R)) then
18193
         Set_Parent (R, Def_Id);
18194
      end if;
18195
 
18196
      --  Reset the kind of the subtype during analysis of the range, to
18197
      --  catch possible premature use in the bounds themselves.
18198
 
18199
      Set_Ekind (Def_Id, E_Void);
18200
      Process_Range_Expr_In_Decl (R, Subt);
18201
      Set_Ekind (Def_Id, Kind);
18202
   end Set_Scalar_Range_For_Subtype;
18203
 
18204
   --------------------------------------------------------
18205
   -- Set_Stored_Constraint_From_Discriminant_Constraint --
18206
   --------------------------------------------------------
18207
 
18208
   procedure Set_Stored_Constraint_From_Discriminant_Constraint
18209
     (E : Entity_Id)
18210
   is
18211
   begin
18212
      --  Make sure set if encountered during Expand_To_Stored_Constraint
18213
 
18214
      Set_Stored_Constraint (E, No_Elist);
18215
 
18216
      --  Give it the right value
18217
 
18218
      if Is_Constrained (E) and then Has_Discriminants (E) then
18219
         Set_Stored_Constraint (E,
18220
           Expand_To_Stored_Constraint (E, Discriminant_Constraint (E)));
18221
      end if;
18222
   end Set_Stored_Constraint_From_Discriminant_Constraint;
18223
 
18224
   -------------------------------------
18225
   -- Signed_Integer_Type_Declaration --
18226
   -------------------------------------
18227
 
18228
   procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
18229
      Implicit_Base : Entity_Id;
18230
      Base_Typ      : Entity_Id;
18231
      Lo_Val        : Uint;
18232
      Hi_Val        : Uint;
18233
      Errs          : Boolean := False;
18234
      Lo            : Node_Id;
18235
      Hi            : Node_Id;
18236
 
18237
      function Can_Derive_From (E : Entity_Id) return Boolean;
18238
      --  Determine whether given bounds allow derivation from specified type
18239
 
18240
      procedure Check_Bound (Expr : Node_Id);
18241
      --  Check bound to make sure it is integral and static. If not, post
18242
      --  appropriate error message and set Errs flag
18243
 
18244
      ---------------------
18245
      -- Can_Derive_From --
18246
      ---------------------
18247
 
18248
      --  Note we check both bounds against both end values, to deal with
18249
      --  strange types like ones with a range of 0 .. -12341234.
18250
 
18251
      function Can_Derive_From (E : Entity_Id) return Boolean is
18252
         Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
18253
         Hi : constant Uint := Expr_Value (Type_High_Bound (E));
18254
      begin
18255
         return Lo <= Lo_Val and then Lo_Val <= Hi
18256
                  and then
18257
                Lo <= Hi_Val and then Hi_Val <= Hi;
18258
      end Can_Derive_From;
18259
 
18260
      -----------------
18261
      -- Check_Bound --
18262
      -----------------
18263
 
18264
      procedure Check_Bound (Expr : Node_Id) is
18265
      begin
18266
         --  If a range constraint is used as an integer type definition, each
18267
         --  bound of the range must be defined by a static expression of some
18268
         --  integer type, but the two bounds need not have the same integer
18269
         --  type (Negative bounds are allowed.) (RM 3.5.4)
18270
 
18271
         if not Is_Integer_Type (Etype (Expr)) then
18272
            Error_Msg_N
18273
              ("integer type definition bounds must be of integer type", Expr);
18274
            Errs := True;
18275
 
18276
         elsif not Is_OK_Static_Expression (Expr) then
18277
            Flag_Non_Static_Expr
18278
              ("non-static expression used for integer type bound!", Expr);
18279
            Errs := True;
18280
 
18281
         --  The bounds are folded into literals, and we set their type to be
18282
         --  universal, to avoid typing difficulties: we cannot set the type
18283
         --  of the literal to the new type, because this would be a forward
18284
         --  reference for the back end,  and if the original type is user-
18285
         --  defined this can lead to spurious semantic errors (e.g. 2928-003).
18286
 
18287
         else
18288
            if Is_Entity_Name (Expr) then
18289
               Fold_Uint (Expr, Expr_Value (Expr), True);
18290
            end if;
18291
 
18292
            Set_Etype (Expr, Universal_Integer);
18293
         end if;
18294
      end Check_Bound;
18295
 
18296
   --  Start of processing for Signed_Integer_Type_Declaration
18297
 
18298
   begin
18299
      --  Create an anonymous base type
18300
 
18301
      Implicit_Base :=
18302
        Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
18303
 
18304
      --  Analyze and check the bounds, they can be of any integer type
18305
 
18306
      Lo := Low_Bound (Def);
18307
      Hi := High_Bound (Def);
18308
 
18309
      --  Arbitrarily use Integer as the type if either bound had an error
18310
 
18311
      if Hi = Error or else Lo = Error then
18312
         Base_Typ := Any_Integer;
18313
         Set_Error_Posted (T, True);
18314
 
18315
      --  Here both bounds are OK expressions
18316
 
18317
      else
18318
         Analyze_And_Resolve (Lo, Any_Integer);
18319
         Analyze_And_Resolve (Hi, Any_Integer);
18320
 
18321
         Check_Bound (Lo);
18322
         Check_Bound (Hi);
18323
 
18324
         if Errs then
18325
            Hi := Type_High_Bound (Standard_Long_Long_Integer);
18326
            Lo := Type_Low_Bound (Standard_Long_Long_Integer);
18327
         end if;
18328
 
18329
         --  Find type to derive from
18330
 
18331
         Lo_Val := Expr_Value (Lo);
18332
         Hi_Val := Expr_Value (Hi);
18333
 
18334
         if Can_Derive_From (Standard_Short_Short_Integer) then
18335
            Base_Typ := Base_Type (Standard_Short_Short_Integer);
18336
 
18337
         elsif Can_Derive_From (Standard_Short_Integer) then
18338
            Base_Typ := Base_Type (Standard_Short_Integer);
18339
 
18340
         elsif Can_Derive_From (Standard_Integer) then
18341
            Base_Typ := Base_Type (Standard_Integer);
18342
 
18343
         elsif Can_Derive_From (Standard_Long_Integer) then
18344
            Base_Typ := Base_Type (Standard_Long_Integer);
18345
 
18346
         elsif Can_Derive_From (Standard_Long_Long_Integer) then
18347
            Base_Typ := Base_Type (Standard_Long_Long_Integer);
18348
 
18349
         else
18350
            Base_Typ := Base_Type (Standard_Long_Long_Integer);
18351
            Error_Msg_N ("integer type definition bounds out of range", Def);
18352
            Hi := Type_High_Bound (Standard_Long_Long_Integer);
18353
            Lo := Type_Low_Bound (Standard_Long_Long_Integer);
18354
         end if;
18355
      end if;
18356
 
18357
      --  Complete both implicit base and declared first subtype entities
18358
 
18359
      Set_Etype          (Implicit_Base, Base_Typ);
18360
      Set_Scalar_Range   (Implicit_Base, Scalar_Range   (Base_Typ));
18361
      Set_Size_Info      (Implicit_Base,                (Base_Typ));
18362
      Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
18363
      Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
18364
 
18365
      Set_Ekind          (T, E_Signed_Integer_Subtype);
18366
      Set_Etype          (T, Implicit_Base);
18367
 
18368
      Set_Size_Info      (T,                (Implicit_Base));
18369
      Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
18370
      Set_Scalar_Range   (T, Def);
18371
      Set_RM_Size        (T, UI_From_Int (Minimum_Size (T)));
18372
      Set_Is_Constrained (T);
18373
   end Signed_Integer_Type_Declaration;
18374
 
18375
end Sem_Ch3;

powered by: WebSVN 2.1.0

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